File manager - Edit - /home/c14075/dragmet-ural.ru/www/Base.pm.tar
Back
usr/share/perl/5.32.1/IO/Compress/Base.pm 0000644 00000056564 15145072420 0013501 0 ustar 00 package IO::Compress::Base ; require 5.006 ; use strict ; use warnings; use IO::Compress::Base::Common 2.093 ; use IO::File (); ; use Scalar::Util (); #use File::Glob; #require Exporter ; use Carp() ; use Symbol(); #use bytes; our (@ISA, $VERSION); @ISA = qw(IO::File Exporter); $VERSION = '2.093'; #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. sub saveStatus { my $self = shift ; ${ *$self->{ErrorNo} } = shift() + 0 ; ${ *$self->{Error} } = '' ; return ${ *$self->{ErrorNo} } ; } sub saveErrorString { my $self = shift ; my $retval = shift ; ${ *$self->{Error} } = shift ; ${ *$self->{ErrorNo} } = shift() + 0 if @_ ; return $retval; } sub croakError { my $self = shift ; $self->saveErrorString(0, $_[0]); Carp::croak $_[0]; } sub closeError { my $self = shift ; my $retval = shift ; my $errno = *$self->{ErrorNo}; my $error = ${ *$self->{Error} }; $self->close(); *$self->{ErrorNo} = $errno ; ${ *$self->{Error} } = $error ; return $retval; } sub error { my $self = shift ; return ${ *$self->{Error} } ; } sub errorNo { my $self = shift ; return ${ *$self->{ErrorNo} } ; } sub writeAt { my $self = shift ; my $offset = shift; my $data = shift; if (defined *$self->{FH}) { my $here = tell(*$self->{FH}); return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) if $here < 0 ; seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET) or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; defined *$self->{FH}->write($data, length $data) or return $self->saveErrorString(undef, $!, $!) ; seek(*$self->{FH}, $here, IO::Handle::SEEK_SET) or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; } else { substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ; } return 1; } sub outputPayload { my $self = shift ; return $self->output(@_); } sub output { my $self = shift ; my $data = shift ; my $last = shift ; return 1 if length $data == 0 && ! $last ; if ( *$self->{FilterContainer} ) { *_ = \$data; &{ *$self->{FilterContainer} }(); } if (length $data) { if ( defined *$self->{FH} ) { defined *$self->{FH}->write( $data, length $data ) or return $self->saveErrorString(0, $!, $!); } else { ${ *$self->{Buffer} } .= $data ; } } return 1; } sub getOneShotParams { return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 1], ); } our %PARAMS = ( # Generic Parameters 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0], 'encode' => [IO::Compress::Base::Common::Parse_any, undef], 'strict' => [IO::Compress::Base::Common::Parse_boolean, 1], 'append' => [IO::Compress::Base::Common::Parse_boolean, 0], 'binmodein' => [IO::Compress::Base::Common::Parse_boolean, 0], 'filtercontainer' => [IO::Compress::Base::Common::Parse_code, undef], ); sub checkParams { my $self = shift ; my $class = shift ; my $got = shift || IO::Compress::Base::Parameters::new(); $got->parse( { %PARAMS, $self->getExtraParams(), *$self->{OneShot} ? $self->getOneShotParams() : (), }, @_) or $self->croakError("${class}: " . $got->getError()) ; return $got ; } sub _create { my $obj = shift; my $got = shift; *$obj->{Closed} = 1 ; my $class = ref $obj; $obj->croakError("$class: Missing Output parameter") if ! @_ && ! $got ; my $outValue = shift ; my $oneShot = 1 ; if (! $got) { $oneShot = 0 ; $got = $obj->checkParams($class, undef, @_) or return undef ; } my $lax = ! $got->getValue('strict') ; my $outType = IO::Compress::Base::Common::whatIsOutput($outValue); $obj->ckOutputParam($class, $outValue) or return undef ; if ($outType eq 'buffer') { *$obj->{Buffer} = $outValue; } else { my $buff = "" ; *$obj->{Buffer} = \$buff ; } # Merge implies Append my $merge = $got->getValue('merge') ; my $appendOutput = $got->getValue('append') || $merge ; *$obj->{Append} = $appendOutput; *$obj->{FilterContainer} = $got->getValue('filtercontainer') ; if ($merge) { # Switch off Merge mode if output file/buffer is empty/doesn't exist if (($outType eq 'buffer' && length $$outValue == 0 ) || ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) { $merge = 0 } } # If output is a file, check that it is writable #no warnings; #if ($outType eq 'filename' && -e $outValue && ! -w _) # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } $obj->ckParams($got) or $obj->croakError("${class}: " . $obj->error()); if ($got->getValue('encode')) { my $want_encoding = $got->getValue('encode'); *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding); my $x = *$obj->{Encoding}; } else { *$obj->{Encoding} = undef; } $obj->saveStatus(STATUS_OK) ; my $status ; if (! $merge) { *$obj->{Compress} = $obj->mkComp($got) or return undef; *$obj->{UnCompSize} = new U64 ; *$obj->{CompSize} = new U64 ; if ( $outType eq 'buffer') { ${ *$obj->{Buffer} } = '' unless $appendOutput ; } else { if ($outType eq 'handle') { *$obj->{FH} = $outValue ; setBinModeOutput(*$obj->{FH}) ; #$outValue->flush() ; *$obj->{Handle} = 1 ; if ($appendOutput) { seek(*$obj->{FH}, 0, IO::Handle::SEEK_END) or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; } } elsif ($outType eq 'filename') { no warnings; my $mode = '>' ; $mode = '>>' if $appendOutput; *$obj->{FH} = new IO::File "$mode $outValue" or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; *$obj->{StdIO} = ($outValue eq '-'); setBinModeOutput(*$obj->{FH}) ; } } *$obj->{Header} = $obj->mkHeader($got) ; $obj->output( *$obj->{Header} ) or return undef; $obj->beforePayload(); } else { *$obj->{Compress} = $obj->createMerge($outValue, $outType) or return undef; } *$obj->{Closed} = 0 ; *$obj->{AutoClose} = $got->getValue('autoclose') ; *$obj->{Output} = $outValue; *$obj->{ClassName} = $class; *$obj->{Got} = $got; *$obj->{OneShot} = 0 ; return $obj ; } sub ckOutputParam { my $self = shift ; my $from = shift ; my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]); $self->croakError("$from: output parameter not a filename, filehandle or scalar ref") if ! $outType ; #$self->croakError("$from: output filename is undef or null string") #if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; $self->croakError("$from: output buffer is read-only") if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] }); return 1; } sub _def { my $obj = shift ; my $class= (caller)[0] ; my $name = (caller(1))[3] ; $obj->croakError("$name: expected at least 1 parameters\n") unless @_ >= 1 ; my $input = shift ; my $haveOut = @_ ; my $output = shift ; my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) or return undef ; push @_, $output if $haveOut && $x->{Hash}; *$obj->{OneShot} = 1 ; my $got = $obj->checkParams($name, undef, @_) or return undef ; $x->{Got} = $got ; # if ($x->{Hash}) # { # while (my($k, $v) = each %$input) # { # $v = \$input->{$k} # unless defined $v ; # # $obj->_singleTarget($x, 1, $k, $v, @_) # or return undef ; # } # # return keys %$input ; # } if ($x->{GlobMap}) { $x->{oneInput} = 1 ; foreach my $pair (@{ $x->{Pairs} }) { my ($from, $to) = @$pair ; $obj->_singleTarget($x, 1, $from, $to, @_) or return undef ; } return scalar @{ $x->{Pairs} } ; } if (! $x->{oneOutput} ) { my $inFile = ($x->{inType} eq 'filenames' || $x->{inType} eq 'filename'); $x->{inType} = $inFile ? 'filename' : 'buffer'; foreach my $in ($x->{oneInput} ? $input : @$input) { my $out ; $x->{oneInput} = 1 ; $obj->_singleTarget($x, $inFile, $in, \$out, @_) or return undef ; push @$output, \$out ; #if ($x->{outType} eq 'array') # { push @$output, \$out } #else # { $output->{$in} = \$out } } return 1 ; } # finally the 1 to 1 and n to 1 return $obj->_singleTarget($x, 1, $input, $output, @_); Carp::croak "should not be here" ; } sub _singleTarget { my $obj = shift ; my $x = shift ; my $inputIsFilename = shift; my $input = shift; if ($x->{oneInput}) { $obj->getFileInfo($x->{Got}, $input) if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ; my $z = $obj->_create($x->{Got}, @_) or return undef ; defined $z->_wr2($input, $inputIsFilename) or return $z->closeError(undef) ; return $z->close() ; } else { my $afterFirst = 0 ; my $inputIsFilename = ($x->{inType} ne 'array'); my $keep = $x->{Got}->clone(); #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) for my $element ( @$input) { my $isFilename = isaFilename($element); if ( $afterFirst ++ ) { defined addInterStream($obj, $element, $isFilename) or return $obj->closeError(undef) ; } else { $obj->getFileInfo($x->{Got}, $element) if isaScalar($element) || $isFilename; $obj->_create($x->{Got}, @_) or return undef ; } defined $obj->_wr2($element, $isFilename) or return $obj->closeError(undef) ; *$obj->{Got} = $keep->clone(); } return $obj->close() ; } } sub _wr2 { my $self = shift ; my $source = shift ; my $inputIsFilename = shift; my $input = $source ; if (! $inputIsFilename) { $input = \$source if ! ref $source; } if ( ref $input && ref $input eq 'SCALAR' ) { return $self->syswrite($input, @_) ; } if ( ! ref $input || isaFilehandle($input)) { my $isFilehandle = isaFilehandle($input) ; my $fh = $input ; if ( ! $isFilehandle ) { $fh = new IO::File "<$input" or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; } binmode $fh ; my $status ; my $buff ; my $count = 0 ; while ($status = read($fh, $buff, 16 * 1024)) { $count += length $buff; defined $self->syswrite($buff, @_) or return undef ; } return $self->saveErrorString(undef, $!, $!) if ! defined $status ; if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-') { $fh->close() or return undef ; } return $count ; } Carp::croak "Should not be here"; return undef; } sub addInterStream { my $self = shift ; my $input = shift ; my $inputIsFilename = shift ; if (*$self->{Got}->getValue('multistream')) { $self->getFileInfo(*$self->{Got}, $input) #if isaFilename($input) and $inputIsFilename ; if isaScalar($input) || isaFilename($input) ; # TODO -- newStream needs to allow gzip/zip header to be modified return $self->newStream(); } elsif (*$self->{Got}->getValue('autoflush')) { #return $self->flush(Z_FULL_FLUSH); } return 1 ; } sub getFileInfo { } sub TIEHANDLE { return $_[0] if ref($_[0]); die "OOPS\n" ; } sub UNTIE { my $self = shift ; } sub DESTROY { my $self = shift ; local ($., $@, $!, $^E, $?); $self->close() ; # TODO - memory leak with 5.8.0 - this isn't called until # global destruction # %{ *$self } = () ; undef $self ; } sub filterUncompressed { } sub syswrite { my $self = shift ; my $buffer ; if (ref $_[0] ) { $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" ) unless ref $_[0] eq 'SCALAR' ; $buffer = $_[0] ; } else { $buffer = \$_[0] ; } if (@_ > 1) { my $slen = defined $$buffer ? length($$buffer) : 0; my $len = $slen; my $offset = 0; $len = $_[1] if $_[1] < $len; if (@_ > 2) { $offset = $_[2] || 0; $self->croakError(*$self->{ClassName} . "::write: offset outside string") if $offset > $slen; if ($offset < 0) { $offset += $slen; $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0; } my $rem = $slen - $offset; $len = $rem if $rem < $len; } $buffer = \substr($$buffer, $offset, $len) ; } return 0 if (! defined $$buffer || length $$buffer == 0) && ! *$self->{FlushPending}; # *$self->{Pending} .= $$buffer ; # # return length $$buffer # if (length *$self->{Pending} < 1024 * 16 && ! *$self->{FlushPending}) ; # # $$buffer = *$self->{Pending} ; # *$self->{Pending} = ''; if (*$self->{Encoding}) { $$buffer = *$self->{Encoding}->encode($$buffer); } else { $] >= 5.008 and ( utf8::downgrade($$buffer, 1) or Carp::croak "Wide character in " . *$self->{ClassName} . "::write:"); } $self->filterUncompressed($buffer); my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; *$self->{UnCompSize}->add($buffer_length) ; my $outBuffer=''; my $status = *$self->{Compress}->compr($buffer, $outBuffer) ; return $self->saveErrorString(undef, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) if $status == STATUS_ERROR; *$self->{CompSize}->add(length $outBuffer) ; $self->outputPayload($outBuffer) or return undef; return $buffer_length; } sub print { my $self = shift; #if (ref $self) { # $self = *$self{GLOB} ; #} if (defined $\) { if (defined $,) { defined $self->syswrite(join($,, @_) . $\); } else { defined $self->syswrite(join("", @_) . $\); } } else { if (defined $,) { defined $self->syswrite(join($,, @_)); } else { defined $self->syswrite(join("", @_)); } } } sub printf { my $self = shift; my $fmt = shift; defined $self->syswrite(sprintf($fmt, @_)); } sub _flushCompressed { my $self = shift ; my $outBuffer=''; my $status = *$self->{Compress}->flush($outBuffer, @_) ; return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) if $status == STATUS_ERROR; if ( defined *$self->{FH} ) { *$self->{FH}->clearerr(); } *$self->{CompSize}->add(length $outBuffer) ; $self->outputPayload($outBuffer) or return 0; return 1; } sub flush { my $self = shift ; $self->_flushCompressed(@_) or return 0; if ( defined *$self->{FH} ) { defined *$self->{FH}->flush() or return $self->saveErrorString(0, $!, $!); } return 1; } sub beforePayload { } sub _newStream { my $self = shift ; my $got = shift; my $class = ref $self; $self->_writeTrailer() or return 0 ; $self->ckParams($got) or $self->croakError("newStream: $self->{Error}"); if ($got->getValue('encode')) { my $want_encoding = $got->getValue('encode'); *$self->{Encoding} = IO::Compress::Base::Common::getEncoding($self, $class, $want_encoding); } else { *$self->{Encoding} = undef; } *$self->{Compress} = $self->mkComp($got) or return 0; *$self->{Header} = $self->mkHeader($got) ; $self->output(*$self->{Header} ) or return 0; *$self->{UnCompSize}->reset(); *$self->{CompSize}->reset(); $self->beforePayload(); return 1 ; } sub newStream { my $self = shift ; my $got = $self->checkParams('newStream', *$self->{Got}, @_) or return 0 ; $self->_newStream($got); # *$self->{Compress} = $self->mkComp($got) # or return 0; # # *$self->{Header} = $self->mkHeader($got) ; # $self->output(*$self->{Header} ) # or return 0; # # *$self->{UnCompSize}->reset(); # *$self->{CompSize}->reset(); # # $self->beforePayload(); # # return 1 ; } sub reset { my $self = shift ; return *$self->{Compress}->reset() ; } sub _writeTrailer { my $self = shift ; my $trailer = ''; my $status = *$self->{Compress}->close($trailer) ; return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) if $status == STATUS_ERROR; *$self->{CompSize}->add(length $trailer) ; $trailer .= $self->mkTrailer(); defined $trailer or return 0; return $self->output($trailer); } sub _writeFinalTrailer { my $self = shift ; return $self->output($self->mkFinalTrailer()); } sub close { my $self = shift ; return 1 if *$self->{Closed} || ! *$self->{Compress} ; *$self->{Closed} = 1 ; untie *$self if $] >= 5.008 ; *$self->{FlushPending} = 1 ; $self->_writeTrailer() or return 0 ; $self->_writeFinalTrailer() or return 0 ; $self->output( "", 1 ) or return 0; if (defined *$self->{FH}) { if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { $! = 0 ; *$self->{FH}->close() or return $self->saveErrorString(0, $!, $!); } delete *$self->{FH} ; # This delete can set $! in older Perls, so reset the errno $! = 0 ; } return 1; } #sub total_in #sub total_out #sub msg # #sub crc #{ # my $self = shift ; # return *$self->{Compress}->crc32() ; #} # #sub msg #{ # my $self = shift ; # return *$self->{Compress}->msg() ; #} # #sub dict_adler #{ # my $self = shift ; # return *$self->{Compress}->dict_adler() ; #} # #sub get_Level #{ # my $self = shift ; # return *$self->{Compress}->get_Level() ; #} # #sub get_Strategy #{ # my $self = shift ; # return *$self->{Compress}->get_Strategy() ; #} sub tell { my $self = shift ; return *$self->{UnCompSize}->get32bit() ; } sub eof { my $self = shift ; return *$self->{Closed} ; } sub seek { my $self = shift ; my $position = shift; my $whence = shift ; my $here = $self->tell() ; my $target = 0 ; #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); use IO::Handle ; if ($whence == IO::Handle::SEEK_SET) { $target = $position ; } elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { $target = $here + $position ; } else { $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"); } # short circuit if seeking to current offset return 1 if $target == $here ; # Outlaw any attempt to seek backwards $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards") if $target < $here ; # Walk the file to the new offset my $offset = $target - $here ; my $buffer ; defined $self->syswrite("\x00" x $offset) or return 0; return 1 ; } sub binmode { 1; # my $self = shift ; # return defined *$self->{FH} # ? binmode *$self->{FH} # : 1 ; } sub fileno { my $self = shift ; return defined *$self->{FH} ? *$self->{FH}->fileno() : undef ; } sub opened { my $self = shift ; return ! *$self->{Closed} ; } sub autoflush { my $self = shift ; return defined *$self->{FH} ? *$self->{FH}->autoflush(@_) : undef ; } sub input_line_number { return undef ; } sub _notAvailable { my $name = shift ; return sub { Carp::croak "$name Not Available: File opened only for output" ; } ; } *read = _notAvailable('read'); *READ = _notAvailable('read'); *readline = _notAvailable('readline'); *READLINE = _notAvailable('readline'); *getc = _notAvailable('getc'); *GETC = _notAvailable('getc'); *FILENO = \&fileno; *PRINT = \&print; *PRINTF = \&printf; *WRITE = \&syswrite; *write = \&syswrite; *SEEK = \&seek; *TELL = \&tell; *EOF = \&eof; *CLOSE = \&close; *BINMODE = \&binmode; #*sysread = \&_notAvailable; #*syswrite = \&_write; 1; __END__ =head1 NAME IO::Compress::Base - Base Class for IO::Compress modules =head1 SYNOPSIS use IO::Compress::Base ; =head1 DESCRIPTION This module is not intended for direct use in application code. Its sole purpose is to be sub-classed by IO::Compress modules. =head1 SUPPORT General feedback/questions/bug reports should be sent to L<https://github.com/pmqs/IO-Compress/issues> (preferred) or L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> L<IO::Compress::FAQ|IO::Compress::FAQ> L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, L<Archive::Tar|Archive::Tar>, L<IO::Zlib|IO::Zlib> =head1 AUTHOR This module was written by Paul Marquess, C<pmqs@cpan.org>. =head1 MODIFICATION HISTORY See the Changes file. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005-2019 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. usr/share/perl/5.32.1/TAP/Base.pm 0000644 00000004375 15145643140 0012017 0 ustar 00 package TAP::Base; use strict; use warnings; use base 'TAP::Object'; =head1 NAME TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness> =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; $@ ? 0 : 1; }; =head1 SYNOPSIS package TAP::Whatever; use base 'TAP::Base'; # ... later ... my $thing = TAP::Whatever->new(); $thing->callback( event => sub { # do something interesting } ); =head1 DESCRIPTION C<TAP::Base> provides callback management. =head1 METHODS =head2 Class Methods =cut sub _initialize { my ( $self, $arg_for, $ok_callback ) = @_; my %ok_map = map { $_ => 1 } @$ok_callback; $self->{ok_callbacks} = \%ok_map; if ( my $cb = delete $arg_for->{callbacks} ) { while ( my ( $event, $callback ) = each %$cb ) { $self->callback( $event, $callback ); } } return $self; } =head3 C<callback> Install a callback for a named event. =cut sub callback { my ( $self, $event, $callback ) = @_; my %ok_map = %{ $self->{ok_callbacks} }; $self->_croak('No callbacks may be installed') unless %ok_map; $self->_croak( "Callback $event is not supported. Valid callbacks are " . join( ', ', sort keys %ok_map ) ) unless exists $ok_map{$event}; push @{ $self->{code_for}{$event} }, $callback; return; } sub _has_callbacks { my $self = shift; return keys %{ $self->{code_for} } != 0; } sub _callback_for { my ( $self, $event ) = @_; return $self->{code_for}{$event}; } sub _make_callback { my $self = shift; my $event = shift; my $cb = $self->_callback_for($event); return unless defined $cb; return map { $_->(@_) } @$cb; } =head3 C<get_time> Return the current time using Time::HiRes if available. =cut sub get_time { return time() } =head3 C<time_is_hires> Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available). =cut sub time_is_hires { return GOT_TIME_HIRES } =head3 C<get_times> Return array reference of the four-element list of CPU seconds, as with L<perlfunc/times>. =cut sub get_times { return [ times() ] } 1; usr/share/perl/5.32.1/ExtUtils/Constant/Base.pm 0000644 00000101052 15145662644 0014745 0 ustar 00 package ExtUtils::Constant::Base; use strict; use vars qw($VERSION); use Carp; use Text::Wrap; use ExtUtils::Constant::Utils qw(C_stringify perl_stringify); $VERSION = '0.06'; use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); =head1 NAME ExtUtils::Constant::Base - base class for ExtUtils::Constant objects =head1 SYNOPSIS require ExtUtils::Constant::Base; @ISA = 'ExtUtils::Constant::Base'; =head1 DESCRIPTION ExtUtils::Constant::Base provides a base implementation of methods to generate C code to give fast constant value lookup by named string. Currently it's mostly used ExtUtils::Constant::XS, which generates the lookup code for the constant() subroutine found in many XS modules. =head1 USAGE ExtUtils::Constant::Base exports no subroutines. The following methods are available =over 4 =cut sub valid_type { # Default to assuming that you don't need different types of return data. 1; } sub default_type { ''; } =item header A method returning a scalar containing definitions needed, typically for a C header file. =cut sub header { '' } # This might actually be a return statement. Note that you are responsible # for any space you might need before your value, as it lets to perform # "tricks" such as "return KEY_" and have strings appended. sub assignment_clause_for_type; # In which case this might be an empty string sub return_statement_for_type {undef}; sub return_statement_for_notdef; sub return_statement_for_notfound; # "#if 1" is true to a C pre-processor sub macro_from_name { 1; } sub macro_from_item { 1; } sub macro_to_ifdef { my ($self, $macro) = @_; if (ref $macro) { return $macro->[0]; } if (defined $macro && $macro ne "" && $macro ne "1") { return $macro ? "#ifdef $macro\n" : "#if 0\n"; } return ""; } sub macro_to_ifndef { my ($self, $macro) = @_; if (ref $macro) { # Can't invert these stylishly, so "bodge it" return "$macro->[0]#else\n"; } if (defined $macro && $macro ne "" && $macro ne "1") { return $macro ? "#ifndef $macro\n" : "#if 1\n"; } croak "Can't generate an ifndef for unconditional code"; } sub macro_to_endif { my ($self, $macro) = @_; if (ref $macro) { return $macro->[1]; } if (defined $macro && $macro ne "" && $macro ne "1") { return "#endif\n"; } return ""; } sub name_param { 'name'; } # This is possibly buggy, in that it's not mandatory (below, in the main # C_constant parameters, but is expected to exist here, if it's needed) # Buggy because if you're definitely pure 8 bit only, and will never be # presented with your constants in utf8, the default form of C_constant can't # be told not to do the utf8 version. sub is_utf8_param { 'utf8'; } sub memEQ { "!memcmp"; } =item memEQ_clause args_hashref A method to return a suitable C C<if> statement to check whether I<name> is equal to the C variable C<name>. If I<checked_at> is defined, then it is used to avoid C<memEQ> for short names, or to generate a comment to highlight the position of the character in the C<switch> statement. If i<checked_at> is a reference to a scalar, then instead it gives the characters pre-checked at the beginning, (and the number of chars by which the C variable name has been advanced. These need to be chopped from the front of I<name>). =cut sub memEQ_clause { # if (memEQ(name, "thingy", 6)) { # Which could actually be a character comparison or even "" my ($self, $args) = @_; my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)}; $indent = ' ' x ($indent || 4); my $front_chop; if (ref $checked_at) { # regexp won't work on 5.6.1 without use utf8; in turn that won't work # on 5.005_03. substr ($name, 0, length $$checked_at,) = ''; $front_chop = C_stringify ($$checked_at); undef $checked_at; } my $len = length $name; if ($len < 2) { return $indent . "{\n" if (defined $checked_at and $checked_at == 0) or $len == 0; # We didn't switch, drop through to the code for the 2 character string $checked_at = 1; } my $name_param = $self->name_param; if ($len < 3 and defined $checked_at) { my $check; if ($checked_at == 1) { $check = 0; } elsif ($checked_at == 0) { $check = 1; } if (defined $check) { my $char = C_stringify (substr $name, $check, 1); # Placate 5.005 with a break in the string. I can't see a good way of # getting it to not take [ as introducing an array lookup, even with # ${name_param}[$check] return $indent . "if ($name_param" . "[$check] == '$char') {\n"; } } if (($len == 2 and !defined $checked_at) or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { my $char1 = C_stringify (substr $name, 0, 1); my $char2 = C_stringify (substr $name, 1, 1); return $indent . "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n"; } if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { my $char1 = C_stringify (substr $name, 0, 1); my $char2 = C_stringify (substr $name, 2, 1); return $indent . "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n"; } my $pointer = '^'; my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; if ($have_checked_last) { # Checked at the last character, so no need to memEQ it. $pointer = C_stringify (chop $name); $len--; } $name = C_stringify ($name); my $memEQ = $self->memEQ(); my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n"; # Put a little ^ under the letter we checked at # Screws up for non printable and non-7 bit stuff, but that's too hard to # get right. if (defined $checked_at) { $body .= $indent . "/* " . (' ' x length $memEQ) . (' ' x length $name_param) . (' ' x $checked_at) . $pointer . (' ' x ($len - $checked_at + length $len)) . " */\n"; } elsif (defined $front_chop) { $body .= $indent . "/* $front_chop" . (' ' x ($len + 1 + length $len)) . " */\n"; } return $body; } =item dump_names arg_hashref, ITEM... An internal function to generate the embedded perl code that will regenerate the constant subroutines. I<default_type>, I<types> and I<ITEM>s are the same as for C_constant. I<indent> is treated as number of spaces to indent by. If C<declare_types> is true a C<$types> is always declared in the perl code generated, if defined and false never declared, and if undefined C<$types> is only declared if the values in I<types> as passed in cannot be inferred from I<default_types> and the I<ITEM>s. =cut sub dump_names { my ($self, $args, @items) = @_; my ($default_type, $what, $indent, $declare_types) = @{$args}{qw(default_type what indent declare_types)}; $indent = ' ' x ($indent || 0); my $result; my (@simple, @complex, %used_types); foreach (@items) { my $type; if (ref $_) { $type = $_->{type} || $default_type; if ($_->{utf8}) { # For simplicity always skip the bytes case, and reconstitute this entry # from its utf8 twin. next if $_->{utf8} eq 'no'; # Copy the hashref, as we don't want to mess with the caller's hashref. $_ = {%$_}; unless (is_perl56) { utf8::decode ($_->{name}); } else { $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; } delete $_->{utf8}; } } else { $_ = {name=>$_}; $type = $default_type; } $used_types{$type}++; if ($type eq $default_type # grr 5.6.1 and length $_->{name} and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) and !defined ($_->{macro}) and !defined ($_->{value}) and !defined ($_->{default}) and !defined ($_->{pre}) and !defined ($_->{post}) and !defined ($_->{def_pre}) and !defined ($_->{def_post}) and !defined ($_->{weight})) { # It's the default type, and the name consists only of A-Za-z0-9_ push @simple, $_->{name}; } else { push @complex, $_; } } if (!defined $declare_types) { # Do they pass in any types we weren't already using? foreach (keys %$what) { next if $used_types{$_}; $declare_types++; # Found one in $what that wasn't used. last; # And one is enough to terminate this loop } } if ($declare_types) { $result = $indent . 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what) . ")};\n"; } local $Text::Wrap::huge = 'overflow'; local $Text::Wrap::columns = 80; $result .= wrap ($indent . "my \@names = (qw(", $indent . " ", join (" ", sort @simple) . ")"); if (@complex) { foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { my $name = perl_stringify $item->{name}; my $line = ",\n$indent {name=>\"$name\""; $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; foreach my $thing (qw (macro value default pre post def_pre def_post)) { my $value = $item->{$thing}; if (defined $value) { if (ref $value) { $line .= ", $thing=>[\"" . join ('", "', map {perl_stringify $_} @$value) . '"]'; } else { $line .= ", $thing=>\"" . perl_stringify($value) . "\""; } } } $line .= "}"; # Ensure that the enclosing C comment doesn't end # by turning */ into *" . "/ $line =~ s!\*\/!\*" . "/!gs; # gcc -Wall doesn't like finding /* inside a comment $line =~ s!\/\*!/" . "\*!gs; $result .= $line; } } $result .= ");\n"; $result; } =item assign arg_hashref, VALUE... A method to return a suitable assignment clause. If I<type> is aggregate (eg I<PVN> expects both pointer and length) then there should be multiple I<VALUE>s for the components. I<pre> and I<post> if defined give snippets of C code to proceed and follow the assignment. I<pre> will be at the start of a block, so variables may be defined in it. =cut # Hmm. value undef to do NOTDEF? value () to do NOTFOUND? sub assign { my $self = shift; my $args = shift; my ($indent, $type, $pre, $post, $item) = @{$args}{qw(indent type pre post item)}; $post ||= ''; my $clause; my $close; if ($pre) { chomp $pre; $close = "$indent}\n"; $clause = $indent . "{\n"; $indent .= " "; $clause .= "$indent$pre"; $clause .= ";" unless $pre =~ /;$/; $clause .= "\n"; } confess "undef \$type" unless defined $type; confess "Can't generate code for type $type" unless $self->valid_type($type); $clause .= join '', map {"$indent$_\n"} $self->assignment_clause_for_type({type=>$type,item=>$item}, @_); chomp $post; if (length $post) { $clause .= "$post"; $clause .= ";" unless $post =~ /;$/; $clause .= "\n"; } my $return = $self->return_statement_for_type($type); $clause .= "$indent$return\n" if defined $return; $clause .= $close if $close; return $clause; } =item return_clause arg_hashref, ITEM A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref (as passed to C<C_constant> and C<match_clause>. I<indent> is the number of spaces to indent, defaulting to 6. =cut sub return_clause { ##ifdef thingy # *iv_return = thingy; # return PERL_constant_ISIV; ##else # return PERL_constant_NOTDEF; ##endif my ($self, $args, $item) = @_; my $indent = $args->{indent}; my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type) = @$item{qw (name value default pre post def_pre def_post type)}; $value = $name unless defined $value; my $macro = $self->macro_from_item($item); $indent = ' ' x ($indent || 6); unless (defined $type) { # use Data::Dumper; print STDERR Dumper ($item); confess "undef \$type"; } ##ifdef thingy my $clause = $self->macro_to_ifdef($macro); # *iv_return = thingy; # return PERL_constant_ISIV; $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post, item=>$item}, ref $value ? @$value : $value); if (defined $macro && $macro ne "" && $macro ne "1") { ##else $clause .= "#else\n"; # return PERL_constant_NOTDEF; if (!defined $default) { my $notdef = $self->return_statement_for_notdef(); $clause .= "$indent$notdef\n" if defined $notdef; } else { my @default = ref $default ? @$default : $default; $type = shift @default; $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post, item=>$item}, @default); } } ##endif $clause .= $self->macro_to_endif($macro); return $clause; } sub match_clause { # $offset defined if we have checked an offset. my ($self, $args, $item) = @_; my ($offset, $indent) = @{$args}{qw(checked_at indent)}; $indent = ' ' x ($indent || 4); my $body = ''; my ($no, $yes, $either, $name, $inner_indent); if (ref $item eq 'ARRAY') { ($yes, $no) = @$item; $either = $yes || $no; confess "$item is $either expecting hashref in [0] || [1]" unless ref $either eq 'HASH'; $name = $either->{name}; } else { confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" if $item->{utf8}; $name = $item->{name}; $inner_indent = $indent; } $body .= $self->memEQ_clause ({name => $name, checked_at => $offset, indent => length $indent}); # If we've been presented with an arrayref for $item, then the user string # contains in the range 128-255, and we need to check whether it was utf8 # (or not). # In the worst case we have two named constants, where one's name happens # encoded in UTF8 happens to be the same byte sequence as the second's # encoded in (say) ISO-8859-1. # In this case, $yes and $no both have item hashrefs. if ($yes) { $body .= $indent . " if (" . $self->is_utf8_param . ") {\n"; } elsif ($no) { $body .= $indent . " if (!" . $self->is_utf8_param . ") {\n"; } if ($either) { $body .= $self->return_clause ({indent=>4 + length $indent}, $either); if ($yes and $no) { $body .= $indent . " } else {\n"; $body .= $self->return_clause ({indent=>4 + length $indent}, $no); } $body .= $indent . " }\n"; } else { $body .= $self->return_clause ({indent=>2 + length $indent}, $item); } $body .= $indent . "}\n"; } =item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM... An internal method to generate a suitable C<switch> clause, called by C<C_constant> I<ITEM>s are in the hash ref format as given in the description of C<C_constant>, and must all have the names of the same length, given by I<NAMELEN>. I<ITEMHASH> is a reference to a hash, keyed by name, values being the hashrefs in the I<ITEM> list. (No parameters are modified, and there can be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without causing problems - the hash is passed in to save generating it afresh for each call). =cut sub switch_clause { my ($self, $args, $namelen, $items, @items) = @_; my ($indent, $comment) = @{$args}{qw(indent comment)}; $indent = ' ' x ($indent || 2); local $Text::Wrap::huge = 'overflow'; local $Text::Wrap::columns = 80; my @names = sort map {$_->{name}} @items; my $leader = $indent . '/* '; my $follower = ' ' x length $leader; my $body = $indent . "/* Names all of length $namelen. */\n"; if (defined $comment) { $body = wrap ($leader, $follower, $comment) . "\n"; $leader = $follower; } my @safe_names = @names; foreach (@safe_names) { confess sprintf "Name '$_' is length %d, not $namelen", length unless length == $namelen; # Argh. 5.6.1 # next unless tr/A-Za-z0-9_//c; next if tr/A-Za-z0-9_// == length; $_ = '"' . perl_stringify ($_) . '"'; # Ensure that the enclosing C comment doesn't end # by turning */ into *" . "/ s!\*\/!\*"."/!gs; # gcc -Wall doesn't like finding /* inside a comment s!\/\*!/"."\*!gs; } $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; # Figure out what to switch on. # (RMS, Spread of jump table, Position, Hashref) my @best = (1e38, ~0); # Prefer the last character over the others. (As it lets us shorten the # memEQ clause at no cost). foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { my ($min, $max) = (~0, 0); my %spread; if (is_perl56) { # Need proper Unicode preserving hash keys for bytes in range 128-255 # here too, for some reason. grr 5.6.1 yet again. tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; } foreach (@names) { my $char = substr $_, $i, 1; my $ord = ord $char; confess "char $ord is out of range" if $ord > 255; $max = $ord if $ord > $max; $min = $ord if $ord < $min; push @{$spread{$char}}, $_; # warn "$_ $char"; } # I'm going to pick the character to split on that minimises the root # mean square of the number of names in each case. Normally this should # be the one with the most keys, but it may pick a 7 where the 8 has # one long linear search. I'm not sure if RMS or just sum of squares is # actually better. # $max and $min are for the tie-breaker if the root mean squares match. # Assuming that the compiler may be building a jump table for the # switch() then try to minimise the size of that jump table. # Finally use < not <= so that if it still ties the earliest part of # the string wins. Because if that passes but the memEQ fails, it may # only need the start of the string to bin the choice. # I think. But I'm micro-optimising. :-) # OK. Trump that. Now favour the last character of the string, before the # rest. my $ss; $ss += @$_ * @$_ foreach values %spread; my $rms = sqrt ($ss / keys %spread); if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { @best = ($rms, $max - $min, $i, \%spread); } } confess "Internal error. Failed to pick a switch point for @names" unless defined $best[2]; # use Data::Dumper; print Dumper (@best); my ($offset, $best) = @best[2,3]; $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; my $do_front_chop = $offset == 0 && $namelen > 2; if ($do_front_chop) { $body .= $indent . "switch (*" . $self->name_param() . "++) {\n"; } else { $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n"; } foreach my $char (sort keys %$best) { confess sprintf "'$char' is %d bytes long, not 1", length $char if length ($char) != 1; confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; $body .= $indent . "case '" . C_stringify ($char) . "':\n"; foreach my $thisone (sort { # Deal with the case of an item actually being an array ref to 1 or 2 # hashrefs. Don't assign to $a or $b, as they're aliases to the # original my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a; my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b; # Sort by weight first ($r->{weight} || 0) <=> ($l->{weight} || 0) # Sort equal weights by name or $l->{name} cmp $r->{name}} # If this looks evil, maybe it is. $items is a # hashref, and we're doing a hash slice on it @{$items}{@{$best->{$char}}}) { # warn "You are here"; if ($do_front_chop) { $body .= $self->match_clause ({indent => 2 + length $indent, checked_at => \$char}, $thisone); } else { $body .= $self->match_clause ({indent => 2 + length $indent, checked_at => $offset}, $thisone); } } $body .= $indent . " break;\n"; } $body .= $indent . "}\n"; return $body; } sub C_constant_return_type { "static int"; } sub C_constant_prefix_param { ''; } sub C_constant_prefix_param_defintion { ''; } sub name_param_definition { "const char *" . $_[0]->name_param; } sub namelen_param { 'len'; } sub namelen_param_definition { 'size_t ' . $_[0]->namelen_param; } sub C_constant_other_params { ''; } sub C_constant_other_params_defintion { ''; } =item params WHAT An "internal" method, subject to change, currently called to allow an overriding class to cache information that will then be passed into all the C<*param*> calls. (Yes, having to read the source to make sense of this is considered a known bug). I<WHAT> is be a hashref of types the constant function will return. In ExtUtils::Constant::XS this method is used to returns a hashref keyed IV NV PV SV to show which combination of pointers will be needed in the C argument list generated by C_constant_other_params_definition and C_constant_other_params =cut sub params { ''; } =item dogfood arg_hashref, ITEM... An internal function to generate the embedded perl code that will regenerate the constant subroutines. Parameters are the same as for C_constant. Currently the base class does nothing and returns an empty string. =cut sub dogfood { '' } =item normalise_items args, default_type, seen_types, seen_items, ITEM... Convert the items to a normalised form. For 8 bit and Unicode values converts the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded. =cut sub normalise_items { my $self = shift; my $args = shift; my $default_type = shift; my $what = shift; my $items = shift; my @new_items; foreach my $orig (@_) { my ($name, $item); if (ref $orig) { # Make a copy which is a normalised version of the ref passed in. $name = $orig->{name}; my ($type, $macro, $value) = @$orig{qw (type macro value)}; $type ||= $default_type; $what->{$type} = 1; $item = {name=>$name, type=>$type}; undef $macro if defined $macro and $macro eq $name; $item->{macro} = $macro if defined $macro; undef $value if defined $value and $value eq $name; $item->{value} = $value if defined $value; foreach my $key (qw(default pre post def_pre def_post weight not_constant)) { my $value = $orig->{$key}; $item->{$key} = $value if defined $value; # warn "$key $value"; } } else { $name = $orig; $item = {name=>$name, type=>$default_type}; $what->{$default_type} = 1; } warn +(ref ($self) || $self) . "doesn't know how to handle values of type $_ used in macro $name" unless $self->valid_type ($item->{type}); # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c # doesn't work. Upgrade to 5.8 # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50 || $args->{disable_utf8_duplication}) { # No characters outside 7 bit ASCII. if (exists $items->{$name}) { die "Multiple definitions for macro $name"; } $items->{$name} = $item; } else { # No characters outside 8 bit. This is hardest. if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { confess "Unexpected ASCII definition for macro $name"; } # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; # if ($name !~ tr/\0-\377//c) { if ($name =~ tr/\0-\377// == length $name) { # if ($] < 5.007) { # $name = pack "C*", unpack "U*", $name; # } $item->{utf8} = 'no'; $items->{$name}[1] = $item; push @new_items, $item; # Copy item, to create the utf8 variant. $item = {%$item}; } # Encode the name as utf8 bytes. unless (is_perl56) { utf8::encode($name); } else { # warn "Was >$name< " . length ${name}; $name = pack 'C*', unpack 'C*', $name . pack 'U*'; # warn "Now '${name}' " . length ${name}; } if ($items->{$name}[0]) { die "Multiple definitions for macro $name"; } $item->{utf8} = 'yes'; $item->{name} = $name; $items->{$name}[0] = $item; # We have need for the utf8 flag. $what->{''} = 1; } push @new_items, $item; } @new_items; } =item C_constant arg_hashref, ITEM... A function that returns a B<list> of C subroutine definitions that return the value and type of constants when passed the name by the XS wrapper. I<ITEM...> gives a list of constant names. Each can either be a string, which is taken as a C macro name, or a reference to a hash with the following keys =over 8 =item name The name of the constant, as seen by the perl code. =item type The type of the constant (I<IV>, I<NV> etc) =item value A C expression for the value of the constant, or a list of C expressions if the type is aggregate. This defaults to the I<name> if not given. =item macro The C pre-processor macro to use in the C<#ifdef>. This defaults to the I<name>, and is mainly used if I<value> is an C<enum>. If a reference an array is passed then the first element is used in place of the C<#ifdef> line, and the second element in place of the C<#endif>. This allows pre-processor constructions such as #if defined (foo) #if !defined (bar) ... #endif #endif to be used to determine if a constant is to be defined. A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> test is omitted. =item default Default value to use (instead of C<croak>ing with "your vendor has not defined...") to return if the macro isn't defined. Specify a reference to an array with type followed by value(s). =item pre C code to use before the assignment of the value of the constant. This allows you to use temporary variables to extract a value from part of a C<struct> and return this as I<value>. This C code is places at the start of a block, so you can declare variables in it. =item post C code to place between the assignment of value (to a temporary) and the return from the function. This allows you to clear up anything in I<pre>. Rarely needed. =item def_pre =item def_post Equivalents of I<pre> and I<post> for the default value. =item utf8 Generated internally. Is zero or undefined if name is 7 bit ASCII, "no" if the name is 8 bit (and so should only match if SvUTF8() is false), "yes" if the name is utf8 encoded. The internals automatically clone any name with characters 128-255 but none 256+ (ie one that could be either in bytes or utf8) into a second entry which is utf8 encoded. =item weight Optional sorting weight for names, to determine the order of linear testing when multiple names fall in the same case of a switch clause. Higher comes earlier, undefined defaults to zero. =back In the argument hashref, I<package> is the name of the package, and is only used in comments inside the generated C code. I<subname> defaults to C<constant> if undefined. I<default_type> is the type returned by C<ITEM>s that don't specify their type. It defaults to the value of C<default_type()>. I<types> should be given either as a comma separated list of types that the C subroutine I<subname> will generate or as a reference to a hash. I<default_type> will be added to the list if not present, as will any types given in the list of I<ITEM>s. The resultant list should be the same list of types that C<XS_constant> is given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of parameters to the constant function. I<indent> is currently unused and ignored. In future it may be used to pass in information used to change the C indentation style used.] The best way to maintain consistency is to pass in a hash reference and let this function update it. I<breakout> governs when child functions of I<subname> are generated. If there are I<breakout> or more I<ITEM>s with the same length of name, then the code to switch between them is placed into a function named I<subname>_I<len>, for example C<constant_5> for names 5 characters long. The default I<breakout> is 3. A single C<ITEM> is always inlined. =cut # The parameter now BREAKOUT was previously documented as: # # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of # this length, and that the constant name passed in by perl is checked and # also of this length. It is used during recursion, and should be C<undef> # unless the caller has checked all the lengths during code generation, and # the generated subroutine is only to be called with a name of this length. # # As you can see it now performs this function during recursion by being a # scalar reference. sub C_constant { my ($self, $args, @items) = @_; my ($package, $subname, $default_type, $what, $indent, $breakout) = @{$args}{qw(package subname default_type types indent breakout)}; $package ||= 'Foo'; $subname ||= 'constant'; # I'm not using this. But a hashref could be used for full formatting without # breaking this API # $indent ||= 0; my ($namelen, $items); if (ref $breakout) { # We are called recursively. We trust @items to be normalised, $what to # be a hashref, and pinch %$items from our parent to save recalculation. ($namelen, $items) = @$breakout; } else { $items = {}; if (is_perl56) { # Need proper Unicode preserving hash keys. require ExtUtils::Constant::Aaargh56Hash; tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; } $breakout ||= 3; $default_type ||= $self->default_type(); if (!ref $what) { # Convert line of the form IV,UV,NV to hash $what = {map {$_ => 1} split /,\s*/, ($what || '')}; # Figure out what types we're dealing with, and assign all unknowns to the # default type } @items = $self->normalise_items ({}, $default_type, $what, $items, @items); # use Data::Dumper; print Dumper @items; } my $params = $self->params ($what); # Probably "static int" my ($body, @subs); $body = $self->C_constant_return_type($params) . "\n$subname (" # Eg "pTHX_ " . $self->C_constant_prefix_param_defintion($params) # Probably "const char *name" . $self->name_param_definition($params); # Something like ", STRLEN len" $body .= ", " . $self->namelen_param_definition($params) unless defined $namelen; $body .= $self->C_constant_other_params_defintion($params); $body .= ") {\n"; if (defined $namelen) { # We are a child subroutine. Print the simple description my $comment = 'When generated this function returned values for the list' . ' of names given here. However, subsequent manual editing may have' . ' added or removed some.'; $body .= $self->switch_clause ({indent=>2, comment=>$comment}, $namelen, $items, @items); } else { # We are the top level. $body .= " /* Initially switch on the length of the name. */\n"; $body .= $self->dogfood ({package => $package, subname => $subname, default_type => $default_type, what => $what, indent => $indent, breakout => $breakout}, @items); $body .= ' switch ('.$self->namelen_param().") {\n"; # Need to group names of the same length my @by_length; foreach (@items) { push @{$by_length[length $_->{name}]}, $_; } foreach my $i (0 .. $#by_length) { next unless $by_length[$i]; # None of this length $body .= " case $i:\n"; if (@{$by_length[$i]} == 1) { my $only_thing = $by_length[$i]->[0]; if ($only_thing->{utf8}) { if ($only_thing->{utf8} eq 'yes') { # With utf8 on flag item is passed in element 0 $body .= $self->match_clause (undef, [$only_thing]); } else { # With utf8 off flag item is passed in element 1 $body .= $self->match_clause (undef, [undef, $only_thing]); } } else { $body .= $self->match_clause (undef, $only_thing); } } elsif (@{$by_length[$i]} < $breakout) { $body .= $self->switch_clause ({indent=>4}, $i, $items, @{$by_length[$i]}); } else { # Only use the minimal set of parameters actually needed by the types # of the names of this length. my $what = {}; foreach (@{$by_length[$i]}) { $what->{$_->{type}} = 1; $what->{''} = 1 if $_->{utf8}; } $params = $self->params ($what); push @subs, $self->C_constant ({package=>$package, subname=>"${subname}_$i", default_type => $default_type, types => $what, indent => $indent, breakout => [$i, $items]}, @{$by_length[$i]}); $body .= " return ${subname}_$i (" # Eg "aTHX_ " . $self->C_constant_prefix_param($params) # Probably "name" . $self->name_param($params); $body .= $self->C_constant_other_params($params); $body .= ");\n"; } $body .= " break;\n"; } $body .= " }\n"; } my $notfound = $self->return_statement_for_notfound(); $body .= " $notfound\n" if $notfound; $body .= "}\n"; return (@subs, $body); } 1; __END__ =back =head1 BUGS Not everything is documented yet. Probably others. =head1 AUTHOR Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and others usr/share/perl/5.32.1/ExtUtils/CBuilder/Base.pm 0000644 00000025043 15146022013 0014627 0 ustar 00 package ExtUtils::CBuilder::Base; use strict; use warnings; use File::Spec; use File::Basename; use Cwd (); use Config; use Text::ParseWords; use IPC::Cmd qw(can_run); use File::Temp qw(tempfile); our $VERSION = '0.280234'; # VERSION # More details about C/C++ compilers: # http://developers.sun.com/sunstudio/documentation/product/compiler.jsp # http://gcc.gnu.org/ # http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp # http://msdn.microsoft.com/en-us/vstudio/default.aspx my %cc2cxx = ( # first line order is important to support wrappers like in pkgsrc cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers gcc => [ 'g++' ], # GNU Compiler Collection xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety cl => [ 'cl' ], # Microsoft Visual Studio ); sub new { my $class = shift; my $self = bless {@_}, $class; $self->{properties}{perl} = $class->find_perl_interpreter or warn "Warning: Can't locate your perl binary"; while (my ($k,$v) = each %Config) { $self->{config}{$k} = $v unless exists $self->{config}{$k}; } $self->{config}{cc} = $ENV{CC} if defined $ENV{CC}; $self->{config}{ccflags} = join(" ", $self->{config}{ccflags}, $ENV{CFLAGS}) if defined $ENV{CFLAGS}; $self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX}; $self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS}; $self->{config}{ld} = $ENV{LD} if defined $ENV{LD}; $self->{config}{ldflags} = join(" ", $self->{config}{ldflags}, $ENV{LDFLAGS}) if defined $ENV{LDFLAGS}; unless ( exists $self->{config}{cxx} ) { my ($ccbase, $ccpath, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); ## If the path is just "cc", fileparse returns $ccpath as "./" $ccpath = "" if $self->{config}{cc} =~ /^\Q$ccbase$ccsfx\E$/; foreach my $cxx (@{$cc2cxx{$ccbase}}) { my $cxx1 = File::Spec->catfile( $ccpath, $cxx . $ccsfx); if( can_run( $cxx1 ) ) { $self->{config}{cxx} = $cxx1; last; } my $cxx2 = $cxx . $ccsfx; if( can_run( $cxx2 ) ) { $self->{config}{cxx} = $cxx2; last; } if( can_run( $cxx ) ) { $self->{config}{cxx} = $cxx; last; } } unless ( exists $self->{config}{cxx} ) { $self->{config}{cxx} = $self->{config}{cc}; my $cflags = $self->{config}{ccflags}; $self->{config}{cxxflags} = '-x c++'; $self->{config}{cxxflags} .= " $cflags" if defined $cflags; } } return $self; } sub find_perl_interpreter { my $perl; File::Spec->file_name_is_absolute($perl = $^X) or -f ($perl = $Config::Config{perlpath}) or ($perl = $^X); # XXX how about using IPC::Cmd::can_run here? return $perl; } sub add_to_cleanup { my $self = shift; foreach (@_) { $self->{files_to_clean}{$_} = 1; } } sub cleanup { my $self = shift; foreach my $file (keys %{$self->{files_to_clean}}) { unlink $file; } } sub get_config { return %{ $_[0]->{config} }; } sub object_file { my ($self, $filename) = @_; # File name, minus the suffix (my $file_base = $filename) =~ s/\.[^.]+$//; return "$file_base$self->{config}{obj_ext}"; } sub arg_include_dirs { my $self = shift; return map {"-I$_"} @_; } sub arg_nolink { '-c' } sub arg_object_file { my ($self, $file) = @_; return ('-o', $file); } sub arg_share_object_file { my ($self, $file) = @_; return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file); } sub arg_exec_file { my ($self, $file) = @_; return ('-o', $file); } sub arg_defines { my ($self, %args) = @_; return map "-D$_=$args{$_}", sort keys %args; } sub compile { my ($self, %args) = @_; die "Missing 'source' argument to compile()" unless defined $args{source}; my $cf = $self->{config}; # For convenience my $object_file = $args{object_file} ? $args{object_file} : $self->object_file($args{source}); my $include_dirs_ref = (exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY") ? [ $args{include_dirs} ] : $args{include_dirs}; my @include_dirs = $self->arg_include_dirs( @{ $include_dirs_ref || [] }, $self->perl_inc(), ); my @defines = $self->arg_defines( %{$args{defines} || {}} ); my @extra_compiler_flags = $self->split_like_shell($args{extra_compiler_flags}); my @cccdlflags = $self->split_like_shell($cf->{cccdlflags}); my @ccflags = $self->split_like_shell($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags}); my @optimize = $self->split_like_shell($cf->{optimize}); my @flags = ( @include_dirs, @defines, @cccdlflags, @extra_compiler_flags, $self->arg_nolink, @ccflags, @optimize, $self->arg_object_file($object_file), ); my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc}); $self->do_system(@cc, @flags, $args{source}) or die "error building $object_file from '$args{source}'"; return $object_file; } sub have_compiler { my ($self, $is_cplusplus) = @_; my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc"; my $suffix = $is_cplusplus ? ".cc" : ".c"; return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag}; my $result; my $attempts = 3; # tmpdir has issues for some people so fall back to current dir # don't clobber existing files (rare, but possible) my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix ); binmode $FH; if ( $is_cplusplus ) { print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; } else { print $FH "int boot_compilet() { return 1; }\n"; } close $FH; my ($obj_file, @lib_files); eval { local $^W = 0; local $self->{quiet} = 1; $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile); @lib_files = $self->link(objects => $obj_file, module_name => 'compilet'); }; $result = $@ ? 0 : 1; foreach (grep defined, $tmpfile, $obj_file, @lib_files) { 1 while unlink; } return $self->{$have_compiler_flag} = $result; } sub have_cplusplus { push @_, 1; goto &have_compiler; } sub lib_file { my ($self, $dl_file, %args) = @_; $dl_file =~ s/\.[^.]+$//; $dl_file =~ tr/"//d; if (defined $args{module_name} and length $args{module_name}) { # Need to create with the same name as DynaLoader will load with. require DynaLoader; if (defined &DynaLoader::mod2fname) { my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]); my ($dev, $lib_dir, undef) = File::Spec->splitpath($dl_file); $dl_file = File::Spec->catpath($dev, $lib_dir, $lib); } } $dl_file .= ".$self->{config}{dlext}"; return $dl_file; } sub exe_file { my ($self, $dl_file) = @_; $dl_file =~ s/\.[^.]+$//; $dl_file =~ tr/"//d; return "$dl_file$self->{config}{_exe}"; } sub need_prelink { 0 } sub extra_link_args_after_prelink { return } sub prelink { my ($self, %args) = @_; my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args); require ExtUtils::Mksymlists; # dl. abbrev for dynamic library ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } ); # Mksymlists will create one of these files return grep -e, map "$dl_file_out.$_", qw(ext def opt); } sub _prepare_mksymlists_args { my $args = shift; ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file}; my %mksymlists_args = ( DL_VARS => $args->{dl_vars} || [], DL_FUNCS => $args->{dl_funcs} || {}, FUNCLIST => $args->{dl_func_list} || [], IMPORTS => $args->{dl_imports} || {}, NAME => $args->{dl_name}, # Name of the Perl module DLBASE => $args->{dl_base}, # Basename of DLL file FILE => $args->{dl_file}, # Dir + Basename of symlist file VERSION => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'), ); return ($args->{dl_file}, \%mksymlists_args); } sub link { my ($self, %args) = @_; return $self->_do_link('lib_file', lddl => 1, %args); } sub link_executable { my ($self, %args) = @_; return $self->_do_link('exe_file', lddl => 0, %args); } sub _do_link { my ($self, $type, %args) = @_; my $cf = $self->{config}; # For convenience my $objects = delete $args{objects}; $objects = [$objects] unless ref $objects; my $out = $args{$type} || $self->$type($objects->[0], %args); my @temp_files; @temp_files = $self->prelink(%args, dl_name => $args{module_name}) if $args{lddl} && $self->need_prelink; my @linker_flags = ( $self->split_like_shell($args{extra_linker_flags}), $self->extra_link_args_after_prelink( %args, dl_name => $args{module_name}, prelink_res => \@temp_files ) ); my @output = $args{lddl} ? $self->arg_share_object_file($out) : $self->arg_exec_file($out); my @shrp = $self->split_like_shell($cf->{shrpenv}); my @ld = $self->split_like_shell($cf->{ld}); $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags) or die "error building $out from @$objects"; return wantarray ? ($out, @temp_files) : $out; } sub do_system { my ($self, @cmd) = @_; print "@cmd\n" if !$self->{quiet}; return !system(@cmd); } sub split_like_shell { my ($self, $string) = @_; return () unless defined($string); return @$string if UNIVERSAL::isa($string, 'ARRAY'); $string =~ s/^\s+|\s+$//g; return () unless length($string); # Text::ParseWords replaces all 'escaped' characters with themselves, which completely # breaks paths under windows. As such, we forcibly replace backwards slashes with forward # slashes on windows. $string =~ s@\\@/@g if $^O eq 'MSWin32'; return Text::ParseWords::shellwords($string); } # if building perl, perl's main source directory sub perl_src { # N.B. makemaker actually searches regardless of PERL_CORE, but # only squawks at not finding it if PERL_CORE is set return unless $ENV{PERL_CORE}; my $Updir = File::Spec->updir; my $dir = File::Spec->curdir; # Try up to 5 levels upwards for (0..10) { if ( -f File::Spec->catfile($dir,"config_h.SH") && -f File::Spec->catfile($dir,"perl.h") && -f File::Spec->catfile($dir,"lib","Exporter.pm") ) { return Cwd::realpath( $dir ); } $dir = File::Spec->catdir($dir, $Updir); } warn "PERL_CORE is set but I can't find your perl source!\n"; return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ??? } # directory of perl's include files sub perl_inc { my $self = shift; $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE"); } sub DESTROY { my $self = shift; local($., $@, $!, $^E, $?); $self->cleanup(); } 1; # vim: ts=2 sw=2 et: usr/share/perl/5.32.1/TAP/Formatter/Base.pm 0000644 00000027136 15146235164 0013766 0 ustar 00 package TAP::Formatter::Base; use strict; use warnings; use base 'TAP::Base'; use POSIX qw(strftime); my $MAX_ERRORS = 5; my %VALIDATION_FOR; BEGIN { %VALIDATION_FOR = ( directives => sub { shift; shift }, verbosity => sub { shift; shift }, normalize => sub { shift; shift }, timer => sub { shift; shift }, failures => sub { shift; shift }, comments => sub { shift; shift }, errors => sub { shift; shift }, color => sub { shift; shift }, jobs => sub { shift; shift }, show_count => sub { shift; shift }, stdout => sub { my ( $self, $ref ) = @_; $self->_croak("option 'stdout' needs a filehandle") unless $self->_is_filehandle($ref); return $ref; }, ); sub _is_filehandle { my ( $self, $ref ) = @_; return 0 if !defined $ref; return 1 if ref $ref eq 'GLOB'; # lexical filehandle return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT return 1 if eval { $ref->can('print') }; return 0; } my @getter_setters = qw( _longest _printed_summary_header _colorizer ); __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); } =head1 NAME TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::Console; my $harness = TAP::Formatter::Console->new( \%args ); =cut sub _initialize { my ( $self, $arg_for ) = @_; $arg_for ||= {}; $self->SUPER::_initialize($arg_for); my %arg_for = %$arg_for; # force a shallow copy $self->verbosity(0); for my $name ( keys %VALIDATION_FOR ) { my $property = delete $arg_for{$name}; if ( defined $property ) { my $validate = $VALIDATION_FOR{$name}; $self->$name( $self->$validate($property) ); } } if ( my @props = keys %arg_for ) { $self->_croak( "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); } $self->stdout( \*STDOUT ) unless $self->stdout; if ( $self->color ) { require TAP::Formatter::Color; $self->_colorizer( TAP::Formatter::Color->new ); } return $self; } sub verbose { shift->verbosity >= 1 } sub quiet { shift->verbosity <= -1 } sub really_quiet { shift->verbosity <= -2 } sub silent { shift->verbosity <= -3 } =head1 METHODS =head2 Class Methods =head3 C<new> my %args = ( verbose => 1, ) my $harness = TAP::Formatter::Console->new( \%args ); The constructor returns a new C<TAP::Formatter::Console> object. If a L<TAP::Harness> is created with no C<formatter> a C<TAP::Formatter::Console> is automatically created. If any of the following options were given to TAP::Harness->new they well be passed to this constructor which accepts an optional hashref whose allowed keys are: =over 4 =item * C<verbosity> Set the verbosity level. =item * C<verbose> Printing individual test results to STDOUT. =item * C<timer> Append run time for each test to output. Uses L<Time::HiRes> if available. =item * C<failures> Show test failures (this is a no-op if C<verbose> is selected). =item * C<comments> Show test comments (this is a no-op if C<verbose> is selected). =item * C<quiet> Suppressing some test output (mostly failures while tests are running). =item * C<really_quiet> Suppressing everything but the tests summary. =item * C<silent> Suppressing all output. =item * C<errors> If parse errors are found in the TAP output, a note of this will be made in the summary report. To see all of the parse errors, set this argument to true: errors => 1 =item * C<directives> If set to a true value, only test results with directives will be displayed. This overrides other settings such as C<verbose>, C<failures>, or C<comments>. =item * C<stdout> A filehandle for catching standard output. =item * C<color> If defined specifies whether color output is desired. If C<color> is not defined it will default to color output if color support is available on the current platform and output is not being redirected. =item * C<jobs> The number of concurrent jobs this formatter will handle. =item * C<show_count> Boolean value. If false, disables the C<X/Y> test count which shows up while tests are running. =back Any keys for which the value is C<undef> will be ignored. =cut # new supplied by TAP::Base =head3 C<prepare> Called by Test::Harness before any test output is generated. This is an advisory and may not be called in the case where tests are being supplied to Test::Harness by an iterator. =cut sub prepare { my ( $self, @tests ) = @_; my $longest = 0; for my $test (@tests) { $longest = length $test if length $test > $longest; } $self->_longest($longest); } sub _format_now { strftime "[%H:%M:%S]", localtime } sub _format_name { my ( $self, $test ) = @_; my $name = $test; my $periods = '.' x ( $self->_longest + 2 - length $test ); $periods = " $periods "; if ( $self->timer ) { my $stamp = $self->_format_now(); return "$stamp $name$periods"; } else { return "$name$periods"; } } =head3 C<open_test> Called to create a new test session. A test session looks like this: my $session = $formatter->open_test( $test, $parser ); while ( defined( my $result = $parser->next ) ) { $session->result($result); exit 1 if $result->is_bailout; } $session->close_test; =cut sub open_test { die "Unimplemented."; } sub _output_success { my ( $self, $msg ) = @_; $self->_output($msg); } =head3 C<summary> $harness->summary( $aggregate ); C<summary> prints the summary report after all tests are run. The first argument is an aggregate to summarise. An optional second argument may be set to a true value to indicate that the summary is being output as a result of an interrupted test run. =cut sub summary { my ( $self, $aggregate, $interrupted ) = @_; return if $self->silent; my @t = $aggregate->descriptions; my $tests = \@t; my $runtime = $aggregate->elapsed_timestr; my $total = $aggregate->total; my $passed = $aggregate->passed; if ( $self->timer ) { $self->_output( $self->_format_now(), "\n" ); } $self->_failure_output("Test run interrupted!\n") if $interrupted; # TODO: Check this condition still works when all subtests pass but # the exit status is nonzero if ( $aggregate->all_passed ) { $self->_output_success("All tests successful.\n"); } # ~TODO option where $aggregate->skipped generates reports if ( $total != $passed or $aggregate->has_problems ) { $self->_output("\nTest Summary Report"); $self->_output("\n-------------------\n"); for my $test (@$tests) { $self->_printed_summary_header(0); my ($parser) = $aggregate->parsers($test); $self->_output_summary_failure( 'failed', [ ' Failed test: ', ' Failed tests: ' ], $test, $parser ); $self->_output_summary_failure( 'todo_passed', " TODO passed: ", $test, $parser ); # ~TODO this cannot be the default #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); if ( my $exit = $parser->exit ) { $self->_summary_test_header( $test, $parser ); $self->_failure_output(" Non-zero exit status: $exit\n"); } elsif ( my $wait = $parser->wait ) { $self->_summary_test_header( $test, $parser ); $self->_failure_output(" Non-zero wait status: $wait\n"); } if ( my @errors = $parser->parse_errors ) { my $explain; if ( @errors > $MAX_ERRORS && !$self->errors ) { $explain = "Displayed the first $MAX_ERRORS of " . scalar(@errors) . " TAP syntax errors.\n" . "Re-run prove with the -p option to see them all.\n"; splice @errors, $MAX_ERRORS; } $self->_summary_test_header( $test, $parser ); $self->_failure_output( sprintf " Parse errors: %s\n", shift @errors ); for my $error (@errors) { my $spaces = ' ' x 16; $self->_failure_output("$spaces$error\n"); } $self->_failure_output($explain) if $explain; } } } my $files = @$tests; $self->_output("Files=$files, Tests=$total, $runtime\n"); my $status = $aggregate->get_status; $self->_output("Result: $status\n"); } sub _output_summary_failure { my ( $self, $method, $name, $test, $parser ) = @_; # ugly hack. Must rethink this :( my $output = $method eq 'failed' ? '_failure_output' : '_output'; if ( my @r = $parser->$method() ) { $self->_summary_test_header( $test, $parser ); my ( $singular, $plural ) = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); $self->$output( @r == 1 ? $singular : $plural ); my @results = $self->_balanced_range( 40, @r ); $self->$output( sprintf "%s\n" => shift @results ); my $spaces = ' ' x 16; while (@results) { $self->$output( sprintf "$spaces%s\n" => shift @results ); } } } sub _summary_test_header { my ( $self, $test, $parser ) = @_; return if $self->_printed_summary_header; my $spaces = ' ' x ( $self->_longest - length $test ); $spaces = ' ' unless $spaces; my $output = $self->_get_output_method($parser); my $wait = $parser->wait; defined $wait or $wait = '(none)'; $self->$output( sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n", $wait, $parser->tests_run, scalar $parser->failed ); $self->_printed_summary_header(1); } sub _output { my $self = shift; print { $self->stdout } @_; } sub _failure_output { my $self = shift; $self->_output(@_); } sub _balanced_range { my ( $self, $limit, @range ) = @_; @range = $self->_range(@range); my $line = ""; my @lines; my $curr = 0; while (@range) { if ( $curr < $limit ) { my $range = ( shift @range ) . ", "; $line .= $range; $curr += length $range; } elsif (@range) { $line =~ s/, $//; push @lines => $line; $line = ''; $curr = 0; } } if ($line) { $line =~ s/, $//; push @lines => $line; } return @lines; } sub _range { my ( $self, @numbers ) = @_; # shouldn't be needed, but subclasses might call this @numbers = sort { $a <=> $b } @numbers; my ( $min, @range ); for my $i ( 0 .. $#numbers ) { my $num = $numbers[$i]; my $next = $numbers[ $i + 1 ]; if ( defined $next && $next == $num + 1 ) { if ( !defined $min ) { $min = $num; } } elsif ( defined $min ) { push @range => "$min-$num"; undef $min; } else { push @range => $num; } } return @range; } sub _get_output_method { my ( $self, $parser ) = @_; return $parser->has_problems ? '_failure_output' : '_output'; } 1; usr/share/perl/5.32.1/IO/Uncompress/Base.pm 0000644 00000113302 15150051617 0014025 0 ustar 00 package IO::Uncompress::Base ; use strict ; use warnings; use bytes; our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(IO::File Exporter); $VERSION = '2.093'; use constant G_EOF => 0 ; use constant G_ERR => -1 ; use IO::Compress::Base::Common 2.093 ; use IO::File ; use Symbol; use Scalar::Util (); use List::Util (); use Carp ; %EXPORT_TAGS = ( ); push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; sub smartRead { my $self = $_[0]; my $out = $_[1]; my $size = $_[2]; $$out = "" ; my $offset = 0 ; my $status = 1; if (defined *$self->{InputLength}) { return 0 if *$self->{InputLengthRemaining} <= 0 ; $size = List::Util::min($size, *$self->{InputLengthRemaining}); } if ( length *$self->{Prime} ) { $$out = substr(*$self->{Prime}, 0, $size) ; substr(*$self->{Prime}, 0, $size) = '' ; if (length $$out == $size) { *$self->{InputLengthRemaining} -= length $$out if defined *$self->{InputLength}; return length $$out ; } $offset = length $$out ; } my $get_size = $size - $offset ; if (defined *$self->{FH}) { if ($offset) { # Not using this # # *$self->{FH}->read($$out, $get_size, $offset); # # because the filehandle may not support the offset parameter # An example is Net::FTP my $tmp = ''; $status = *$self->{FH}->read($tmp, $get_size) ; substr($$out, $offset) = $tmp if defined $status && $status > 0 ; } else { $status = *$self->{FH}->read($$out, $get_size) } } elsif (defined *$self->{InputEvent}) { my $got = 1 ; while (length $$out < $size) { last if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; } if (length $$out > $size ) { *$self->{Prime} = substr($$out, $size, length($$out)); substr($$out, $size, length($$out)) = ''; } *$self->{EventEof} = 1 if $got <= 0 ; } else { no warnings 'uninitialized'; my $buf = *$self->{Buffer} ; $$buf = '' unless defined $$buf ; substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); if (*$self->{ConsumeInput}) { substr($$buf, 0, $get_size) = '' } else { *$self->{BufferOffset} += length($$out) - $offset } } *$self->{InputLengthRemaining} -= length($$out) #- $offset if defined *$self->{InputLength}; if (! defined $status) { $self->saveStatus($!) ; return STATUS_ERROR; } $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ; return length $$out; } sub pushBack { my $self = shift ; return if ! defined $_[0] || length $_[0] == 0 ; if (defined *$self->{FH} || defined *$self->{InputEvent} ) { *$self->{Prime} = $_[0] . *$self->{Prime} ; *$self->{InputLengthRemaining} += length($_[0]); } else { my $len = length $_[0]; if($len > *$self->{BufferOffset}) { *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ; *$self->{InputLengthRemaining} = *$self->{InputLength}; *$self->{BufferOffset} = 0 } else { *$self->{InputLengthRemaining} += length($_[0]); *$self->{BufferOffset} -= length($_[0]) ; } } } sub smartSeek { my $self = shift ; my $offset = shift ; my $truncate = shift; my $position = shift || SEEK_SET; # TODO -- need to take prime into account *$self->{Prime} = ''; if (defined *$self->{FH}) { *$self->{FH}->seek($offset, $position) } else { if ($position == SEEK_END) { *$self->{BufferOffset} = length(${ *$self->{Buffer} }) + $offset ; } elsif ($position == SEEK_CUR) { *$self->{BufferOffset} += $offset ; } else { *$self->{BufferOffset} = $offset ; } substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' if $truncate; return 1; } } sub smartTell { my $self = shift ; if (defined *$self->{FH}) { return *$self->{FH}->tell() } else { return *$self->{BufferOffset} } } sub smartWrite { my $self = shift ; my $out_data = shift ; if (defined *$self->{FH}) { # flush needed for 5.8.0 defined *$self->{FH}->write($out_data, length $out_data) && defined *$self->{FH}->flush() ; } else { my $buf = *$self->{Buffer} ; substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ; *$self->{BufferOffset} += length($out_data) ; return 1; } } sub smartReadExact { return $_[0]->smartRead($_[1], $_[2]) == $_[2]; } sub smartEof { my ($self) = $_[0]; local $.; return 0 if length *$self->{Prime} || *$self->{PushMode}; if (defined *$self->{FH}) { # Could use # # *$self->{FH}->eof() # # here, but this can cause trouble if # the filehandle is itself a tied handle, but it uses sysread. # Then we get into mixing buffered & non-buffered IO, # which will cause trouble my $info = $self->getErrInfo(); my $buffer = ''; my $status = $self->smartRead(\$buffer, 1); $self->pushBack($buffer) if length $buffer; $self->setErrInfo($info); return $status == 0 ; } elsif (defined *$self->{InputEvent}) { *$self->{EventEof} } else { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } } sub clearError { my $self = shift ; *$self->{ErrorNo} = 0 ; ${ *$self->{Error} } = '' ; } sub getErrInfo { my $self = shift ; return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ; } sub setErrInfo { my $self = shift ; my $ref = shift; *$self->{ErrorNo} = $ref->[0] ; ${ *$self->{Error} } = $ref->[1] ; } sub saveStatus { my $self = shift ; my $errno = shift() + 0 ; *$self->{ErrorNo} = $errno; ${ *$self->{Error} } = '' ; return *$self->{ErrorNo} ; } sub saveErrorString { my $self = shift ; my $retval = shift ; ${ *$self->{Error} } = shift ; *$self->{ErrorNo} = @_ ? shift() + 0 : STATUS_ERROR ; return $retval; } sub croakError { my $self = shift ; $self->saveErrorString(0, $_[0]); croak $_[0]; } sub closeError { my $self = shift ; my $retval = shift ; my $errno = *$self->{ErrorNo}; my $error = ${ *$self->{Error} }; $self->close(); *$self->{ErrorNo} = $errno ; ${ *$self->{Error} } = $error ; return $retval; } sub error { my $self = shift ; return ${ *$self->{Error} } ; } sub errorNo { my $self = shift ; return *$self->{ErrorNo}; } sub HeaderError { my ($self) = shift; return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR); } sub TrailerError { my ($self) = shift; return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR); } sub TruncatedHeader { my ($self) = shift; return $self->HeaderError("Truncated in $_[0] Section"); } sub TruncatedTrailer { my ($self) = shift; return $self->TrailerError("Truncated in $_[0] Section"); } sub postCheckParams { return 1; } sub checkParams { my $self = shift ; my $class = shift ; my $got = shift || IO::Compress::Base::Parameters::new(); my $Valid = { 'blocksize' => [IO::Compress::Base::Common::Parse_unsigned, 16 * 1024], 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0], 'strict' => [IO::Compress::Base::Common::Parse_boolean, 0], 'append' => [IO::Compress::Base::Common::Parse_boolean, 0], 'prime' => [IO::Compress::Base::Common::Parse_any, undef], 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 0], 'transparent' => [IO::Compress::Base::Common::Parse_any, 1], 'scan' => [IO::Compress::Base::Common::Parse_boolean, 0], 'inputlength' => [IO::Compress::Base::Common::Parse_unsigned, undef], 'binmodeout' => [IO::Compress::Base::Common::Parse_boolean, 0], #'decode' => [IO::Compress::Base::Common::Parse_any, undef], #'consumeinput' => [IO::Compress::Base::Common::Parse_boolean, 0], $self->getExtraParams(), #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, # ContinueAfterEof } ; $Valid->{trailingdata} = [IO::Compress::Base::Common::Parse_writable_scalar, undef] if *$self->{OneShot} ; $got->parse($Valid, @_ ) or $self->croakError("${class}: " . $got->getError()) ; $self->postCheckParams($got) or $self->croakError("${class}: " . $self->error()) ; return $got; } sub _create { my $obj = shift; my $got = shift; my $append_mode = shift ; my $class = ref $obj; $obj->croakError("$class: Missing Input parameter") if ! @_ && ! $got ; my $inValue = shift ; *$obj->{OneShot} = 0 ; if (! $got) { $got = $obj->checkParams($class, undef, @_) or return undef ; } my $inType = whatIsInput($inValue, 1); $obj->ckInputParam($class, $inValue, 1) or return undef ; *$obj->{InNew} = 1; $obj->ckParams($got) or $obj->croakError("${class}: " . *$obj->{Error}); if ($inType eq 'buffer' || $inType eq 'code') { *$obj->{Buffer} = $inValue ; *$obj->{InputEvent} = $inValue if $inType eq 'code' ; } else { if ($inType eq 'handle') { *$obj->{FH} = $inValue ; *$obj->{Handle} = 1 ; # Need to rewind for Scan *$obj->{FH}->seek(0, SEEK_SET) if $got->getValue('scan'); } else { no warnings ; my $mode = '<'; $mode = '+<' if $got->getValue('scan'); *$obj->{StdIO} = ($inValue eq '-'); *$obj->{FH} = new IO::File "$mode $inValue" or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; } *$obj->{LineNo} = $. = 0; setBinModeInput(*$obj->{FH}) ; my $buff = "" ; *$obj->{Buffer} = \$buff ; } # if ($got->getValue('decode')) { # my $want_encoding = $got->getValue('decode'); # *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding); # } # else { # *$obj->{Encoding} = undef; # } *$obj->{InputLength} = $got->parsed('inputlength') ? $got->getValue('inputlength') : undef ; *$obj->{InputLengthRemaining} = $got->getValue('inputlength'); *$obj->{BufferOffset} = 0 ; *$obj->{AutoClose} = $got->getValue('autoclose'); *$obj->{Strict} = $got->getValue('strict'); *$obj->{BlockSize} = $got->getValue('blocksize'); *$obj->{Append} = $got->getValue('append'); *$obj->{AppendOutput} = $append_mode || $got->getValue('append'); *$obj->{ConsumeInput} = $got->getValue('consumeinput'); *$obj->{Transparent} = $got->getValue('transparent'); *$obj->{MultiStream} = $got->getValue('multistream'); # TODO - move these two into RawDeflate *$obj->{Scan} = $got->getValue('scan'); *$obj->{ParseExtra} = $got->getValue('parseextra') || $got->getValue('strict') ; *$obj->{Type} = ''; *$obj->{Prime} = $got->getValue('prime') || '' ; *$obj->{Pending} = ''; *$obj->{Plain} = 0; *$obj->{PlainBytesRead} = 0; *$obj->{InflatedBytesRead} = 0; *$obj->{UnCompSize} = new U64; *$obj->{CompSize} = new U64; *$obj->{TotalInflatedBytesRead} = 0; *$obj->{NewStream} = 0 ; *$obj->{EventEof} = 0 ; *$obj->{ClassName} = $class ; *$obj->{Params} = $got ; if (*$obj->{ConsumeInput}) { *$obj->{InNew} = 0; *$obj->{Closed} = 0; return $obj } my $status = $obj->mkUncomp($got); return undef unless defined $status; *$obj->{InNew} = 0; *$obj->{Closed} = 0; return $obj if *$obj->{Pause} ; if ($status) { # Need to try uncompressing to catch the case # where the compressed file uncompresses to an # empty string - so eof is set immediately. my $out_buffer = ''; $status = $obj->read(\$out_buffer); if ($status < 0) { *$obj->{ReadStatus} = [ $status, $obj->error(), $obj->errorNo() ]; } $obj->ungetc($out_buffer) if length $out_buffer; } else { return undef unless *$obj->{Transparent}; $obj->clearError(); *$obj->{Type} = 'plain'; *$obj->{Plain} = 1; $obj->pushBack(*$obj->{HeaderPending}) ; } push @{ *$obj->{InfoList} }, *$obj->{Info} ; $obj->saveStatus(STATUS_OK) ; *$obj->{InNew} = 0; *$obj->{Closed} = 0; return $obj; } sub ckInputParam { my $self = shift ; my $from = shift ; my $inType = whatIsInput($_[0], $_[1]); $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref") if ! $inType ; # if ($inType eq 'filename' ) # { # return $self->saveErrorString(1, "$from: input filename is undef or null string", STATUS_ERROR) # if ! defined $_[0] || $_[0] eq '' ; # # if ($_[0] ne '-' && ! -e $_[0] ) # { # return $self->saveErrorString(1, # "input file '$_[0]' does not exist", STATUS_ERROR); # } # } return 1; } sub _inf { my $obj = shift ; my $class = (caller)[0] ; my $name = (caller(1))[3] ; $obj->croakError("$name: expected at least 1 parameters\n") unless @_ >= 1 ; my $input = shift ; my $haveOut = @_ ; my $output = shift ; my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) or return undef ; push @_, $output if $haveOut && $x->{Hash}; *$obj->{OneShot} = 1 ; my $got = $obj->checkParams($name, undef, @_) or return undef ; if ($got->parsed('trailingdata')) { # my $value = $got->valueRef('TrailingData'); # warn "TD $value "; # #$value = $$value; ## warn "TD $value $$value "; # # return retErr($obj, "Parameter 'TrailingData' not writable") # if readonly $$value ; # # if (ref $$value) # { # return retErr($obj,"Parameter 'TrailingData' not a scalar reference") # if ref $$value ne 'SCALAR' ; # # *$obj->{TrailingData} = $$value ; # } # else # { # return retErr($obj,"Parameter 'TrailingData' not a scalar") # if ref $value ne 'SCALAR' ; # # *$obj->{TrailingData} = $value ; # } *$obj->{TrailingData} = $got->getValue('trailingdata'); } *$obj->{MultiStream} = $got->getValue('multistream'); $got->setValue('multistream', 0); $x->{Got} = $got ; # if ($x->{Hash}) # { # while (my($k, $v) = each %$input) # { # $v = \$input->{$k} # unless defined $v ; # # $obj->_singleTarget($x, $k, $v, @_) # or return undef ; # } # # return keys %$input ; # } if ($x->{GlobMap}) { $x->{oneInput} = 1 ; foreach my $pair (@{ $x->{Pairs} }) { my ($from, $to) = @$pair ; $obj->_singleTarget($x, $from, $to, @_) or return undef ; } return scalar @{ $x->{Pairs} } ; } if (! $x->{oneOutput} ) { my $inFile = ($x->{inType} eq 'filenames' || $x->{inType} eq 'filename'); $x->{inType} = $inFile ? 'filename' : 'buffer'; foreach my $in ($x->{oneInput} ? $input : @$input) { my $out ; $x->{oneInput} = 1 ; $obj->_singleTarget($x, $in, $output, @_) or return undef ; } return 1 ; } # finally the 1 to 1 and n to 1 return $obj->_singleTarget($x, $input, $output, @_); croak "should not be here" ; } sub retErr { my $x = shift ; my $string = shift ; ${ $x->{Error} } = $string ; return undef ; } sub _singleTarget { my $self = shift ; my $x = shift ; my $input = shift; my $output = shift; my $buff = ''; $x->{buff} = \$buff ; my $fh ; if ($x->{outType} eq 'filename') { my $mode = '>' ; $mode = '>>' if $x->{Got}->getValue('append') ; $x->{fh} = new IO::File "$mode $output" or return retErr($x, "cannot open file '$output': $!") ; binmode $x->{fh} ; } elsif ($x->{outType} eq 'handle') { $x->{fh} = $output; binmode $x->{fh} ; if ($x->{Got}->getValue('append')) { seek($x->{fh}, 0, SEEK_END) or return retErr($x, "Cannot seek to end of output filehandle: $!") ; } } elsif ($x->{outType} eq 'buffer' ) { $$output = '' unless $x->{Got}->getValue('append'); $x->{buff} = $output ; } if ($x->{oneInput}) { defined $self->_rd2($x, $input, $output) or return undef; } else { for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) { defined $self->_rd2($x, $element, $output) or return undef ; } } if ( ($x->{outType} eq 'filename' && $output ne '-') || ($x->{outType} eq 'handle' && $x->{Got}->getValue('autoclose'))) { $x->{fh}->close() or return retErr($x, $!); delete $x->{fh}; } return 1 ; } sub _rd2 { my $self = shift ; my $x = shift ; my $input = shift; my $output = shift; my $z = IO::Compress::Base::Common::createSelfTiedObject($x->{Class}, *$self->{Error}); $z->_create($x->{Got}, 1, $input, @_) or return undef ; my $status ; my $fh = $x->{fh}; while (1) { while (($status = $z->read($x->{buff})) > 0) { if ($fh) { local $\; print $fh ${ $x->{buff} } or return $z->saveErrorString(undef, "Error writing to output file: $!", $!); ${ $x->{buff} } = '' ; } } if (! $x->{oneOutput} ) { my $ot = $x->{outType} ; if ($ot eq 'array') { push @$output, $x->{buff} } elsif ($ot eq 'hash') { $output->{$input} = $x->{buff} } my $buff = ''; $x->{buff} = \$buff; } last if $status < 0 || $z->smartEof(); last unless *$self->{MultiStream}; $status = $z->nextStream(); last unless $status == 1 ; } return $z->closeError(undef) if $status < 0 ; ${ *$self->{TrailingData} } = $z->trailingData() if defined *$self->{TrailingData} ; $z->close() or return undef ; return 1 ; } sub TIEHANDLE { return $_[0] if ref($_[0]); die "OOPS\n" ; } sub UNTIE { my $self = shift ; } sub getHeaderInfo { my $self = shift ; wantarray ? @{ *$self->{InfoList} } : *$self->{Info}; } sub readBlock { my $self = shift ; my $buff = shift ; my $size = shift ; if (defined *$self->{CompressedInputLength}) { if (*$self->{CompressedInputLengthRemaining} == 0) { delete *$self->{CompressedInputLength}; *$self->{CompressedInputLengthDone} = 1; return STATUS_OK ; } $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} ); *$self->{CompressedInputLengthRemaining} -= $size ; } my $status = $self->smartRead($buff, $size) ; return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!) if $status == STATUS_ERROR ; if ($status == 0 ) { *$self->{Closed} = 1 ; *$self->{EndStream} = 1 ; return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR); } return STATUS_OK; } sub postBlockChk { return STATUS_OK; } sub _raw_read { # return codes # >0 - ok, number of bytes read # =0 - ok, eof # <0 - not ok my $self = shift ; return G_EOF if *$self->{Closed} ; return G_EOF if *$self->{EndStream} ; my $buffer = shift ; my $scan_mode = shift ; if (*$self->{Plain}) { my $tmp_buff ; my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) if $len == STATUS_ERROR ; if ($len == 0 ) { *$self->{EndStream} = 1 ; } else { *$self->{PlainBytesRead} += $len ; $$buffer .= $tmp_buff; } return $len ; } if (*$self->{NewStream}) { $self->gotoNextStream() > 0 or return G_ERR; # For the headers that actually uncompressed data, put the # uncompressed data into the output buffer. $$buffer .= *$self->{Pending} ; my $len = length *$self->{Pending} ; *$self->{Pending} = ''; return $len; } my $temp_buf = ''; my $outSize = 0; my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ; return G_ERR if $status == STATUS_ERROR ; my $buf_len = 0; if ($status == STATUS_OK) { my $beforeC_len = length $temp_buf; my $before_len = defined $$buffer ? length $$buffer : 0 ; $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer, defined *$self->{CompressedInputLengthDone} || $self->smartEof(), $outSize); # Remember the input buffer if it wasn't consumed completely $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput}; return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo}) if $self->saveStatus($status) == STATUS_ERROR; $self->postBlockChk($buffer, $before_len) == STATUS_OK or return G_ERR; $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0; *$self->{CompSize}->add($beforeC_len - length $temp_buf) ; *$self->{InflatedBytesRead} += $buf_len ; *$self->{TotalInflatedBytesRead} += $buf_len ; *$self->{UnCompSize}->add($buf_len) ; $self->filterUncompressed($buffer, $before_len); # if (*$self->{Encoding}) { # use Encode ; # *$self->{PendingDecode} .= substr($$buffer, $before_len) ; # my $got = *$self->{Encoding}->decode(*$self->{PendingDecode}, Encode::FB_QUIET) ; # substr($$buffer, $before_len) = $got; # } } if ($status == STATUS_ENDSTREAM) { *$self->{EndStream} = 1 ; my $trailer; my $trailer_size = *$self->{Info}{TrailerLength} ; my $got = 0; if (*$self->{Info}{TrailerLength}) { $got = $self->smartRead(\$trailer, $trailer_size) ; } if ($got == $trailer_size) { $self->chkTrailer($trailer) == STATUS_OK or return G_ERR; } else { return $self->TrailerError("trailer truncated. Expected " . "$trailer_size bytes, got $got") if *$self->{Strict}; $self->pushBack($trailer) ; } # TODO - if want file pointer, do it here if (! $self->smartEof()) { *$self->{NewStream} = 1 ; if (*$self->{MultiStream}) { *$self->{EndStream} = 0 ; return $buf_len ; } } } # return the number of uncompressed bytes read return $buf_len ; } sub reset { my $self = shift ; return *$self->{Uncomp}->reset(); } sub filterUncompressed { } #sub isEndStream #{ # my $self = shift ; # return *$self->{NewStream} || # *$self->{EndStream} ; #} sub nextStream { my $self = shift ; my $status = $self->gotoNextStream(); $status == 1 or return $status ; *$self->{Pending} = '' if $self !~ /IO::Uncompress::RawInflate/ && ! *$self->{MultiStream}; *$self->{TotalInflatedBytesRead} = 0 ; *$self->{LineNo} = $. = 0; return 1; } sub gotoNextStream { my $self = shift ; if (! *$self->{NewStream}) { my $status = 1; my $buffer ; # TODO - make this more efficient if know the offset for the end of # the stream and seekable $status = $self->read($buffer) while $status > 0 ; return $status if $status < 0; } *$self->{NewStream} = 0 ; *$self->{EndStream} = 0 ; *$self->{CompressedInputLengthDone} = undef ; *$self->{CompressedInputLength} = undef ; $self->reset(); *$self->{UnCompSize}->reset(); *$self->{CompSize}->reset(); my $magic = $self->ckMagic(); if ( ! defined $magic) { if (! *$self->{Transparent} || $self->eof()) { *$self->{EndStream} = 1 ; return 0; } # Not EOF, so Transparent mode kicks in now for trailing data # Reset member name in case anyone calls getHeaderInfo()->{Name} *$self->{Info} = { Name => undef, Type => 'plain' }; $self->clearError(); *$self->{Type} = 'plain'; *$self->{Plain} = 1; $self->pushBack(*$self->{HeaderPending}) ; } else { *$self->{Info} = $self->readHeader($magic); if ( ! defined *$self->{Info} ) { *$self->{EndStream} = 1 ; return -1; } } push @{ *$self->{InfoList} }, *$self->{Info} ; return 1; } sub streamCount { my $self = shift ; return 1 if ! defined *$self->{InfoList}; return scalar @{ *$self->{InfoList} } ; } sub read { # return codes # >0 - ok, number of bytes read # =0 - ok, eof # <0 - not ok my $self = shift ; if (defined *$self->{ReadStatus} ) { my $status = *$self->{ReadStatus}[0]; $self->saveErrorString( @{ *$self->{ReadStatus} } ); delete *$self->{ReadStatus} ; return $status ; } return G_EOF if *$self->{Closed} ; my $buffer ; if (ref $_[0] ) { $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") if Scalar::Util::readonly(${ $_[0] }); $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" ) unless ref $_[0] eq 'SCALAR' ; $buffer = $_[0] ; } else { $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") if Scalar::Util::readonly($_[0]); $buffer = \$_[0] ; } my $length = $_[1] ; my $offset = $_[2] || 0; if (! *$self->{AppendOutput}) { if (! $offset) { $$buffer = '' ; } else { if ($offset > length($$buffer)) { $$buffer .= "\x00" x ($offset - length($$buffer)); } else { substr($$buffer, $offset) = ''; } } } elsif (! defined $$buffer) { $$buffer = '' ; } return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; # the core read will return 0 if asked for 0 bytes return 0 if defined $length && $length == 0 ; $length = $length || 0; $self->croakError(*$self->{ClassName} . "::read: length parameter is negative") if $length < 0 ; # Short-circuit if this is a simple read, with no length # or offset specified. unless ( $length || $offset) { if (length *$self->{Pending}) { $$buffer .= *$self->{Pending} ; my $len = length *$self->{Pending}; *$self->{Pending} = '' ; return $len ; } else { my $len = 0; $len = $self->_raw_read($buffer) while ! *$self->{EndStream} && $len == 0 ; return $len ; } } # Need to jump through more hoops - either length or offset # or both are specified. my $out_buffer = *$self->{Pending} ; *$self->{Pending} = ''; while (! *$self->{EndStream} && length($out_buffer) < $length) { my $buf_len = $self->_raw_read(\$out_buffer); return $buf_len if $buf_len < 0 ; } $length = length $out_buffer if length($out_buffer) < $length ; return 0 if $length == 0 ; $$buffer = '' if ! defined $$buffer; $offset = length $$buffer if *$self->{AppendOutput} ; *$self->{Pending} = $out_buffer; $out_buffer = \*$self->{Pending} ; substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; substr($$out_buffer, 0, $length) = '' ; return $length ; } sub _getline { my $self = shift ; my $status = 0 ; # Slurp Mode if ( ! defined $/ ) { my $data ; 1 while ($status = $self->read($data)) > 0 ; return ($status, \$data); } # Record Mode if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) { my $reclen = ${$/} ; my $data ; $status = $self->read($data, $reclen) ; return ($status, \$data); } # Paragraph Mode if ( ! length $/ ) { my $paragraph ; while (($status = $self->read($paragraph)) > 0 ) { if ($paragraph =~ s/^(.*?\n\n+)//s) { *$self->{Pending} = $paragraph ; my $par = $1 ; return (1, \$par); } } return ($status, \$paragraph); } # $/ isn't empty, or a reference, so it's Line Mode. { my $line ; my $p = \*$self->{Pending} ; while (($status = $self->read($line)) > 0 ) { my $offset = index($line, $/); if ($offset >= 0) { my $l = substr($line, 0, $offset + length $/ ); substr($line, 0, $offset + length $/) = ''; $$p = $line; return (1, \$l); } } return ($status, \$line); } } sub getline { my $self = shift; if (defined *$self->{ReadStatus} ) { $self->saveErrorString( @{ *$self->{ReadStatus} } ); delete *$self->{ReadStatus} ; return undef; } return undef if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ; my $current_append = *$self->{AppendOutput} ; *$self->{AppendOutput} = 1; my ($status, $lineref) = $self->_getline(); *$self->{AppendOutput} = $current_append; return undef if $status < 0 || length $$lineref == 0 ; $. = ++ *$self->{LineNo} ; return $$lineref ; } sub getlines { my $self = shift; $self->croakError(*$self->{ClassName} . "::getlines: called in scalar context\n") unless wantarray; my($line, @lines); push(@lines, $line) while defined($line = $self->getline); return @lines; } sub READLINE { goto &getlines if wantarray; goto &getline; } sub getc { my $self = shift; my $buf; return $buf if $self->read($buf, 1); return undef; } sub ungetc { my $self = shift; *$self->{Pending} = "" unless defined *$self->{Pending} ; *$self->{Pending} = $_[0] . *$self->{Pending} ; } sub trailingData { my $self = shift ; if (defined *$self->{FH} || defined *$self->{InputEvent} ) { return *$self->{Prime} ; } else { my $buf = *$self->{Buffer} ; my $offset = *$self->{BufferOffset} ; return substr($$buf, $offset) ; } } sub eof { my $self = shift ; return (*$self->{Closed} || (!length *$self->{Pending} && ( $self->smartEof() || *$self->{EndStream}))) ; } sub tell { my $self = shift ; my $in ; if (*$self->{Plain}) { $in = *$self->{PlainBytesRead} ; } else { $in = *$self->{TotalInflatedBytesRead} ; } my $pending = length *$self->{Pending} ; return 0 if $pending > $in ; return $in - $pending ; } sub close { # todo - what to do if close is called before the end of the gzip file # do we remember any trailing data? my $self = shift ; return 1 if *$self->{Closed} ; untie *$self if $] >= 5.008 ; my $status = 1 ; if (defined *$self->{FH}) { if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { local $.; $! = 0 ; $status = *$self->{FH}->close(); return $self->saveErrorString(0, $!, $!) if !*$self->{InNew} && $self->saveStatus($!) != 0 ; } delete *$self->{FH} ; $! = 0 ; } *$self->{Closed} = 1 ; return 1; } sub DESTROY { my $self = shift ; local ($., $@, $!, $^E, $?); $self->close() ; } sub seek { my $self = shift ; my $position = shift; my $whence = shift ; my $here = $self->tell() ; my $target = 0 ; if ($whence == SEEK_SET) { $target = $position ; } elsif ($whence == SEEK_CUR) { $target = $here + $position ; } elsif ($whence == SEEK_END) { $target = $position ; $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ; } else { $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter"); } # short circuit if seeking to current offset if ($target == $here) { # On ordinary filehandles, seeking to the current # position also clears the EOF condition, so we # emulate this behavior locally while simultaneously # cascading it to the underlying filehandle if (*$self->{Plain}) { *$self->{EndStream} = 0; seek(*$self->{FH},0,1) if *$self->{FH}; } return 1; } # Outlaw any attempt to seek backwards $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards") if $target < $here ; # Walk the file to the new offset my $offset = $target - $here ; my $got; while (($got = $self->read(my $buffer, List::Util::min($offset, *$self->{BlockSize})) ) > 0) { $offset -= $got; last if $offset == 0 ; } $here = $self->tell() ; return $offset == 0 ? 1 : 0 ; } sub fileno { my $self = shift ; return defined *$self->{FH} ? fileno *$self->{FH} : undef ; } sub binmode { 1; # my $self = shift ; # return defined *$self->{FH} # ? binmode *$self->{FH} # : 1 ; } sub opened { my $self = shift ; return ! *$self->{Closed} ; } sub autoflush { my $self = shift ; return defined *$self->{FH} ? *$self->{FH}->autoflush(@_) : undef ; } sub input_line_number { my $self = shift ; my $last = *$self->{LineNo}; $. = *$self->{LineNo} = $_[1] if @_ ; return $last; } *BINMODE = \&binmode; *SEEK = \&seek; *READ = \&read; *sysread = \&read; *TELL = \&tell; *EOF = \&eof; *FILENO = \&fileno; *CLOSE = \&close; sub _notAvailable { my $name = shift ; return sub { croak "$name Not Available: File opened only for intput" ; } ; } *print = _notAvailable('print'); *PRINT = _notAvailable('print'); *printf = _notAvailable('printf'); *PRINTF = _notAvailable('printf'); *write = _notAvailable('write'); *WRITE = _notAvailable('write'); #*sysread = \&read; #*syswrite = \&_notAvailable; package IO::Uncompress::Base ; 1 ; __END__ =head1 NAME IO::Uncompress::Base - Base Class for IO::Uncompress modules =head1 SYNOPSIS use IO::Uncompress::Base ; =head1 DESCRIPTION This module is not intended for direct use in application code. Its sole purpose is to be sub-classed by IO::Uncompress modules. =head1 SUPPORT General feedback/questions/bug reports should be sent to L<https://github.com/pmqs/IO-Compress/issues> (preferred) or L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> L<IO::Compress::FAQ|IO::Compress::FAQ> L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, L<Archive::Tar|Archive::Tar>, L<IO::Zlib|IO::Zlib> =head1 AUTHOR This module was written by Paul Marquess, C<pmqs@cpan.org>. =head1 MODIFICATION HISTORY See the Changes file. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005-2019 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. usr/lib/x86_64-linux-gnu/perl5/5.32/DBD/Gofer/Transport/Base.pm 0000644 00000030723 15150771631 0017275 0 ustar 00 package DBD::Gofer::Transport::Base; # $Id: Base.pm 14120 2010-06-07 19:52:19Z H.Merijn $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use base qw(DBI::Gofer::Transport::Base); our $VERSION = "0.014121"; __PACKAGE__->mk_accessors(qw( trace go_dsn go_url go_policy go_timeout go_retry_hook go_retry_limit go_cache cache_hit cache_miss cache_store )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($class, $args) = @_; $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; #warn "args @{[ %$args ]}\n"; return $class->SUPER::new($args); } sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } sub new_response { my $self = shift; return DBI::Gofer::Response->new(@_); } sub transmit_request { my ($self, $request) = @_; my $trace = $self->trace; my $response; my ($go_cache, $request_cache_key); if ($go_cache = $self->{go_cache}) { $request_cache_key = $request->{meta}{request_cache_key} = $self->get_cache_key_for_request($request); if ($request_cache_key) { my $frozen_response = eval { $go_cache->get($request_cache_key) }; if ($frozen_response) { $self->_dump("cached response found for ".ref($request), $request) if $trace; $response = $self->thaw_response($frozen_response); $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") if $trace; ++$self->{cache_hit}; return $response; } warn $@ if $@; ++$self->{cache_miss}; $self->trace_msg("transmit_request cache miss\n") if $trace; } } my $to = $self->go_timeout; my $transmit_sub = sub { $self->trace_msg("transmit_request\n") if $trace; local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { local $SIG{PIPE} = sub { my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; die "Unable to send request: Broken pipe$extra\n"; }; alarm($to) if $to; $self->transmit_request_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("transmit_request", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; $response = $self->_transmit_request_with_retries($request, $transmit_sub); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key; } $self->trace_msg("transmit_request is returning a response itself\n") if $trace && $response; return $response unless wantarray; return ($response, $transmit_sub); } sub _transmit_request_with_retries { my ($self, $request, $transmit_sub) = @_; my $response; do { $response = $transmit_sub->(); } while ( $response && $self->response_needs_retransmit($request, $response) ); return $response; } sub receive_response { my ($self, $request, $retransmit_sub) = @_; my $to = $self->go_timeout; my $receive_sub = sub { $self->trace_msg("receive_response\n"); local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { alarm($to) if $to; $self->receive_response_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("receive_response", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; my $response; do { $response = $receive_sub->(); if ($self->response_needs_retransmit($request, $response)) { $response = $self->_transmit_request_with_retries($request, $retransmit_sub); $response ||= $receive_sub->(); } } while ( $self->response_needs_retransmit($request, $response) ); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; my $request_cache_key = $request->{meta}{request_cache_key}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key && $self->{go_cache}; } return $response; } sub response_retry_preference { my ($self, $request, $response) = @_; # give the user a chance to express a preference (or undef for default) if (my $go_retry_hook = $self->go_retry_hook) { my $retry = $go_retry_hook->($request, $response, $self); $self->trace_msg(sprintf "go_retry_hook returned %s\n", (defined $retry) ? $retry : 'undef'); return $retry if defined $retry; } # This is the main decision point. We don't retry requests that got # as far as executing because the error is probably from the database # (not transport) so retrying is unlikely to help. But note that any # severe transport error occurring after execute is likely to return # a new response object that doesn't have the execute flag set. Beware! return 0 if $response->executed_flag_set; return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set return undef; # we couldn't make up our mind } sub response_needs_retransmit { my ($self, $request, $response) = @_; my $err = $response->err or return 0; # nothing went wrong my $retry = $self->response_retry_preference($request, $response); if (!$retry) { # false or undef $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); return 0; } # we'd like to retry but have we retried too much already? my $retry_limit = $self->go_retry_limit; if (!$retry_limit) { $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); return 0; } my $request_meta = $request->meta; my $retry_count = $request_meta->{retry_count} || 0; if ($retry_count >= $retry_limit) { $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); # XXX should be possible to disable altering the err $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); return 0; } # will retry now, do the admin ++$retry_count; $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); # hook so response_retry_preference can defer some code execution # until we've checked retry_count and retry_limit. if (ref $retry eq 'CODE') { $retry->($retry_count, $retry_limit) and warn "should return false"; # protect future use } ++$request_meta->{retry_count}; # update count for this request object ++$self->meta->{request_retry_count}; # update cumulative transport stats return 1; } sub transport_timedout { my ($self, $method, $timeout) = @_; $timeout ||= $self->go_timeout; return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); } # return undef if we don't want to cache this request # subclasses may use more specialized rules sub get_cache_key_for_request { my ($self, $request) = @_; # we only want to cache idempotent requests # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set return undef if not $request->is_idempotent; # XXX would be nice to avoid the extra freeze here my $key = $self->freeze_request($request, undef, 1); #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; return $key; } sub _store_response_in_cache { my ($self, $frozen_response, $request_cache_key) = @_; my $go_cache = $self->{go_cache} or return; # new() ensures that enabling go_cache also enables keep_meta_frozen warn "No meta frozen in response" if !$frozen_response; warn "No request_cache_key" if !$request_cache_key; if ($frozen_response && $request_cache_key) { $self->trace_msg("receive_response added response to cache $go_cache\n"); eval { $go_cache->set($request_cache_key, $frozen_response) }; warn $@ if $@; ++$self->{cache_store}; } } 1; __END__ =head1 NAME DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports =head1 SYNOPSIS my $remote_dsn = "..." DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...' which will force I<all> DBI connections to be made via that Gofer server. =head1 DESCRIPTION This is the base class for all DBD::Gofer client transports. =head1 ATTRIBUTES Gofer transport attributes can be specified either in the attributes parameter of the connect() method call, or in the DSN string. When used in the DSN string, attribute names don't have the C<go_> prefix. =head2 go_dsn The full DBI DSN that the Gofer server should connect to on your behalf. When used in the DSN it must be the last element in the DSN string. =head2 go_timeout A time limit for sending a request and receiving a response. Some drivers may implement sending and receiving as separate steps, in which case (currently) the timeout applies to each separately. If a request needs to be resent then the timeout is restarted for each sending of a request and receiving of a response. =head2 go_retry_limit The maximum number of times an request may be retried. The default is 2. =head2 go_retry_hook This subroutine reference is called, if defined, for each response received where $response->err is true. The subroutine is pass three parameters: the request object, the response object, and the transport object. If it returns an undefined value then the default retry behaviour is used. See L</RETRY ON ERROR> below. If it returns a defined but false value then the request is not resent. If it returns true value then the request is resent, so long as the number of retries does not exceed C<go_retry_limit>. =head1 RETRY ON ERROR The default retry on error behaviour is: - Retry if the error was due to DBI_GOFER_RANDOM. See L<DBI::Gofer::Execute>. - Retry if $request->is_idempotent returns true. See L<DBI::Gofer::Request>. A retry won't be allowed if the number of previous retries has reached C<go_retry_limit>. =head1 TRACING Tracing of gofer requests and responses can be enabled by setting the C<DBD_GOFER_TRACE> environment variable. A value of 1 gives a reasonably compact summary of each request and response. A value of 2 or more gives a detailed, and voluminous, dump. The trace is written using DBI->trace_msg() and so is written to the default DBI trace output, which is usually STDERR. =head1 METHODS I<This section is currently far from complete.> =head2 response_retry_preference $retry = $transport->response_retry_preference($request, $response); The response_retry_preference is called by DBD::Gofer when considering if a request should be retried after an error. Returns true (would like to retry), false (must not retry), undef (no preference). If a true value is returned in the form of a CODE ref then, if DBD::Gofer does decide to retry the request, it calls the code ref passing $retry_count, $retry_limit. Can be used for logging and/or to implement exponential backoff behaviour. Currently the called code must return using C<return;> to allow for future extensions. =head1 AUTHOR Tim Bunce, L<http://www.tim.bunce.name> =head1 LICENCE AND COPYRIGHT Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =head1 SEE ALSO L<DBD::Gofer>, L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>. and some example transports: L<DBD::Gofer::Transport::stream> L<DBD::Gofer::Transport::http> L<DBI::Gofer::Transport::mod_perl> =cut usr/lib/x86_64-linux-gnu/perl5/5.32/DBD/Gofer/Policy/Base.pm 0000644 00000011740 15151274647 0016544 0 ustar 00 package DBD::Gofer::Policy::Base; # $Id: Base.pm 10087 2007-10-16 12:42:37Z Tim $ # # Copyright (c) 2007, Tim Bunce, Ireland # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. use strict; use warnings; use Carp; our $VERSION = "0.010088"; our $AUTOLOAD; my %policy_defaults = ( # force connect method (unless overridden by go_connect_method=>'...' attribute) # if false: call same method on client as on server connect_method => 'connect', # force prepare method (unless overridden by go_prepare_method=>'...' attribute) # if false: call same method on client as on server prepare_method => 'prepare', skip_connect_check => 0, skip_default_methods => 0, skip_prepare_check => 0, skip_ping => 0, dbh_attribute_update => 'every', dbh_attribute_list => ['*'], locally_quote => 0, locally_quote_identifier => 0, cache_parse_trace_flags => 1, cache_parse_trace_flag => 1, cache_data_sources => 1, cache_type_info_all => 1, cache_tables => 0, cache_table_info => 0, cache_column_info => 0, cache_primary_key_info => 0, cache_foreign_key_info => 0, cache_statistics_info => 0, cache_get_info => 0, cache_func => 0, ); my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; __PACKAGE__->create_policy_subs(\%policy_defaults); sub create_policy_subs { my ($class, $policy_defaults) = @_; while ( my ($policy_name, $policy_default) = each %$policy_defaults) { my $policy_attr_name = "go_$policy_name"; my $sub = sub { # $policy->foo($attr, ...) #carp "$policy_name($_[1],...)"; # return the policy default value unless an attribute overrides it return (ref $_[1] && exists $_[1]->{$policy_attr_name}) ? $_[1]->{$policy_attr_name} : $policy_default; }; no strict 'refs'; *{$class . '::' . $policy_name} = $sub; } } sub AUTOLOAD { carp "Unknown policy name $AUTOLOAD used"; # only warn once no strict 'refs'; *$AUTOLOAD = sub { undef }; return undef; } sub new { my ($class, $args) = @_; my $policy = {}; bless $policy, $class; } sub DESTROY { }; 1; =head1 NAME DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...) =head1 DESCRIPTION DBD::Gofer can be configured via a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. The L<DBD::Gofer::Policy::Base> class is the base class for all the policy classes and describes all the individual policy items. The Base policy is not used directly. You should use a policy class derived from it. =head1 POLICY CLASSES Three policy classes are supplied with DBD::Gofer: L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it makes more round-trips to the Gofer server. L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy. L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications. Generally the default C<classic> policy is fine. When first testing an existing application with Gofer it is a good idea to start with the C<pedantic> policy first and then switch to C<classic> or a custom policy, for final testing. =head1 POLICY ITEMS These are temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. See the source code to this module for more details. =head1 POLICY CUSTOMIZATION XXX This area of DBD::Gofer is subject to change. There are three ways to customize policies: Policy classes are designed to influence the overall behaviour of DBD::Gofer with existing, unaltered programs, so they work in a reasonably optimal way without requiring code changes. You can implement new policy classes as subclasses of existing policies. In many cases individual policy items can be overridden on a case-by-case basis within your application code. You do this by passing a corresponding C<<go_<policy_name>>> attribute into DBI methods by your application code. This lets you fine-tune the behaviour for special cases. The policy items are implemented as methods. In many cases the methods are passed parameters relating to the DBD::Gofer code being executed. This means the policy can implement dynamic behaviour that varies depending on the particular circumstances, such as the particular statement being executed. =head1 AUTHOR Tim Bunce, L<http://www.tim.bunce.name> =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =cut
| ver. 1.4 |
Github
|
.
| PHP 7.4.33 | Generation time: 0.26 |
proxy
|
phpinfo
|
Settings