diff options
Diffstat (limited to 'gnu/usr.bin/perl/lib')
29 files changed, 958 insertions, 1128 deletions
diff --git a/gnu/usr.bin/perl/lib/Benchmark.pm b/gnu/usr.bin/perl/lib/Benchmark.pm index c472d58ffd6..d7e34f88a68 100644 --- a/gnu/usr.bin/perl/lib/Benchmark.pm +++ b/gnu/usr.bin/perl/lib/Benchmark.pm @@ -432,7 +432,7 @@ our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); clearcache clearallcache disablecache enablecache); %EXPORT_TAGS=( all => [ @EXPORT, @EXPORT_OK ] ) ; -$VERSION = 1.051; +$VERSION = 1.052; # --- ':hireswallclock' special handling @@ -890,7 +890,7 @@ sub cmpthese{ @vals = sort { $a->[7] <=> $b->[7] } @vals; # If more than half of the rates are greater than one... - my $display_as_rate = $vals[$#vals>>1]->[7] > 1; + my $display_as_rate = @vals ? ($vals[$#vals>>1]->[7] > 1) : 0; my @rows; my @col_widths; diff --git a/gnu/usr.bin/perl/lib/CGI.pm b/gnu/usr.bin/perl/lib/CGI.pm index 96bba36edf5..a7dc37ccfcc 100644 --- a/gnu/usr.bin/perl/lib/CGI.pm +++ b/gnu/usr.bin/perl/lib/CGI.pm @@ -18,13 +18,13 @@ use Carp 'croak'; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.7 2003/12/03 03:02:35 millert Exp $ + patches by merlyn'; -$CGI::VERSION='3.00'; +$CGI::revision = '$Id: CGI.pm,v 1.8 2004/04/07 21:33:04 millert Exp $'; +$CGI::VERSION=3.01; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $CGITempFile::TMPDIRECTORY = '/usr/tmp'; -use CGI::Util qw(rearrange make_attributes unescape escape expires); +use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; @@ -210,9 +210,9 @@ if ($OS eq 'VMS') { } if ($needs_binmode) { - $CGI::DefaultClass->binmode(main::STDOUT); - $CGI::DefaultClass->binmode(main::STDIN); - $CGI::DefaultClass->binmode(main::STDERR); + $CGI::DefaultClass->binmode(\*main::STDOUT); + $CGI::DefaultClass->binmode(\*main::STDIN); + $CGI::DefaultClass->binmode(\*main::STDERR); } %EXPORT_TAGS = ( @@ -232,8 +232,8 @@ if ($needs_binmode) { start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type - remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error/], @@ -295,6 +295,7 @@ sub expand_tags { sub new { my($class,@initializer) = @_; my $self = {}; + bless $self,ref $class || $class || $DefaultClass; if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'Apache') @@ -322,9 +323,20 @@ sub new { return $self; } -# We provide a DESTROY method so that the autoloader -# doesn't bother trying to find it. -sub DESTROY { } +# We provide a DESTROY method so that we can ensure that +# temporary files are closed (via Fh->DESTROY) before they +# are unlinked (via CGITempFile->DESTROY) because it is not +# possible to unlink an open file on Win32. We explicitly +# call DESTROY on each, rather than just undefing them and +# letting Perl DESTROY them by garbage collection, in case the +# user is still holding any reference to them as well. +sub DESTROY { + my $self = shift; + foreach my $href (values %{$self->{'.tmpfiles'}}) { + $href->{hndl}->DESTROY if defined $href->{hndl}; + $href->{name}->DESTROY if defined $href->{name}; + } +} sub r { my $self = shift; @@ -333,6 +345,12 @@ sub r { $r; } +sub upload_hook { + my ($self,$hook,$data) = self_or_default(@_); + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; +} + #### Method: param # Returns the value(s)of a named parameter. # If invoked in a list context, returns the @@ -447,12 +465,15 @@ sub init { # quietly read and discard the post my $buffer; my $max = $content_length; - while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max : 10000))) { - $max -= $bytes; + while ($max > 0 && + (my $bytes = $MOD_PERL + ? $self->r->read($buffer,$max < 10000 ? $max : 10000) + : read(STDIN,$buffer,$max < 10000 ? $max : 10000) + )) { + $self->cgi_error("413 Request entity too large"); + last METHOD; } - $self->cgi_error("413 Request entity too large"); - last METHOD; - } + } # Process multipart postings, but only if the initializer is # not defined. @@ -495,6 +516,21 @@ sub init { last METHOD; } + if (defined($fh) && ($fh ne '')) { + while (<$fh>) { + chomp; + last if /^=/; + push(@lines,$_); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + # last chance -- treat it as a string $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; @@ -515,7 +551,7 @@ sub init { } if ($meth eq 'POST') { - $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + $self->read_from_client(\$query_string,$content_length,0) if $content_length > 0; # Some people want to have their cake and eat it too! # Uncomment this line to have the contents of the query string @@ -528,7 +564,15 @@ sub init { # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. - $query_string = read_from_cmdline() if $DEBUG; + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } } # YL: Begin Change for XML handler 10/19/2001 @@ -655,6 +699,7 @@ sub all_parameters { # put a filehandle into binary mode (DOS) sub binmode { + return unless defined($_[1]) && defined fileno($_[1]); CORE::binmode($_[1]); } @@ -823,18 +868,19 @@ END_OF_FUNC 'new_MultipartBuffer' => <<'END_OF_FUNC', # Create a new multipart buffer sub new_MultipartBuffer { - my($self,$boundary,$length,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); } END_OF_FUNC 'read_from_client' => <<'END_OF_FUNC', # Read data from a file handle sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; + my($self, $buff, $len, $offset) = @_; local $^W=0; # prevent a warning - return undef unless defined($fh); - return read($fh, $$buff, $len, $offset); + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); } END_OF_FUNC @@ -1300,7 +1346,7 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); - return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], @@ -1530,7 +1576,7 @@ sub _style { : qq(<link rel="stylesheet" type="$type" href="$src"$other>) ) if $src; } - if ($verbatim) { + if ($verbatim) { push(@result, "<style type=\"text/css\">\n$verbatim\n</style>"); } push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code; @@ -1639,6 +1685,7 @@ sub startform { $method = lc($method) || 'post'; $enctype = $enctype || &URL_ENCODED; unless (defined $action) { + $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1)); if (length($ENV{QUERY_STRING})>0) { $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1); @@ -2509,7 +2556,7 @@ sub url { $url .= server_name(); my $port = $self->server_port; $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) + unless (lc($protocol) eq 'http' && $port == 80) || (lc($protocol) eq 'https' && $port == 443); } return $url if $base; @@ -2850,6 +2897,21 @@ sub server_software { } END_OF_FUNC +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +'virtual_port' => <<'END_OF_FUNC', +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('host'); + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || '80'; + } else { + return $self->server_port(); + } +} +END_OF_FUNC + #### Method: server_port # Return the tcp/ip port the server is running on #### @@ -3062,11 +3124,12 @@ END_OF_FUNC sub read_from_cmdline { my($input,@words); my($query_string); + my($subpath); if ($DEBUG && @ARGV) { @words = @ARGV; } elsif ($DEBUG > 1) { require "shellwords.pl"; - print STDERR "(offline mode: enter name=value pairs on standard input)\n"; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; chomp(@lines = <STDIN>); # remove newlines $input = join(" ",@lines); @words = &shellwords($input); @@ -3081,7 +3144,12 @@ sub read_from_cmdline { } else { $query_string = join('+',@words); } - return $query_string; + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; } END_OF_FUNC @@ -3095,8 +3163,8 @@ END_OF_FUNC ##### 'read_multipart' => <<'END_OF_FUNC', sub read_multipart { - my($self,$boundary,$length,$filehandle) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle); + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); my $filenumber = 0; @@ -3156,10 +3224,11 @@ sub read_multipart { $seqno += int rand(100); } die "CGI open of tmpfile: $!\n" unless defined $filehandle; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); # if this is an multipart/mixed attachment, save the header - # together with the body for lateron parsing with an external + # together with the body for later parsing with an external # MIME parser module if ( $multipart ) { foreach ( keys %header ) { @@ -3170,9 +3239,15 @@ sub read_multipart { my ($data); local($\) = ''; - while (defined($data = $buffer->read)) { + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); + } print $filehandle $data; - } + } # back up to beginning of file seek($filehandle,0,0); @@ -3187,6 +3262,7 @@ sub read_multipart { # Save some information about the uploaded file where we can get # at it later. $self->{'.tmpfiles'}->{fileno($filehandle)}= { + hndl => $filehandle, name => $tmpfile, info => {%header}, }; @@ -3337,6 +3413,8 @@ END_OF_AUTOLOAD ######################## MultipartBuffer #################### package MultipartBuffer; +use constant DEBUG => 0; + # how many bytes to read at a time. We use # a 4K buffer by default. $INITIAL_FILLUNIT = 1024 * 4; @@ -3359,17 +3437,9 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package,$interface,$boundary,$length,$filehandle) = @_; + my($package,$interface,$boundary,$length) = @_; $FILLUNIT = $INITIAL_FILLUNIT; - my $IN; - if ($filehandle) { - my($package) = caller; - # force into caller's package if necessary - $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; - } - $IN = "main::STDIN" unless $IN; - - $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always # If the user types garbage into the file upload field, # then Netscape passes NOTHING to the server (not good). @@ -3392,7 +3462,7 @@ sub new { } else { # otherwise we find it ourselves my($old); ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line - $boundary = <$IN>; # BUG: This won't work correctly under mod_perl + $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl $length -= length($boundary); chomp($boundary); # remove the CRLF $/ = $old; # restore old line separator @@ -3401,7 +3471,6 @@ sub new { my $self = {LENGTH=>$length, BOUNDARY=>$boundary, - IN=>$IN, INTERFACE=>$interface, BUFFER=>'', }; @@ -3415,7 +3484,7 @@ sub new { unless ($boundary_read) { while ($self->read(0)) { } } - die "Malformed multipart POST\n" if $self->eof; + die "Malformed multipart POST: data truncated\n" if $self->eof; return $retval; } @@ -3428,7 +3497,7 @@ sub readHeader { my($ok) = 0; my($bad) = 0; - local($CRLF) = "\015\012" if $CGI::OS eq 'VMS'; + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; do { $self->fillBuffer($FILLUNIT); @@ -3440,10 +3509,18 @@ sub readHeader { } until $ok || $bad; return () if $bad; + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if DEBUG; + } + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 # (Folding Long Header Fields), 3.4.3 (Comments) # and 3.4.5 (Quoted-Strings). @@ -3466,9 +3543,18 @@ sub readBody { my($self) = @_; my($data); my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + while (defined($data = $self->read)) { $returnval .= $data; } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if DEBUG; + } return $returnval; } END_OF_FUNC @@ -3481,30 +3567,38 @@ sub read { my($self,$bytes) = @_; # default number of bytes to read - $bytes = $bytes || $FILLUNIT; + $bytes = $bytes || $FILLUNIT; # Fill up our internal buffer in such a way that the boundary # is never split between reads. $self->fillBuffer($bytes); + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + # Find the boundary in the buffer (it may not be there). - my $start = index($self->{BUFFER},$self->{BOUNDARY}); + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG; # protect against malformed multipart POST operations die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. + # If the boundary begins the data, then skip past it # and return undef. if ($start == 0) { # clear us out completely if we've hit the last boundary. - if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { + if (index($self->{BUFFER},$boundary_end)==0) { $self->{BUFFER}=''; $self->{LENGTH}=0; return undef; } # just remove the boundary. - substr($self->{BUFFER},0,length($self->{BOUNDARY}))=''; + substr($self->{BUFFER},0,length($boundary_start))=''; $self->{BUFFER} =~ s/^\012\015?//; return undef; } @@ -3516,7 +3610,7 @@ sub read { # leave enough bytes in the buffer to allow us to read # the boundary. Thanks to Kevin Hendrick for finding # this one. - $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); + $bytesToReturn = $bytes - (length($boundary_start)+1); } my $returnval=substr($self->{BUFFER},0,$bytesToReturn); @@ -3541,11 +3635,11 @@ sub fillBuffer { my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; - # Try to read some data. We may hang here if the browser is screwed up. - my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, - \$self->{BUFFER}, + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, $bytesToRead, $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG; $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() @@ -4634,11 +4728,8 @@ The redirect() function redirects the browser to a different URL. If you use redirection like this, you should B<not> print out a header as well. -One hint I can offer is that relative links may not work correctly -when you generate a redirection to another document on your site. -This is due to a well-intentioned optimization that some servers use. -The solution to this is to use the full URL (including the http: part) -of the document you are redirecting to. +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. You can also use named arguments: @@ -5544,6 +5635,29 @@ Example: You are free to create a custom HTML page to complain about the error, if you wish. +You can set up a callback that will be called whenever a file upload +is being read during the form processing. This is much like the +UPLOAD_HOOK facility available in Apache::Request, with the exception +that the first argument to the callback is an Apache::Upload object, +here it's the remote filename. + + $q = CGI->new(); + $q->upload_hook(\&hook,$data); + + sub hook + { + my ($filename, $buffer, $bytes_read, $data) = @_; + print "Read $bytes_read bytes of $filename\n"; + } + +If using the function-oriented interface, call the CGI::upload_hook() +method before calling param() or any other CGI functions: + + CGI::upload_hook(\&hook,$data); + +This method is not exported by default. You will have to import it +explicitly if you wish to use it without the CGI:: prefix. + If you are using CGI.pm on a Windows platform and find that binary files get slightly larger when uploaded but that text files remain the same, then you have forgotten to activate binary mode on the output @@ -6393,8 +6507,8 @@ side-by-side frames. CGI.pm has limited support for HTML3's cascading style sheets (css). To incorporate a stylesheet into your document, pass the start_html() method a B<-style> parameter. The value of this -parameter may be a scalar, in which case it is incorporated directly -into a <style> section, or it may be a hash reference. In the latter +parameter may be a scalar, in which case it is treated as the source +URL for the stylesheet, or it may be a hash reference. In the latter case you should provide the hash with one or more of B<-src> or B<-code>. B<-src> points to a URL where an externally-defined stylesheet can be found. B<-code> points to a scalar value to be @@ -6534,6 +6648,11 @@ pairs: your_script.pl "name1='I am a long value'" "name2=two\ words" +Finally, you can set the path info for the script by prefixing the first +name/value parameter with the path followed by a question mark (?): + + your_script.pl /your/path/here?name1=value1&name2=value2 + =head2 DUMPING OUT ALL THE NAME/VALUE PAIRS The Dump() method produces a string consisting of all the query's @@ -6662,6 +6781,11 @@ the browser attempted to contact Return the port that the server is listening on. +=item B<virtual_port ()> + +Like server_port() except that it takes virtual hosts into account. +Use this when running with virtual hosts. + =item B<server_software ()> Returns the server software and version number. diff --git a/gnu/usr.bin/perl/lib/CGI/Carp.pm b/gnu/usr.bin/perl/lib/CGI/Carp.pm index b99004189d3..255b9e758a6 100644 --- a/gnu/usr.bin/perl/lib/CGI/Carp.pm +++ b/gnu/usr.bin/perl/lib/CGI/Carp.pm @@ -243,6 +243,8 @@ non-overridden program name former isn't working in some people's hands. There is no such thing as reliable exception handling in Perl. +1.27 Replaced tell STDOUT with bytes=tell STDOUT. + =head1 AUTHORS Copyright 1995-2002, Lincoln D. Stein. All rights reserved. @@ -279,7 +281,7 @@ use File::Spec; $main::SIG{__WARN__}=\&CGI::Carp::warn; -$CGI::Carp::VERSION = '1.26'; +$CGI::Carp::VERSION = '1.27'; $CGI::Carp::CUSTOM_MSG = undef; @@ -490,7 +492,8 @@ END $r->custom_response(500,$mess); } } else { - if (eval{tell STDOUT}) { + my $bytes_written = eval{tell STDOUT}; + if (defined $bytes_written && $bytes_written > 0) { print STDOUT $mess; } else { diff --git a/gnu/usr.bin/perl/lib/CGI/Cookie.pm b/gnu/usr.bin/perl/lib/CGI/Cookie.pm index 7060fb48273..27a93c55b0d 100644 --- a/gnu/usr.bin/perl/lib/CGI/Cookie.pm +++ b/gnu/usr.bin/perl/lib/CGI/Cookie.pm @@ -220,7 +220,7 @@ sub expires { sub max_age { my $self = shift; my $expires = shift; - $self->{'max-age'} = CGI::Util::expire_calc($expires)-time if defined $expires; + $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires; return $self->{'max-age'}; } diff --git a/gnu/usr.bin/perl/lib/CGI/Fast.pm b/gnu/usr.bin/perl/lib/CGI/Fast.pm index 5f744e3584c..ad7a28eddc7 100644 --- a/gnu/usr.bin/perl/lib/CGI/Fast.pm +++ b/gnu/usr.bin/perl/lib/CGI/Fast.pm @@ -16,7 +16,7 @@ package CGI::Fast; # The most recent version and complete docs are available at: # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -$CGI::Fast::VERSION='1.041'; +$CGI::Fast::VERSION='1.05'; use CGI; use FCGI; diff --git a/gnu/usr.bin/perl/lib/CGI/Pretty.pm b/gnu/usr.bin/perl/lib/CGI/Pretty.pm index 61aff822565..d824a025e4f 100644 --- a/gnu/usr.bin/perl/lib/CGI/Pretty.pm +++ b/gnu/usr.bin/perl/lib/CGI/Pretty.pm @@ -10,7 +10,7 @@ package CGI::Pretty; use strict; use CGI (); -$CGI::Pretty::VERSION = '1.07_00'; +$CGI::Pretty::VERSION = '1.08'; $CGI::DefaultClass = __PACKAGE__; $CGI::Pretty::AutoloadClass = 'CGI'; @CGI::Pretty::ISA = qw( CGI ); diff --git a/gnu/usr.bin/perl/lib/CGI/Util.pm b/gnu/usr.bin/perl/lib/CGI/Util.pm index e0e7a842283..be104facf91 100644 --- a/gnu/usr.bin/perl/lib/CGI/Util.pm +++ b/gnu/usr.bin/perl/lib/CGI/Util.pm @@ -4,9 +4,10 @@ use strict; use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(rearrange make_attributes unescape escape expires); +@EXPORT_OK = qw(rearrange make_attributes unescape escape + expires ebcdic2ascii ascii2ebcdic); -$VERSION = '1.31'; +$VERSION = '1.4'; $EBCDIC = "\t" ne "\011"; if ($EBCDIC) { @@ -268,6 +269,18 @@ sub expire_calc { return (time+$offset); } +sub ebcdic2ascii { + my $data = shift; + $data =~ s/(.)/chr $E2A[ord($1)]/ge; + $data; +} + +sub ascii2ebcdic { + my $data = shift; + $data =~ s/(.)/chr $A2E[ord($1)]/ge; + $data; +} + 1; __END__ diff --git a/gnu/usr.bin/perl/lib/CGI/t/carp.t b/gnu/usr.bin/perl/lib/CGI/t/carp.t index dcdf7324108..6d20a4fe9d6 100644 --- a/gnu/usr.bin/perl/lib/CGI/t/carp.t +++ b/gnu/usr.bin/perl/lib/CGI/t/carp.t @@ -8,7 +8,7 @@ use lib qw(t/lib); # ensure the blib's are in @INC, else we might use the core CGI.pm use lib qw(blib/lib blib/arch); -use Test::More tests => 47; +use Test::More tests => 41; use IO::Handle; BEGIN { use_ok('CGI::Carp') }; @@ -68,7 +68,6 @@ like(stamp2(), $stamp, "Time in correct format"); # set some variables to control what's going on. $CGI::Carp::WARN = 0; $CGI::Carp::EMIT_WARNINGS = 0; -@CGI::Carp::WARNINGS = (); my $q_file = quotemeta($file); @@ -82,7 +81,6 @@ $expect_l = __LINE__ + 1; is(CGI::Carp::warn("There is a problem"), "Called realwarn", "CGI::Carp::warn calls CORE::warn"); -is(@CGI::Carp::WARNINGS, 0, "_warn not called"); # Test that message is constructed correctly eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};'; @@ -91,21 +89,15 @@ $expect_l = __LINE__ + 1; like(CGI::Carp::warn("There is a problem"), "/] $id: There is a problem at $q_file line $expect_l.".'$/', "CGI::Carp::warn builds correct message"); -is(@CGI::Carp::WARNINGS, 0, "_warn not called"); # Test that _warn is called at the correct time $CGI::Carp::WARN = 1; -$expect_l = __LINE__ + 1; +my $warn_expect_l = $expect_l = __LINE__ + 1; like(CGI::Carp::warn("There is a problem"), "/] $id: There is a problem at $q_file line $expect_l.".'$/', "CGI::Carp::warn builds correct message"); -is(@CGI::Carp::WARNINGS, 1, "_warn now called"); -like($CGI::Carp::WARNINGS[0], - "/There is a problem at $q_file line $expect_l.".'$/', - "CGI::Carp::WARNINGS has correct message (without stamp)"); - #----------------------------------------------------------------------------- # Test ineval #----------------------------------------------------------------------------- @@ -180,9 +172,6 @@ is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset corre CGI::Carp::warningsToBrowser(0); is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off"); -unless( is(@CGI::Carp::WARNINGS, 1, "_warn not called") ) { - print join "\n", map "'$_'", @CGI::Carp::WARNINGS; -} # turn off STDOUT (prevents spurious warnings to screen tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; @@ -193,11 +182,10 @@ untie *STDOUT; open(STDOUT, ">&REAL_STDOUT"); my $fname = $0; $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also -is( $fake_out, "<!-- warning: There is a problem at $fname line 100. -->\n", +is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n", 'warningsToBrowser() on' ); is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off"); -is(@CGI::Carp::WARNINGS, 0, "_warn is called"); #----------------------------------------------------------------------------- # Test fatals_to_browser diff --git a/gnu/usr.bin/perl/lib/CGI/t/request.t b/gnu/usr.bin/perl/lib/CGI/t/request.t index 96775a92797..d39619c4908 100644 --- a/gnu/usr.bin/perl/lib/CGI/t/request.t +++ b/gnu/usr.bin/perl/lib/CGI/t/request.t @@ -2,7 +2,7 @@ # Test ability to retrieve HTTP request info ######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; +use lib '.','../blib/lib','../blib/arch'; BEGIN {$| = 1; print "1..33\n"; } END {print "not ok 1\n" unless $loaded;} diff --git a/gnu/usr.bin/perl/lib/Cwd.pm b/gnu/usr.bin/perl/lib/Cwd.pm index 984375fb0f6..51ca5b6f540 100644 --- a/gnu/usr.bin/perl/lib/Cwd.pm +++ b/gnu/usr.bin/perl/lib/Cwd.pm @@ -1,5 +1,4 @@ package Cwd; -use 5.006; =head1 NAME @@ -137,12 +136,14 @@ L<File::chdir> =cut use strict; +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -our $VERSION = '2.08'; +$VERSION = '2.12'; -use base qw/ Exporter /; -our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +@ISA = qw/ Exporter /; +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command @@ -150,16 +151,19 @@ our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # there is no sense to process the rest of the file. # The best choice may be to have this in BEGIN, but how to return from BEGIN? -if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) { +if ($^O eq 'os2') { local $^W = 0; - *cwd = \&sys_cwd; - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&sys_abspath; - *fast_abs_path = \&abs_path; - *realpath = \&abs_path; - *fast_realpath = \&abs_path; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + return 1; } @@ -191,6 +195,10 @@ unless ($pwd_cmd) { } } +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +sub _croak { require Carp; Carp::croak(@_) } + # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; @@ -358,8 +366,7 @@ sub _perl_abs_path unless (@cst = stat( $start )) { - require Carp; - Carp::carp ("stat($start): $!"); + _carp("stat($start): $!"); return ''; } $cwd = ''; @@ -371,14 +378,12 @@ sub _perl_abs_path local *PARENT; unless (opendir(PARENT, $dotdots)) { - require Carp; - Carp::carp ("opendir($dotdots): $!"); + _carp("opendir($dotdots): $!"); return ''; } unless (@cst = stat($dotdots)) { - require Carp; - Carp::carp ("stat($dotdots): $!"); + _carp("stat($dotdots): $!"); closedir(PARENT); return ''; } @@ -392,8 +397,7 @@ sub _perl_abs_path { unless (defined ($dir = readdir(PARENT))) { - require Carp; - Carp::carp ("readdir($dotdots): $!"); + _carp("readdir($dotdots): $!"); closedir(PARENT); return ''; } @@ -426,13 +430,11 @@ sub fast_abs_path { ($cwd) = $cwd =~ /(.*)/; if (!CORE::chdir($path)) { - require Carp; - Carp::croak ("Cannot chdir to $path: $!"); + _croak("Cannot chdir to $path: $!"); } my $realpath = getcwd(); if (! ((-d $cwd) && (CORE::chdir($cwd)))) { - require Carp; - Carp::croak ("Cannot chdir back to $cwd: $!"); + _croak("Cannot chdir back to $cwd: $!"); } $realpath; } @@ -461,8 +463,7 @@ sub _vms_abs_path { my $path = VMS::Filespec::pathify($_[0]); if (! defined $path) { - require Carp; - Carp::croak("Invalid path name $_[0]") + _croak("Invalid path name $_[0]") } return VMS::Filespec::rmsexpand($path); } @@ -545,14 +546,6 @@ sub _epoc_cwd { *abs_path = \&fast_abs_path; *realpath = \&fast_abs_path; } - elsif ($^O eq 'os2') { - # sys_cwd may keep the builtin command - *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&fast_abs_path; - } elsif ($^O eq 'dos') { *cwd = \&_dos_cwd; *getcwd = \&_dos_cwd; @@ -573,6 +566,7 @@ sub _epoc_cwd { *fastgetcwd = \&cwd; *fastcwd = \&cwd; *abs_path = \&fast_abs_path; + *realpath = \&abs_path; } elsif ($^O eq 'epoc') { *cwd = \&_epoc_cwd; diff --git a/gnu/usr.bin/perl/lib/Digest.t b/gnu/usr.bin/perl/lib/Digest.t deleted file mode 100644 index fbc2dac8056..00000000000 --- a/gnu/usr.bin/perl/lib/Digest.t +++ /dev/null @@ -1,23 +0,0 @@ -print "1..3\n"; - -use Digest; - -my $hexdigest = "900150983cd24fb0d6963f7d28e17f72"; # ASCII - -if (ord('A') == 193) { # EBCDIC - $hexdigest = "fe4ea0d98f9cd8d1d27f102a93cb0bb0"; # IBM-1047 -} - -print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest; -print "ok 1\n"; - -print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest; -print "ok 2\n"; - -eval { - # Not yet EBCDICified. - print "not " unless Digest->new("HMAC-MD5" => "Jefe")->add("what do ya want for nothing?")->hexdigest eq "750c783e6ab0b503eaa86e310a5db738"; - print "ok 3\n"; -}; -print "ok 3\n" if $@ && $@ =~ /^Can't locate/; - diff --git a/gnu/usr.bin/perl/lib/Exporter.pm b/gnu/usr.bin/perl/lib/Exporter.pm index 753ea6aab27..176f6b8a98f 100644 --- a/gnu/usr.bin/perl/lib/Exporter.pm +++ b/gnu/usr.bin/perl/lib/Exporter.pm @@ -9,7 +9,7 @@ require 5.006; our $Debug = 0; our $ExportLevel = 0; our $Verbose ||= 0; -our $VERSION = '5.567'; +our $VERSION = '5.57'; our (%Cache); $Carp::Internal{Exporter} = 1; @@ -30,6 +30,11 @@ sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); + if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { + *{$callpkg."::import"} = \&import; + return; + } + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); return export $pkg, $callpkg, @_ @@ -103,6 +108,12 @@ In module YourModule.pm: @ISA = qw(Exporter); @EXPORT_OK = qw(munge frobnicate); # symbols to export on request +or + + package YourModule; + use Exporter 'import'; # gives you Exporter's import() method directly + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + In other files which wish to use YourModule: use ModuleName qw(frobnicate); # import listed symbols @@ -286,9 +297,21 @@ Instead, say the following: This will export the symbols one level 'above' the current package - ie: to the program or module that used package A. -Note: Be careful not to modify '@_' at all before you call export_to_level +Note: Be careful not to modify C<@_> at all before you call export_to_level - or people using your package will get very unexplained results! +=head2 Exporting without inheriting from Exporter + +By including Exporter in your @ISA you inherit an Exporter's import() method +but you also inherit several other helper methods which you probably don't +want. To avoid this you can do + + package YourModule; + use Exporter qw( import ); + +which will export Exporter's own import() method into YourModule. +Everything will work as before but you won't need to include Exporter in +@YourModule::ISA. =head2 Module Version Checking diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm index 97987332547..3cd6cd37ce1 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm @@ -2769,7 +2769,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) require File::Find; File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; - return if m/^libperl/; + return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/; # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; diff --git a/gnu/usr.bin/perl/lib/File/CheckTree.pm b/gnu/usr.bin/perl/lib/File/CheckTree.pm index 7884ca711e6..20ffd68124d 100644 --- a/gnu/usr.bin/perl/lib/File/CheckTree.pm +++ b/gnu/usr.bin/perl/lib/File/CheckTree.pm @@ -7,7 +7,7 @@ use File::Spec; use warnings; use strict; -our $VERSION = '4.2'; +our $VERSION = '4.3'; our @ISA = qw(Exporter); our @EXPORT = qw(validate); @@ -50,7 +50,9 @@ The routine returns the number of warnings issued. =head1 AUTHOR -Unknown. Revised by Paul Grassie <F<grassie@perl.com>> in 2002. +File::CheckTree was derived from lib/validate.pl which was +written by Larry Wall. +Revised by Paul Grassie <F<grassie@perl.com>> in 2002. =head1 HISTORY diff --git a/gnu/usr.bin/perl/lib/File/Copy.pm b/gnu/usr.bin/perl/lib/File/Copy.pm index 0e87e988d52..f5b22e288a0 100644 --- a/gnu/usr.bin/perl/lib/File/Copy.pm +++ b/gnu/usr.bin/perl/lib/File/Copy.pm @@ -24,7 +24,7 @@ sub mv; # package has not yet been updated to work with Perl 5.004, and so it # would be a Bad Thing for the CPAN module to grab it and replace this # module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.06'; +$VERSION = '2.07'; require Exporter; @ISA = qw(Exporter); @@ -77,13 +77,12 @@ sub copy { croak("'$from' and '$to' are identical (not copied)"); } - if ($Config{d_symlink} && $Config{d_readlink} && - !($^O eq 'Win32' || $^O eq 'os2' || $^O eq 'vms')) { - no warnings 'io'; # don't warn if -l on filehandle - if ((-e $from && -l $from) || (-e $to && -l $to)) { - my @fs = stat($from); + if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && + !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) { + my @fs = stat($from); + if (@fs) { my @ts = stat($to); - if (@fs && @ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { + if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { croak("'$from' and '$to' are identical (not copied)"); } } diff --git a/gnu/usr.bin/perl/lib/File/Find.pm b/gnu/usr.bin/perl/lib/File/Find.pm index 4c15d384d75..f9fb16b12c2 100644 --- a/gnu/usr.bin/perl/lib/File/Find.pm +++ b/gnu/usr.bin/perl/lib/File/Find.pm @@ -3,7 +3,7 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.05'; +our $VERSION = '1.06'; require Exporter; require Cwd; @@ -44,27 +44,29 @@ but have subtle differences. find(\&wanted, @directories); find(\%options, @directories); -find() does a breadth-first search over the given @directories in the +C<find()> does a breadth-first search over the given C<@directories> in the order they are given. In essence, it works from the top down. -For each file or directory found the &wanted subroutine is called (see -below for details). Additionally, for each directory found it will go -into that directory and continue the search. +For each file or directory found, the C<&wanted> subroutine is called, +with the return code ignored. (See below for details on how to use +the C<&wanted> function). Additionally, for each directory found, +it will go into that directory and continue the search. =item B<finddepth> finddepth(\&wanted, @directories); finddepth(\%options, @directories); -finddepth() works just like find() except it does a depth-first search. +C<finddepth()> works just like C<find()> except it does a depth-first search. It works from the bottom of the directory tree up. =back =head2 %options -The first argument to find() is either a hash reference describing the -operations to be performed for each file, or a code reference. The +The first argument to C<find()> is either a code reference to your +C<&wanted> function, or a hash reference describing the operations +to be performed for each file. The code reference is described in L<The wanted function> below. Here are the possible keys for the hash: @@ -79,15 +81,15 @@ described in L<The wanted function> below. =item C<bydepth> Reports the name of a directory only AFTER all its entries -have been reported. Entry point finddepth() is a shortcut for -specifying C<{ bydepth =E<gt> 1 }> in the first argument of find(). +have been reported. Entry point C<finddepth()> is a shortcut for +specifying C<<{ bydepth => 1 }>> in the first argument of C<find()>. =item C<preprocess> The value should be a code reference. This code reference is used to -preprocess the current directory. The name of currently processed -directory is in $File::Find::dir. Your preprocessing function is -called after readdir() but before the loop that calls the wanted() +preprocess the current directory. The name of the currently processed +directory is in C<$File::Find::dir>. Your preprocessing function is +called after C<readdir()>, but before the loop that calls the C<wanted()> function. It is called with a list of strings (actually file/directory names) and is expected to return a list of strings. The code can be used to sort the file/directory names alphabetically, numerically, @@ -98,7 +100,7 @@ I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. The value should be a code reference. It is invoked just before leaving the currently processed directory. It is called in void context with no -arguments. The name of the current directory is in $File::Find::dir. This +arguments. The name of the current directory is in C<$File::Find::dir>. This hook is handy for summarizing a directory, such as calculating its disk usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a no-op. @@ -117,7 +119,7 @@ If either I<follow> or I<follow_fast> is in effect: =item * It is guaranteed that an I<lstat> has been called before the user's -I<wanted()> function is called. This enables fast file checks involving S< _>. +C<wanted()> function is called. This enables fast file checks involving S< _>. =item * @@ -131,7 +133,7 @@ pathname of the file with all symbolic links resolved This is similar to I<follow> except that it may report some files more than once. It does detect cycles, however. Since only symbolic links have to be hashed, this is much cheaper both in space and time. If -processing a file more than once (by the user's I<wanted()> function) +processing a file more than once (by the user's C<wanted()> function) is worse than just taking time, the option I<follow> should be used. =item C<follow_skip> @@ -140,8 +142,10 @@ C<follow_skip==1>, which is the default, causes all files which are neither directories nor symbolic links to be ignored if they are about to be processed a second time. If a directory or a symbolic link are about to be processed a second time, File::Find dies. + C<follow_skip==0> causes File::Find to die if any file is about to be processed a second time. + C<follow_skip==2> causes File::Find to ignore any duplicate files and directories but to proceed normally otherwise. @@ -155,7 +159,7 @@ will be silently ignored. =item C<no_chdir> -Does not C<chdir()> to each directory as it recurses. The wanted() +Does not C<chdir()> to each directory as it recurses. The C<wanted()> function will need to be aware of this, of course. In this case, C<$_> will be the same as C<$File::Find::name>. @@ -183,8 +187,13 @@ including all its sub-directories. The default is to 'die' in such a case. =head2 The wanted function -The wanted() function does whatever verifications you want on each -file and directory. It takes no arguments but rather does its work +The C<wanted()> function does whatever verifications you want on +each file and directory. Note that despite its name, the C<wanted()> +function is a generic callback function, and does B<not> tell +File::Find if a file is "wanted" or not. In fact, its return value +is ignored. + +The wanted function takes no arguments but rather does its work through a collection of variables. =over 4 @@ -199,7 +208,7 @@ through a collection of variables. Don't modify these variables. -For example, when examining the file /some/path/foo.ext you will have: +For example, when examining the file F</some/path/foo.ext> you will have: $File::Find::dir = /some/path/ $_ = foo.ext @@ -251,7 +260,7 @@ produces something like: Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical filehandle that caches the information from the preceding -stat(), lstat(), or filetest. +C<stat()>, C<lstat()>, or filetest. Here's another interesting wanted function. It will find all symbolic links that don't resolve: diff --git a/gnu/usr.bin/perl/lib/FindBin.pm b/gnu/usr.bin/perl/lib/FindBin.pm index 8be9cb6b5af..4610beb2cd3 100644 --- a/gnu/usr.bin/perl/lib/FindBin.pm +++ b/gnu/usr.bin/perl/lib/FindBin.pm @@ -42,13 +42,19 @@ directory. =head1 KNOWN ISSUES If there are two modules using C<FindBin> from different directories -under the same interpreter, this won't work. Since C<FindBin> uses +under the same interpreter, this won't work. Since C<FindBin> uses a C<BEGIN> block, it'll be executed only once, and only the first caller will get it right. This is a problem under mod_perl and other persistent Perl environments, where you shouldn't use this module. Which also means that you should avoid using C<FindBin> in modules that you plan to put -on CPAN. The only way to make sure that C<FindBin> will work is to force -the C<BEGIN> block to be executed again: +on CPAN. To make sure that C<FindBin> will work is to call the C<again> +function: + + use FindBin; + FindBin::again(); # or FindBin->again; + +In former versions of FindBin there was no C<again> function. The +workaround was to force the C<BEGIN> block to be executed again: delete $INC{'FindBin.pm'}; require FindBin; @@ -96,9 +102,9 @@ use File::Spec; %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = "1.43"; +$VERSION = "1.44"; -BEGIN +sub init { *Dir = \$Bin; *RealDir = \$RealBin; @@ -179,5 +185,9 @@ BEGIN } } +BEGIN { init } + +*again = \&init; + 1; # Keep require happy diff --git a/gnu/usr.bin/perl/lib/Getopt/Std.pm b/gnu/usr.bin/perl/lib/Getopt/Std.pm index 6c420937636..9bbc24f55a0 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Std.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Std.pm @@ -71,7 +71,7 @@ and version_mess() with the switches string as an argument. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); -$VERSION = '1.04'; +$VERSION = '1.05'; # uncomment the next line to disable 1.03-backward compatibility paranoia # $STANDARD_HELP_VERSION = 1; diff --git a/gnu/usr.bin/perl/lib/Math/BigInt.pm b/gnu/usr.bin/perl/lib/Math/BigInt.pm index c193b8b4671..9a26f335210 100644 --- a/gnu/usr.bin/perl/lib/Math/BigInt.pm +++ b/gnu/usr.bin/perl/lib/Math/BigInt.pm @@ -18,21 +18,20 @@ package Math::BigInt; my $class = "Math::BigInt"; require 5.005; -$VERSION = '1.66'; +$VERSION = '1.68'; use Exporter; @ISA = qw( Exporter ); -@EXPORT_OK = qw( objectify _swap bgcd blcm); -use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode/; -use vars qw/$upgrade $downgrade/; -# the following are internal and should never be accessed from the outside -use vars qw/$_trap_nan $_trap_inf/; +@EXPORT_OK = qw( objectify bgcd blcm); +# _trap_inf and _trap_nan are internal and should never be accessed from the +# outside +use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode + $upgrade $downgrade $_trap_nan $_trap_inf/; use strict; # Inside overload, the first arg is always an object. If the original code had -# it reversed (like $x = 2 * $y), then the third paramater indicates this -# swapping. To make it work, we use a helper routine which not only reswaps the -# params, but also makes a new object in this case. See _swap() for details, -# especially the cases of operators with different classes. +# it reversed (like $x = 2 * $y), then the third paramater is true. +# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes +# no difference, but in some cases it does. # For overloaded ops with only one argument we simple use $_[0]->copy() to # preserve the argument. @@ -43,14 +42,6 @@ use strict; use overload '=' => sub { $_[0]->copy(); }, -# '+' and '-' do not use _swap, since it is a triffle slower. If you want to -# override _swap (if ever), then override overload of '+' and '-', too! -# for sub it is a bit tricky to keep b: b-a => -a+b -'-' => sub { my $c = $_[0]->copy; $_[2] ? - $c->bneg()->badd($_[1]) : - $c->bsub( $_[1]) }, -'+' => sub { $_[0]->copy()->badd($_[1]); }, - # some shortcuts for speed (assumes that reversed order of arguments is routed # to normal '+' and we thus can always modify first arg. If this is changed, # this breaks and must be adjusted.) @@ -75,35 +66,62 @@ use overload "$_[1]" cmp $_[0]->bstr() : $_[0]->bstr() cmp "$_[1]" }, -'log' => sub { $_[0]->copy()->blog(); }, +# make cos()/sin()/exp() "work" with BigInt's or subclasses +'cos' => sub { cos($_[0]->numify()) }, +'sin' => sub { sin($_[0]->numify()) }, +'exp' => sub { exp($_[0]->numify()) }, +'atan2' => sub { atan2($_[0]->numify(),$_[1]) }, + +'log' => sub { $_[0]->copy()->blog($_[1]); }, 'int' => sub { $_[0]->copy(); }, 'neg' => sub { $_[0]->copy()->bneg(); }, 'abs' => sub { $_[0]->copy()->babs(); }, 'sqrt' => sub { $_[0]->copy()->bsqrt(); }, '~' => sub { $_[0]->copy()->bnot(); }, -'*' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bmul($a[1]); }, -'/' => sub { my @a = ref($_[0])->_swap(@_);scalar $a[0]->bdiv($a[1]);}, -'%' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bmod($a[1]); }, -'**' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bpow($a[1]); }, -'<<' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->blsft($a[1]); }, -'>>' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->brsft($a[1]); }, - -'&' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->band($a[1]); }, -'|' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bior($a[1]); }, -'^' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bxor($a[1]); }, - -# can modify arg of ++ and --, so avoid a new-copy for speed, but don't -# use $_[0]->__one(), it modifies $_[0] to be 1! +# for sub it is a bit tricky to keep b: b-a => -a+b +'-' => sub { my $c = $_[0]->copy; $_[2] ? + $c->bneg()->badd($_[1]) : + $c->bsub( $_[1]) }, +'+' => sub { $_[0]->copy()->badd($_[1]); }, +'*' => sub { $_[0]->copy()->bmul($_[1]); }, + +'/' => sub { + $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]); + }, +'%' => sub { + $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]); + }, +'**' => sub { + $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]); + }, +'<<' => sub { + $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]); + }, +'>>' => sub { + $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]); + }, +'&' => sub { + $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]); + }, +'|' => sub { + $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]); + }, +'^' => sub { + $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]); + }, + +# can modify arg of ++ and --, so avoid a copy() for speed, but don't +# use $_[0]->bone(), it would modify $_[0] to be 1! '++' => sub { $_[0]->binc() }, '--' => sub { $_[0]->bdec() }, # if overloaded, O(1) instead of O(N) and twice as fast for small numbers 'bool' => sub { # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/ - # v5.6.1 dumps on that: return !$_[0]->is_zero() || undef; :-( - my $t = !$_[0]->is_zero(); - undef $t if $t == 0; + # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef; :-( + my $t = undef; + $t = 1 if !$_[0]->is_zero(); $t; }, @@ -129,16 +147,21 @@ $downgrade = undef; # default is no downgrade # these are internally, and not to be used from the outside -use constant MB_NEVER_ROUND => 0x0001; +sub MB_NEVER_ROUND () { 0x0001; } $_trap_nan = 0; # are NaNs ok? set w/ config() $_trap_inf = 0; # are infs ok? set w/ config() my $nan = 'NaN'; # constants for easier life my $CALC = 'Math::BigInt::Calc'; # module to do the low level math + # default is Calc.pm +my %CAN; # cache for $CALC->can(...) my $IMPORT = 0; # was import() called yet? # used to make require work +my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math +my $EMU = 'Math::BigInt::CalcEmu'; # emulate low-level math + ############################################################################## # the old code had $rnd_mode, so we need to support it, too @@ -147,7 +170,16 @@ sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; } sub FETCH { return $round_mode; } sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); } -BEGIN { tie $rnd_mode, 'Math::BigInt'; } +BEGIN + { + # tie to enable $rnd_mode to work transparently + tie $rnd_mode, 'Math::BigInt'; + + # set up some handy alias names + *as_int = \&as_number; + *is_pos = \&is_positive; + *is_neg = \&is_negative; + } ############################################################################## @@ -746,6 +778,7 @@ sub bone } else { + # call like: $x->bone($sign,$a,$p,$r); $self->{_a} = $_[0] if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a})); $self->{_p} = $_[1] @@ -772,8 +805,9 @@ sub bsstr return 'inf'; # +inf } my ($m,$e) = $x->parts(); - my $sign = 'e+'; # e can only be positive - return $m->bstr().$sign.$e->bstr(); + #$m->bstr() . 'e+' . $e->bstr(); # e can only be positive in BigInt + # 'e+' because E can only be positive in BigInt + $m->bstr() . 'e+' . ${$CALC->_str($e->{value})}; } sub bstr @@ -788,7 +822,7 @@ sub bstr return 'inf'; # +inf } my $es = ''; $es = $x->{sign} if $x->{sign} eq '-'; - return $es.${$CALC->_str($x->{value})}; + $es.${$CALC->_str($x->{value})}; } sub numify @@ -808,7 +842,7 @@ sub numify sub sign { # return the sign of the number: +/-/-inf/+inf/NaN - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); $x->{sign}; } @@ -934,7 +968,7 @@ sub round $r = ${"$c\::round_mode"} unless defined $r; if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc)$/) { - + require Carp; Carp::croak ("Unknown round mode '$r'"); } # now round, by calling either fround or ffround: @@ -953,7 +987,7 @@ sub bnorm { # (numstr or BINT) return BINT # Normalize number -- no-op here - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); $x; } @@ -1024,7 +1058,7 @@ sub bcmp } # $x && $y both < 0 - $CALC->_acmp($y->{value},$x->{value}); # swaped (lib returns 0,1,-1) + $CALC->_acmp($y->{value},$x->{value}); # swaped acmp (lib returns 0,1,-1) } sub bacmp @@ -1068,7 +1102,7 @@ sub badd } return $x if $x->modify('badd'); - return $upgrade->badd($x,$y,@r) if defined $upgrade && + return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade && ((!$x->isa($self)) || (!$y->isa($self))); $r[3] = $y; # no push! @@ -1090,34 +1124,29 @@ sub badd return $x; } - my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs + my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs if ($sx eq $sy) { $x->{value} = $CALC->_add($x->{value},$y->{value}); # same sign, abs add - $x->{sign} = $sx; } else { my $a = $CALC->_acmp ($y->{value},$x->{value}); # absolute compare if ($a > 0) { - #print "swapped sub (a=$a)\n"; $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap $x->{sign} = $sy; } elsif ($a == 0) { # speedup, if equal, set result to 0 - #print "equal sub, result = 0\n"; $x->{value} = $CALC->_zero(); $x->{sign} = '+'; } else # a < 0 { - #print "unswapped sub (a=$a)\n"; $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub - $x->{sign} = $sx; } } $x->round(@r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; @@ -1126,7 +1155,7 @@ sub badd sub bsub { - # (BINT or num_str, BINT or num_str) return num_str + # (BINT or num_str, BINT or num_str) return BINT # subtract second arg from first, modify first # set up parameters @@ -1175,46 +1204,71 @@ sub binc return $x; } # inf, nan handling etc - $x->badd($self->__one(),$a,$p,$r); # badd does round + $x->badd($self->bone(),$a,$p,$r); # badd does round } sub bdec { # decrement arg by one - my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); + my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); return $x if $x->modify('bdec'); - my $zero = $CALC->_is_zero($x->{value}) && $x->{sign} eq '+'; - # <= 0 - if (($x->{sign} eq '-') || $zero) + if ($x->{sign} eq '-') { + # < 0 $x->{value} = $CALC->_inc($x->{value}); - $x->{sign} = '-' if $zero; # 0 => 1 => -1 - $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0 - $x->round($a,$p,$r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; - return $x; - } - # > 0 - elsif ($x->{sign} eq '+') + } + else { - $x->{value} = $CALC->_dec($x->{value}); - $x->round($a,$p,$r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; - return $x; + return $x->badd($self->bone('-'),@r) unless $x->{sign} eq '+'; # inf/NaN + # >= 0 + if ($CALC->_is_zero($x->{value})) + { + # == 0 + $x->{value} = $CALC->_one(); $x->{sign} = '-'; # 0 => -1 + } + else + { + # > 0 + $x->{value} = $CALC->_dec($x->{value}); + } } - # inf, nan handling etc - $x->badd($self->__one('-'),$a,$p,$r); # badd does round - } + $x->round(@r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; + $x; + } sub blog { - # not implemented yet - my ($self,$x,$base,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); - - return $upgrade->blog($upgrade->new($x),$base,$a,$p,$r) if defined $upgrade; + # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base + # $base of $x) - return $x->bnan(); + # set up parameters + my ($self,$x,$base,@r) = (ref($_[0]),@_); + # objectify is costly, so avoid it + if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) + { + ($self,$x,$base,@r) = objectify(2,$class,@_); + } + + # inf, -inf, NaN, <0 => NaN + return $x->bnan() + if $x->{sign} ne '+' || $base->{sign} ne '+'; + + return $upgrade->blog($upgrade->new($x),$base,@r) if + defined $upgrade && (ref($x) ne $upgrade || ref($base) ne $upgrade); + + if ($CAN{log_int}) + { + my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value}); + return $x->bnan() unless defined $rc; + $x->{value} = $rc; + return $x->round(@r); + } + + require $EMU_LIB; + __emu_blog($self,$x,$base,@r); } - + sub blcm { # (BINT or num_str, BINT or num_str) return BINT @@ -1244,7 +1298,7 @@ sub bgcd $y = __PACKAGE__->new($y) if !ref($y); my $self = ref($y); my $x = $y->copy(); # keep arguments - if ($CALC->can('_gcd')) + if ($CAN{gcd}) { while (@_) { @@ -1273,15 +1327,16 @@ sub bnot my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_); return $x if $x->modify('bnot'); - $x->bneg()->bdec(); # bdec already does round + $x->binc()->bneg(); # binc already does round } +############################################################################## # is_foo test routines +# we don't need $self, so undef instead of ref($_[0]) make it slightly faster sub is_zero { # return true if arg (BINT or num_str) is zero (array '+', '0') - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't @@ -1291,36 +1346,28 @@ sub is_zero sub is_nan { # return true if arg (BINT or num_str) is NaN - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); - return 1 if $x->{sign} eq $nan; - 0; + $x->{sign} eq $nan ? 1 : 0; } sub is_inf { # return true if arg (BINT or num_str) is +-inf - my ($self,$x,$sign) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); - - $sign = '' if !defined $sign; - return 1 if $sign eq $x->{sign}; # match ("+inf" eq "+inf") - return 0 if $sign !~ /^([+-]|)$/; + my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_); - if ($sign eq '') + if (defined $sign) { - return 1 if ($x->{sign} =~ /^[+-]inf$/); - return 0; + $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf + $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-' + return $x->{sign} =~ /^$sign$/ ? 1 : 0; } - $sign = quotemeta($sign.'inf'); - return 1 if ($x->{sign} =~ /^$sign$/); - 0; + $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity } sub is_one { - # return true if arg (BINT or num_str) is +1 - # or -1 if sign is given - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster + # return true if arg (BINT or num_str) is +1, or -1 if sign is given my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_); $sign = '+' if !defined $sign || $sign ne '-'; @@ -1332,7 +1379,6 @@ sub is_one sub is_odd { # return true when arg (BINT or num_str) is odd, false for even - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't @@ -1342,7 +1388,6 @@ sub is_odd sub is_even { # return true when arg (BINT or num_str) is even, false for odd - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't @@ -1352,28 +1397,23 @@ sub is_even sub is_positive { # return true when arg (BINT or num_str) is positive (>= 0) - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); - return 1 if $x->{sign} =~ /^\+/; - 0; + $x->{sign} =~ /^\+/ ? 1 : 0; # +inf is also positive, but NaN not } sub is_negative { # return true when arg (BINT or num_str) is negative (< 0) - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); - return 1 if ($x->{sign} =~ /^-/); - 0; + $x->{sign} =~ /^-/ ? 1 : 0; # -inf is also negative, but NaN not } sub is_int { # return true when arg (BINT or num_str) is an integer - # always true for BigInt, but different for Floats - # we don't need $self, so undef instead of ref($_[0]) make it slightly faster + # always true for BigInt, but different for BigFloats my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't @@ -1550,7 +1590,7 @@ sub bmod return $x->round(@r); } - if ($CALC->can('_mod')) + if ($CAN{mod}) { # calc new sign and in case $y == +/- 1, return $x $x->{value} = $CALC->_mod($x->{value},$y->{value}); @@ -1561,7 +1601,6 @@ sub bmod if ($xsign ne $y->{sign}) { my $t = $CALC->_copy($x->{value}); # copy $x - $x->{value} = $CALC->_copy($y->{value}); # copy $y to $x $x->{value} = $CALC->_sub($y->{value},$t,1); # $y-$x } } @@ -1572,6 +1611,8 @@ sub bmod $x->round(@r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; return $x; } + # disable upgrade temporarily, otherwise endless loop due to bdiv() + local $upgrade = undef; my ($t,$rem) = $self->bdiv($x->copy(),$y,@r); # slow way (also rounds) # modify in place foreach (qw/value sign _a _p/) @@ -1607,57 +1648,19 @@ sub bmodinv # put least residue into $x if $x was negative, and thus make it positive $x->bmod($y) if $x->{sign} eq '-'; - if ($CALC->can('_modinv')) + if ($CAN{modinv}) { my $sign; ($x->{value},$sign) = $CALC->_modinv($x->{value},$y->{value}); - $x->bnan() if !defined $x->{value}; # in case no GCD found - return $x if !defined $sign; # already real result - $x->{sign} = $sign; # flip/flop see below - $x->bmod($y); # calc real result + return $x->bnan() if !defined $x->{value}; # in case no GCD found + return $x if !defined $sign; # already real result + $x->{sign} = $sign; # flip/flop see below + $x->bmod($y); # calc real result return $x; } - my ($u, $u1) = ($self->bzero(), $self->bone()); - my ($a, $b) = ($y->copy(), $x->copy()); - - # first step need always be done since $num (and thus $b) is never 0 - # Note that the loop is aligned so that the check occurs between #2 and #1 - # thus saving us one step #2 at the loop end. Typical loop count is 1. Even - # a case with 28 loops still gains about 3% with this layout. - my $q; - ($a, $q, $b) = ($b, $a->bdiv($b)); # step #1 - # Euclid's Algorithm (calculate GCD of ($a,$b) in $a and also calculate - # two values in $u and $u1, we use only $u1 afterwards) - my $sign = 1; # flip-flop - while (!$b->is_zero()) # found GCD if $b == 0 - { - # the original algorithm had: - # ($u, $u1) = ($u1, $u->bsub($u1->copy()->bmul($q))); # step #2 - # The following creates exact the same sequence of numbers in $u1, - # except for the sign ($u1 is now always positive). Since formerly - # the sign of $u1 was alternating between '-' and '+', the $sign - # flip-flop will take care of that, so that at the end of the loop - # we have the real sign of $u1. Keeping numbers positive gains us - # speed since badd() is faster than bsub() and makes it possible - # to have the algorithmn in Calc for even more speed. - - ($u, $u1) = ($u1, $u->badd($u1->copy()->bmul($q))); # step #2 - $sign = - $sign; # flip sign - - ($a, $q, $b) = ($b, $a->bdiv($b)); # step #1 again - } - - # If the gcd is not 1, then return NaN! It would be pointless to - # have called bgcd to check this first, because we would then be - # performing the same Euclidean Algorithm *twice*. - return $x->bnan() unless $a->is_one(); - $u1->bneg() if $sign != 1; # need to flip? - - $u1->bmod($y); # calc result - $x->{value} = $u1->{value}; # and copy over to $x - $x->{sign} = $u1->{sign}; # to modify in place - $x; + require $EMU_LIB; + __emu_bmodinv($self,$x,$y,@r); } sub bmodpow @@ -1685,34 +1688,15 @@ sub bmodpow # check num for valid values (also NaN if there was no inverse but $exp < 0) return $num->bnan() if $num->{sign} !~ /^[+-]$/; - if ($CALC->can('_modpow')) + if ($CAN{modpow}) { # $mod is positive, sign on $exp is ignored, result also positive $num->{value} = $CALC->_modpow($num->{value},$exp->{value},$mod->{value}); return $num; } - # in the trivial case, - return $num->bzero(@r) if $mod->is_one(); - return $num->bone('+',@r) if $num->is_zero() or $num->is_one(); - - # $num->bmod($mod); # if $x is large, make it smaller first - my $acc = $num->copy(); # but this is not really faster... - - $num->bone(); # keep ref to $num - - my $expbin = $exp->as_bin(); $expbin =~ s/^[-]?0b//; # ignore sign and prefix - my $len = CORE::length($expbin); - while (--$len >= 0) - { - if( substr($expbin,$len,1) eq '1') - { - $num->bmul($acc)->bmod($mod); - } - $acc->bmul($acc)->bmod($mod); - } - - $num; + require $EMU_LIB; + __emu_bmodpow($self,$num,$exp,$mod,@r); } ############################################################################### @@ -1720,30 +1704,22 @@ sub bmodpow sub bfac { # (BINT or num_str, BINT or num_str) return BINT - # compute factorial numbers - # modifies first argument + # compute factorial number from $x, modify $x in place my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); return $x if $x->modify('bfac'); - return $x->bnan() if $x->{sign} ne '+'; # inf, NnN, <0 etc => NaN - return $x->bone('+',@r) if $x->is_zero() || $x->is_one(); # 0 or 1 => 1 + return $x if $x->{sign} eq '+inf'; # inf => inf + return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN - if ($CALC->can('_fac')) + if ($CAN{fac}) { $x->{value} = $CALC->_fac($x->{value}); return $x->round(@r); } - my $n = $x->copy(); - $x->bone(); - # seems we need not to temp. clear A/P of $x since the result is the same - my $f = $self->new(2); - while ($f->bacmp($n) < 0) - { - $x->bmul($f); $f->binc(); - } - $x->bmul($f,@r); # last step and also round + require $EMU_LIB; + __emu_bfac($self,$x,@r); } sub bpow @@ -1768,8 +1744,9 @@ sub bpow $r[3] = $y; # no push! return $x if $x->{sign} =~ /^[+-]inf$/; # -inf/+inf ** x return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan; - return $x->bone('+',@r) if $y->is_zero(); - return $x->round(@r) if $x->is_one() || $y->is_one(); + + # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu + if ($x->{sign} eq '-' && $CALC->_is_one($x->{value})) { # if $x == -1 and odd/even y => +1/-1 @@ -1778,44 +1755,18 @@ sub bpow } # 1 ** -y => 1 / (1 ** |y|) # so do test for negative $y after above's clause - return $x->bnan() if $y->{sign} eq '-'; - return $x->round(@r) if $x->is_zero(); # 0**y => 0 (if not y <= 0) + return $x->bnan() if $y->{sign} eq '-' && !$x->is_one(); - if ($CALC->can('_pow')) + if ($CAN{pow}) { $x->{value} = $CALC->_pow($x->{value},$y->{value}); + $x->{sign} = '+' if $CALC->_is_zero($y->{value}); $x->round(@r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; return $x; } -# based on the assumption that shifting in base 10 is fast, and that mul -# works faster if numbers are small: we count trailing zeros (this step is -# O(1)..O(N), but in case of O(N) we save much more time due to this), -# stripping them out of the multiplication, and add $count * $y zeros -# afterwards like this: -# 300 ** 3 == 300*300*300 == 3*3*3 . '0' x 2 * 3 == 27 . '0' x 6 -# creates deep recursion since brsft/blsft use bpow sometimes. -# my $zeros = $x->_trailing_zeros(); -# if ($zeros > 0) -# { -# $x->brsft($zeros,10); # remove zeros -# $x->bpow($y); # recursion (will not branch into here again) -# $zeros = $y * $zeros; # real number of zeros to add -# $x->blsft($zeros,10); -# return $x->round(@r); -# } - - my $pow2 = $self->__one(); - my $y_bin = $y->as_bin(); $y_bin =~ s/^0b//; - my $len = CORE::length($y_bin); - while (--$len > 0) - { - $pow2->bmul($x) if substr($y_bin,$len,1) eq '1'; # is odd? - $x->bmul($x); - } - $x->bmul($pow2); - $x->round(@r) if !exists $x->{_f} || $x->{_f} & MB_NEVER_ROUND == 0; - $x; + require $EMU_LIB; + __emu_bpow($self,$x,$y,@r); } sub blsft @@ -1837,13 +1788,13 @@ sub blsft $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-'; - my $t; $t = $CALC->_lsft($x->{value},$y->{value},$n) if $CALC->can('_lsft'); + my $t; $t = $CALC->_lsft($x->{value},$y->{value},$n) if $CAN{lsft}; if (defined $t) { $x->{value} = $t; return $x->round(@r); } # fallback - return $x->bmul( $self->bpow($n, $y, @r), @r ); + $x->bmul( $self->bpow($n, $y, @r), @r ); } sub brsft @@ -1899,10 +1850,11 @@ sub brsft $x->{value} = $res->{value}; # take over value return $x->round(@r); # we are done now, magic, isn't? } + # x < 0, n == 2, y == 1 $x->bdec(); # n == 2, but $y == 1: this fixes it } - my $t; $t = $CALC->_rsft($x->{value},$y->{value},$n) if $CALC->can('_rsft'); + my $t; $t = $CALC->_rsft($x->{value},$y->{value},$n) if $CAN{rsft}; if (defined $t) { $x->{value} = $t; @@ -1929,40 +1881,26 @@ sub band return $x if $x->modify('band'); $r[3] = $y; # no push! - local $Math::BigInt::upgrade = undef; return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); - return $x->bzero(@r) if $y->is_zero() || $x->is_zero(); - my $sign = 0; # sign of result - $sign = 1 if ($x->{sign} eq '-') && ($y->{sign} eq '-'); - my $sx = 1; $sx = -1 if $x->{sign} eq '-'; - my $sy = 1; $sy = -1 if $y->{sign} eq '-'; + my $sx = $x->{sign} eq '+' ? 1 : -1; + my $sy = $y->{sign} eq '+' ? 1 : -1; - if ($CALC->can('_and') && $sx == 1 && $sy == 1) + if ($CAN{and} && $sx == 1 && $sy == 1) { $x->{value} = $CALC->_and($x->{value},$y->{value}); return $x->round(@r); } - - my $m = $self->bone(); my ($xr,$yr); - my $x10000 = $self->new (0x1000); - my $y1 = copy(ref($x),$y); # make copy - $y1->babs(); # and positive - my $x1 = $x->copy()->babs(); $x->bzero(); # modify x in place! - use integer; # need this for negative bools - while (!$x1->is_zero() && !$y1->is_zero()) + + if ($CAN{signed_and}) { - ($x1, $xr) = bdiv($x1, $x10000); - ($y1, $yr) = bdiv($y1, $x10000); - # make both op's numbers! - $x->badd( bmul( $class->new( - abs($sx*int($xr->numify()) & $sy*int($yr->numify()))), - $m)); - $m->bmul($x10000); + $x->{value} = $CALC->_signed_and($x->{value},$y->{value},$sx,$sy); + return $x->round(@r); } - $x->bneg() if $sign; - $x->round(@r); + + require $EMU_LIB; + __emu_band($self,$x,$y,$sx,$sy,@r); } sub bior @@ -1984,38 +1922,28 @@ sub bior local $Math::BigInt::upgrade = undef; return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); - return $x->round(@r) if $y->is_zero(); - my $sign = 0; # sign of result - $sign = 1 if ($x->{sign} eq '-') || ($y->{sign} eq '-'); - my $sx = 1; $sx = -1 if $x->{sign} eq '-'; - my $sy = 1; $sy = -1 if $y->{sign} eq '-'; + my $sx = $x->{sign} eq '+' ? 1 : -1; + my $sy = $y->{sign} eq '+' ? 1 : -1; + # the sign of X follows the sign of X, e.g. sign of Y irrelevant for bior() + # don't use lib for negative values - if ($CALC->can('_or') && $sx == 1 && $sy == 1) + if ($CAN{or} && $sx == 1 && $sy == 1) { $x->{value} = $CALC->_or($x->{value},$y->{value}); return $x->round(@r); } - my $m = $self->bone(); my ($xr,$yr); - my $x10000 = $self->new(0x10000); - my $y1 = copy(ref($x),$y); # make copy - $y1->babs(); # and positive - my $x1 = $x->copy()->babs(); $x->bzero(); # modify x in place! - use integer; # need this for negative bools - while (!$x1->is_zero() || !$y1->is_zero()) + # if lib can do negative values, let it handle this + if ($CAN{signed_or}) { - ($x1, $xr) = bdiv($x1,$x10000); - ($y1, $yr) = bdiv($y1,$x10000); - # make both op's numbers! - $x->badd( bmul( $class->new( - abs($sx*int($xr->numify()) | $sy*int($yr->numify()))), - $m)); - $m->bmul($x10000); + $x->{value} = $CALC->_signed_or($x->{value},$y->{value},$sx,$sy); + return $x->round(@r); } - $x->bneg() if $sign; - $x->round(@r); + + require $EMU_LIB; + __emu_bior($self,$x,$y,$sx,$sy,@r); } sub bxor @@ -2034,49 +1962,35 @@ sub bxor return $x if $x->modify('bxor'); $r[3] = $y; # no push! - local $Math::BigInt::upgrade = undef; - return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/); - return $x->round(@r) if $y->is_zero(); - my $sign = 0; # sign of result - $sign = 1 if $x->{sign} ne $y->{sign}; - my $sx = 1; $sx = -1 if $x->{sign} eq '-'; - my $sy = 1; $sy = -1 if $y->{sign} eq '-'; + my $sx = $x->{sign} eq '+' ? 1 : -1; + my $sy = $y->{sign} eq '+' ? 1 : -1; # don't use lib for negative values - if ($CALC->can('_xor') && $sx == 1 && $sy == 1) + if ($CAN{xor} && $sx == 1 && $sy == 1) { $x->{value} = $CALC->_xor($x->{value},$y->{value}); return $x->round(@r); } - - my $m = $self->bone(); my ($xr,$yr); - my $x10000 = $self->new(0x10000); - my $y1 = copy(ref($x),$y); # make copy - $y1->babs(); # and positive - my $x1 = $x->copy()->babs(); $x->bzero(); # modify x in place! - use integer; # need this for negative bools - while (!$x1->is_zero() || !$y1->is_zero()) + + # if lib can do negative values, let it handle this + if ($CAN{signed_xor}) { - ($x1, $xr) = bdiv($x1, $x10000); - ($y1, $yr) = bdiv($y1, $x10000); - # make both op's numbers! - $x->badd( bmul( $class->new( - abs($sx*int($xr->numify()) ^ $sy*int($yr->numify()))), - $m)); - $m->bmul($x10000); + $x->{value} = $CALC->_signed_xor($x->{value},$y->{value},$sx,$sy); + return $x->round(@r); } - $x->bneg() if $sign; - $x->round(@r); + + require $EMU_LIB; + __emu_bxor($self,$x,$y,$sx,$sy,@r); } sub length { - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); my $e = $CALC->_len($x->{value}); - return wantarray ? ($e,0) : $e; + wantarray ? ($e,0) : $e; } sub digit @@ -2089,13 +2003,13 @@ sub digit sub _trailing_zeros { - # return the amount of trailing zeros in $x + # return the amount of trailing zeros in $x (as scalar) my $x = shift; $x = $class->new($x) unless ref $x; return 0 if $x->is_zero() || $x->is_odd() || $x->{sign} !~ /^[+-]$/; - return $CALC->_zeros($x->{value}) if $CALC->can('_zeros'); + return $CALC->_zeros($x->{value}) if $CAN{zeros}; # if not: since we do not know underlying internal representation: my $es = "$x"; $es =~ /([0]*)$/; @@ -2112,35 +2026,17 @@ sub bsqrt return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf - return $x->round(@r) if $x->is_zero() || $x->is_one(); # 0,1 => 0,1 return $upgrade->bsqrt($x,@r) if defined $upgrade; - if ($CALC->can('_sqrt')) + if ($CAN{sqrt}) { $x->{value} = $CALC->_sqrt($x->{value}); return $x->round(@r); } - return $x->bone('+',@r) if $x < 4; # 2,3 => 1 - my $y = $x->copy(); - my $l = int($x->length()/2); - - $x->bone(); # keep ref($x), but modify it - $x->blsft($l,10) if $l != 0; # first guess: 1.('0' x (l/2)) - - my $last = $self->bzero(); - my $two = $self->new(2); - my $lastlast = $self->bzero(); - #my $lastlast = $x+$two; - while ($last != $x && $lastlast != $x) - { - $lastlast = $last; $last = $x->copy(); - $x->badd($y / $x); - $x->bdiv($two); - } - $x->bdec() if $x * $x > $y; # overshot? - $x->round(@r); + require $EMU_LIB; + __emu_bsqrt($self,$x,@r); } sub broot @@ -2155,7 +2051,7 @@ sub broot # objectify is costly, so avoid it if ((!ref($x)) || (ref($x) ne ref($y))) { - ($self,$x,$y,@r) = $self->objectify(2,@_); + ($self,$x,$y,@r) = objectify(2,$self || $class,@_); } return $x if $x->modify('broot'); @@ -2169,54 +2065,14 @@ sub broot return $upgrade->new($x)->broot($upgrade->new($y),@r) if defined $upgrade; - if ($CALC->can('_root')) + if ($CAN{root}) { $x->{value} = $CALC->_root($x->{value},$y->{value}); return $x->round(@r); } - return $x->bsqrt() if $y->bacmp(2) == 0; # 2 => square root - - # since we take at least a cubic root, and only 8 ** 1/3 >= 2 (==2): - return $x->bone('+',@r) if $x < 8; # $x=2..7 => 1 - - my $num = $x->numify(); - - if ($num <= 1000000) - { - $x = $self->new( int($num ** (1 / $y->numify()) )); - return $x->round(@r); - } - - # if $n is a power of two, we can repeatedly take sqrt($X) and find the - # proper result, because sqrt(sqrt($x)) == root($x,4) - # See Calc.pm for more details - my $b = $y->as_bin(); - if ($b =~ /0b1(0+)/) - { - my $count = CORE::length($1); # 0b100 => len('00') => 2 - my $cnt = $count; # counter for loop - my $shift = $self->new(6); - $x->blsft($shift); # add some zeros (even amount) - while ($cnt-- > 0) - { - # 'inflate' $X by adding more zeros - $x->blsft($shift); - # calculate sqrt($x), $x is now a bit too big, again. In the next - # round we make even bigger, again. - $x->bsqrt($x); - } - # $x is still to big, so truncate result - $x->brsft($shift); - } - else - { - # Should compute a guess of the result (by rule of thumb), then improve it - # via Newton's method or something similiar. - # XXX TODO - warn ('broot() not fully implemented in BigInt.'); - } - return $x->round(@r); + require $EMU_LIB; + __emu_broot($self,$x,$y,@r); } sub exponent @@ -2226,13 +2082,12 @@ sub exponent if ($x->{sign} !~ /^[+-]$/) { - my $s = $x->{sign}; $s =~ s/^[+-]//; - return $self->new($s); # -inf,+inf => inf + my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf,+inf => NaN or inf + return $self->new($s); } - my $e = $class->bzero(); - return $e->binc() if $x->is_zero(); - $e += $x->_trailing_zeros(); - $e; + return $self->bone() if $x->is_zero(); + + $self->new($x->_trailing_zeros()); } sub mantissa @@ -2242,10 +2097,11 @@ sub mantissa if ($x->{sign} !~ /^[+-]$/) { - return $self->new($x->{sign}); # keep + or - sign + # for NaN, +inf, -inf: keep the sign + return $self->new($x->{sign}); } - my $m = $x->copy(); - # that's inefficient + my $m = $x->copy(); delete $m->{_p}; delete $m->{_a}; + # that's a bit inefficient: my $zeros = $m->_trailing_zeros(); $m->brsft($zeros,10) if $zeros != 0; $m; @@ -2254,9 +2110,9 @@ sub mantissa sub parts { # return a copy of both the exponent and the mantissa - my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_); + my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); - return ($x->mantissa(),$x->exponent()); + ($x->mantissa(),$x->exponent()); } ############################################################################## @@ -2267,18 +2123,14 @@ sub bfround # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.' # $n == 0 || $n == 1 => round to integer my $x = shift; $x = $class->new($x) unless ref $x; + my ($scale,$mode) = $x->_scale_p($x->precision(),$x->round_mode(),@_); - return $x if !defined $scale; # no-op - return $x if $x->modify('bfround'); + + return $x if !defined $scale || $x->modify('bfround'); # no-op # no-op for BigInts if $n <= 0 - if ($scale <= 0) - { - $x->{_a} = undef; # clear an eventual set A - $x->{_p} = $scale; return $x; - } + $x->bround( $x->length()-$scale, $mode) if $scale > 0; - $x->bround( $x->length()-$scale, $mode); $x->{_a} = undef; # bround sets {_a} $x->{_p} = $scale; # so correct it $x; @@ -2286,9 +2138,8 @@ sub bfround sub _scan_for_nonzero { - my $x = shift; - my $pad = shift; - my $xs = shift; + # internal, used by bround() + my ($x,$pad,$xs) = @_; my $len = $x->length(); return 0 if $len == 1; # '5' is trailed by invisible zeros @@ -2296,18 +2147,16 @@ sub _scan_for_nonzero return 0 if $follow > $len || $follow < 1; # since we do not know underlying represention of $x, use decimal string - #my $r = substr ($$xs,-$follow); my $r = substr ("$x",-$follow); - return 1 if $r =~ /[^0]/; - 0; + $r =~ /[^0]/ ? 1 : 0; } sub fround { - # to make life easier for switch between MBF and MBI (autoload fxxx() - # like MBF does for bxxx()?) + # Exists to make life easier for switch between MBF and MBI (should we + # autoload fxxx() like MBF does for bxxx()?) my $x = shift; - return $x->bround(@_); + $x->bround(@_); } sub bround @@ -2418,61 +2267,67 @@ sub bround sub bfloor { - # return integer less or equal then number, since it is already integer, - # always returns $self - my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); + # return integer less or equal then number; no-op since it's already integer + my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_); $x->round(@r); } sub bceil { - # return integer greater or equal then number, since it is already integer, - # always returns $self - my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); + # return integer greater or equal then number; no-op since it's already int + my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_); $x->round(@r); } -############################################################################## -# private stuff (internal use only) +sub as_number + { + # An object might be asked to return itself as bigint on certain overloaded + # operations, this does exactly this, so that sub classes can simple inherit + # it or override with their own integer conversion routine. + $_[0]->copy(); + } -sub __one +sub as_hex { - # internal speedup, set argument to 1, or create a +/- 1 - my $self = shift; - my $x = $self->bone(); # $x->{value} = $CALC->_one(); - $x->{sign} = shift || '+'; - $x; + # return as hex string, with prefixed 0x + my $x = shift; $x = $class->new($x) if !ref($x); + + return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + + my $s = ''; + $s = $x->{sign} if $x->{sign} eq '-'; + if ($CAN{as_hex}) + { + return $s . ${$CALC->_as_hex($x->{value})}; + } + + require $EMU_LIB; + __emu_as_hex(ref($x),$x,$s); } -sub _swap +sub as_bin { - # Overload will swap params if first one is no object ref so that the first - # one is always an object ref. In this case, third param is true. - # This routine is to overcome the effect of scalar,$object creating an object - # of the class of this package, instead of the second param $object. This - # happens inside overload, when the overload section of this package is - # inherited by sub classes. - # For overload cases (and this is used only there), we need to preserve the - # args, hence the copy(). - # You can override this method in a subclass, the overload section will call - # $object->_swap() to make sure it arrives at the proper subclass, with some - # exceptions like '+' and '-'. To make '+' and '-' work, you also need to - # specify your own overload for them. - - # object, (object|scalar) => preserve first and make copy - # scalar, object => swapped, re-swap and create new from first - # (using class of second object, not $class!!) - my $self = shift; # for override in subclass - if ($_[2]) + # return as binary string, with prefixed 0b + my $x = shift; $x = $class->new($x) if !ref($x); + + return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc + + my $s = ''; $s = $x->{sign} if $x->{sign} eq '-'; + if ($CAN{as_bin}) { - my $c = ref ($_[0]) || $class; # fallback $class should not happen - return ( $c->new($_[1]), $_[0] ); + return $s . ${$CALC->_as_bin($x->{value})}; } - return ( $_[0]->copy(), $_[1] ); + + require $EMU_LIB; + __emu_as_bin(ref($x),$x,$s); + } +############################################################################## +# private stuff (internal use only) + sub objectify { # check for strings, if yes, return objects instead @@ -2574,15 +2429,16 @@ sub import { my $self = shift; - $IMPORT++; + $IMPORT++; # remember we did import() my @a; my $l = scalar @_; for ( my $i = 0; $i < $l ; $i++ ) { if ($_[$i] eq ':constant') { # this causes overlord er load to step in - overload::constant integer => sub { $self->new(shift) }; - overload::constant binary => sub { $self->new(shift) }; + overload::constant + integer => sub { $self->new(shift) }, + binary => sub { $self->new(shift) }; } elsif ($_[$i] eq 'upgrade') { @@ -2634,7 +2490,23 @@ sub import if ($CALC eq '') { require Carp; - Carp::croak ("Couldn't load any math lib, not even the default"); + Carp::croak ("Couldn't load any math lib, not even 'Calc.pm'"); + } + _fill_can_cache(); + } + +sub _fill_can_cache + { + # fill $CAN with the results of $CALC->can(...) + + %CAN = (); + for my $method (qw/gcd mod modinv modpow fac pow lsft rsft + and signed_and or signed_or xor signed_xor + from_hex as_hex from_bin as_bin + zeros sqrt root log_int log + /) + { + $CAN{$method} = $CALC->can("_$method") ? 1 : 0; } } @@ -2654,17 +2526,17 @@ sub __from_hex my $sign = '+'; $sign = '-' if ($$hs =~ /^-/); $$hs =~ s/^[+-]//; # strip sign - if ($CALC->can('_from_hex')) + if ($CAN{'from_hex'}) { $x->{value} = $CALC->_from_hex($hs); } else { # fallback to pure perl - my $mul = Math::BigInt->bzero(); $mul++; + my $mul = Math::BigInt->bone(); my $x65536 = Math::BigInt->new(65536); - my $len = CORE::length($$hs)-2; - $len = int($len/4); # 4-digit parts, w/o '0x' + my $len = CORE::length($$hs)-2; # minus 2 for 0x + $len = int($len/4); # 4-digit parts, w/o '0x' my $val; my $i = -4; while ($len >= 0) { @@ -2693,15 +2565,15 @@ sub __from_bin my $sign = '+'; $sign = '-' if ($$bs =~ /^\-/); $$bs =~ s/^[+-]//; # strip sign - if ($CALC->can('_from_bin')) + if ($CAN{'from_bin'}) { $x->{value} = $CALC->_from_bin($bs); } else { - my $mul = Math::BigInt->bzero(); $mul++; + my $mul = Math::BigInt->bone(); my $x256 = Math::BigInt->new(256); - my $len = CORE::length($$bs)-2; + my $len = CORE::length($$bs)-2; # minus 2 for 0b $len = int($len/8); # 8-digit parts, w/o '0b' my $val; my $i = -8; while ($len >= 0) @@ -2770,7 +2642,7 @@ sub _split # valid mantissa? return if $m eq '.' || $m eq ''; my ($mi,$mf,$lastf) = split /\./,$m; - return if defined $lastf; # last defined => 1.2.3 or others + return if defined $lastf; # lastf defined => 1.2.3 or others $mi = '0' if !defined $mi; $mi .= '0' if $mi =~ /^[\-\+]?$/; $mf = '0' if !defined $mf || $mf eq ''; @@ -2787,91 +2659,6 @@ sub _split return; # NaN, not a number } -sub as_number - { - # an object might be asked to return itself as bigint on certain overloaded - # operations, this does exactly this, so that sub classes can simple inherit - # it or override with their own integer conversion routine - my $self = shift; - - $self->copy(); - } - -sub as_hex - { - # return as hex string, with prefixed 0x - my $x = shift; $x = $class->new($x) if !ref($x); - - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc - - my $es = ''; my $s = ''; - $s = $x->{sign} if $x->{sign} eq '-'; - if ($CALC->can('_as_hex')) - { - $es = ${$CALC->_as_hex($x->{value})}; - } - else - { - return '0x0' if $x->is_zero(); - - my $x1 = $x->copy()->babs(); my ($xr,$x10000,$h); - if ($] >= 5.006) - { - $x10000 = Math::BigInt->new (0x10000); $h = 'h4'; - } - else - { - $x10000 = Math::BigInt->new (0x1000); $h = 'h3'; - } - while (!$x1->is_zero()) - { - ($x1, $xr) = bdiv($x1,$x10000); - $es .= unpack($h,pack('v',$xr->numify())); - } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - $s .= '0x'; - } - $s . $es; - } - -sub as_bin - { - # return as binary string, with prefixed 0b - my $x = shift; $x = $class->new($x) if !ref($x); - - return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc - - my $es = ''; my $s = ''; - $s = $x->{sign} if $x->{sign} eq '-'; - if ($CALC->can('_as_bin')) - { - $es = ${$CALC->_as_bin($x->{value})}; - } - else - { - return '0b0' if $x->is_zero(); - my $x1 = $x->copy()->babs(); my ($xr,$x10000,$b); - if ($] >= 5.006) - { - $x10000 = Math::BigInt->new (0x10000); $b = 'b16'; - } - else - { - $x10000 = Math::BigInt->new (0x1000); $b = 'b12'; - } - while (!$x1->is_zero()) - { - ($x1, $xr) = bdiv($x1,$x10000); - $es .= unpack($b,pack('v',$xr->numify())); - } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - $s .= '0b'; - } - $s . $es; - } - ############################################################################## # internal calculation routines (others are in Math::BigInt::Calc etc) @@ -2904,7 +2691,7 @@ sub __gcd ############################################################################### # this method return 0 if the object can be modified, or 1 for not -# We use a fast use constant statement here, to avoid costly calls. Subclasses +# We use a fast constant sub() here, to avoid costly calls. Subclasses # may override it with special code (f.i. Math::BigInt::Constant does so) sub modify () { 0; } @@ -2944,8 +2731,8 @@ Math::BigInt - Arbitrary size integer math package $x->is_one('-'); # if $x is -1 $x->is_odd(); # if $x is odd $x->is_even(); # if $x is even - $x->is_positive(); # if $x >= 0 - $x->is_negative(); # if $x < 0 + $x->is_pos(); # if $x >= 0 + $x->is_neg(); # if $x < 0 $x->is_inf(sign); # if $x is +inf, or -inf (sign is default '+') $x->is_int(); # if $x is an integer (not a float) @@ -3022,14 +2809,15 @@ Math::BigInt - Arbitrary size integer math package $x->mantissa(); # return (signed) mantissa as BigInt $x->parts(); # return (mantissa,exponent) as BigInt $x->copy(); # make a true copy of $x (unlike $y = $x;) - $x->as_number(); # return as BigInt (in BigInt: same as copy()) + $x->as_int(); # return as BigInt (in BigInt: same as copy()) + $x->numify(); # return as scalar (might overflow!) # conversation to string (do not modify their argument) $x->bstr(); # normalized string $x->bsstr(); # normalized string in scientific notation $x->as_hex(); # as signed hexadecimal string with prefixed 0x $x->as_bin(); # as signed binary string with prefixed 0b - + # precision and accuracy (see section about rounding for more) $x->precision(); # return P of $x (or global, if P of $x undef) @@ -3061,7 +2849,7 @@ and results in an integer, including hexadecimal and binary numbers. Scalars holding numbers may also be passed, but note that non-integer numbers may already have lost precision due to the conversation to float. Quote -your input if you want BigInt to see all the digits. +your input if you want BigInt to see all the digits: $x = Math::BigInt->new(12345678890123456789); # bad $x = Math::BigInt->new('12345678901234567890'); # good @@ -3072,10 +2860,14 @@ This means integer values like 1.01E2 or even 1000E-2 are also accepted. Non-integer values result in NaN. Currently, Math::BigInt::new() defaults to 0, while Math::BigInt::new('') -results in 'NaN'. +results in 'NaN'. This might change in the future, so use always the following +explicit forms to get a zero or NaN: + + $zero = Math::BigInt->bzero(); + $nan = Math::BigInt->bnan(); C<bnorm()> on a BigInt object is now effectively a no-op, since the numbers -are always stored in normalized form. On a string, it creates a BigInt +are always stored in normalized form. If passed a string, creates a BigInt object from the input. =item Output @@ -3109,15 +2901,15 @@ appropriate information. key Description Example ============================================================ - lib Name of the Math library + lib Name of the low-level math library Math::BigInt::Calc - lib_version Version of 'lib' + lib_version Version of low-level math library (see 'lib') 0.30 - class The class of config you just called + class The class name of config() you just called Math::BigInt - upgrade To which class numbers are upgraded + upgrade To which class math operations might be upgraded Math::BigFloat - downgrade To which class numbers are downgraded + downgrade To which class math operations might be downgraded undef precision Global precision undef @@ -3129,6 +2921,10 @@ appropriate information. 1.61 div_scale Fallback acccuracy for div 40 + trap_nan If true, traps creation of NaN via croak() + 1 + trap_inf If true, traps creation of +inf/-inf via croak() + 1 The following values can be set by passing C<config()> a reference to a hash: @@ -3300,10 +3096,10 @@ like: if ($x == 0) -=head2 is_positive()/is_negative() +=head2 is_pos()/is_neg() - $x->is_positive(); # true if >= 0 - $x->is_negative(); # true if < 0 + $x->is_pos(); # true if >= 0 + $x->is_neg(); # true if < 0 The methods return true if the argument is positive or negative, respectively. C<NaN> is neither positive nor negative, while C<+inf> counts as positive, and @@ -3311,6 +3107,11 @@ C<-inf> is negative. A C<zero> is positive. These methods are only testing the sign, and not the value. +C<is_positive()> and C<is_negative()> are aliase to C<is_pos()> and +C<is_neg()>, respectively. C<is_positive()> and C<is_negative()> were +introduced in v1.36, while C<is_pos()> and C<is_neg()> were only introduced +in v1.68. + =head2 is_odd()/is_even()/is_int() $x->is_odd(); # true if odd, false for even @@ -3341,9 +3142,11 @@ Compares $x with $y while ignoring their. Returns -1, 0, 1 or undef. Return the sign, of $x, meaning either C<+>, C<->, C<-inf>, C<+inf> or NaN. -=head2 bcmp +=head2 digit + + $x->digit($n); # return the nth digit, counting from right - $x->digit($n); # return the nth digit, counting from right +If C<$n> is negative, returns the digit counting from left. =head2 bneg @@ -3366,7 +3169,13 @@ numbers. =head2 bnot - $x->bnot(); # two's complement (bit wise not) + $x->bnot(); + +Two's complement (bit wise not). This is equivalent to + + $x->binc()->bneg(); + +but faster. =head2 binc @@ -3416,7 +3225,7 @@ writing $num ** $exp % $mod -because C<bmodpow> is much faster--it reduces internal variables into +because it is much faster - it reduces internal variables into the modulus whenever possible, so it operates on smaller numbers. C<bmodpow> also supports negative exponents. @@ -3531,13 +3340,21 @@ Return the signed mantissa of $x as BigInt. $x->copy(); # make a true copy of $x (unlike $y = $x;) -=head2 as_number +=head2 as_int + + $x->as_int(); - $x->as_number(); # return as BigInt (in BigInt: same as copy()) +Returns $x as a BigInt (truncated towards zero). In BigInt this is the same as +C<copy()>. + +C<as_number()> is an alias to this method. C<as_number> was introduced in +v1.22, while C<as_int()> was only introduced in v1.68. -=head2 bsrt +=head2 bstr + + $x->bstr(); - $x->bstr(); # return normalized string +Returns a normalized string represantation of C<$x>. =head2 bsstr @@ -3555,7 +3372,7 @@ Return the signed mantissa of $x as BigInt. Since version v1.33, Math::BigInt and Math::BigFloat have full support for accuracy and precision based rounding, both automatically after every -operation as well as manually. +operation, as well as manually. This section describes the accuracy/precision handling in Math::Big* as it used to be and as it is now, complete with an explanation of all terms and @@ -3713,7 +3530,7 @@ versions <= 5.7.2) is like this: Actually, the 'difference' added to the scale is calculated from the number of "significant digits" in dividend and divisor, which is derived by looking at the length of the mantissa. Which is wrong, since it includes - the + sign (oups) and actually gets 2 for '+100' and 4 for '+101'. Oups + the + sign (oops) and actually gets 2 for '+100' and 4 for '+101'. Oops again. Thus 124/3 with div_scale=1 will get you '41.3' based on the strange assumption that 124 has 3 significant digits, while 120/7 will get you '17', not '17.1' since 120 is thought to have 2 significant digits. @@ -3730,23 +3547,26 @@ This is how it works now: =item Setting/Accessing - * You can set the A global via Math::BigInt->accuracy() or - Math::BigFloat->accuracy() or whatever class you are using. - * You can also set P globally by using Math::SomeClass->precision() likewise. + * You can set the A global via C<< Math::BigInt->accuracy() >> or + C<< Math::BigFloat->accuracy() >> or whatever class you are using. + * You can also set P globally by using C<< Math::SomeClass->precision() >> + likewise. * Globals are classwide, and not inherited by subclasses. - * to undefine A, use Math::SomeCLass->accuracy(undef); - * to undefine P, use Math::SomeClass->precision(undef); - * Setting Math::SomeClass->accuracy() clears automatically - Math::SomeClass->precision(), and vice versa. + * to undefine A, use C<< Math::SomeCLass->accuracy(undef); >> + * to undefine P, use C<< Math::SomeClass->precision(undef); >> + * Setting C<< Math::SomeClass->accuracy() >> clears automatically + C<< Math::SomeClass->precision() >>, and vice versa. * To be valid, A must be > 0, P can have any value. * If P is negative, this means round to the P'th place to the right of the decimal point; positive values mean to the left of the decimal point. P of 0 means round to integer. - * to find out the current global A, take Math::SomeClass->accuracy() - * to find out the current global P, take Math::SomeClass->precision() - * use $x->accuracy() respective $x->precision() for the local setting of $x. - * Please note that $x->accuracy() respecive $x->precision() fall back to the - defined globals, when $x's A or P is not set. + * to find out the current global A, use C<< Math::SomeClass->accuracy() >> + * to find out the current global P, use C<< Math::SomeClass->precision() >> + * use C<< $x->accuracy() >> respective C<< $x->precision() >> for the local + setting of C<< $x >>. + * Please note that C<< $x->accuracy() >> respecive C<< $x->precision() >> + return eventually defined global A or P, when C<< $x >>'s A or P is not + set. =item Creating numbers @@ -3761,7 +3581,7 @@ This is how it works now: B<not> be used. This is used by subclasses to create numbers without suffering rounding in the parent. Thus a subclass is able to have it's own globals enforced upon creation of a number by using - $x = Math::BigInt->new($number,undef,undef): + C<< $x = Math::BigInt->new($number,undef,undef) >>: use Math::BigInt::SomeSubclass; use Math::BigInt; @@ -3779,22 +3599,21 @@ This is how it works now: operation according to the rules below * Negative P is ignored in Math::BigInt, since BigInts never have digits after the decimal point - * Math::BigFloat uses Math::BigInts internally, but setting A or P inside - Math::BigInt as globals should not tamper with the parts of a BigFloat. - Thus a flag is used to mark all Math::BigFloat numbers as 'never round' + * Math::BigFloat uses Math::BigInt internally, but setting A or P inside + Math::BigInt as globals does not tamper with the parts of a BigFloat. + A flag is used to mark all Math::BigFloat numbers as 'never round'. =item Precedence * It only makes sense that a number has only one of A or P at a time. - Since you can set/get both A and P, there is a rule that will practically - enforce only A or P to be in effect at a time, even if both are set. - This is called precedence. + If you set either A or P on one object, or globally, the other one will + be automatically cleared. * If two objects are involved in an operation, and one of them has A in effect, and the other P, this results in an error (NaN). - * A takes precendence over P (Hint: A comes before P). If A is defined, it - is used, otherwise P is used. If neither of them is defined, nothing is - used, i.e. the result will have as many digits as it can (with an - exception for fdiv/fsqrt) and will not be rounded. + * A takes precendence over P (Hint: A comes before P). + If neither of them is defined, nothing is used, i.e. the result will have + as many digits as it can (with an exception for fdiv/fsqrt) and will not + be rounded. * There is another setting for fdiv() (and thus for fsqrt()). If neither of A or P is defined, fdiv() will use a fallback (F) of $div_scale digits. If either the dividend's or the divisor's mantissa has more digits than @@ -3805,7 +3624,7 @@ This is how it works now: A, P or F), and, if F is not used, round the result (this will still fail in the case of a result like 0.12345000000001 with A or P of 5, but this can not be helped - or can it?) - * Thus you can have the math done by on Math::Big* class in three modes: + * Thus you can have the math done by on Math::Big* class in two modi: + never round (this is the default): This is done by setting A and P to undef. No math operation will round the result, with fdiv() and fsqrt() as exceptions to guard @@ -3854,10 +3673,11 @@ This is how it works now: =item Local settings - * You can set A and P locally by using $x->accuracy() and $x->precision() + * You can set A or P locally by using C<< $x->accuracy() >> or + C<< $x->precision() >> and thus force different A and P for different objects/numbers. * Setting A or P this way immediately rounds $x to the new value. - * $x->accuracy() clears $x->precision(), and vice versa. + * C<< $x->accuracy() >> clears C<< $x->precision() >>, and vice versa. =item Rounding @@ -3867,12 +3687,12 @@ This is how it works now: * the two rounding functions take as the second parameter one of the following rounding modes (R): 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' - * you can set and get the global R by using Math::SomeClass->round_mode() - or by setting $Math::SomeClass::round_mode - * after each operation, $result->round() is called, and the result may + * you can set/get the global R by using C<< Math::SomeClass->round_mode() >> + or by setting C<< $Math::SomeClass::round_mode >> + * after each operation, C<< $result->round() >> is called, and the result may eventually be rounded (that is, if A or P were set either locally, globally or as parameter to the operation) - * to manually round a number, call $x->round($A,$P,$round_mode); + * to manually round a number, call C<< $x->round($A,$P,$round_mode); >> this will round the number by using the appropriate rounding function and then normalize it. * rounding modifies the local settings of the number: @@ -3911,7 +3731,7 @@ instead relying on the internal hash keys like in C<< $x->{sign}; >>. =head2 MATH LIBRARY Math with the numbers is done (by default) by a module called -Math::BigInt::Calc. This is equivalent to saying: +C<Math::BigInt::Calc>. This is equivalent to saying: use Math::BigInt lib => 'Calc'; @@ -3924,11 +3744,17 @@ Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc: use Math::BigInt lib => 'Foo,Math::BigInt::Bar'; -Calc.pm uses as internal format an array of elements of some decimal base -(usually 1e5 or 1e7) with the least significant digit first, while BitVect.pm -uses a bit vector of base 2, most significant bit first. Other modules might -use even different means of representing the numbers. See the respective -module documentation for further details. +Since Math::BigInt::GMP is in almost all cases faster than Calc (especially in +cases involving really big numbers, where it is B<much> faster), and there is +no penalty if Math::BigInt::GMP is not installed, it is a good idea to always +use the following: + + use Math::BigInt lib => 'GMP'; + +Different low-level libraries use different formats to store the +numbers. You should not depend on the number having a specific format. + +See the respective math library module documentation for further details. =head2 SIGN @@ -3952,14 +3778,13 @@ that: C<< ($m,$e) = $x->parts() >> is just a shortcut that gives you both of them in one go. Both the returned mantissa and exponent have a sign. -Currently, for BigInts C<$e> will be always 0, except for NaN, +inf and -inf, -where it will be NaN; and for $x == 0, where it will be 1 -(to be compatible with Math::BigFloat's internal representation of a zero as -C<0E1>). +Currently, for BigInts C<$e> is always 0, except for NaN, +inf and -inf, +where it is C<NaN>; and for C<$x == 0>, where it is C<1> (to be compatible +with Math::BigFloat's internal representation of a zero as C<0E1>). -C<$m> will always be a copy of the original number. The relation between $e -and $m might change in the future, but will always be equivalent in a -numerical sense, e.g. $m might get minimized. +C<$m> is currently just a copy of the original number. The relation between +C<$e> and C<$m> will stay always the same, though their real values might +change. =head1 EXAMPLES @@ -4068,18 +3893,19 @@ more time then the actual addition. With a technique called copy-on-write, the cost of copying with overload could be minimized or even completely avoided. A test implementation of COW did show performance gains for overloaded math, but introduced a performance loss due -to a constant overhead for all other operatons. +to a constant overhead for all other operatons. So Math::BigInt does currently +not COW. -The rewritten version of this module is slower on certain operations, like -new(), bstr() and numify(). The reason are that it does now more work and -handles more cases. The time spent in these operations is usually gained in -the other operations so that programs on the average should get faster. If -they don't, please contect the author. +The rewritten version of this module (vs. v0.01) is slower on certain +operations, like C<new()>, C<bstr()> and C<numify()>. The reason are that it +does now more work and handles much more cases. The time spent in these +operations is usually gained in the other math operations so that code on +the average should get (much) faster. If they don't, please contact the author. Some operations may be slower for small numbers, but are significantly faster -for big numbers. Other operations are now constant (O(1), like bneg(), babs() -etc), instead of O(N) and thus nearly always take much less time. These -optimizations were done on purpose. +for big numbers. Other operations are now constant (O(1), like C<bneg()>, +C<babs()> etc), instead of O(N) and thus nearly always take much less time. +These optimizations were done on purpose. If you find the Calc module to slow, try to install any of the replacement modules and see if they help you. @@ -4236,14 +4062,16 @@ known to be troublesome: =over 1 -=item stringify, bstr(), bsstr() and 'cmp' +=item bstr(), bsstr() and 'cmp' -Both stringify and bstr() now drop the leading '+'. The old code would return -'+3', the new returns '3'. This is to be consistent with Perl and to make -cmp (especially with overloading) to work as you expect. It also solves -problems with Test.pm, it's ok() uses 'eq' internally. +Both C<bstr()> and C<bsstr()> as well as automated stringify via overload now +drop the leading '+'. The old code would return '+3', the new returns '3'. +This is to be consistent with Perl and to make C<cmp> (especially with +overloading) to work as you expect. It also solves problems with C<Test.pm>, +because it's C<ok()> uses 'eq' internally. -Mark said, when asked about to drop the '+' altogether, or make only cmp work: +Mark Biggar said, when asked about to drop the '+' altogether, or make only +C<cmp> work: I agree (with the first alternative), don't add the '+' on positive numbers. It's not as important anymore with the new internal @@ -4273,7 +4101,8 @@ Additionally, the following still works: There is now a C<bsstr()> method to get the string in scientific notation aka C<1e+2> instead of C<100>. Be advised that overloaded 'eq' always uses bstr() for comparisation, but Perl will represent some numbers as 100 and others -as 1e+308. If in doubt, convert both arguments to Math::BigInt before doing eq: +as 1e+308. If in doubt, convert both arguments to Math::BigInt before +comparing them as strings: use Test; BEGIN { plan tests => 3 } @@ -4285,9 +4114,9 @@ as 1e+308. If in doubt, convert both arguments to Math::BigInt before doing eq: $y = Math::BigInt->new($y); ok ($x,$y); # okay -Alternatively, simple use <=> for comparisations, that will get it always -right. There is not yet a way to get a number automatically represented as -a string that matches exactly the way Perl represents it. +Alternatively, simple use C<< <=> >> for comparisations, this will get it +always right. There is not yet a way to get a number automatically represented +as a string that matches exactly the way Perl represents it. =item int() diff --git a/gnu/usr.bin/perl/lib/Math/BigInt/Scalar.pm b/gnu/usr.bin/perl/lib/Math/BigInt/Scalar.pm deleted file mode 100644 index 44bab5d53f4..00000000000 --- a/gnu/usr.bin/perl/lib/Math/BigInt/Scalar.pm +++ /dev/null @@ -1,242 +0,0 @@ -############################################################################### -# core math lib for BigInt, representing big numbers by normal int/float's -# for testing only, will fail any bignum test if range is exceeded - -package Math::BigInt::Scalar; - -use 5.005; -use strict; -# use warnings; # dont use warnings for older Perls - -require Exporter; - -use vars qw/@ISA $VERSION/; -@ISA = qw(Exporter); - -$VERSION = '0.11'; - -############################################################################## -# global constants, flags and accessory - -# constants for easier life -my $nan = 'NaN'; - -############################################################################## -# create objects from various representations - -sub _new - { - # (string) return ref to num - my $d = $_[1]; - my $x = $$d; # make copy - return \$x; - } - -sub _zero - { - my $x = 0; return \$x; - } - -sub _one - { - my $x = 1; return \$x; - } - -sub _copy - { - my $x = $_[1]; - my $z = $$x; - return \$z; - } - -# catch and throw away -sub import { } - -############################################################################## -# convert back to string and number - -sub _str - { - # make string - return \"${$_[1]}"; - } - -sub _num - { - # make a number - return ${$_[1]}; - } - - -############################################################################## -# actual math code - -sub _add - { - my ($c,$x,$y) = @_; - $$x += $$y; - return $x; - } - -sub _sub - { - my ($c,$x,$y) = @_; - $$x -= $$y; - return $x; - } - -sub _mul - { - my ($c,$x,$y) = @_; - $$x *= $$y; - return $x; - } - -sub _div - { - my ($c,$x,$y) = @_; - - my $u = int($$x / $$y); my $r = $$x % $$y; $$x = $u; - return ($x,\$r) if wantarray; - return $x; - } - -sub _pow - { - my ($c,$x,$y) = @_; - my $u = $$x ** $$y; $$x = $u; - return $x; - } - -sub _and - { - my ($c,$x,$y) = @_; - my $u = int($$x) & int($$y); $$x = $u; - return $x; - } - -sub _xor - { - my ($c,$x,$y) = @_; - my $u = int($$x) ^ int($$y); $$x = $u; - return $x; - } - -sub _or - { - my ($c,$x,$y) = @_; - my $u = int($$x) | int($$y); $$x = $u; - return $x; - } - -sub _inc - { - my ($c,$x) = @_; - my $u = int($$x)+1; $$x = $u; - return $x; - } - -sub _dec - { - my ($c,$x) = @_; - my $u = int($$x)-1; $$x = $u; - return $x; - } - -############################################################################## -# testing - -sub _acmp - { - my ($c,$x, $y) = @_; - return ($$x <=> $$y); - } - -sub _len - { - return length("${$_[1]}"); - } - -sub _digit - { - # return the nth digit, negative values count backward - # 0 is the rightmost digit - my ($c,$x,$n) = @_; - - $n ++; # 0 => 1, 1 => 2 - return substr($$x,-$n,1); # 1 => -1, -2 => 2 etc - } - -############################################################################## -# _is_* routines - -sub _is_zero - { - # return true if arg is zero - my ($c,$x) = @_; - return ($$x == 0) <=> 0; - } - -sub _is_even - { - # return true if arg is even - my ($c,$x) = @_; - return (!($$x & 1)) <=> 0; - } - -sub _is_odd - { - # return true if arg is odd - my ($c,$x) = @_; - return ($$x & 1) <=> 0; - } - -sub _is_one - { - # return true if arg is one - my ($c,$x) = @_; - return ($$x == 1) <=> 0; - } - -############################################################################### -# check routine to test internal state of corruptions - -sub _check - { - # no checks yet, pull it out from the test suite - my ($c,$x) = @_; - return "$x is not a reference" if !ref($x); - return 0; - } - -1; -__END__ - -=head1 NAME - -Math::BigInt::Scalar - Pure Perl module to test Math::BigInt with scalars - -=head1 SYNOPSIS - -Provides support for big integer calculations via means of 'small' int/floats. -Only for testing purposes, since it will fail at large values. But it is simple -enough not to introduce bugs on it's own and to serve as a testbed. - -=head1 DESCRIPTION - -Please see Math::BigInt::Calc. - -=head1 LICENSE - -This program is free software; you may redistribute it and/or modify it under -the same terms as Perl itself. - -=head1 AUTHOR - -Tels http://bloodgate.com in 2001. - -=head1 SEE ALSO - -L<Math::BigInt>, L<Math::BigInt::Calc>. - -=cut diff --git a/gnu/usr.bin/perl/lib/Pod/Html.pm b/gnu/usr.bin/perl/lib/Pod/Html.pm index c4af19cb80e..3f697205bcd 100644 --- a/gnu/usr.bin/perl/lib/Pod/Html.pm +++ b/gnu/usr.bin/perl/lib/Pod/Html.pm @@ -3,7 +3,7 @@ use strict; require Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = 1.0501; +$VERSION = 1.0502; @ISA = qw(Exporter); @EXPORT = qw(pod2html htmlify); @EXPORT_OK = qw(anchorify); @@ -78,6 +78,20 @@ section. By default, no headers are generated. Displays the usage message. +=item hiddendirs + + --hiddendirs + --nohiddendirs + +Include hidden directories in the search for POD's in podpath if recurse +is set. +The default is not to traverse any directory whose name begins with C<.>. +See L</"podpath"> and L</"recurse">. + +[This option is for backward compatibility only. +It's hard to imagine that one would usefully create a module with a +name component beginning with C<.>.] + =item htmldir --htmldir=name @@ -213,6 +227,7 @@ my $Css; my $Recurse; my $Quiet; +my $HiddenDirs; my $Verbose; my $Doindex; @@ -604,6 +619,7 @@ Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name> --flush - flushes the item and directory caches. --[no]header - produce block header/footer (default is no headers). --help - prints this message. + --hiddendirs - search hidden directories in podpath --htmldir - directory for resulting HTML files. --htmlroot - http-server base directory from which all relative paths in podpath stem (default is /). @@ -636,7 +652,7 @@ sub parse_command_line { my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help, $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods, $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet, - $opt_recurse,$opt_title,$opt_verbose); + $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs); unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; my $result = GetOptions( @@ -646,6 +662,7 @@ sub parse_command_line { 'flush' => \$opt_flush, 'header!' => \$opt_header, 'help' => \$opt_help, + 'hiddendirs!'=> \$opt_hiddendirs, 'htmldir=s' => \$opt_htmldir, 'htmlroot=s' => \$opt_htmlroot, 'index!' => \$opt_index, @@ -676,6 +693,7 @@ sub parse_command_line { $Htmlroot = $opt_htmlroot if defined $opt_htmlroot; $Doindex = $opt_index if defined $opt_index; $Podfile = $opt_infile if defined $opt_infile; + $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs; $Htmlfile = $opt_outfile if defined $opt_outfile; $Podroot = $opt_podroot if defined $opt_podroot; $Quiet = $opt_quiet if defined $opt_quiet; @@ -921,7 +939,9 @@ sub scan_dir { opendir(DIR, $dir) || die "$0: error opening directory $dir: $!\n"; while (defined($_ = readdir(DIR))) { - if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory + if (-d "$dir/$_" && $_ ne "." && $_ ne ".." + && ($HiddenDirs || !/^\./) + ) { # directory $Pages{$_} = "" unless defined $Pages{$_}; $Pages{$_} .= "$dir/$_:"; push(@subdirs, $_); diff --git a/gnu/usr.bin/perl/lib/Pod/InputObjects.pm b/gnu/usr.bin/perl/lib/Pod/InputObjects.pm index 9cd347b969a..d895b104a48 100644 --- a/gnu/usr.bin/perl/lib/Pod/InputObjects.pm +++ b/gnu/usr.bin/perl/lib/Pod/InputObjects.pm @@ -932,6 +932,8 @@ See L<Pod::Parser>, L<Pod::Select> =head1 AUTHOR +Please report bugs using L<http://rt.cpan.org>. + Brad Appleton E<lt>bradapp@enteract.comE<gt> =cut diff --git a/gnu/usr.bin/perl/lib/Pod/Perldoc.pm b/gnu/usr.bin/perl/lib/Pod/Perldoc.pm index d00b604483c..5413fbd3307 100644 --- a/gnu/usr.bin/perl/lib/Pod/Perldoc.pm +++ b/gnu/usr.bin/perl/lib/Pod/Perldoc.pm @@ -12,7 +12,7 @@ use File::Spec::Functions qw(catfile catdir splitdir); use vars qw($VERSION @Pagers $Bindir $Pod2man $Temp_Files_Created $Temp_File_Lifetime ); -$VERSION = '3.11'; +$VERSION = '3.12'; #.......................................................................... BEGIN { # Make a DEBUG constant very first thing... @@ -766,9 +766,12 @@ sub maybe_generate_dynamic_pod { push @{ $self->{'temp_file_list'} }, $buffer; # I.e., it MIGHT be deleted at the end. - print $buffd "=over 8\n\n"; + my $in_list = $self->opt_f; + + print $buffd "=over 8\n\n" if $in_list; print $buffd @dynamic_pod or die "Can't print $buffer: $!"; - print $buffd "=back\n"; + print $buffd "=back\n" if $in_list; + close $buffd or die "Can't close $buffer: $!"; @$found_things = $buffer; diff --git a/gnu/usr.bin/perl/lib/Pod/PlainText.pm b/gnu/usr.bin/perl/lib/Pod/PlainText.pm index 02c9205714e..316cd077d78 100644 --- a/gnu/usr.bin/perl/lib/Pod/PlainText.pm +++ b/gnu/usr.bin/perl/lib/Pod/PlainText.pm @@ -1,5 +1,5 @@ # Pod::PlainText -- Convert POD data to formatted ASCII text. -# $Id: PlainText.pm,v 1.2 2003/12/03 03:02:40 millert Exp $ +# $Id: PlainText.pm,v 1.3 2004/04/07 21:33:06 millert Exp $ # # Copyright 1999-2000 by Russ Allbery <rra@stanford.edu> # @@ -29,7 +29,7 @@ use vars qw(@ISA %ESCAPES $VERSION); # by Pod::Usage. @ISA = qw(Pod::Select); -($VERSION = (split (' ', q$Revision: 1.2 $ ))[1]) =~ s/\.(\d)$/.0$1/; +$VERSION = '2.02'; ############################################################################ @@ -396,7 +396,10 @@ sub seq_l { # something looking like L<manpage(section)>. The latter is an # enhancement over the original Pod::Text. my ($manpage, $section) = ('', $_); - if (/^"\s*(.*?)\s*"$/) { + if (/^(?:https?|ftp|news):/) { + # a URL + return $_; + } elsif (/^"\s*(.*?)\s*"$/) { $section = '"' . $1 . '"'; } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { ($manpage, $section) = ($_, ''); @@ -404,8 +407,8 @@ sub seq_l { ($manpage, $section) = split (/\s*\/\s*/, $_, 2); } - # Now build the actual output text. my $text = ''; + # Now build the actual output text. if (!length $section) { $text = "the $manpage manpage" if length $manpage; } elsif ($section =~ /^[:\w]+(?:\(\))?/) { @@ -692,6 +695,8 @@ pod2text(1) =head1 AUTHOR +Please report bugs using L<http://rt.cpan.org>. + Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and its conversion to Pod::Parser by Brad Appleton diff --git a/gnu/usr.bin/perl/lib/Test/Harness.pm b/gnu/usr.bin/perl/lib/Test/Harness.pm index bcb72368f6e..95e1501ea3a 100644 --- a/gnu/usr.bin/perl/lib/Test/Harness.pm +++ b/gnu/usr.bin/perl/lib/Test/Harness.pm @@ -1,5 +1,5 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Harness.pm,v 1.7 2003/12/03 03:02:41 millert Exp $ +# $Id: Harness.pm,v 1.8 2004/04/07 21:33:06 millert Exp $ package Test::Harness; @@ -11,19 +11,39 @@ use Benchmark; use Config; use strict; -use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest - $Columns $verbose $switches $ML $Strap - @ISA @EXPORT @EXPORT_OK $Last_ML_Print - ); +use vars qw( + $VERSION + @ISA @EXPORT @EXPORT_OK + $Verbose $Switches $Debug + $verbose $switches $debug + $Have_Devel_Corestack + $Curtest + $Columns + $ML $Last_ML_Print + $Strap +); + +=head1 NAME + +Test::Harness - Run Perl standard test scripts with statistics + +=head1 VERSION + +Version 2.40 + + $Header: /home/cvs/src/gnu/usr.bin/perl/lib/Test/Attic/Harness.pm,v 1.8 2004/04/07 21:33:06 millert Exp $ + +=cut + +$VERSION = '2.40'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; *switches = *Switches; +*debug = *Debug; $Have_Devel_Corestack = 0; -$VERSION = '2.30'; - $ENV{HARNESS_ACTIVE} = 1; END { @@ -45,15 +65,11 @@ $Strap = Test::Harness::Straps->new; @EXPORT_OK = qw($verbose $switches); $Verbose = $ENV{HARNESS_VERBOSE} || 0; +$Debug = $ENV{HARNESS_DEBUG} || 0; $Switches = "-w"; $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; $Columns--; # Some shells have trouble with a full line of text. - -=head1 NAME - -Test::Harness - run perl standard test scripts with statistics - =head1 SYNOPSIS use Test::Harness; @@ -163,13 +179,15 @@ emitted if the test script is skipped completely: =item B<Todo tests> -If the standard output line contains the substring C< # TODO> after +If the standard output line contains the substring C< # TODO > after C<not ok> or C<not ok NUMBER>, it is counted as a todo test. The text afterwards is the thing that has to be done before this test will succeed. not ok 13 # TODO harness the power of the atom +Note that the TODO must have a space after it. + =begin _deprecated Alternatively, you can specify a list of what tests are todo as part @@ -220,17 +238,15 @@ test script, please use a comment. =back - =head2 Taint mode -Test::Harness will honor the C<-T> in the #! line on your test files. So -if you begin a test with: +Test::Harness will honor the C<-T> or C<-t> in the #! line on your +test files. So if you begin a test with: #!perl -T the test will be run with taint mode on. - =head2 Configuration variables. These variables can be used to configure the behavior of @@ -238,24 +254,25 @@ Test::Harness. They are exported on request. =over 4 -=item B<$Test::Harness::verbose> +=item B<$Test::Harness::Verbose> -The global variable $Test::Harness::verbose is exportable and can be -used to let runtests() display the standard output of the script -without altering the behavior otherwise. +The global variable C<$Test::Harness::Verbose> is exportable and can be +used to let C<runtests()> display the standard output of the script +without altering the behavior otherwise. The F<prove> utility's C<-v> +flag will set this. =item B<$Test::Harness::switches> -The global variable $Test::Harness::switches is exportable and can be +The global variable C<$Test::Harness::switches> is exportable and can be used to set perl command line options used for running the test -script(s). The default value is C<-w>. +script(s). The default value is C<-w>. It overrides C<HARNESS_SWITCHES>. =back =head2 Failure -It will happen, your tests will fail. After you mop up your ego, you +It will happen: your tests will fail. After you mop up your ego, you can begin examining the summary report: t/base..............ok @@ -288,7 +305,7 @@ If the test exited with non-zero, this is its exit status. =item B<Wstat> -The wait status of the test I<umm, I need a better explanation here>. +The wait status of the test. =item B<Total> @@ -388,9 +405,9 @@ sub _globdir { my($total, $failed) = _run_all_tests(@test_files); -Runs all the given @test_files (as runtests()) but does it quietly (no -report). $total is a hash ref summary of all the tests run. Its keys -and values are this: +Runs all the given C<@test_files> (as C<runtests()>) but does it +quietly (no report). $total is a hash ref summary of all the tests +run. Its keys and values are this: bonus Number of individual todo tests unexpectedly passed max Number of individual tests ran @@ -404,8 +421,8 @@ and values are this: tests Number of test files originally given skipped Number of test files skipped -If $total->{bad} == 0 and $total->{max} > 0, you've got a successful -test. +If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've +got a successful test. $failed is a hash ref of all the test scripts which failed. Each key is the name of a test script, each value is another hash representing @@ -419,7 +436,7 @@ how that script failed. Its keys are these: percent Percentage of tests which failed canon List of tests which failed (as string). -Needless to say, $failed should be empty if everything passed. +C<$failed> should be empty if everything passed. B<NOTE> Currently this function is still noisy. I'm working on it. @@ -451,16 +468,21 @@ sub _run_all_tests { my $width = _leader_width(@tests); foreach my $tfile (@tests) { + if ( $Test::Harness::Debug ) { + print "# Running: ", $Strap->_command_line($tfile), "\n"; + } + $Last_ML_Print = 0; # so each test prints at least once my($leader, $ml) = _mk_leader($tfile, $width); local $ML = $ml; + print $leader; $tot{files}++; $Strap->{_seen_header} = 0; my %results = $Strap->analyze_file($tfile) or - do { warn "$Strap->{error}\n"; next }; + do { warn $Strap->{error}, "\n"; next }; # state of the current test. my @failed = grep { !$results{details}[$_-1]{ok} } @@ -526,7 +548,7 @@ sub _run_all_tests { } elsif($results{seen}) { if (@{$test{failed}} and $test{max}) { - my ($txt, $canon) = canonfailed($test{max},$test{skipped}, + my ($txt, $canon) = _canonfailed($test{max},$test{skipped}, @{$test{failed}}); print "$test{ml}$txt"; $failedtests{$tfile} = { canon => $canon, @@ -587,12 +609,12 @@ sub _run_all_tests { my($leader, $ml) = _mk_leader($test_file, $width); -Generates the 't/foo........' $leader for the given $test_file as well +Generates the 't/foo........' $leader for the given C<$test_file> as well as a similar version which will overwrite the current line (by use of -\r and such). $ml may be empty if Test::Harness doesn't think you're +\r and such). C<$ml> may be empty if Test::Harness doesn't think you're on TTY. -The $width is the width of the "yada/blah.." string. +The C<$width> is the width of the "yada/blah.." string. =cut @@ -789,7 +811,7 @@ sub _dubious_return { $wstatus,$wstatus; print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; - if (corestatus($wstatus)) { # until we have a wait module + if (_corestatus($wstatus)) { # until we have a wait module if ($Have_Devel_Corestack) { Devel::CoreStack::stack($^X); } else { @@ -808,7 +830,7 @@ sub _dubious_return { else { push @{$test->{failed}}, $test->{'next'}..$test->{max}; $failed = @{$test->{failed}}; - (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}}); + (my $txt, $canon) = _canonfailed($test->{max},$test->{skipped},@{$test->{failed}}); $percent = 100*(scalar @{$test->{failed}})/$test->{max}; print "DIED. ",$txt; } @@ -878,7 +900,7 @@ sub _create_fmts { { my $tried_devel_corestack; - sub corestatus { + sub _corestatus { my($st) = @_; my $did_core; @@ -898,7 +920,7 @@ sub _create_fmts { } } -sub canonfailed ($$@) { +sub _canonfailed ($$@) { my($max,$skipped,@failed) = @_; my %seen; @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; @@ -966,8 +988,7 @@ __END__ C<&runtests> is exported by Test::Harness by default. -C<$verbose> and C<$switches> are exported upon request. - +C<$verbose>, C<$switches> and C<$debug> are exported upon request. =head1 DIAGNOSTICS @@ -1027,6 +1048,13 @@ C<perlcc> before running it. B<NOTE> This currently only works when sitting in the perl source directory! +=item C<HARNESS_DEBUG> + +If true, Test::Harness will print debugging information about itself as +it runs the tests. This is different from C<HARNESS_VERBOSE>, which prints +the output from the test being run. Setting C<$Test::Harness::Debug> will +override this, or you can use the C<-d> switch in the F<prove> utility. + =item C<HARNESS_FILELEAK_IN_DIR> When set to the name of a directory, harness will check after each @@ -1052,9 +1080,17 @@ somewhat messy output). =item C<HARNESS_OK_SLOW> -If true, the C<ok> messages are printed out only every second. -This reduces output and therefore may for example help testing -over slow connections. +If true, the C<ok> messages are printed out only every second. This +reduces output and may help increase testing speed over slow +connections, or with very large numbers of tests. + +=item C<HARNESS_PERL> + +Usually your tests will be run by C<$^X>, the currently-executing Perl. +However, you may want to have it run by a different executable, such as +a threading perl, or a different version. + +If you're using the F<prove> utility, you can use the C<--perl> switch. =item C<HARNESS_PERL_SWITCHES> @@ -1065,7 +1101,8 @@ run all tests with all warnings enabled. =item C<HARNESS_VERBOSE> If true, Test::Harness will output the verbose results of running -its tests. Setting $Test::Harness::verbose will override this. +its tests. Setting C<$Test::Harness::verbose> will override this, +or you can use the C<-v> switch in the F<prove> utility. =back @@ -1165,4 +1202,22 @@ Clean up how the summary is printed. Get rid of those damned formats. HARNESS_COMPILE_TEST currently assumes it's run from the Perl source directory. +Please use the CPAN bug ticketing system at L<http://rt.cpan.org/>. +You can also mail bugs, fixes and enhancements to +C<< <bug-test-harness@rt.cpan.org> >>. + +=head1 AUTHORS + +Original code by Michael G Schwern, maintained by Andy Lester. + +=head1 COPYRIGHT + +Copyright 2003 by Michael G Schwern C<< <schwern@pobox.com> >>, + Andy Lester C<< <andy@petdance.com> >>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html>. + =cut diff --git a/gnu/usr.bin/perl/lib/Tie/Hash.pm b/gnu/usr.bin/perl/lib/Tie/Hash.pm index 65f9dd0b385..98e0d50e7de 100644 --- a/gnu/usr.bin/perl/lib/Tie/Hash.pm +++ b/gnu/usr.bin/perl/lib/Tie/Hash.pm @@ -1,6 +1,6 @@ package Tie::Hash; -our $VERSION = '1.00'; +our $VERSION = '1.01'; =head1 NAME @@ -105,6 +105,13 @@ Delete the key I<key> from the tied hash I<this>. Clear all values from the tied hash I<this>. +=item SCALAR this + +Returns what evaluating the hash in scalar context yields. + +B<Tie::Hash> does not implement this method (but B<Tie::StdHash> +and B<Tie::ExtraHash> do). + =back =head1 Inheriting from B<Tie::StdHash> @@ -131,7 +138,7 @@ should operate on the hash referenced by the first argument: =head1 Inheriting from B<Tie::ExtraHash> The accessor methods assume that the actual storage for the data in the tied -hash is in the hash referenced by C<(tied(%tiedhash))[0]>. Thus overwritten +hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten C<TIEHASH> method should return an array reference with the first element being a hash reference, and the remaining methods should operate on the hash C<< %{ $_[0]->[0] } >>: @@ -156,15 +163,18 @@ same storage algorithm as in TIEHASH subroutine above. Hence, a typical package inheriting from B<Tie::ExtraHash> does not need to overwrite this method. -=head1 C<UNTIE> and C<DESTROY> +=head1 C<SCALAR>, C<UNTIE> and C<DESTROY> The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require presense of these methods, but if defined, the methods will be called in proper time, see L<perltie>. +C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>. + If needed, these methods should be defined by the package inheriting from -B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. +B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR"> +to find out what happens when C<SCALAR> does not exist. =head1 MORE INFORMATION @@ -230,6 +240,7 @@ sub NEXTKEY { each %{$_[0]} } sub EXISTS { exists $_[0]->{$_[1]} } sub DELETE { delete $_[0]->{$_[1]} } sub CLEAR { %{$_[0]} = () } +sub SCALAR { scalar %{$_[0]} } package Tie::ExtraHash; @@ -241,5 +252,6 @@ sub NEXTKEY { each %{$_[0][0]} } sub EXISTS { exists $_[0][0]->{$_[1]} } sub DELETE { delete $_[0][0]->{$_[1]} } sub CLEAR { %{$_[0][0]} = () } +sub SCALAR { scalar %{$_[0][0]} } 1; diff --git a/gnu/usr.bin/perl/lib/base.pm b/gnu/usr.bin/perl/lib/base.pm index 3177488eac0..04a8aa961ea 100644 --- a/gnu/usr.bin/perl/lib/base.pm +++ b/gnu/usr.bin/perl/lib/base.pm @@ -2,7 +2,7 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.03'; +$VERSION = '2.04'; # constant.pm is slow sub SUCCESS () { 1 } @@ -113,7 +113,7 @@ sub inherit_fields { if( keys %$dfields ) { warn "$derived is inheriting from $base but already has its own ". "fields!\n". - "This will cause problems with pseudo-hashes.\n". + "This will cause problems.\n". "Be sure you use base BEFORE declaring fields\n"; } @@ -151,7 +151,7 @@ __END__ =head1 NAME -base - Establish IS-A relationship with base class at compile time +base - Establish IS-A relationship with base classes at compile time =head1 SYNOPSIS @@ -160,31 +160,29 @@ base - Establish IS-A relationship with base class at compile time =head1 DESCRIPTION -Roughly similar in effect to +Allows you to both load one or more modules, while setting up inheritance from +those modules at the same time. Roughly similar in effect to + package Baz; BEGIN { require Foo; require Bar; push @ISA, qw(Foo Bar); } +If any of the listed modules are not loaded yet, I<base> silently attempts to +C<require> them (and silently continues if the C<require> failed). Whether to +C<require> a base class module is determined by the absence of a global variable +$VERSION in the base package. If $VERSION is not detected even after loading +it, <base> will define $VERSION in the base package, setting it to the string +C<-1, set by base.pm>. + Will also initialize the fields if one of the base classes has it. -Multiple Inheritence of fields is B<NOT> supported, if two or more +Multiple inheritence of fields is B<NOT> supported, if two or more base classes each have inheritable fields the 'base' pragma will croak. See L<fields>, L<public> and L<protected> for a description of this feature. -When strict 'vars' is in scope, I<base> also lets you assign to @ISA -without having to declare @ISA with the 'vars' pragma first. - -If any of the base classes are not loaded yet, I<base> silently -C<require>s them (but it won't call the C<import> method). Whether to -C<require> a base class package is determined by the absence of a global -$VERSION in the base package. If $VERSION is not detected even after -loading it, I<base> will define $VERSION in the base package, setting it to -the string C<-1, set by base.pm>. - - =head1 HISTORY This module was introduced with Perl 5.004_04. @@ -192,7 +190,7 @@ This module was introduced with Perl 5.004_04. =head1 CAVEATS -Due to the limitations of the pseudo-hash implementation, you must use +Due to the limitations of the implementation, you must use base I<before> you declare any of your own fields. diff --git a/gnu/usr.bin/perl/lib/diagnostics.pm b/gnu/usr.bin/perl/lib/diagnostics.pm index 0d1a7e2e6ef..7445aade042 100644 --- a/gnu/usr.bin/perl/lib/diagnostics.pm +++ b/gnu/usr.bin/perl/lib/diagnostics.pm @@ -2,13 +2,11 @@ package diagnostics; =head1 NAME -diagnostics - Perl compiler pragma to force verbose warning diagnostics - -splain - filter to produce verbose descriptions of perl warning diagnostics +diagnostics, splain - produce verbose warning diagnostics =head1 SYNOPSIS -As a pragma: +Using the C<diagnostics> pragma: use diagnostics; use diagnostics -verbose; @@ -16,12 +14,11 @@ As a pragma: enable diagnostics; disable diagnostics; -As a program: +Using the C<splain> standalone filter program: perl program 2>diag.out splain [-v] [-p] diag.out - =head1 DESCRIPTION =head2 The C<diagnostics> Pragma @@ -171,7 +168,7 @@ use strict; use 5.006; use Carp; -our $VERSION = 1.11; +our $VERSION = 1.12; our $DEBUG; our $VERBOSE; our $PRETTY; diff --git a/gnu/usr.bin/perl/lib/perl5db.pl b/gnu/usr.bin/perl/lib/perl5db.pl index 580a70dcf27..3674d0372c4 100644 --- a/gnu/usr.bin/perl/lib/perl5db.pl +++ b/gnu/usr.bin/perl/lib/perl5db.pl @@ -492,7 +492,8 @@ package DB; use IO::Handle; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.22; +$VERSION = 1.23; + $header = "perl5db.pl version $VERSION"; =head1 DEBUGGER ROUTINES @@ -678,7 +679,10 @@ sub eval { # (for subroutines defined outside of the package DB). In fact the same is # true if $deep is not defined. # -# $Log: perldb.pl,v $ +# $Log: perl5db.pl,v $ +# Revision 1.7 2003/12/03 03:02:36 millert +# Resolve conflicts for perl 5.8.2, remove old files, and add OpenBSD-specific scaffolding +# # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -899,6 +903,8 @@ sub eval { # + Includes cleanup by Robin Barker and Jarkko Hietaniemi. # Changes: 1.22 Jun 09, 2003 Alex Vandiver <alexmv@MIT.EDU> # + Flush stdout/stderr before the debugger prompt is printed. +# Changes: 1.23: Dec 21, 2003 Dominique Quatravaux +# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug") #################################################################### @@ -1344,6 +1350,9 @@ if (not defined &get_fork_TTY # no routine exists, elsif ($^O eq 'os2') { # If this is OS/2, *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version } +# untaint $^O, which may have been tainted by the last statement. +# see bug [perl #24674] +$^O =~ m/^(.*)\z/; $^O = $1; # "Here begin the unreadable code. It needs fixing." |