diff options
author | markm <markm@FreeBSD.org> | 1999-05-02 14:33:17 +0000 |
---|---|---|
committer | markm <markm@FreeBSD.org> | 1999-05-02 14:33:17 +0000 |
commit | 77644ee620b6a79cf8c538abaf7cd301a875528d (patch) | |
tree | b4adabf341898a4378f4b7f8c7fb65f3f7c77769 /contrib/perl5/lib | |
parent | 4fcbc3669aa997848e15198cc9fb856287a6788c (diff) | |
download | FreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.zip FreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.tar.gz |
Maintenance releace 3 of perl5.005. Includes support for threads.
Diffstat (limited to 'contrib/perl5/lib')
69 files changed, 2827 insertions, 1208 deletions
diff --git a/contrib/perl5/lib/AutoLoader.pm b/contrib/perl5/lib/AutoLoader.pm index 666c6ca..5b083a7 100644 --- a/contrib/perl5/lib/AutoLoader.pm +++ b/contrib/perl5/lib/AutoLoader.pm @@ -178,7 +178,7 @@ such a file exists, AUTOLOAD will read and evaluate it, thus (presumably) defining the needed subroutine. AUTOLOAD will then C<goto> the newly defined subroutine. -Once this process completes for a given funtion, it is defined, so +Once this process completes for a given function, it is defined, so future calls to the subroutine will bypass the AUTOLOAD mechanism. =head2 Subroutine Stubs @@ -266,7 +266,7 @@ C<__DATA__>, after which routines are cached. B<SelfLoader> can also handle multiple packages in a file. B<AutoLoader> only reads code as it is requested, and in many cases -should be faster, but requires a machanism like B<AutoSplit> be used to +should be faster, but requires a mechanism like B<AutoSplit> be used to create the individual files. L<ExtUtils::MakeMaker> will invoke B<AutoSplit> automatically if B<AutoLoader> is used in a module source file. diff --git a/contrib/perl5/lib/AutoSplit.pm b/contrib/perl5/lib/AutoSplit.pm index 121d261..f818371 100644 --- a/contrib/perl5/lib/AutoSplit.pm +++ b/contrib/perl5/lib/AutoSplit.pm @@ -11,7 +11,7 @@ use vars qw( $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime ); -$VERSION = "1.0302"; +$VERSION = "1.0303"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -219,7 +219,7 @@ sub autosplit_file { while (<IN>) { # Skip pod text. $fnr++; - $in_pod = 1 if /^=/; + $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); diff --git a/contrib/perl5/lib/Benchmark.pm b/contrib/perl5/lib/Benchmark.pm index a28f510..ef12d02 100644 --- a/contrib/perl5/lib/Benchmark.pm +++ b/contrib/perl5/lib/Benchmark.pm @@ -124,6 +124,11 @@ The COUNT can be zero or negative, see timethis(). Returns the difference between two Benchmark times as a Benchmark object suitable for passing to timestr(). +=item timesum ( T1, T2 ) + +Returns the sum of two Benchmark times as a Benchmark object suitable +for passing to timestr(). + =item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] ) Returns a string that formats the times in the TIMEDIFF object in @@ -293,6 +298,15 @@ sub timediff { bless \@r; } +sub timesum { + my($a, $b) = @_; + my @r; + for (my $i=0; $i < @$a; ++$i) { + push(@r, $a->[$i] + $b->[$i]); + } + bless \@r; +} + sub timestr { my($tr, $style, $f) = @_; my @t = @$tr; diff --git a/contrib/perl5/lib/CGI.pm b/contrib/perl5/lib/CGI.pm index 22d91a4..f5615f2 100644 --- a/contrib/perl5/lib/CGI.pm +++ b/contrib/perl5/lib/CGI.pm @@ -15,11 +15,10 @@ require 5.004; # listing the modifications you have made. # 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/ +# http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $'; -$CGI::VERSION='2.42'; +$CGI::revision = '$Id: CGI.pm,v 1.5 1998/12/06 10:19:48 lstein Exp $'; +$CGI::VERSION='2.46'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -59,6 +58,12 @@ sub initialize_globals { # Change this to 1 to disable uploads entirely: $DISABLE_UPLOADS = 0; + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 0; + # Other globals that you shouldn't worry about. undef $Q; $BEEN_THERE = 0; @@ -116,8 +121,9 @@ $SL = { $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (defined($ENV{'GATEWAY_INTERFACE'}) && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) +if (exists $ENV{'GATEWAY_INTERFACE'} + && + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { $| = 1; require Apache; @@ -151,20 +157,21 @@ if ($needs_binmode) { tt u i b blockquote pre img a address cite samp dfn html head base body Link nextid title meta kbd start_html end_html input Select option comment/], - ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param embed basefont style span layer ilayer font frameset frame script small big/], ':netscape'=>[qw/blink fontsize center/], ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group submit reset defaults radio_group popup_menu button autoEscape scrolling_list image_button start_form end_form startform endform - start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump - raw_cookie request_method query_string accept user_agent remote_host + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host remote_addr referer server_name server_software server_port server_protocol virtual_host remote_ident auth_type http use_named_parameters save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param/], ':ssl' => [qw/https/], + ':imagemap' => [qw/Area Map/], ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], ':html' => [qw/:html2 :html3 :netscape/], ':standard' => [qw/:html2 :html3 :form :cgi/], @@ -206,6 +213,7 @@ sub compile { sub expand_tags { my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; foreach (@{$EXPORT_TAGS{$tag}}) { @@ -273,7 +281,7 @@ sub param { $name = $p[0]; } - return () unless defined($name) && $self->{$name}; + return unless defined($name) && $self->{$name}; return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; } @@ -315,6 +323,7 @@ sub self_or_CGI { sub init { my($self,$initializer) = @_; my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + local($/) = "\n"; # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone @@ -341,7 +350,7 @@ sub init { && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| && !defined($initializer) ) { - my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/; + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; $self->read_multipart($boundary,$content_length); last METHOD; } @@ -496,7 +505,7 @@ sub save_request { sub parse_params { my($self,$tosplit) = @_; - my(@pairs) = split('&',$tosplit); + my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); foreach (@pairs) { ($param,$value) = split('=',$_,2); @@ -526,11 +535,9 @@ sub binmode { } sub _make_tag_func { - my $tagname = shift; - return qq{ + my ($self,$tagname) = @_; + my $func = qq# sub $tagname { - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors shift if \$_[0] && (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || (ref(\$_[0]) && @@ -542,12 +549,20 @@ sub _make_tag_func { my(\@attr) = make_attributes( '',shift() ); \$attr = " \@attr" if \@attr; } + #; + if ($tagname=~/start_(\w+)/i) { + $func .= qq! return "<\U$1\E\$attr>";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! return "<\U/$1\E>"; } !; + } else { + $func .= qq# my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E"); return \$tag unless \@_; my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; return "\@result"; - } -} + }#; + } +return $func; } sub AUTOLOAD { @@ -619,12 +634,13 @@ sub _compile { $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); if (!$code) { + (my $base = $func_name) =~ s/^(start_|end_)//i; if ($EXPORT{':any'} || $EXPORT{'-any'} || - $EXPORT{$func_name} || + $EXPORT{$base} || (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$func_name}) { - $code = _make_tag_func($func_name); + && $EXPORT_OK{$base}) { + $code = $CGI::DefaultClass->_make_tag_func($func_name); } } die "Undefined subroutine $AUTOLOAD\n" unless $code; @@ -644,14 +660,15 @@ sub _setup_symbols { my $self = shift; my $compile = 0; foreach (@_) { - $NPH++, next if /^[:-]nph$/; - $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; - $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; - $EXPORT{$_}++, next if /^[:-]any$/; - $compile++, next if /^[:-]compile$/; + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; + $EXPORT{$_}++, next if /^[:-]any$/; + $compile++, next if /^[:-]compile$/; - # This is probably extremely evil code -- to be deleted - # some day. + # This is probably extremely evil code -- to be deleted some day. if (/^[-]autoload$/) { my($pkg) = caller(1); *{"${pkg}::AUTOLOAD"} = sub { @@ -978,7 +995,7 @@ sub url_param { unless (exists($self->{'.url_param'})) { $self->{'.url_param'}={}; # empty hash if ($ENV{QUERY_STRING} =~ /=/) { - my(@pairs) = split('&',$ENV{QUERY_STRING}); + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); my($param,$value); foreach (@pairs) { ($param,$value) = split('=',$_,2); @@ -1043,6 +1060,7 @@ sub save { $filehandle = to_filehandle($filehandle); my($param); local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value foreach $param ($self->param) { my($escaped_param) = escape($param); my($value); @@ -1141,18 +1159,21 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); + return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/; + next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; } - $type = $type || 'text/html'; + $type ||= 'text/html' unless defined($type); # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; @@ -1164,7 +1185,8 @@ sub header { if ($cookie) { my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; foreach (@cookie) { - push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_)); + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@header,"Set-Cookie: $cs") if $cs ne ''; } } # if the user indicates an expiration time, then we need @@ -1175,7 +1197,7 @@ sub header { push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,@other); - push(@header,"Content-Type: $type"); + push(@header,"Content-Type: $type") if $type ne ''; my $header = join($CRLF,@header)."${CRLF}${CRLF}"; if ($MOD_PERL and not $nph) { @@ -1221,6 +1243,7 @@ sub redirect { '-nph'=>$nph); unshift(@o,'-Target'=>$target) if $target; unshift(@o,'-Cookie'=>$cookie) if $cookie; + unshift(@o,'-Type'=>''); return $self->header(@o); } END_OF_FUNC @@ -1407,6 +1430,11 @@ sub start_form { } END_OF_FUNC +'end_multipart_form' => <<'END_OF_FUNC', +sub end_multipart_form { + &endform; +} +END_OF_FUNC #### Method: start_multipart_form # synonym for startform @@ -1459,8 +1487,11 @@ sub _textfield { $name = defined($name) ? $self->escapeHTML($name) : ''; my($s) = defined($size) ? qq/ SIZE=$size/ : ''; my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(VALUE="$current") : ''; + return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/; } END_OF_FUNC @@ -1787,12 +1818,17 @@ END_OF_FUNC sub unescapeHTML { my $string = ref($_[0]) ? $_[1] : $_[0]; return undef unless defined($string); - $string=~s/&/&/ig; - $string=~s/"/\"/ig; - $string=~s/>/>/ig; - $string=~s/</</ig; - $string=~s/&#(\d+);/chr($1)/eg; - $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg; + # thanks to Randal Schwartz for the correct solution to this one + $string=~ s[&(.*?);]{ + local $_ = $1; + /^amp$/i ? "&" : + /^quot$/i ? '"' : + /^gt$/i ? ">" : + /^lt$/i ? "<" : + /^#(\d+)$/ ? chr($1) : + /^#x([0-9a-f]+)$/i ? chr(hex($1)) : + $_ + }gex; return $string; } END_OF_FUNC @@ -1867,14 +1903,13 @@ sub radio_group { } else { $checked = $default; } - # If no check array is specified, check the first by default - $checked = $values->[0] unless defined($checked) && $checked ne ''; - $name=$self->escapeHTML($name); - my(@elements,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); + # If no check array is specified, check the first by default + $checked = $values[0] unless defined($checked) && $checked ne ''; + $name=$self->escapeHTML($name); + my($other) = @other ? " @other" : ''; foreach (@values) { my($checkit) = $checked eq $_ ? ' CHECKED' : ''; @@ -2321,7 +2356,7 @@ sub query_string { push(@pairs,"$eparam=$value"); } } - return join("&",@pairs); + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } END_OF_FUNC @@ -2337,8 +2372,8 @@ END_OF_FUNC # declares a quantitative score for it. # This handles MIME type globs correctly. #### -'accept' => <<'END_OF_FUNC', -sub accept { +'Accept' => <<'END_OF_FUNC', +sub Accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); @@ -2758,6 +2793,7 @@ sub read_multipart { chmod 0600,$tmp; # only the owner can tamper with it my ($data); + local($\) = ''; while (defined($data = $buffer->read)) { print $filehandle $data; } @@ -2841,10 +2877,18 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'asString' => <<'END_OF_FUNC', sub asString { my $self = shift; - my $i = $$self; - $i=~ s/^\*(\w+::)+//; # get rid of package name + # get rid of package name + (my $i = $$self) =~ s/^\*(\w+::)+//; $i =~ s/\\(.)/$1/g; return $i; +# BEGIN DEAD CODE +# This was an extremely clever patch that allowed "use strict refs". +# Unfortunately it relied on another bug that caused leaky file descriptors. +# The underlying bug has been fixed, so this no longer works. However +# "strict refs" still works for some reason. +# my $self = shift; +# return ${*{$self}{SCALAR}}; +# END DEAD CODE } END_OF_FUNC @@ -2861,11 +2905,12 @@ sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; ++$FH; - *{$FH} = quotemeta($name); - sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) + my $ref = \*{'Fh::' . quotemeta($name)}; + sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) || die "CGI open of $file: $!\n"; unlink($file) if $delete; - return bless \*{$FH},$pack; + delete $Fh::{$FH}; + return bless $ref,$pack; } END_OF_FUNC @@ -2883,10 +2928,10 @@ END_OF_AUTOLOAD package MultipartBuffer; # how many bytes to read at a time. We use -# a 5K buffer by default. -$INITIAL_FILLUNIT = 1024 * 5; -$TIMEOUT = 10*60; # 10 minute timeout -$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers $CRLF=$CGI::CRLF; #reuse the autoload function @@ -2930,8 +2975,8 @@ sub new { # characters "--" PLUS the Boundary string # BUG: IE 3.01 on the Macintosh uses just the boundary -- not - # the two extra spaces. We do a special case here on the user-agent!!!! - $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; Mac'); + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; ?Mac'); } else { # otherwise we find it ourselves my($old); @@ -3088,6 +3133,7 @@ sub fillBuffer { \$self->{BUFFER}, $bytesToRead, $bufferLength); + $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the @@ -3129,7 +3175,7 @@ $MAC = $CGI::OS eq 'MACINTOSH'; my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", - "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", + "C:${SL}temp","${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", "${SL}WWW_ROOT"); foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; @@ -3273,10 +3319,10 @@ the CGI script, and because each object's parameter list is independent of the others, this allows you to save the state of the script and restore it later. -For example, using the object oriented style, here is now you create +For example, using the object oriented style, here is how you create a simple "Hello World" HTML page: - #!/usr/local/bin/pelr + #!/usr/local/bin/perl use CGI; # load CGI routines $q = new CGI; # create new CGI object print $q->header, # create the HTTP header @@ -3294,7 +3340,7 @@ The main differences are that we now need to import a set of functions into our name space (usually the "standard" functions), and we don't need to create the CGI object. - #!/usr/local/bin/pelr + #!/usr/local/bin/perl use CGI qw/:standard/; # load standard CGI routines print header, # create the HTTP header start_html('hello world'), # start the HTML @@ -3319,7 +3365,7 @@ acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument, CGI.pm assumes dashes for the subsequent ones. -You don't have to use the hyphen at allif you don't want to. After +You don't have to use the hyphen at all if you don't want to. After creating a CGI object, call the B<use_named_parameters()> method with a nonzero value. This will tell CGI.pm that you intend to use named parameters exclusively: @@ -3667,7 +3713,7 @@ methods, and then use them directly: $zipcode = param('zipcode'); More frequently, you'll import common sets of functions by referring -to the gropus by name. All function sets are preceded with a ":" +to the groups by name. All function sets are preceded with a ":" character as in ":html3" (for tags defined in the HTML 3 standard). Here is a list of the function sets you can import: @@ -3719,7 +3765,7 @@ provide for the rapidly-evolving HTML "standard." For example, say Microsoft comes out with a new tag called <GRADIENT> (which causes the user's desktop to be flooded with a rotating gradient fill until his machine reboots). You don't need to wait for a new version of CGI.pm -to start using it immeidately: +to start using it immediately: use CGI qw/:standard :html3 gradient/; print gradient({-start=>'red',-end=>'blue'}); @@ -3799,7 +3845,7 @@ This causes the indicated autoloaded methods to be compiled up front, rather than deferred to later. This is useful for scripts that run for an extended period of time under FastCGI or mod_perl, and for those destined to be crunched by Malcom Beattie's Perl compiler. Use -it in conjunction with the methods or method familes you plan to use. +it in conjunction with the methods or method families you plan to use. use CGI qw(-compile :standard :html3); @@ -3819,6 +3865,17 @@ parsed header) script. You may need to do other things as well to tell the server that the script is NPH. See the discussion of NPH scripts below. +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +semicolons rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, but will not be +emitted by self_url() and query_string() unless the -newstyle_urls +pragma is specified. + =item -autoload This overrides the autoloader so that any function in your program @@ -3859,7 +3916,51 @@ upload, even if it is confidential information. On Unix systems, the -private_tempfiles pragma will cause the temporary file to be unlinked as soon as it is opened and before any data is written into it, eliminating the risk of eavesdropping. -n + +=back + +=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS + +Many of the methods generate HTML tags. As described below, tag +functions automatically generate both the opening and closing tags. +For example: + + print h1('Level 1 Header'); + +produces + + <H1>Level 1 Header</H1> + +There will be some times when you want to produce the start and end +tags yourself. In this case, you can use the form start_I<tag_name> +and end_I<tag_name>, as in: + + print start_h1,'Level 1 Header',end_h1; + +With a few exceptions (described below), start_I<tag_name> and +end_I<tag_name> functions are not generated automatically when you +I<use CGI>. However, you can specify the tags you want to generate +I<start/end> functions for by putting an asterisk in front of their +name, or, alternatively, requesting either "start_I<tag_name>" or +"end_I<tag_name>" in the import list. + +Example: + + use CGI qw/:standard *table start_ul/; + +In this example, the following functions are generated in addition to +the standard ones: + +=over 4 + +=item 1. start_table() (generates a <TABLE> tag) + +=item 2. end_table() (generates a </TABLE> tag) + +=item 3. start_ul() (generates a <UL> tag) + +=item 4. end_ul() (generates a </UL> tag) + =back =head1 GENERATING DYNAMIC DOCUMENTS @@ -4247,6 +4348,25 @@ as a synonym. =back +=head2 MIXING POST AND URL PARAMETERS + + $color = $query->url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as +well as in the fill-out form by creating a form that POSTs to a URL +containing a query string (a "?" mark followed by arguments). The +B<param()> method will always return the contents of the POSTed +fill-out form, ignoring the URL's query string. To retrieve URL +parameters, call the B<url_param()> method. Use it in the same way as +B<param()>. The main difference is that it allows you to read the +parameters, but not set them. + + +Under no circumstances will the contents of the URL query string +interfere with similarly-named CGI parameters in POSTed forms. If you +try to mix a URL query string with a form submitted with the GET +method, the results will not be what you expect. + =head1 CREATING STANDARD HTML ELEMENTS: CGI.pm defines general HTML shortcut methods for most, if not all of @@ -4325,7 +4445,7 @@ that points to an undef string: Prior to CGI.pm version 2.41, providing an empty ('') string as an attribute argument was the same as providing undef. However, this has -changed in order to accomodate those who want to create tags of the form +changed in order to accommodate those who want to create tags of the form <IMG ALT="">. The difference is shown in these two pieces of code: CODE RESULT @@ -4410,11 +4530,21 @@ begin with initial caps: Tr Link Delete + Accept + Sub In addition, start_html(), end_html(), start_form(), end_form(), start_multipart_form() and all the fill-out form tags are special. See their respective sections. +=head2 PRETTY-PRINTING HTML + +By default, all the HTML produced by these functions comes out as one +long line without carriage returns or indentation. This is yuck, but +it does reduce the size of the documents by 10-20%. To get +pretty-printed output, please use L<CGI::Pretty>, a subclass +contributed by Brian Paulsen. + =head1 CREATING FILL-OUT FORMS: I<General note> The various form-creating methods all return strings @@ -4469,7 +4599,7 @@ default is to process the query with the current script. print $query->startform(-method=>$method, -action=>$action, - -encoding=>$encoding); + -enctype=>$encoding); <... various form stuff ...> print $query->endform; @@ -4484,11 +4614,11 @@ action and form encoding that you specify. The defaults are: method: POST action: this script - encoding: application/x-www-form-urlencoded + enctype: application/x-www-form-urlencoded endform() returns the closing </FORM> tag. -Startform()'s encoding method tells the browser how to package the various +Startform()'s enctype argument tells the browser how to package the various fields of the form before sending the form to the server. Two values are possible: @@ -4671,12 +4801,11 @@ The first parameter is the required name for the field (-name). The optional second parameter is the starting value for the field contents to be used as the default file name (-default). -The beta2 version of Netscape 2.0 currently doesn't pay any attention -to this field, and so the starting value will always be blank. Worse, -the field loses its "sticky" behavior and forgets its previous -contents. The starting value field is called for in the HTML -specification, however, and possibly later versions of Netscape will -honor it. +For security reasons, browsers don't pay any attention to this field, +and so the starting value will always be blank. Worse, the field +loses its "sticky" behavior and forgets its previous contents. The +starting value field is called for in the HTML specification, however, +and possibly some browser will eventually provide support for it. =item 3. @@ -5093,7 +5222,7 @@ To include row and column headings in the returned table, you can use the B<-rowheader> and B<-colheader> parameters. Both of these accept a pointer to an array of headings to use. The headings are just decorative. They don't reorganize the -interpetation of the radio buttons -- they're still a single named +interpretation of the radio buttons -- they're still a single named unit. =back @@ -5157,6 +5286,9 @@ reset() creates the "reset" button. Note that it restores the form to its value from the last time the script was called, NOT necessarily to the defaults. +Note that this conflicts with the Perl reset() built-in. Use +CORE::reset() to get the original reset function. + =head2 CREATING A DEFAULT BUTTON print $query->defaults('button_label') @@ -5263,11 +5395,12 @@ pointed to by the B<-onClick> parameter will be executed. On non-Netscape browsers this form element will probably not even display. -=head1 NETSCAPE COOKIES +=head1 HTTP COOKIES -Netscape browsers versions 1.1 and higher support a so-called -"cookie" designed to help maintain state within a browser session. -CGI.pm has several methods that support cookies. +Netscape browsers versions 1.1 and higher, and all versions of +Internet Explorer, support a so-called "cookie" designed to help +maintain state within a browser session. CGI.pm has several methods +that support cookies. A cookie is a name=value pair much like the named parameters in a CGI query string. CGI scripts create one or more cookies and send @@ -5285,15 +5418,15 @@ optional attributes: This is a time/date string (in a special GMT format) that indicates when a cookie expires. The cookie will be saved and returned to your script until this expiration date is reached if the user exits -Netscape and restarts it. If an expiration date isn't specified, the cookie -will remain active until the user quits Netscape. +the browser and restarts it. If an expiration date isn't specified, the cookie +will remain active until the user quits the browser. =item 2. a domain This is a partial or complete domain name for which the cookie is valid. The browser will return the cookie to any host that matches the partial domain name. For example, if you specify a domain name -of ".capricorn.com", then Netscape will return the cookie to +of ".capricorn.com", then the browser will return the cookie to Web servers running on any of the machines "www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names must contain at least two periods to prevent attempts to match @@ -5318,7 +5451,7 @@ script if the CGI request is occurring on a secure channel, such as SSL. =back -The interface to Netscape cookies is the B<cookie()> method: +The interface to HTTP cookies is the B<cookie()> method: $cookie = $query->cookie(-name=>'sessionID', -value=>'xyzzy', @@ -5335,7 +5468,7 @@ B<cookie()> creates a new cookie. Its parameters include: =item B<-name> The name of the cookie (required). This can be any string at all. -Although Netscape limits its cookie names to non-whitespace +Although browsers limit their cookie names to non-whitespace alphanumeric characters, CGI.pm removes this restriction by escaping and unescaping cookies behind the scenes. @@ -5406,19 +5539,11 @@ simple to turn a CGI parameter into a cookie, and vice-versa: See the B<cookie.cgi> example script for some ideas on how to use cookies effectively. -B<NOTE:> There appear to be some (undocumented) restrictions on -Netscape cookies. In Netscape 2.01, at least, I haven't been able to -set more than three cookies at a time. There may also be limits on -the length of cookies. If you need to store a lot of information, -it's probably better to create a unique session ID, store it in a -cookie, and use the session ID to locate an external file/database -saved on the server's side of the connection. - -=head1 WORKING WITH NETSCAPE FRAMES +=head1 WORKING WITH FRAMES -It's possible for CGI.pm scripts to write into several browser -panels and windows using Netscape's frame mechanism. -There are three techniques for defining new frames programmatically: +It's possible for CGI.pm scripts to write into several browser panels +and windows using the HTML 4 frame mechanism. There are three +techniques for defining new frames programmatically: =over 4 @@ -5441,12 +5566,12 @@ You may provide a B<-target> parameter to the header() method: print $q->header(-target=>'ResultsWindow'); -This will tell Netscape to load the output of your script into the -frame named "ResultsWindow". If a frame of that name doesn't -already exist, Netscape will pop up a new window and load your -script's document into that. There are a number of magic names -that you can use for targets. See the frame documents on Netscape's -home pages for details. +This will tell the browser to load the output of your script into the +frame named "ResultsWindow". If a frame of that name doesn't already +exist, the browser will pop up a new window and load your script's +document into that. There are a number of magic names that you can +use for targets. See the frame documents on Netscape's home pages for +details. =item 3. Specify the destination for the document in the <FORM> tag @@ -5591,13 +5716,8 @@ Produces something that looks like: </UL> </UL> -You can pass a value of 'true' to dump() in order to get it to -print the results out as plain text, suitable for incorporating -into a <PRE> section. - -As a shortcut, as of version 1.56 you can interpolate the entire CGI -object into a string and it will be replaced with the a nice HTML dump -shown above: +As a shortcut, you can interpolate the entire CGI object into a string +and it will be replaced with the a nice HTML dump shown above: $query=new CGI; print "<H2>Current Values</H2> $query\n"; @@ -5609,24 +5729,25 @@ through this interface. The methods are as follows: =over 4 -=item B<accept()> +=item B<Accept()> + +Return a list of MIME types that the remote browser accepts. If you +give this method a single argument corresponding to a MIME type, as in +$query->Accept('text/html'), it will return a floating point value +corresponding to the browser's preference for this type from 0.0 +(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept +list are handled correctly. -Return a list of MIME types that the remote browser -accepts. If you give this method a single argument -corresponding to a MIME type, as in -$query->accept('text/html'), it will return a -floating point value corresponding to the browser's -preference for this type from 0.0 (don't want) to 1.0. -Glob types (e.g. text/*) in the browser's accept list -are handled correctly. +Note that the capitalization changed between version 2.43 and 2.44 in +order to avoid conflict with Perl's accept() function. =item B<raw_cookie()> Returns the HTTP_COOKIE variable, an HTTP extension implemented by -Netscape browsers version 1.1 and higher. Cookies have a special -format, and this method call just returns the raw form (?cookie -dough). See cookie() for ways of setting and retrieving cooked -cookies. +Netscape browsers version 1.1 and higher, and all versions of Internet +Explorer. Cookies have a special format, and this method call just +returns the raw form (?cookie dough). See cookie() for ways of +setting and retrieving cooked cookies. Called with no parameters, raw_cookie() returns the packed cookie structure. You can separate it into individual cookies by splitting @@ -5708,10 +5829,9 @@ verification, if this script is protected. =item B<user_name ()> -Attempt to obtain the remote user's name, using a variety -of different techniques. This only works with older browsers -such as Mosaic. Netscape does not reliably report the user -name! +Attempt to obtain the remote user's name, using a variety of different +techniques. This only works with older browsers such as Mosaic. +Newer browsers do not report the user name for privacy reasons! =item B<request_method()> @@ -5935,14 +6055,17 @@ of CGI.pm without rewriting your old scripts from scratch. =head1 AUTHOR INFORMATION -Copyright 1995-1997, Lincoln D. Stein. All rights reserved. It may -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +Address bug reports and comments to: lstein@cshl.org. When sending +bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and +version of the operating system you are using. If the problem is even +remotely browser dependent, please provide information about the +affected browers as well. =head1 CREDITS @@ -5962,7 +6085,7 @@ Thanks very much to: =item Joergen Haegg (jh@axis.se) -=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu) +=item Laurent Delfosse (delfosse@delfosse.com) =item Richard Resnick (applepi1@aol.com) @@ -6054,7 +6177,7 @@ for suggestions and bug fixes. -rows=>10, -columns=>50); - print "<P>",$query->reset; + print "<P>",$query->Reset; print $query->submit('Action','Shout'); print $query->submit('Action','Scream'); print $query->endform; @@ -6095,8 +6218,8 @@ warnings when programs are run with the B<-w> switch. =head1 SEE ALSO L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>, -L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>, -L<CGI::Push>, L<CGI::Fast> +L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>, +L<CGI::Pretty> =cut diff --git a/contrib/perl5/lib/CGI/Apache.pm b/contrib/perl5/lib/CGI/Apache.pm index eed3e55..82a3669 100644 --- a/contrib/perl5/lib/CGI/Apache.pm +++ b/contrib/perl5/lib/CGI/Apache.pm @@ -78,7 +78,7 @@ CGI::Apache - Make things work with CGI.pm against Perl-Apache API =head1 DESCRIPTION When using the Perl-Apache API, your applications are faster, but the -enviroment is different than CGI. +environment is different than CGI. This module attempts to set-up that environment as best it can. =head1 NOTE 1 diff --git a/contrib/perl5/lib/CGI/Carp.pm b/contrib/perl5/lib/CGI/Carp.pm index e20f754..dfae1a6 100644 --- a/contrib/perl5/lib/CGI/Carp.pm +++ b/contrib/perl5/lib/CGI/Carp.pm @@ -14,6 +14,12 @@ B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log warn "I'm confused"; die "I'm dying.\n"; + use CGI::Carp qw(cluck); + cluck "I wouldn't do that if I were you"; + + use CGI::Carp qw(fatalsToBrowser); + die "Fatal error messages are now sent to browser"; + =head1 DESCRIPTION CGI scripts have a nasty habit of leaving warning messages in the error @@ -155,11 +161,21 @@ set_message() from within a BEGIN{} block. 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow module to run correctly under mod_perl. +1.11 Changed order of > and < escapes. + +1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. + +1.13 Added cluck() to make the module orthogonal with Carp. + More mod_perl related fixes. + =head1 AUTHORS -Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute -this under the Perl Artistic License. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. +Address bug reports and comments to: lstein@cshl.org =head1 SEE ALSO @@ -174,11 +190,11 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message); +@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck); $main::SIG{__WARN__}=\&CGI::Carp::warn; $main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.101'; +$CGI::Carp::VERSION = '1.13'; $CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. @@ -194,7 +210,6 @@ sub import { } # These are the originals -# XXX Why not just use CORE::die etc., instead of these two? GSAR sub realwarn { CORE::warn(@_); } sub realdie { CORE::die(@_); } @@ -230,8 +245,7 @@ sub warn { # eval. These evals don't count when looking at the stack backtrace. sub _longmess { my $message = Carp::longmess(); - my $mod_perl = ($ENV{'GATEWAY_INTERFACE'} - && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//); + my $mod_perl = exists $ENV{MOD_PERL}; $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; return( $message ); } @@ -240,7 +254,7 @@ sub die { my $message = shift; my $time = scalar(localtime); my($file,$line,$id) = id(1); - $message .= " at $file line $line.\n" unless $message=~/\n$/; + $message .= " at $file line $line." unless $message=~/\n$/; &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m; my $stamp = stamp; $message=~s/^/$stamp/gm; @@ -258,8 +272,9 @@ sub set_message { local $^W=0; eval <<EOF; sub confess { CGI::Carp::die Carp::longmess \@_; } -sub croak { CGI::Carp::die Carp::shortmess \@_; } -sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub croak { CGI::Carp::die Carp::shortmess \@_; } +sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub cluck { CGI::Carp::warn Carp::longmess \@_; } EOF ; } @@ -269,7 +284,7 @@ EOF sub carpout { my($in) = @_; my($no) = fileno(to_filehandle($in)); - realdie "Invalid filehandle $in\n" unless defined $no; + realdie("Invalid filehandle $in\n") unless defined $no; open(SAVEERR, ">&STDERR"); open(STDERR, ">&$no") or @@ -279,9 +294,9 @@ sub carpout { # headers sub fatalsToBrowser { my($msg) = @_; + $msg=~s/&/&/g; $msg=~s/>/>/g; $msg=~s/</</g; - $msg=~s/&/&/g; $msg=~s/\"/"/g; my($wm) = $ENV{SERVER_ADMIN} ? qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : @@ -291,7 +306,9 @@ For help, please send mail to $wm, giving this error message and the time and date of the error. END ; - print STDOUT "Content-type: text/html\n\n"; + my $mod_perl = exists $ENV{MOD_PERL}; + print STDOUT "Content-type: text/html\n\n" + unless $mod_perl; if ($CUSTOM_MSG) { if (ref($CUSTOM_MSG) eq 'CODE') { @@ -302,13 +319,30 @@ END } } - print STDOUT <<END; + my $mess = <<END; <H1>Software error:</H1> <CODE>$msg</CODE> <P> -$outer_message; +$outer_message END ; + + if ($mod_perl) { + my $r = Apache->request; + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $r->exit; + } else { + $r->status(500); + $r->custom_response(500,$mess); + } + } else { + print STDOUT $mess; + } } # Cut and paste from CGI.pm so that we don't have the overhead of diff --git a/contrib/perl5/lib/CGI/Cookie.pm b/contrib/perl5/lib/CGI/Cookie.pm index c32891a..204d67b 100644 --- a/contrib/perl5/lib/CGI/Cookie.pm +++ b/contrib/perl5/lib/CGI/Cookie.pm @@ -69,7 +69,9 @@ sub parse { my($key,$value) = split("="); my(@values) = map CGI::unescape($_),split('&',$value); $key = CGI::unescape($key); - $results{$key} = $self->new(-name=>$key,-value=>\@values); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); } return \%results unless wantarray; return %results; @@ -399,13 +401,12 @@ Get or set the cookie's expiration time. =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1997-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CGI/Fast.pm b/contrib/perl5/lib/CGI/Fast.pm index 03b5407..a39fe05 100644 --- a/contrib/perl5/lib/CGI/Fast.pm +++ b/contrib/perl5/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.00a'; +$CGI::Fast::VERSION='1.01'; use CGI; use FCGI; @@ -34,9 +34,11 @@ sub save_request { # New is slightly different in that it calls FCGI's # accept() method. sub new { - return undef unless FCGI::accept() >= 0; - my($self,@param) = @_; - return $CGI::Q = $self->SUPER::new(@param); + my ($self, $initializer, @param) = @_; + unless (defined $initializer) { + return undef unless FCGI::accept() >= 0; + } + return $CGI::Q = $self->SUPER::new($initializer, @param); } 1; @@ -154,13 +156,12 @@ I haven't tested this very much. =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1996-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CGI/Push.pm b/contrib/perl5/lib/CGI/Push.pm index eeec3f8..e4a66ae 100644 --- a/contrib/perl5/lib/CGI/Push.pm +++ b/contrib/perl5/lib/CGI/Push.pm @@ -14,8 +14,7 @@ package CGI::Push; # listing the modifications you have made. # 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/ +# http://stein.cshl.org/WWW/software/CGI/ $CGI::Push::VERSION='1.01'; use CGI; @@ -287,19 +286,14 @@ Recognition of NPH scripts happens automatically with WebSTAR and Microsoft IIS. Users of other servers should see their documentation for help. -=head1 CAVEATS - -This is a new module. It hasn't been extensively tested. - =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CPAN.pm b/contrib/perl5/lib/CPAN.pm index b510ea2..2276943 100644 --- a/contrib/perl5/lib/CPAN.pm +++ b/contrib/perl5/lib/CPAN.pm @@ -1,24 +1,25 @@ package CPAN; -use vars qw{$Try_autoload $Revision +use vars qw{$Try_autoload + $Revision $META $Signal $Cwd $End $Suppress_readline %Dontload $Frontend $Defaultsite - }; + }; #}; -$VERSION = '1.3901'; +$VERSION = '1.48'; -# $Id: CPAN.pm,v 1.226 1998/07/08 22:29:29 k Exp k $ +# $Id: CPAN.pm,v 1.260 1999/03/06 19:31:02 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.226 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.260 $, 10)."]"; use Carp (); use Config (); use Cwd (); use DirHandle; use Exporter (); -use ExtUtils::MakeMaker (); +use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1; use File::Basename (); use File::Copy (); use File::Find; @@ -27,10 +28,11 @@ use FileHandle (); use Safe (); use Text::ParseWords (); use Text::Wrap; +use File::Spec; END { $End++; &cleanup; } -%CPAN::DEBUG = qw( +%CPAN::DEBUG = qw[ CPAN 1 Index 2 InfoObj 4 @@ -45,7 +47,7 @@ END { $End++; &cleanup; } Eval 2048 Config 4096 Tarzip 8192 - ); +]; $CPAN::DEBUG ||= 0; $CPAN::Signal ||= 0; @@ -56,13 +58,7 @@ package CPAN; use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); -@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away - # soonish. Already version - # 1.29 doesn't rely on - # catfile and catdir being - # available via - # inheritance. Anything else - # in danger? +@CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( autobundle bundle expand force get @@ -75,6 +71,7 @@ sub AUTOLOAD { $l =~ s/.*:://; my(%EXPORT); @EXPORT{@EXPORT} = ''; + CPAN::Config->load unless $CPAN::Config_loaded++; if (exists $EXPORT{$l}){ CPAN::Shell->$l(@_); } else { @@ -92,7 +89,9 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { + my($self) = @_; $Suppress_readline ||= ! -t STDIN; + CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; local($^W) = 1; @@ -100,8 +99,20 @@ sub shell { require Term::ReadLine; # import Term::ReadLine; $term = Term::ReadLine->new('CPAN Monitor'); - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::cpl'; + if ($term->ReadLine eq "Term::ReadLine::Gnu") { + my $attribs = $term->Attribs; +# $attribs->{completion_entry_function} = +# $attribs->{'list_completion_function'}; + $attribs->{attempted_completion_function} = sub { + &CPAN::Complete::gnu_cpl; + } +# $attribs->{completion_word} = +# [qw(help me somebody to find out how +# to use completion with GNU)]; + } else { + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } } no strict; @@ -109,6 +120,7 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); + my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -131,7 +143,7 @@ ReadLine support $rl_avail $_ = "$continuation$_" if $continuation; s/^\s+//; next if /^$/; - $_ = 'h' if $_ eq '?'; + $_ = 'h' if /^\s*\?/; if (/^(?:q(?:uit)?|bye|exit)$/i) { last; } elsif (s/\\$//s) { @@ -168,6 +180,20 @@ ReadLine support $rl_avail } } continue { $Signal=0; + CPAN::Queue->nullify_queue; + if ($try_detect_readline) { + if ($CPAN::META->has_inst("Term::ReadLine::Gnu") + || + $CPAN::META->has_inst("Term::ReadLine::Perl") + ) { + delete $INC{"Term/ReadLine.pm"}; + my $redef; + local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); + require Term::ReadLine; + $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); + goto &shell; + } + } } } @@ -230,7 +256,7 @@ sub AUTOLOAD { $CPAN::Frontend->mywarn(qq{ Commands starting with "w" require CPAN::WAIT to be installed. Please consider installing CPAN::WAIT to use the fulltext index. -For this you just need to type +For this you just need to type install CPAN::WAIT }); } @@ -260,7 +286,7 @@ sub try_dot_al { if (defined($name=$INC{"$pkg.pm"})) { $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; - $name = undef unless (-r $name); + $name = undef unless (-r $name); } unless (defined $name) { @@ -275,7 +301,7 @@ sub try_dot_al { *$autoload = sub {}; $ok = 1; } else { - if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){ eval {local $SIG{__DIE__};require $name}; } if ($@){ @@ -286,7 +312,9 @@ sub try_dot_al { } } } else { - $ok = 1; + + $ok = 1; + } $@ = $save; # my $lm = Carp::longmess(); @@ -303,7 +331,7 @@ sub try_dot_al { # $Try_autoload = 1; if ($CPAN::Try_autoload) { - my $p; + my $p; for $p (qw( CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP @@ -318,21 +346,127 @@ use vars qw($AUTOLOAD @ISA); @CPAN::Tarzip::ISA = qw(CPAN::Debug); package CPAN::Queue; -# currently only used to determine if we should or shouldn't announce -# the availability of a new CPAN module + +# One use of the queue is to determine if we should or shouldn't +# announce the availability of a new CPAN module + +# Now we try to use it for dependency tracking. For that to happen +# we need to draw a dependency tree and do the leaves first. This can +# easily be reached by running CPAN.pm recursively, but we don't want +# to waste memory and run into deep recursion. So what we can do is +# this: + +# CPAN::Queue is the package where the queue is maintained. Dependencies +# often have high priority and must be brought to the head of the queue, +# possibly by jumping the queue if they are already there. My first code +# attempt tried to be extremely correct. Whenever a module needed +# immediate treatment, I either unshifted it to the front of the queue, +# or, if it was already in the queue, I spliced and let it bypass the +# others. This became a too correct model that made it impossible to put +# an item more than once into the queue. Why would you need that? Well, +# you need temporary duplicates as the manager of the queue is a loop +# that +# +# (1) looks at the first item in the queue without shifting it off +# +# (2) cares for the item +# +# (3) removes the item from the queue, *even if its agenda failed and +# even if the item isn't the first in the queue anymore* (that way +# protecting against never ending queues) +# +# So if an item has prerequisites, the installation fails now, but we +# want to retry later. That's easy if we have it twice in the queue. +# +# I also expect insane dependency situations where an item gets more +# than two lives in the queue. Simplest example is triggered by 'install +# Foo Foo Foo'. People make this kind of mistakes and I don't want to +# get in the way. I wanted the queue manager to be a dumb servant, not +# one that knows everything. +# +# Who would I tell in this model that the user wants to be asked before +# processing? I can't attach that information to the module object, +# because not modules are installed but distributions. So I'd have to +# tell the distribution object that it should ask the user before +# processing. Where would the question be triggered then? Most probably +# in CPAN::Distribution::rematein. +# Hope that makes sense, my head is a bit off:-) -- AK + +use vars qw{ @All }; + sub new { my($class,$mod) = @_; - # warn "Queue object for mod[$mod]"; - bless {mod => $mod}, $class; + my $self = bless {mod => $mod}, $class; + push @All, $self; + # my @all = map { $_->{mod} } @All; + # warn "Adding Queue object for mod[$mod] all[@all]"; + return $self; } -package CPAN; +sub first { + my $obj = $All[0]; + $obj->{mod}; +} + +sub delete_first { + my($class,$what) = @_; + my $i; + for my $i (0..$#All) { + if ( $All[$i]->{mod} eq $what ) { + splice @All, $i, 1; + return; + } + } +} + +sub jumpqueue { + my $class = shift; + my @what = @_; + my $obj; + WHAT: for my $what (reverse @what) { + my $jumped = 0; + for (my $i=0; $i<$#All;$i++) { #prevent deep recursion + if ($All[$i]->{mod} eq $what){ + $jumped++; + if ($jumped > 100) { # one's OK if e.g. just processing now; + # more are OK if user typed it several + # times + $CPAN::Frontend->mywarn( +qq{Object [$what] queued more than 100 times, ignoring} + ); + next WHAT; + } + } + } + my $obj = bless { mod => $what }, $class; + unshift @All, $obj; + } +} + +sub exists { + my($self,$what) = @_; + my @all = map { $_->{mod} } @All; + my $exists = grep { $_->{mod} eq $what } @All; + # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]"; + $exists; +} + +sub delete { + my($self,$mod) = @_; + @All = grep { $_->{mod} ne $mod } @All; + # my @all = map { $_->{mod} } @All; + # warn "Deleting Queue object for mod[$mod] all[@all]"; +} -$META ||= CPAN->new; # In case we reeval ourselves we - # need a || +sub nullify_queue { + @All = (); +} + + + +package CPAN; -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +$META ||= CPAN->new; # In case we re-eval ourselves we need the || 1; @@ -356,12 +490,14 @@ sub clean; sub test; #-> sub CPAN::all ; -sub all { +sub all_objects { my($mgr,$class) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; CPAN::Index->reload; values %{ $META->{$class} }; } +*all = \&all_objects; # Called by shell, not in batch mode. Not clean XXX #-> sub CPAN::checklock ; @@ -434,8 +570,8 @@ or $self->{LOCK} = $lockfile; $fh->close; $SIG{'TERM'} = sub { - &cleanup; - $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); }; $SIG{'INT'} = sub { # no blocks!!! @@ -491,13 +627,18 @@ sub has_inst { $file =~ s|/|\\|g if $^O eq 'MSWin32'; $file .= ".pm"; if ($INC{$file}) { -# warn "$file in %INC"; #debug + # checking %INC is wrong, because $INC{LWP} may be true + # although $INC{"URI/URL.pm"} may have failed. But as + # I really want to say "bla loaded OK", I have to somehow + # cache results. + ### warn "$file in %INC"; #debug return 1; } elsif (eval { require $file }) { # eval is good: if we haven't yet read the database it's # perfect and if we have installed the module in the meantime, # it tries again. The second require is only a NOOP returning # 1 if we had success, otherwise it's retrying + $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); if ($mod eq "CPAN::WAIT") { push @CPAN::Shell::ISA, CPAN::WAIT; @@ -518,6 +659,8 @@ sub has_inst { }); sleep 2; + } else { + delete $INC{$file}; # if it inc'd LWP but failed during, say, URI } return 0; } @@ -537,16 +680,30 @@ sub new { #-> sub CPAN::cleanup ; sub cleanup { - local $SIG{__DIE__} = ''; - my $i = 0; my $ineval = 0; my $sub; - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; + # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]"; + local $SIG{__DIE__} = ''; + my($message) = @_; + my $i = 0; + my $ineval = 0; + if ( + 0 && # disabled, try reload cpan with it + $] > 5.004_60 # thereabouts + ) { + $ineval = $^S; + } else { + my($subroutine); + while ((undef,undef,undef,$subroutine) = caller(++$i)) { + $ineval = 1, last if + $subroutine eq '(eval)'; } - return if $ineval && !$End; - return unless defined $META->{'LOCK'}; - return unless -f $META->{'LOCK'}; - unlink $META->{'LOCK'}; - $CPAN::Frontend->mywarn("Lockfile removed.\n"); + } + return if $ineval && !$End; + return unless defined $META->{'LOCK'}; + return unless -f $META->{'LOCK'}; + unlink $META->{'LOCK'}; + # require Carp; + # Carp::cluck("DEBUGGING"); + $CPAN::Frontend->mywarn("Lockfile removed.\n"); } package CPAN::CacheMgr; @@ -597,7 +754,8 @@ sub entries { $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my($cwd) = CPAN->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); for ($dh->read) { next if $_ eq "." || $_ eq ".."; @@ -621,9 +779,15 @@ sub disk_usage { my($Du) = 0; find( sub { - $File::Find::prune++ if $CPAN::Signal; - return if -l $_; - $Du += -s _; + $File::Find::prune++ if $CPAN::Signal; + return if -l $_; + if ($^O eq 'MacOS') { + require Mac::Files; + my $cat = Mac::Files::FSpGetCatInfo($_); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + } else { + $Du += (-s _); + } }, $dir ); @@ -655,26 +819,36 @@ sub new { my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, + SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', DU => 0 }; File::Path::mkpath($self->{ID}); my $dh = DirHandle->new($self->{ID}); bless $self, $class; - my $e; + $self->scan_cache; + $t2 = time; + $debug .= "timing of CacheMgr->new: ".($t2 - $time); + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; + $self; +} + +#-> sub CPAN::CacheMgr::scan_cache ; +sub scan_cache { + my $self = shift; + return if $self->{SCAN} eq 'never'; + $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") + unless $self->{SCAN} eq 'atstart'; $CPAN::Frontend->myprint( sprintf("Scanning cache %s for sizes\n", $self->{ID})); + my $e; for $e ($self->entries($self->{ID})) { next if $e eq ".." || $e eq "."; $self->disk_usage($e); return if $CPAN::Signal; } $self->tidyup; - $t2 = time; - $debug .= "timing of CacheMgr->new: ".($t2 - $time); - $time = $t2; - CPAN->debug($debug) if $CPAN::DEBUG; - $self; } package CPAN::Debug; @@ -755,7 +929,7 @@ sub commit { unless (defined $configpm){ $configpm ||= $INC{"CPAN/MyConfig.pm"}; $configpm ||= $INC{"CPAN/Config.pm"}; - $configpm || Carp::confess(qq{ + $configpm || Carp::confess(q{ CPAN::Config::commit called without an argument. Please specify a filename where to save the configuration or try "o conf init" to have an interactive course through configing. @@ -779,6 +953,7 @@ Please specify a filename where to save the configuration or try EOF $msg ||= "\n"; my($fh) = FileHandle->new; + rename $configpm, "$configpm~" if -f $configpm; open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { @@ -823,6 +998,7 @@ sub init { sub load { my($self) = shift; my(@miss); + use Carp; eval {require CPAN::Config;}; # We eval because of some # MakeMaker problems unless ($dot_cpan++){ @@ -887,11 +1063,11 @@ sub load { } } local($") = ", "; - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled; We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -}) if $redo && ! $theycalled; +END $CPAN::Frontend->myprint(qq{ $configpm initialized. }); @@ -903,9 +1079,10 @@ $configpm initialized. sub not_loaded { my(@miss); for (qw( - cpan_home keep_source_where build_dir build_cache index_expire - gzip tar unzip make pager makepl_arg make_arg make_install_arg - urllist inhibit_startup_message ftp_proxy http_proxy no_proxy + cpan_home keep_source_where build_dir build_cache scan_cache + index_expire gzip tar unzip make pager makepl_arg make_arg + make_install_arg urllist inhibit_startup_message + ftp_proxy http_proxy no_proxy prerequisites_policy )) { push @miss, $_ unless defined $CPAN::Config->{$_}; } @@ -918,10 +1095,9 @@ sub unload { delete $INC{'CPAN/Config.pm'}; } -*h = \&help; #-> sub CPAN::Config::help ; sub help { - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(q[ Known options: defaults reload default config values from disk commit commit session changes to disk @@ -937,7 +1113,7 @@ You may edit key values in the follow fashion: o conf urllist unshift ftp://ftp.foo.bar/ -}); +]); undef; #don't reprint CPAN::Config } @@ -1024,7 +1200,9 @@ sub b { #-> sub CPAN::Shell::d ; sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; -sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} +sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here + $CPAN::Frontend->myprint(shift->format_result('Module',@_)); +} #-> sub CPAN::Shell::i ; sub i { @@ -1139,6 +1317,21 @@ Known options: } } +sub dotdot_onreload { + my($ref) = shift; + sub { + if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { + my($subr) = $1; + ++$$ref; + local($|) = 1; + # $CPAN::Frontend->myprint(".($subr)"); + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; +} + #-> sub CPAN::Shell::reload ; sub reload { my($self,$command,@arg) = @_; @@ -1148,27 +1341,16 @@ sub reload { CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; my $fh = FileHandle->new($INC{'CPAN.pm'}); local($/); - undef $/; $redef = 0; - local($SIG{__WARN__}) - = sub { - if ( $_[0] =~ /Subroutine \w+ redefined/ ) { - ++$redef; - local($|) = 1; - $CPAN::Frontend->myprint("."); - return; - } - warn @_; - }; + local($SIG{__WARN__}) = dotdot_onreload(\$redef); eval <$fh>; warn $@ if $@; $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); } elsif ($command =~ /index/) { - CPAN::Index->force_reload; + CPAN::Index->force_reload; } else { - $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file -index re-reads the index files -}); + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files\n}); } } @@ -1323,6 +1505,7 @@ sub u { #-> sub CPAN::Shell::autobundle ; sub autobundle { my($self) = shift; + CPAN::Config->load unless $CPAN::Config_loaded++; my(@bundle) = $self->_u_r_common("a",@_); my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); @@ -1379,7 +1562,7 @@ sub expand { my $class = "CPAN::$type"; my $obj; if (defined $regex) { - for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { + for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { push @m, $obj if $obj->id =~ /$regex/i @@ -1500,22 +1683,23 @@ sub rematein { CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { + CPAN::Queue->new($s); + } + while ($s = CPAN::Queue->first) { my $obj; if (ref $s) { $obj = $s; } elsif ($s =~ m|/|) { # looks like a file $obj = $CPAN::META->instance('CPAN::Distribution',$s); } elsif ($s =~ m|^Bundle::|) { - $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s); $obj = $CPAN::META->instance('CPAN::Bundle',$s); } else { - $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s); $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s); } if (ref $obj) { CPAN->debug( - qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}. + qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. $obj->as_string. qq{\]} ) if $CPAN::DEBUG; @@ -1530,7 +1714,9 @@ sub rematein { if ($]>=5.00303 && $obj->can('called_for')) { $obj->called_for($s); } - $obj->$meth(); + CPAN::Queue->delete($s) if $obj->$meth(); # if it is more + # than once in + # the queue } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); $CPAN::Frontend->myprint( @@ -1540,7 +1726,9 @@ sub rematein { " ;-)\n" ); } else { - $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. + $CPAN::Frontend + ->myprint(qq{Warning: Cannot $meth $s, }. + qq{don\'t know what it is. Try the command i /$s/ @@ -1548,6 +1736,7 @@ Try the command to find objects with similar identifiers. }); } + CPAN::Queue->delete_first($s); } } @@ -1572,35 +1761,35 @@ package CPAN::FTP; #-> sub CPAN::FTP::ftp_get ; sub ftp_get { - my($class,$host,$dir,$file,$target) = @_; - $class->debug( - qq[Going to fetch file [$file] from dir [$dir] + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] on host [$host] as local [$target]\n] ) if $CPAN::DEBUG; - my $ftp = Net::FTP->new($host); - return 0 unless defined $ftp; - $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; - $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); - unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ - warn "Couldn't login on $host"; - return; - } - unless ( $ftp->cwd($dir) ){ - warn "Couldn't cwd $dir"; - return; - } - $ftp->binary; - $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; - unless ( $ftp->get($file,$target) ){ - warn "Couldn't fetch $file from $host\n"; - return; - } - $ftp->quit; # it's ok if this fails - return 1; + my $ftp = Net::FTP->new($host); + return 0 unless defined $ftp; + $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; + $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ + warn "Couldn't login on $host"; + return; + } + unless ( $ftp->cwd($dir) ){ + warn "Couldn't cwd $dir"; + return; + } + $ftp->binary; + $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; + unless ( $ftp->get($file,$target) ){ + warn "Couldn't fetch $file from $host\n"; + return; + } + $ftp->quit; # it's ok if this fails + return 1; } # If more accuracy is wanted/needed, Chris Leach sent me this patch... - + # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997 # leach,> *************** @@ -1664,6 +1853,20 @@ sub localize { $self->debug("file[$file] aslocal[$aslocal] force[$force]") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + my($name, $path) = File::Basename::fileparse($aslocal, ''); + if (length($name) > 31) { + $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//; + my $suf = $1; + my $size = 31 - length($suf); + while (length($name) > $size) { + chop $name; + } + $name .= $suf; + $aslocal = File::Spec->catfile($path, $name); + } + } + return $aslocal if -f $aslocal && -r _ && !($force & 1); my($restore) = 0; if (-f $aslocal){ @@ -1679,7 +1882,7 @@ sub localize { to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP::UserAgent')) { require LWP::UserAgent; unless ($Ua) { $Ua = LWP::UserAgent->new; @@ -1704,7 +1907,7 @@ sub localize { @reordered = sort { (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") - <=> + <=> (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") or defined($Thesite) @@ -1713,11 +1916,6 @@ sub localize { <=> ($a == $Thesite) } 0..$last; - -# ((grep { substr($CPAN::Config->{urllist}[$_],0,4) -# eq "file" } 0..$last), -# (grep { substr($CPAN::Config->{urllist}[$_],0,4) -# ne "file" } 0..$last)); } my($level,@levels); if ($Themethod) { @@ -1725,6 +1923,7 @@ sub localize { } else { @levels = qw/easy hard hardest/; } + @levels = qw/easy/ if $^O eq 'MacOS'; for $level (@levels) { my $method = "host$level"; my @host_seq = $level eq "easy" ? @@ -1732,9 +1931,11 @@ sub localize { @host_seq = (0) unless @host_seq; my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { - $Themethod = $level; - $self->debug("level[$level]") if $CPAN::DEBUG; - return $ret; + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } else { + unlink $aslocal; } } my(@mess); @@ -1780,8 +1981,11 @@ sub hosteasy { # fileurl = "file://" [ host | "localhost" ] "/" fpath # Thanks to "Mark D. Baushke" <mdb@cisco.com> for # the code - ($l = $url) =~ s,^file://[^/]+,,; # discard the host part - $l =~ s/^file://; # assume they meant file://localhost + ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part + $l =~ s|^file:||; # assume they + # meant + # file://localhost + $l =~ s|^/|| unless -f $l; # e.g. /P: } if ( -f $l && -r _) { $Thesite = $i; @@ -1797,10 +2001,14 @@ sub hosteasy { } } } - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP')) { $CPAN::Frontend->myprint("Fetching with LWP: $url "); + unless ($Ua) { + require LWP::UserAgent; + $Ua = LWP::UserAgent->new; + } my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { $Thesite = $i; @@ -1847,7 +2055,7 @@ sub hosteasy { $CPAN::Frontend->myprint("Fetching with Net::FTP $url.gz "); - if (CPAN::FTP->ftp_get($host, + if (CPAN::FTP->ftp_get($host, $dir, "$getfile.gz", $gz) && @@ -1864,15 +2072,17 @@ sub hosteasy { } sub hosthard { - my($self,$host_seq,$file,$aslocal) = @_; + my($self,$host_seq,$file,$aslocal) = @_; - # Came back if Net::FTP couldn't establish connection (or - # failed otherwise) Maybe they are behind a firewall, but they - # gave us a socksified (or other) ftp program... + # Came back if Net::FTP couldn't establish connection (or + # failed otherwise) Maybe they are behind a firewall, but they + # gave us a socksified (or other) ftp program... - my($i); - my($aslocal_dir) = File::Basename::dirname($aslocal); - File::Path::mkpath($aslocal_dir); + my($i); + my($devnull) = $CPAN::Config->{devnull} || ""; + # < /dev/null "; + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { @@ -1894,7 +2104,7 @@ sub hosthard { } $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); - for $f ('lynx','ncftp') { + for $f ('lynx','ncftpget','ncftp') { next unless exists $CPAN::Config->{$f}; $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; @@ -1903,14 +2113,14 @@ sub hosthard { my $aslocal_uncompressed; ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; my($source_switch) = ""; - $source_switch = "-source" if $funkyftp =~ /\blynx$/; - $source_switch = "-c" if $funkyftp =~ /\bncftp$/; + $source_switch = " -source" if $funkyftp =~ /\blynx$/; + $source_switch = " -c" if $funkyftp =~ /\bncftp$/; $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + qq[ +Trying with "$funkyftp$source_switch" to get $url -}); - my($system) = "$funkyftp $source_switch '$url' > ". +]); + my($system) = "$funkyftp$source_switch '$url' $devnull > ". "$aslocal_uncompressed"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); @@ -1929,36 +2139,40 @@ Trying with "$funkyftp $source_switch" to get CPAN::Tarzip->gzip($aslocal_uncompressed, "$aslocal_uncompressed.gz"); } - $Thesite = $i; - return $aslocal; } + $Thesite = $i; + return $aslocal; } elsif ($url !~ /\.gz$/) { - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get $url.gz -}); - my($system) = "$funkyftp $source_switch '$url.gz' > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); - } else { - rename $aslocal_uncompressed, $aslocal; - } -#line 1739 - $Thesite = $i; - return $aslocal; +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s "$aslocal_uncompressed.gz" + ) { + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); + } else { + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; + } else { + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } } else { my $estatus = $wstatus >> 8; my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; @@ -2047,7 +2261,7 @@ sub hosthardest { $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host nor does it have a default entry\n"); } - + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' # then and login manually to host, using e-mail as # password. @@ -2085,7 +2299,6 @@ sub talk_ftp { Subprocess "|$command" returned status $estatus (wstat $wstatus) }) if $wstatus; - } # find2perl needs modularization, too, all the following is stolen @@ -2212,6 +2425,27 @@ sub contains { package CPAN::Complete; +sub gnu_cpl { + my($text, $line, $start, $end) = @_; + my(@perlret) = cpl($text, $line, $start); + # find longest common match. Can anybody show me how to peruse + # T::R::Gnu to have this done automatically? Seems expensive. + return () unless @perlret; + my($newtext) = $text; + for (my $i = length($text)+1;;$i++) { + last unless length($perlret[0]) && length($perlret[0]) >= $i; + my $try = substr($perlret[0],0,$i); + my @tries = grep {substr($_,0,$i) eq $try} @perlret; + # warn "try[$try]tries[@tries]"; + if (@tries == @perlret) { + $newtext = $try; + } else { + last; + } + } + ($newtext,@perlret); +} + #-> sub CPAN::Complete::cpl ; sub cpl { my($word,$line,$pos) = @_; @@ -2257,7 +2491,7 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } #-> sub CPAN::Complete::cpl_any ; @@ -2327,26 +2561,35 @@ sub reload { my $needshort = $^O eq "dos"; - $cl->rd_authindex($cl->reload_x( - "authors/01mailrc.txt.gz", - $needshort ? "01mailrc.gz" : "", - $force)); + $cl->rd_authindex($cl + ->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? + File::Spec->catfile('authors', '01mailrc.gz') : + File::Spec->catfile('authors', '01mailrc.txt.gz'), + $force)); $t2 = time; $debug = "timing reading 01[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modpacks($cl->reload_x( - "modules/02packages.details.txt.gz", - $needshort ? "02packag.gz" : "", - $force)); + $cl->rd_modpacks($cl + ->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? + File::Spec->catfile('modules', '02packag.gz') : + File::Spec->catfile('modules', '02packages.details.txt.gz'), + $force)); $t2 = time; $debug .= "02[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modlist($cl->reload_x( - "modules/03modlist.data.gz", - $needshort ? "03mlist.gz" : "", - $force)); + $cl->rd_modlist($cl + ->reload_x( + "modules/03modlist.data.gz", + $needshort ? + File::Spec->catfile('modules', '03mlist.gz') : + File::Spec->catfile('modules', '03modlist.data.gz'), + $force)); $t2 = time; $debug .= "03[".($t2 - $time)."]"; $time = $t2; @@ -2379,7 +2622,8 @@ sub reload_x { #-> sub CPAN::Index::rd_authindex ; sub rd_authindex { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); # my $fh = CPAN::Tarzip->TIEHANDLE($index_target); @@ -2388,10 +2632,10 @@ sub rd_authindex { local(*FH); tie *FH, CPAN::Tarzip, $index_target; local($/) = "\n"; - while (<FH>) { - chomp; + push @lines, split /\012/ while <FH>; + foreach (@lines) { my($userid,$fullname,$email) = - /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/; next unless $userid && $fullname && $email; # instantiate an author object @@ -2410,26 +2654,34 @@ sub userid { #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local($/) = "\n"; while ($_ = $fh->READLINE) { - last if /^\s*$/; + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @lines, @ls; } - while ($_ = $fh->READLINE) { + while (@lines) { + my $shift = shift(@lines); + last if $shift =~ /^\s*$/; + } + foreach (@lines) { chomp; my($mod,$version,$dist) = split; ### $version =~ s/^\+//; # if it is a bundle, instatiate a bundle object my($bundle,$id,$userid); - + if ($mod eq 'CPAN' && ! ( - $CPAN::META->exists('CPAN::Queue','Bundle::CPAN') || - $CPAN::META->exists('CPAN::Queue','CPAN') + CPAN::Queue->exists('Bundle::CPAN') || + CPAN::Queue->exists('CPAN') ) ) { local($^W)= 0; @@ -2452,9 +2704,11 @@ sub rd_modpacks { if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); + # warn "made mod[$mod]a bundle"; # Let's make it a module too, because bundles have so much # in common with modules $CPAN::META->instance('CPAN::Module',$mod); + # warn "made mod[$mod]a module"; # This "next" makes us faster but if the job is running long, we ignore # rereads which is bad. So we have to be a bit slower again. @@ -2499,13 +2753,19 @@ sub rd_modlist { my @eval; local($/) = "\n"; while ($_ = $fh->READLINE) { - if (/^Date:\s+(.*)/){ + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @eval, @ls; + } + while (@eval) { + my $shift = shift(@eval); + if ($shift =~ /^Date:\s+(.*)/){ return if $date_of_03 eq $1; ($date_of_03) = $1; } - last if /^\s*$/; + last if $shift =~ /^\s*$/; } - push @eval, $_ while $_ = $fh->READLINE; undef $fh; push @eval, q{CPAN::Modulelist->data;}; local($^W) = 0; @@ -2604,6 +2864,7 @@ sub as_glimpse { #-> sub CPAN::Author::fullname ; sub fullname { shift->{'FULLNAME'} } *name = \&fullname; + #-> sub CPAN::Author::email ; sub email { shift->{'EMAIL'} } @@ -2667,11 +2928,12 @@ sub get { } else { $self->{archived} = "NO"; } - chdir ".."; + chdir File::Spec->updir; if ($self->{archived} ne 'NO') { - chdir "tmp"; + chdir File::Spec->catdir(File::Spec->curdir, "tmp"); # Let's check if the package has its own directory. - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? $dh->close; my ($distdir,$packagedir); @@ -2694,7 +2956,7 @@ sub get { } } $self->{'build_dir'} = $packagedir; - chdir ".."; + chdir File::Spec->updir; $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; @@ -2783,6 +3045,12 @@ sub new { #-> sub CPAN::Distribution::look ; sub look { my($self) = @_; + + if ($^O eq 'MacOS') { + $self->ExtUtils::MM_MacOS::look; + return; + } + if ( $CPAN::Config->{'shell'} ) { $CPAN::Frontend->myprint(qq{ Trying to open a subshell in the build directory... @@ -2825,6 +3093,12 @@ sub readme { $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted) or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::launch_file($local_file); + return; + } + my $fh_pager = FileHandle->new; local($SIG{PIPE}) = "IGNORE"; $fh_pager->open("|$CPAN::Config->{'pager'}") @@ -2891,6 +3165,7 @@ sub MD5_check_file { if (open $fh, $chk_file){ local($/); my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); @@ -2978,16 +3253,14 @@ sub eq_MD5 { #-> sub CPAN::Distribution::force ; sub force { - my($self) = @_; - $self->{'force_update'}++; - delete $self->{'MD5_STATUS'}; - delete $self->{'archived'}; - delete $self->{'build_dir'}; - delete $self->{'localfile'}; - delete $self->{'make'}; - delete $self->{'install'}; - delete $self->{'unwrapped'}; - delete $self->{'writemakefile'}; + my($self) = @_; + $self->{'force_update'}++; + for my $att (qw( + MD5_STATUS archived build_dir localfile make install unwrapped + writemakefile have_sponsored + )) { + delete $self->{$att}; + } } sub isa_perl { @@ -3078,6 +3351,11 @@ or chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make($self); + return; + } + my $system; if ($self->{'configure'}) { $system = $self->{'configure'}; @@ -3097,10 +3375,11 @@ or if ($CPAN::Config->{inactivity_timeout}) { eval { alarm $CPAN::Config->{inactivity_timeout}; - local $SIG{CHLD} = sub { wait }; + local $SIG{CHLD}; # = sub { wait }; if (defined($pid = fork)) { if ($pid) { #parent - wait; + # wait; + waitpid $pid, 0; } else { #child # note, this exec isn't necessary if # inactivity_timeout is 0. On the Mac I'd @@ -3122,37 +3401,41 @@ or return; } } else { - if (0) { - warn "Trying to intercept the output of 'perl Makefile.PL'"; - require IO::File; - # my $fh = FileHandle->new("$system 2>&1 |") or - my $fh = IO::File->new("$system 2>&1 |") or - die "Couldn't run '$system': $!"; - local($|) = 1; - while (length($_ = getc($fh))) { - print $_; # we want to parse that some day! - # unfortunately we have Makefile.PLs that want to talk - # and we can't emulate that reliably. I think, we have - # to parse Makefile.PL directly - } - $ret = $fh->close; - unless ($ret) { - warn $! ? "Error during 'perl Makefile.PL' subprocess: $!" : - "Exit status of 'perl Makefile.PL': $?"; - $self->{writemakefile} = "NO"; - return; - } - } else { - $ret = system($system); - if ($ret != 0) { - $self->{writemakefile} = "NO"; - return; - } + $ret = system($system); + if ($ret != 0) { + $self->{writemakefile} = "NO"; + return; } } $self->{writemakefile} = "YES"; } return if $CPAN::Signal; + if (my @prereq = $self->needs_prereq){ + my $id = $self->id; + $CPAN::Frontend->myprint("---- Dependencies detected ". + "during [$id] -----\n"); + + for my $p (@prereq) { + $CPAN::Frontend->myprint(" $p\n"); + } + my $follow = 0; + if ($CPAN::Config->{prerequisites_policy} eq "follow") { + $follow = 1; + } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { + require ExtUtils::MakeMaker; + my $answer = ExtUtils::MakeMaker::prompt( +"Shall I follow them and prepend them to the queue +of modules we are processing right now?", "yes"); + $follow = $answer =~ /^\s*y/i; + } else { + local($") = ", "; + $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n"); + } + if ($follow) { + CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself + return; + } + } $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3164,6 +3447,44 @@ or } } +#-> sub CPAN::Distribution::needs_prereq ; +sub needs_prereq { + my($self) = @_; + return unless -f "Makefile"; # we cannot say much + my $fh = FileHandle->new("<Makefile") or + $CPAN::Frontend->mydie("Couldn't open Makefile: $!"); + local($/) = "\n"; + + my(@p,@need); + while (<$fh>) { + last if /MakeMaker post_initialize section/; + my($p) = m{^[\#] + \s+PREREQ_PM\s+=>\s+(.+) + }x; + next unless $p; + # warn "Found prereq expr[$p]"; + + while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){ + push @p, $1; + } + last; + } + for my $p (@p) { + my $mo = $CPAN::META->instance("CPAN::Module",$p); + next if $mo->uptodate; + # it's not needed, so don't push it. We cannot omit this step, because + # if 'force' is in effect, nobody else will check. + if ($self->{'have_sponsored'}{$p}++){ + # We have already sponsored it and for some reason it's still + # not available. So we do nothing. Or what should we do? + # if we push it again, we have a potential infinite loop + next; + } + push @need, $p; + } + return @need; +} + #-> sub CPAN::Distribution::test ; sub test { my($self) = @_; @@ -3186,6 +3507,12 @@ sub test { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_test($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "test"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3208,6 +3535,12 @@ sub clean { chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_clean($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "clean"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3250,9 +3583,16 @@ sub install { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_install($self); + return; + } + my $system = join(" ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}); - my($pipe) = FileHandle->new("$system 2>&1 |"); + my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 "; + my($pipe) = FileHandle->new("$system $stderr |"); my($makeout) = ""; while (<$pipe>){ $CPAN::Frontend->myprint($_); @@ -3261,7 +3601,7 @@ sub install { $pipe->close; if ($?==0) { $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{'install'} = "YES"; + return $self->{'install'} = "YES"; } else { $self->{'install'} = "NO"; $CPAN::Frontend->myprint(" $system -- NOT OK\n"); @@ -3289,58 +3629,67 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file; - my($id) = $self->id; - $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; - unless ($parsefile) { - # Try to get at it in the cpan directory - $self->debug("no parsefile") if $CPAN::DEBUG; - Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->{CPAN_FILE}); - $dist->get; - $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = MM->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},$me); - $to = MM->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $parsefile = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; - $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : - /^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = join ", ", @result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - @result; + my($self) = @_; + my($parsefile) = $self->inst_file; + my($id) = $self->id; + $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; + unless ($parsefile) { + # Try to get at it in the cpan directory + $self->debug("no parsefile") if $CPAN::DEBUG; + Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->{CPAN_FILE}); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $parsefile = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; + while (<$fh>) { + $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = join ", ", @result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + unless (@result) { + $CPAN::Frontend->mywarn(qq{ +The bundle file "$parsefile" may be a broken +bundlefile. It seems not to contain any bundle definition. +Please check the file and if it is bogus, please delete it. +Sorry for the inconvenience. +}); + } + @result; } #-> sub CPAN::Bundle::find_bundle_file sub find_bundle_file { my($self,$where,$what) = @_; $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; - my $bu = MM->catfile($where,$what); - return $bu if -f $bu; +### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( +### my $bu = MM->catfile($where,$what); +### return $bu if -f $bu; my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; @@ -3353,20 +3702,30 @@ sub find_bundle_file { my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!"); local($/) = "\n"; + my $what2 = $what; + if ($^O eq 'MacOS') { + $what =~ s/^://; + $what2 =~ tr|:|/|; + $what2 =~ s/:Bundle://; + $what2 =~ tr|:|/|; + } else { + $what2 =~ s|Bundle/||; + } + my $bu; while (<$fh>) { next if /^\s*\#/; my($file) = /(\S+)/; if ($file =~ m|\Q$what\E$|) { $bu = $file; - return MM->catfile($where,$bu); - } elsif ($what =~ s|Bundle/||) { # retry if she managed to - # have no Bundle directory - if ($file =~ m|\Q$what\E$|) { - $bu = $file; - return MM->catfile($where,$bu); - } + # return MM->catfile($where,$bu); # bad + last; } + # retry if she managed to + # have no Bundle directory + $bu = $file if $file =~ m|\Q$what2\E$|; } + $bu =~ tr|/|:| if $^O eq 'MacOS'; + return MM->catfile($where, $bu) if $bu; Carp::croak("Couldn't find a Bundle file in $where"); } @@ -3395,7 +3754,7 @@ sub rematein { my($id) = $self->id; Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" unless $self->inst_file || $self->{CPAN_FILE}; - my($s); + my($s,%fail); for $s ($self->contains) { my($type) = $s =~ m|/| ? 'CPAN::Distribution' : $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; @@ -3406,7 +3765,26 @@ explicitly a file $s. }); sleep 3; } - $CPAN::META->instance($type,$s)->$meth(); + # possibly noisy action: + my $obj = $CPAN::META->instance($type,$s); + $obj->$meth(); + my $success = $obj->can("uptodate") ? $obj->uptodate : 0; + $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; + $fail{$s} = 1 unless $success; + } + # recap with less noise + if ( $meth eq "install") { + if (%fail) { + $CPAN::Frontend->myprint(qq{\nBundle summary: }. + qq{The following items seem to }. + qq{have had installation problems:\n}); + for $s ($self->contains) { + $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + } + $CPAN::Frontend->myprint(qq{\n}); + } else { + $self->{'install'} = 'YES'; + } } } @@ -3429,7 +3807,6 @@ sub test { shift->rematein('test',@_); } sub install { my $self = shift; $self->rematein('install',@_); - $CPAN::META->delete('CPAN::Queue',$self->id); } #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } @@ -3496,9 +3873,9 @@ sub as_string { pre-alpha alpha beta released mature standard,; @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; - @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; - @stati{qw,? f r O,} = qw,unknown functions - references+ties object-oriented,; + @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,; + @stati{qw,? f r O h,} = qw,unknown functions + references+ties object-oriented hybrid,; $statd{' '} = 'unknown'; $stats{' '} = 'unknown'; $statl{' '} = 'unknown'; @@ -3544,8 +3921,8 @@ sub manpage_headline { my $inpod = 0; local $/ = "\n"; while (<$fh>) { - $inpod = /^=(?!head1\s+NAME)/ ? 0 : - /^=head1\s+NAME/ ? 1 : $inpod; + $inpod = m/^=(?!head1\s+NAME)/ ? 0 : + m/^=head1\s+NAME/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -3586,7 +3963,7 @@ sub cpan_file { #-> sub CPAN::Module::cpan_version ; sub cpan_version { my $self = shift; - $self->{'CPAN_VERSION'} = 'undef' + $self->{'CPAN_VERSION'} = 'undef' unless defined $self->{'CPAN_VERSION'}; # I believe this is # always a bug in the # index and should be @@ -3640,10 +4017,9 @@ sub get { shift->rematein('get',@_); } sub make { shift->rematein('make') } #-> sub CPAN::Module::test ; sub test { shift->rematein('test') } -#-> sub CPAN::Module::install ; -sub install { +#-> sub CPAN::Module::uptodate ; +sub uptodate { my($self) = @_; - my($doit) = 0; my($latest) = $self->cpan_version; $latest ||= 0; my($inst_file) = $self->inst_file; @@ -3651,22 +4027,28 @@ sub install { if (defined $inst_file) { $have = $self->inst_version; } - if (1){ # A block for scoping $^W, the if is just for the visual - # appeal - local($^W)=0; - if ($inst_file - && - $have >= $latest - && - not exists $self->{'force_update'} - ) { - $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); - } else { - $doit = 1; - } + local($^W)=0; + if ($inst_file + && + $have >= $latest + ) { + return 1; + } + return; +} +#-> sub CPAN::Module::install ; +sub install { + my($self) = @_; + my($doit) = 0; + if ($self->uptodate + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); + } else { + $doit = 1; } $self->rematein('install') if $doit; - $CPAN::META->delete('CPAN::Queue',$self->id); } #-> sub CPAN::Module::clean ; sub clean { shift->rematein('clean') } @@ -3707,6 +4089,7 @@ sub inst_version { my($self) = @_; my $parsefile = $self->inst_file or return; local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; $have =~ s/\s+//g; $have; @@ -3728,7 +4111,7 @@ sub gzip { $fhw->close; return 1; } else { - system("$CPAN::Config->{'gzip'} -c $read > $write")==0; + system("$CPAN::Config->{'gzip'} -c $read > $write")==0; } } @@ -3830,15 +4213,40 @@ sub untar { if (MM->maybe_command($CPAN::Config->{'gzip'}) && MM->maybe_command($CPAN::Config->{'tar'})) { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "$file | $CPAN::Config->{tar} xvf -"; - return system($system) == 0; + if ($^O =~ /win/i) { # irgggh + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; + } else { + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + return system($system) == 0; + } } elsif ($CPAN::META->has_inst("Archive::Tar") && $CPAN::META->has_inst("Compress::Zlib") ) { my $tar = Archive::Tar->new($file,1); $tar->extract($tar->list_files); # I'm pretty sure we have nothing # that isn't compressed + + ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) + if ($^O eq 'MacOS'); + return 1; } else { $CPAN::Frontend->mydie(qq{ @@ -3893,7 +4301,15 @@ session. The cache manager keeps track of the disk space occupied by the make processes and deletes excess space according to a simple FIFO mechanism. -All methods provided are accessible in a programmer style and in an +For extended searching capabilities there's a plugin for CPAN available, +L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes +all documents available in CPAN authors directories. If C<CPAN::WAIT> +is installed on your system, the interactive shell of <CPAN.pm> will +enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send +queries to the WAIT server that has been configured for your +installation. + +All other methods provided are accessible in a programmer style and in an interactive shell style. =head2 Interactive Mode @@ -3949,11 +4365,13 @@ each as object-E<gt>as_glimpse. E.g. =item make, test, install, clean modules or distributions -These commands take any number of arguments and investigate what is +These commands take any number of arguments and investigates what is necessary to perform the action. If the argument is a distribution -file name (recognized by embedded slashes), it is processed. If it is a -module, CPAN determines the distribution file in which this module is -included and processes that. +file name (recognized by embedded slashes), it is processed. If it is +a module, CPAN determines the distribution file in which this module +is included and processes that, following any dependencies named in +the module's Makefile.PL (this behavior is controlled by +I<prerequisites_policy>.) Any C<make> or C<test> are run unconditionally. An @@ -3983,7 +4401,7 @@ Example: OpenGL-0.4/COPYRIGHT [...] -A C<clean> command results in a +A C<clean> command results in a make clean @@ -4133,7 +4551,7 @@ functionalities that are available in the shell. =back -=head2 Methods in the four +=head2 Methods in the four Classes =head2 Cache Manager @@ -4212,7 +4630,7 @@ the $VERSION variable. Currently all programs that are dealing with version use something like this perl -MExtUtils::MakeMaker -le \ - 'print MM->parse_version($ARGV[0])' filename + 'print MM->parse_version(shift)' filename If you are author of a package and wonder if your $VERSION can be parsed, please try the above method. @@ -4239,7 +4657,7 @@ have an idea which part of the package may have a bug, it's sometimes worth to give it a try and send me more specific output. You should know that "o debug" has built-in completion support. -=head2 Floppy, Zip, and all that Jazz +=head2 Floppy, Zip, Offline Mode CPAN.pm works nicely without network too. If you maintain machines that are not networked at all, you should consider working with file: @@ -4278,10 +4696,17 @@ defined: make_install_arg same as make_arg for 'make install' makepl_arg arguments passed to 'perl Makefile.PL' pager location of external program more (or any pager) + prerequisites_policy + what to do if you are missing module prerequisites + ('follow' automatically, 'ask' me, or 'ignore') + scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) wait_list arrayref to a wait server to try (See CPAN::WAIT) + ftp_proxy, } the three usual variables for configuring + http_proxy, } proxy requests. Both as CPAN::Config variables + no_proxy } and as environment variables configurable. You can set and query each of these options interactively in the cpan shell with the command set defined within the C<o conf> command: @@ -4311,7 +4736,7 @@ works like the corresponding perl commands. =back -=head2 CD-ROM support +=head2 urllist parameter has CD-ROM support The C<urllist> parameter of the configuration table contains a list of URLs that are to be used for downloading. If the list contains any @@ -4326,6 +4751,14 @@ CPAN.pm will then fetch the index files from one of the CPAN sites that come at the beginning of urllist. It will later check for each module if there is a local copy of the most recent version. +Another peculiarity of urllist is that the site that we could +successfully fetch the last file from automatically gets a preference +token and is tried as the first site for the next request. So if you +add a new site at runtime it may happen that the previously preferred +site will be tried another time. This means that if you want to disallow +a site for the next transfer, it must be explicitly removed from +urllist. + =head1 SECURITY There's no strong security layer in CPAN.pm. CPAN.pm helps you to @@ -4333,7 +4766,7 @@ install foreign, unmasked, unsigned code on your machine. We compare to a checksum that comes from the net just as the distribution file itself. If somebody has managed to tamper with the distribution file, they may have as well tampered with the CHECKSUMS file. Future -development will go towards strong authentification. +development will go towards strong authentication. =head1 EXPORT @@ -4341,6 +4774,90 @@ Most functions in package CPAN are exported per default. The reason for this is that the primary use is intended for the cpan shell or for oneliners. +=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES + +To populate a freshly installed perl with my favorite modules is pretty +easiest by maintaining a private bundle definition file. To get a useful +blueprint of a bundle definition file, the command autobundle can be used +on the CPAN shell command line. This command writes a bundle definition +file for all modules that re installed for the currently running perl +interpreter. It's recommended to run this command only once and from then +on maintain the file manually under a private name, say +Bundle/my_bundle.pm. With a clever bundle file you can then simply say + + cpan> install Bundle::my_bundle + +then answer a few questions and then go out. + +Maintaining a bundle definition file means to keep track of two things: +dependencies and interactivity. CPAN.pm (currently) does not take into +account dependencies between distributions, so a bundle definition file +should specify distributions that depend on others B<after> the others. +On the other hand, it's a bit annoying that many distributions need some +interactive configuring. So what I try to accomplish in my private bundle +file is to have the packages that need to be configured early in the file +and the gentle ones later, so I can go out after a few minutes and leave +CPAN.pm unattained. + +=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS + +Thanks to Graham Barr for contributing the firewall following howto. + +Firewalls can be categorized into three basic types. + +=over + +=item http firewall + +This is where the firewall machine runs a web server and to access the +outside world you must do it via the web server. If you set environment +variables like http_proxy or ftp_proxy to a values beginning with http:// +or in your web browser you have to set proxy information then you know +you are running a http firewall. + +To access servers outside these types of firewalls with perl (even for +ftp) you will need to use LWP. + +=item ftp firewall + +This where the firewall machine runs a ftp server. This kind of firewall will +only let you access ftp serves outside the firewall. This is usually done by +connecting to the firewall with ftp, then entering a username like +"user@outside.host.com" + +To access servers outside these type of firewalls with perl you +will need to use Net::FTP. + +=item One way visibility + +I say one way visibility as these firewalls try to make themselve look +invisible to the users inside the firewall. An FTP data connection is +normally created by sending the remote server your IP address and then +listening for the connection. But the remote server will not be able to +connect to you because of the firewall. So for these types of firewall +FTP connections need to be done in a passive mode. + +There are two that I can think off. + +=over + +=item SOCKS + +If you are using a SOCKS firewall you will need to compile perl and link +it with the SOCKS library, this is what is normally called a ``socksified'' +perl. With this executable you will be able to connect to servers outside +the firewall as if it is not there. + +=item IP Masquerade + +This is the firewall implemented in the Linux kernel, it allows you to +hide a complete network behind one IP address. With this firewall no +special compiling is need as you can access hosts directly. + +=back + +=back + =head1 BUGS We should give coverage for _all_ of the CPAN and not just the PAUSE @@ -4358,7 +4875,7 @@ traditional method of building a Perl module package from a shell. =head1 AUTHOR -Andreas König E<lt>a.koenig@mind.deE<gt> +Andreas König E<lt>a.koenig@kulturbox.deE<gt> =head1 SEE ALSO diff --git a/contrib/perl5/lib/CPAN/FirstTime.pm b/contrib/perl5/lib/CPAN/FirstTime.pm index aa7a55d..df95812 100644 --- a/contrib/perl5/lib/CPAN/FirstTime.pm +++ b/contrib/perl5/lib/CPAN/FirstTime.pm @@ -16,7 +16,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.29 $, 10; +$VERSION = substr q$Revision: 1.36 $, 10; =head1 NAME @@ -37,7 +37,9 @@ file. Nothing special. sub init { my($configpm) = @_; use Config; - require CPAN::Nox; + unless ($CPAN::VERSION) { + require CPAN::Nox; + } eval {require CPAN::Config;}; $CPAN::Config ||= {}; local($/) = "\n"; @@ -45,12 +47,12 @@ sub init { local($|) = 1; my($ans,$default,$local,$cont,$url,$expected_size); - + # # Files, directories # - print qq{ + print qq[ CPAN is the world-wide archive of perl resources. It consists of about 100 sites that all replicate the same contents all around the globe. @@ -62,7 +64,7 @@ If you do not want to enter a dialog now, you can answer 'no' to this question and I\'ll try to autoconfigure. (Note: you can revisit this dialog anytime later by typing 'o conf init' at the cpan prompt.) -}; +]; my $manual_conf = ExtUtils::MakeMaker::prompt("Are you ready for manual configuration?", @@ -111,16 +113,21 @@ First of all, I\'d like to create this directory. Where? $default = $cpan_home; while ($ans = prompt("CPAN build and cache directory?",$default)) { - File::Path::mkpath($ans); # dies if it can't - if (-d $ans && -w _) { - last; - } else { - warn "Couldn't find directory $ans + eval { File::Path::mkpath($ans); }; # dies if it can't + if ($@) { + warn "Couldn't create directory $ans. +Please retry.\n"; + next; + } + if (-d $ans && -w _) { + last; + } else { + warn "Couldn't find directory $ans or directory is not writable. Please retry.\n"; - } + } } $CPAN::Config->{cpan_home} = $ans; - + print qq{ If you want, I can keep the source files after a build in the cpan @@ -151,6 +158,42 @@ with all the intermediate files? # XXX This the time when we refetch the index files (in days) $CPAN::Config->{'index_expire'} = 1; + print qq{ + +By default, each time the CPAN module is started, cache scanning +is performed to keep the cache size in sync. To prevent from this, +disable the cache scanning with 'never'. + +}; + + $default = $CPAN::Config->{scan_cache} || 'atstart'; + do { + $ans = prompt("Perform cache scanning (atstart or never)?", $default); + } while ($ans ne 'atstart' && $ans ne 'never'); + $CPAN::Config->{scan_cache} = $ans; + + # + # prerequisites_policy + # Do we follow PREREQ_PM? + # + print qq{ + +The CPAN module can detect when a module that which you are trying to +build depends on prerequisites. If this happens, it can build the +prerequisites for you automatically ('follow'), ask you for +confirmation ('ask'), or just ignore them ('ignore'). Please set your +policy to one of the three values. + +}; + + $default = $CPAN::Config->{prerequisites_policy} || 'follow'; + do { + $ans = + prompt("Policy on building prerequisites (follow, ask or ignore)?", + $default); + } while ($ans ne 'follow' && $ans ne 'ask' && $ans ne 'ignore'); + $CPAN::Config->{prerequisites_policy} = $ans; + # # External programs # @@ -164,36 +207,46 @@ those. }; + my $old_warn = $^W; + local $^W if $^O eq 'MacOS'; my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; + local $^W = $old_warn; my $progname; - for $progname (qw/gzip tar unzip make lynx ncftp ftp/){ + for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){ + if ($^O eq 'MacOS') { + $CPAN::Config->{$progname} = 'not_here'; + next; + } my $progcall = $progname; - my $path = $CPAN::Config->{$progname} - || $Config::Config{$progname} - || ""; - if (MM->file_name_is_absolute($path)) { - # testing existence is not good enough, some have these exe - # extensions - - # warn "Warning: configured $path does not exist\n" unless -e $path; - # $path = ""; - } else { - $path = ''; - } - unless ($path) { - # e.g. make -> nmake - $progcall = $Config::Config{$progname} if $Config::Config{$progname}; - } + # we don't need ncftp if we have ncftpget + next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " "; + my $path = $CPAN::Config->{$progname} + || $Config::Config{$progname} + || ""; + if (MM->file_name_is_absolute($path)) { + # testing existence is not good enough, some have these exe + # extensions + + # warn "Warning: configured $path does not exist\n" unless -e $path; + # $path = ""; + } else { + $path = ''; + } + unless ($path) { + # e.g. make -> nmake + $progcall = $Config::Config{$progname} if $Config::Config{$progname}; + } - $path ||= find_exe($progcall,[@path]); - warn "Warning: $progcall not found in PATH\n" unless - $path; # not -e $path, because find_exe already checked that - $ans = prompt("Where is your $progname program?",$path) || $path; - $CPAN::Config->{$progname} = $ans; + $path ||= find_exe($progcall,[@path]); + warn "Warning: $progcall not found in PATH\n" unless + $path; # not -e $path, because find_exe already checked that + $ans = prompt("Where is your $progname program?",$path) || $path; + $CPAN::Config->{$progname} = $ans; } my $path = $CPAN::Config->{'pager'} || $ENV{PAGER} || find_exe("less",[@path]) || - find_exe("more",[@path]) || "more"; + find_exe("more",[@path]) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 ) + || "more"; $ans = prompt("What is your favorite pager program?",$path); $CPAN::Config->{'pager'} = $ans; $path = $CPAN::Config->{'shell'}; @@ -202,9 +255,13 @@ those. $path = ""; } $path ||= $ENV{SHELL}; - $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only - $ans = prompt("What is your favorite shell?",$path); - $CPAN::Config->{'shell'} = $ans; + if ($^O eq 'MacOS') { + $CPAN::Config->{'shell'} = 'not_here'; + } else { + $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only + $ans = prompt("What is your favorite shell?",$path); + $CPAN::Config->{'shell'} = $ans; + } # # Arguments to make etc. @@ -327,11 +384,38 @@ sub find_exe { } } +sub picklist { + my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_; + $default ||= ''; + + my ($item, $i); + for $item (@$items) { + printf "(%d) %s\n", ++$i, $item; + } + + my @nums; + while (1) { + my $num = prompt($prompt,$default); + @nums = split (' ', $num); + (warn "invalid items entered, try again\n"), next + if grep (/\D/ || $_ < 1 || $_ > $i, @nums); + if ($require_nonempty) { + (warn "$empty_warning\n"), next + unless @nums; + } + last; + } + print "\n"; + for (@nums) { $_-- } + @{$items}[@nums]; +} + sub read_mirrored_by { my($local) = @_; my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); my $fh = FileHandle->new; $fh->open($local) or die "Couldn't open $local: $!"; + local $/ = "\012"; while (<$fh>) { ($host) = /^([\w\.\-]+)/ unless defined $host; next unless defined $host; @@ -339,6 +423,7 @@ sub read_mirrored_by { /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; + $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; next unless $host && $dst && $continent && $country; $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); @@ -347,93 +432,97 @@ sub read_mirrored_by { } $fh->close; $CPAN::Config->{urllist} ||= []; - if ($expected_size = @{$CPAN::Config->{urllist}}) { - for $url (@{$CPAN::Config->{urllist}}) { - # sanity check, scheme+colon, not "q" there: - next unless $url =~ /^\w+:\/./; - $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url); - } + my(@previous_urls); + if (@previous_urls = @{$CPAN::Config->{urllist}}) { $CPAN::Config->{urllist} = []; - } else { - $expected_size = 6; } - + print qq{ -Now we need to know, where your favorite CPAN sites are located. Push +Now we need to know where your favorite CPAN sites are located. Push a few sites onto the array (just in case the first on the array won\'t work). If you are mirroring CPAN to your local workstation, specify a file: URL. -You can enter the number in front of the URL on the next screen, a -file:, ftp: or http: URL, or "q" to finish selecting. +First, pick a nearby continent and country (you can pick several of +each, separated by spaces, or none if you just want to keep your +existing selections). Then, you will be presented with a list of URLs +of CPAN mirrors in the countries you selected, along with previously +selected URLs. Select some of those URLs, or just keep the old list. +Finally, you will be prompted for any extra URLs -- file:, ftp:, or +http: -- that host a CPAN mirror. }; - $ans = prompt("Press RETURN to continue"); - my $other; - $ans = $other = ""; - my(%seen); - - my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; - while () { - my(@valid,$previous_best); - my $fh = FileHandle->new; - $fh->open($pipe); - { - my($cont,$country,$url,$item); - my(@cont) = sort keys %all; - for $cont (@cont) { - $fh->print(" $cont\n"); - for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { - for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { - my $t = sprintf( - " %-16s (%2d) %s\n", - $country, - ++$item, - $url - ); - if ($cont =~ /^\[/) { - $previous_best ||= $item; - } - push @valid, $all{$cont}{$country}{$url}; - $fh->print($t); - } - } - } - } - $fh->close; - $previous_best ||= ""; - $default = - @{$CPAN::Config->{urllist}} >= - $expected_size ? "q" : $previous_best; - $ans = prompt( - "\nSelect an$other ftp or file URL or a number (q to finish)", - $default - ); - my $sel; - if ($ans =~ /^\d/) { - my $this = $valid[$ans-1]; - my($con,$cou,$url) = ($this->continent,$this->country,$this->url); - push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++; - delete $all{$con}{$cou}{$url}; - # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n"; - } elsif ($ans =~ /^q/i) { - last; - } else { - $ans =~ s|/?$|/|; # has to end with one slash - $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: - if ($ans =~ /^\w+:\/./) { - push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++; - } else { - print qq{"$ans" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm -later and report a bug in my Makefile.PL to me (andreas koenig). -Thanks.\n}; - } - } - $other ||= "other"; + my (@cont, $cont, %cont, @countries, @urls, %seen); + my $no_previous_warn = + "Sorry! since you don't have any existing picks, you must make a\n" . + "geographic selection."; + @cont = picklist([sort keys %all], + "Select your continent (or several nearby continents)", + '', + ! @previous_urls, + $no_previous_warn); + + + foreach $cont (@cont) { + my @c = sort keys %{$all{$cont}}; + @cont{@c} = map ($cont, 0..$#c); + @c = map ("$_ ($cont)", @c) if @cont > 1; + push (@countries, @c); + } + + if (@countries) { + @countries = picklist (\@countries, + "Select your country (or several nearby countries)", + '', + ! @previous_urls, + $no_previous_warn); + %seen = map (($_ => 1), @previous_urls); + # hmmm, should take list of defaults from CPAN::Config->{'urllist'}... + foreach $country (@countries) { + (my $bare_country = $country) =~ s/ \(.*\)//; + my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}}; + @u = grep (! $seen{$_}, @u); + @u = map ("$_ ($bare_country)", @u) + if @countries > 1; + push (@urls, @u); + } } + push (@urls, map ("$_ (previous pick)", @previous_urls)); + my $prompt = "Select as many URLs as you like"; + if (@previous_urls) { + $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. + (scalar @urls)); + $prompt .= "\n(or just hit RETURN to keep your previous picks)"; + } + + @urls = picklist (\@urls, $prompt, $default); + foreach (@urls) { s/ \(.*\)//; } + %seen = map (($_ => 1), @urls); + + do { + $ans = prompt ("Enter another URL or RETURN to quit:", ""); + + if ($ans) { + $ans =~ s|/?$|/|; # has to end with one slash + $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: + if ($ans =~ /^\w+:\/./) { + push @urls, $ans + unless $seen{$ans}; + } + else { + print qq{"$ans" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'} +later if you\'re sure it\'s right.\n}; + } + } + } while $ans; + + push @{$CPAN::Config->{urllist}}, @urls; + # xxx delete or comment these out when you're happy that it works + print "New set of picks:\n"; + map { print " $_\n" } @{$CPAN::Config->{urllist}}; } 1; diff --git a/contrib/perl5/lib/CPAN/Nox.pm b/contrib/perl5/lib/CPAN/Nox.pm index c4016a4..e9cb189 100644 --- a/contrib/perl5/lib/CPAN/Nox.pm +++ b/contrib/perl5/lib/CPAN/Nox.pm @@ -1,7 +1,10 @@ +package CPAN::Nox; + BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} use CPAN; +$VERSION = "1.00"; $CPAN::META->has_inst('MD5','no'); $CPAN::META->has_inst('LWP','no'); $CPAN::META->has_inst('Compress::Zlib','no'); diff --git a/contrib/perl5/lib/Carp.pm b/contrib/perl5/lib/Carp.pm index 6bac364..f8f750a 100644 --- a/contrib/perl5/lib/Carp.pm +++ b/contrib/perl5/lib/Carp.pm @@ -35,7 +35,7 @@ and a carp as a cluck across I<all> modules. In other words, force a detailed stack trace to be given. This can be very helpful when trying to understand why, or from where, a warning or error is being generated. -This feature is enabled by 'importing' the non-existant symbol +This feature is enabled by 'importing' the non-existent symbol 'verbose'. You would typically enable it by saying perl -MCarp=verbose script.pl @@ -43,6 +43,12 @@ This feature is enabled by 'importing' the non-existant symbol or by including the string C<MCarp=verbose> in the L<PERL5OPT> environment variable. +=head1 BUGS + +The Carp routines don't handle exception objects currently. +If called with a first argument that is a reference, they simply +call die() or warn(), as appropriate. + =cut # This package is heavily used. Be small. Be fast. Be good. @@ -88,6 +94,7 @@ sub export_fail { # each function call on the stack. sub longmess { + return @_ if ref $_[0]; my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; @@ -190,6 +197,7 @@ sub longmess { sub shortmess { # Short-circuit &longmess if called via multiple packages goto &longmess if $Verbose; + return @_ if ref $_[0]; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm index 7febb0d..5c10e8e 100644 --- a/contrib/perl5/lib/Cwd.pm +++ b/contrib/perl5/lib/Cwd.pm @@ -32,7 +32,7 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The abs_path() function takes a single argument and returns the -absolute pathname for that argument. It uses the same algoritm as +absolute pathname for that argument. It uses the same algorithm as getcwd(). (actually getcwd() is abs_path(".")) The fastcwd() function looks the same as getcwd(), but runs faster. @@ -269,7 +269,7 @@ sub fast_abs_path { # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times -# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu # Note: Use of Cwd::chdir() causes the logical name PWD to be defined # in the process logical name table as the default device and directory # seen by Perl. This may not be the same as the default device diff --git a/contrib/perl5/lib/Dumpvalue.pm b/contrib/perl5/lib/Dumpvalue.pm new file mode 100644 index 0000000..5bcd58f --- /dev/null +++ b/contrib/perl5/lib/Dumpvalue.pm @@ -0,0 +1,600 @@ +require 5.005; # For (defined ref) and $#$v +package Dumpvalue; +use strict; +use vars qw(%address *stab %subs); + +# translate control chars to ^X - Randal Schwartz +# Modifications to print types by Peter Gordon v1.0 + +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + +# Won't dump symbol tables and contents of debugged files by default + +# (IZ) changes for objectification: +# c) quote() renamed to method set_quote(); +# d) unctrlSet() renamed to method set_unctrl(); +# f) Compiles with `use strict', but in two places no strict refs is needed: +# maybe more problems are waiting... + +my %defaults = ( + globPrint => 0, + printUndef => 1, + tick => "auto", + unctrl => 'quote', + subdump => 1, + dumpReused => 0, + bareStringify => 1, + hashDepth => '', + arrayDepth => '', + dumpDBFiles => '', + dumpPackages => '', + quoteHighBit => '', + usageOnly => '', + compactDump => '', + veryCompact => '', + stopDbSignal => '', + ); + +sub new { + my $class = shift; + my %opt = (%defaults, @_); + bless \%opt, $class; +} + +sub set { + my $self = shift; + my %opt = @_; + @$self{keys %opt} = values %opt; +} + +sub get { + my $self = shift; + wantarray ? @$self{@_} : $$self{pop @_}; +} + +sub dumpValue { + my $self = shift; + die "usage: \$dumper->dumpValue(value)" unless @_ == 1; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + (print $self->stringify($_[0]), "\n"), return unless ref $_[0]; + $self->unwrap($_[0],0); +} + +sub dumpValues { + my $self = shift; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + $self->unwrap(\@_,0); +} + +# This one is good for variable names: + +sub unctrl { + local($_) = @_; + + return \$_ if ref \$_ eq "GLOB"; + s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; + $_; +} + +sub stringify { + my $self = shift; + local $_ = shift; + my $noticks = shift; + my $tick = $self->{tick}; + + return 'undef' unless defined $_ or not $self->{printUndef}; + return $_ . "" if ref \$_ eq 'GLOB'; + { no strict 'refs'; + $_ = &{'overload::StrVal'}($_) + if $self->{bareStringify} and ref $_ + and defined %overload:: and defined &{'overload::StrVal'}; + } + + if ($tick eq 'auto') { + if (/[\000-\011\013-\037\177]/) { + $tick = '"'; + } else { + $tick = "'"; + } + } + if ($tick eq "'") { + s/([\'\\])/\\$1/g; + } elsif ($self->{unctrl} eq 'unctrl') { + s/([\"\\])/\\$1/g ; + s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg; + s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg + if $self->{quoteHighBit}; + } elsif ($self->{unctrl} eq 'quote') { + s/([\"\\\$\@])/\\$1/g if $tick eq '"'; + s/\033/\\e/g; + s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg; + } + s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit}; + ($noticks || /^\d+(\.\d*)?\Z/) + ? $_ + : $tick . $_ . $tick; +} + +sub DumpElem { + my ($self, $v) = (shift, shift); + my $short = $self->stringify($v, ref $v); + my $shortmore = ''; + if ($self->{veryCompact} && ref $v + && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) { + my $depth = $#$v; + ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1) + if $self->{arrayDepth} and $depth >= $self->{arrayDepth}; + my @a = map $self->stringify($_), @$v[0..$depth]; + print "0..$#{$v} @a$shortmore\n"; + } elsif ($self->{veryCompact} && ref $v + && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) { + my @a = sort keys %$v; + my $depth = $#a; + ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1) + if $self->{hashDepth} and $depth >= $self->{hashDepth}; + my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})} + @a[0..$depth]; + local $" = ', '; + print "@b$shortmore\n"; + } else { + print "$short\n"; + $self->unwrap($v,shift); + } +} + +sub unwrap { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($v) = shift ; + my ($s) = shift ; # extra no of spaces + my $sp; + my (%v,@v,$address,$short,$fileno); + + $sp = " " x $s ; + $s += 3 ; + + # Check for reused addresses + if (ref $v) { + my $val = $v; + { no strict 'refs'; + $val = &{'overload::StrVal'}($v) + if defined %overload:: and defined &{'overload::StrVal'}; + } + ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; + if (!$self->{dumpReused} && defined $address) { + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}-> REUSED_ADDRESS\n" ; + return ; + } + } + } elsif (ref \$v eq 'GLOB') { + $address = "$v" . ""; # To avoid a bug with globs + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}*DUMPED_GLOB*\n" ; + return ; + } + } + + if ( UNIVERSAL::isa($v, 'HASH') ) { + my @sortKeys = sort keys(%$v) ; + my $more; + my $tHashDepth = $#sortKeys ; + $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1 + unless $self->{hashDepth} eq '' ; + $more = "....\n" if $tHashDepth < $#sortKeys ; + my $shortmore = ""; + $shortmore = ", ..." if $tHashDepth < $#sortKeys ; + $#sortKeys = $tHashDepth ; + if ($self->{compactDump} && !grep(ref $_, values %{$v})) { + $short = $sp; + my @keys; + for (@sortKeys) { + push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_}); + } + $short .= join ', ', @keys; + $short .= $shortmore; + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $key (@sortKeys) { + return if $DB::signal and $self->{stopDbSignal}; + my $value = $ {$v}{$key} ; + print $sp, $self->stringify($key), " => "; + $self->DumpElem($value, $s); + } + print "$sp empty hash\n" unless @sortKeys; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { + my $tArrayDepth = $#{$v} ; + my $more ; + $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1 + unless $self->{arrayDepth} eq '' ; + $more = "....\n" if $tArrayDepth < $#{$v} ; + my $shortmore = ""; + $shortmore = " ..." if $tArrayDepth < $#{$v} ; + if ($self->{compactDump} && !grep(ref $_, @{$v})) { + if ($#$v >= 0) { + $short = $sp . "0..$#{$v} " . + join(" ", + map {$self->stringify($_)} @{$v}[0..$tArrayDepth]) + . "$shortmore"; + } else { + $short = $sp . "empty array"; + } + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $num ($[ .. $tArrayDepth) { + return if $DB::signal and $self->{stopDbSignal}; + print "$sp$num "; + $self->DumpElem($v->[$num], $s); + } + print "$sp empty array\n" unless @$v; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { + print "$sp-> "; + $self->DumpElem($$v, $s); + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { + print "$sp-> "; + $self->dumpsub(0, $v); + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { + print "$sp-> ",$self->stringify($$v,1),"\n"; + if ($self->{globPrint}) { + $s += 3; + $self->dumpglob('', $s, "{$$v}", $$v, 1); + } elsif (defined ($fileno = fileno($v))) { + print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); + } + } elsif (ref \$v eq 'GLOB') { + if ($self->{globPrint}) { + $self->dumpglob('', $s, "{$v}", $v, 1); + } elsif (defined ($fileno = fileno(\$v))) { + print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); + } + } +} + +sub matchvar { + $_[0] eq $_[1] or + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); +} + +sub compactDump { + my $self = shift; + $self->{compactDump} = shift if @_; + $self->{compactDump} = 6*80-1 + if $self->{compactDump} and $self->{compactDump} < 2; + $self->{compactDump}; +} + +sub veryCompact { + my $self = shift; + $self->{veryCompact} = shift if @_; + $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact}; + $self->{veryCompact}; +} + +sub set_unctrl { + my $self = shift; + if (@_) { + my $in = shift; + if ($in eq 'unctrl' or $in eq 'quote') { + $self->{unctrl} = $in; + } else { + print "Unknown value for `unctrl'.\n"; + } + } + $self->{unctrl}; +} + +sub set_quote { + my $self = shift; + if (@_ and $_[0] eq '"') { + $self->{tick} = '"'; + $self->{unctrl} = 'quote'; + } elsif (@_ and $_[0] eq 'auto') { + $self->{tick} = 'auto'; + $self->{unctrl} = 'quote'; + } elsif (@_) { # Need to set + $self->{tick} = "'"; + $self->{unctrl} = 'unctrl'; + } + $self->{tick}; +} + +sub dumpglob { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($package, $off, $key, $val, $all) = @_; + local(*stab) = $val; + my $fileno; + if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) { + print( (' ' x $off) . "\$", &unctrl($key), " = " ); + $self->DumpElem($stab, 3+$off); + } + if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined @stab) { + print( (' ' x $off) . "\@$key = (\n" ); + $self->unwrap(\@stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if ($key ne "main::" && $key ne "DB::" && defined %stab + && ($self->{dumpPackages} or $key !~ /::$/) + && ($key !~ /^_</ or $self->{dumpDBFiles}) + && !($package eq "Dumpvalue" and $key eq "stab")) { + print( (' ' x $off) . "\%$key = (\n" ); + $self->unwrap(\%stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if (defined ($fileno = fileno(*stab))) { + print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" ); + } + if ($all) { + if (defined &stab) { + $self->dumpsub($off, $key); + } + } +} + +sub dumpsub { + my $self = shift; + my ($off,$sub) = @_; + $sub = $1 if $sub =~ /^\{\*(.*)\}$/; + my $subref = \&$sub; + my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) + || ($self->{subdump} && ($sub = $self->findsubs("$subref")) + && $DB::sub{$sub}); + $place = '???' unless defined $place; + print( (' ' x $off) . "&$sub in $place\n" ); +} + +sub findsubs { + my $self = shift; + return undef unless defined %DB::sub; + my ($addr, $name, $loc); + while (($name, $loc) = each %DB::sub) { + $addr = \&$name; + $subs{"$addr"} = $name; + } + $self->{subdump} = 0; + $subs{ shift() }; +} + +sub dumpvars { + my $self = shift; + my ($package,@vars) = @_; + local(%address,$^W); + my ($key,$val); + $package .= "::" unless $package =~ /::$/; + *stab = *main::; + + while ($package =~ /(\w+?::)/g) { + *stab = $ {stab}{$1}; + } + $self->{TotalStrings} = 0; + $self->{Strings} = 0; + $self->{CompleteTotal} = 0; + while (($key,$val) = each(%stab)) { + return if $DB::signal and $self->{stopDbSignal}; + next if @vars && !grep( matchvar($key, $_), @vars ); + if ($self->{usageOnly}) { + $self->globUsage(\$val, $key) + unless $package eq 'Dumpvalue' and $key eq 'stab'; + } else { + $self->dumpglob($package, 0,$key, $val); + } + } + if ($self->{usageOnly}) { + print <<EOP; +String space: $self->{TotalStrings} bytes in $self->{Strings} strings. +EOP + $self->{CompleteTotal} += $self->{TotalStrings}; + print <<EOP; +Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead. +EOP + } +} + +sub scalarUsage { + my $self = shift; + my $size = length($_[0]); + $self->{TotalStrings} += $size; + $self->{Strings}++; + $size; +} + +sub arrayUsage { # array ref, name + my $self = shift; + my $size = 0; + map {$size += $self->scalarUsage($_)} @{$_[0]}; + my $len = @{$_[0]}; + print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n" + if defined $_[1]; + $self->{CompleteTotal} += $size; + $size; +} + +sub hashUsage { # hash ref, name + my $self = shift; + my @keys = keys %{$_[0]}; + my @values = values %{$_[0]}; + my $keys = $self->arrayUsage(\@keys); + my $values = $self->arrayUsage(\@values); + my $len = @keys; + my $total = $keys + $values; + print "\%$_[1] = $len item", ($len > 1 ? "s" : ""), + " (keys: $keys; values: $values; total: $total bytes)\n" + if defined $_[1]; + $total; +} + +sub globUsage { # glob ref, name + my $self = shift; + local *stab = *{$_[0]}; + my $total = 0; + $total += $self->scalarUsage($stab) if defined $stab; + $total += $self->arrayUsage(\@stab, $_[1]) if defined @stab; + $total += $self->hashUsage(\%stab, $_[1]) + if defined %stab and $_[1] ne "main::" and $_[1] ne "DB::"; + #and !($package eq "Dumpvalue" and $key eq "stab")); + $total; +} + +1; + +=head1 NAME + +Dumpvalue - provides screen dump of Perl data. + +=head1 SYNOPSYS + + use Dumpvalue; + my $dumper = new Dumpvalue; + $dumper->set(globPrint => 1); + $dumper->dumpValue(\*::); + $dumper->dumpvars('main'); + +=head1 DESCRIPTION + +=head2 Creation + +A new dumper is created by a call + + $d = new Dumpvalue(option1 => value1, option2 => value2) + +Recognized options: + +=over + +=item C<arrayDepth>, C<hashDepth> + +Print only first N elements of arrays and hashes. If false, prints all the +elements. + +=item C<compactDump>, C<veryCompact> + +Change style of array and hash dump. If true, short array +may be printed on one line. + +=item C<globPrint> + +Whether to print contents of globs. + +=item C<DumpDBFiles> + +Dump arrays holding contents of debugged files. + +=item C<DumpPackages> + +Dump symbol tables of packages. + +=item C<DumpReused> + +Dump contents of "reused" addresses. + +=item C<tick>, C<HighBit>, C<printUndef> + +Change style of string dump. Default value of C<tick> is C<auto>, one +can enable either double-quotish dump, or single-quotish by setting it +to C<"> or C<'>. By default, characters with high bit set are printed +I<as is>. + +=item C<UsageOnly> + +I<very> rudimentally per-package memory usage dump. If set, +C<dumpvars> calculates total size of strings in variables in the package. + +=item unctrl + +Changes the style of printout of strings. Possible values are +C<unctrl> and C<quote>. + +=item subdump + +Whether to try to find the subroutine name given the reference. + +=item bareStringify + +Whether to write the non-overloaded form of the stringify-overloaded objects. + +=item quoteHighBit + +Whether to print chars with high bit set in binary or "as is". + +=item stopDbSignal + +Whether to abort printing if debugger signal flag is raised. + +=back + +Later in the life of the object the methods may be queries with get() +method and set() method (which accept multiple arguments). + +=head2 Methods + +=over + +=item dumpValue + + $dumper->dumpValue($value); + $dumper->dumpValue([$value1, $value2]); + +=item dumpValues + + $dumper->dumpValues($value1, $value2); + +=item dumpvars + + $dumper->dumpvars('my_package'); + $dumper->dumpvars('my_package', 'foo', '~bar$', '!......'); + +The optional arguments are considered as literal strings unless they +start with C<~> or C<!>, in which case they are interpreted as regular +expressions (possibly negated). + +The second example prints entries with names C<foo>, and also entries +with names which ends on C<bar>, or are shorter than 5 chars. + +=item set_quote + + $d->set_quote('"'); + +Sets C<tick> and C<unctrl> options to suitable values for printout with the +given quote char. Possible values are C<auto>, C<'> and C<">. + +=item set_unctrl + + $d->set_unctrl('"'); + +Sets C<unctrl> option with checking for an invalid argument. +Possible values are C<unctrl> and C<quote>. + +=item compactDump + + $d->compactDump(1); + +Sets C<compactDump> option. If the value is 1, sets to a reasonable +big number. + +=item veryCompact + + $d->veryCompact(1); + +Sets C<compactDump> and C<veryCompact> options simultaneously. + +=item set + + $d->set(option1 => value1, option2 => value2); + +=item get + + @values = $d->get('option1', 'option2'); + +=back + +=cut + diff --git a/contrib/perl5/lib/English.pm b/contrib/perl5/lib/English.pm index bbb6bd7..9f29a48 100644 --- a/contrib/perl5/lib/English.pm +++ b/contrib/perl5/lib/English.pm @@ -15,6 +15,14 @@ English - use nice English (or awk) names for ugly punctuation variables =head1 DESCRIPTION +You should I<not> use this module in programs intended to be portable +among Perl versions, programs that must perform regular expression +matching operations efficiently, or libraries intended for use with +such programs. In a sense, this module is deprecated. The reasons +for this have to do with implementation details of the Perl +interpreter which are too thorny to go into here. Perhaps someday +they will be fixed to make "C<use English>" more practical. + This module provides aliases for the built-in variables whose names no one seems to like to read. Variables with side-effects which get triggered just by accessing them (like $0) will still @@ -160,6 +168,7 @@ sub import { *PERL_VERSION = *] ; *ACCUMULATOR = *^A ; + *COMPILING = *^C ; *DEBUGGING = *^D ; *SYSTEM_FD_MAX = *^F ; *INPLACE_EDIT = *^I ; diff --git a/contrib/perl5/lib/ExtUtils/Command.pm b/contrib/perl5/lib/ExtUtils/Command.pm index 2f5f1e1..e900e51 100644 --- a/contrib/perl5/lib/ExtUtils/Command.pm +++ b/contrib/perl5/lib/ExtUtils/Command.pm @@ -31,8 +31,8 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 DESCRIPTION -The module is used in Win32 port to replace common UNIX commands. -Most commands are wrapers on generic modules File::Path and File::Basename. +The module is used in the Win32 port to replace common UNIX commands. +Most commands are wrappers on generic modules File::Path and File::Basename. =over 4 diff --git a/contrib/perl5/lib/ExtUtils/Embed.pm b/contrib/perl5/lib/ExtUtils/Embed.pm index e41ca40..4b56e88 100644 --- a/contrib/perl5/lib/ExtUtils/Embed.pm +++ b/contrib/perl5/lib/ExtUtils/Embed.pm @@ -416,7 +416,7 @@ This will print arguments for linking with B<libperl.a>, B<DynaLoader> and extensions found in B<$Config{static_ext}>. This includes libraries found in B<$Config{libs}> and the first ModuleName.a library for each extension that is found by searching B<@INC> or the path -specifed by the B<-I> option. +specified by the B<-I> option. In addition, when ModuleName.a is found, additional linker arguments are picked up from the B<extralibs.ld> file in the same directory. diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm index 6a5c184..f75aa55 100644 --- a/contrib/perl5/lib/ExtUtils/Install.pm +++ b/contrib/perl5/lib/ExtUtils/Install.pm @@ -354,7 +354,7 @@ The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>. This function calls install() with the same arguments as the defaults the MakeMaker would use. -The argumement-less form is convenient for install scripts like +The argument-less form is convenient for install scripts like perl -MExtUtils::Install -e install_default Tk/Canvas diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm index b072c12..dae3125 100644 --- a/contrib/perl5/lib/ExtUtils/Liblist.pm +++ b/contrib/perl5/lib/ExtUtils/Liblist.pm @@ -225,6 +225,9 @@ sub _win32_ext { my $search = 1; my($fullname, $thislib, $thispth); + # add "$Config{installarchlib}/CORE" to default search path + push @libpath, "$Config{installarchlib}/CORE"; + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; @@ -240,8 +243,8 @@ sub _win32_ext { # if searching is disabled, do compiler-specific translations unless ($search) { - s/^-L/-libpath:/ if $VC; s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; push(@extralibs, $_); $found++; next; @@ -575,7 +578,7 @@ Unix-OS/2 version in several respects: =item * Input library and path specifications are accepted with or without the -C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is present, a token is considered a directory to search if it is in fact a directory, and a library to search for otherwise. Authors who wish their extensions to be portable to Unix or OS/2 should use the Unix @@ -586,7 +589,7 @@ prefixes, since the Unix-OS/2 version of ext() requires them. Wherever possible, shareable images are preferred to object libraries, and object libraries to plain object files. In accordance with VMS naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; -it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions used in some ported software. =item * @@ -625,14 +628,15 @@ Unix-OS/2 version in several respects: If C<$potential_libs> is empty, the return value will be empty. Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries -will be searched for in the directories specified in C<$potential_libs> -as well as in C<$Config{libpth}>. For each library that is found, a -space-separated list of fully qualified library pathnames is generated. +will be searched for in the directories specified in C<$potential_libs>, +C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +For each library that is found, a space-separated list of fully qualified +library pathnames is generated. =item * Input library and path specifications are accepted with or without the -C<-l> and C<-L> prefices used by Unix linkers. +C<-l> and C<-L> prefixes used by Unix linkers. An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look for the libraries that follow. @@ -651,7 +655,7 @@ library to search for otherwise. The C<$Config{lib_ext}> suffix will be appended to any entries that are not directories and don't already have the suffix. -Note that the C<-L> and <-l> prefixes are B<not required>, but authors +Note that the C<-L> and C<-l> prefixes are B<not required>, but authors who wish their extensions to be portable to Unix or OS/2 should use the prefixes, since the Unix-OS/2 version of ext() requires them. diff --git a/contrib/perl5/lib/ExtUtils/MM_OS2.pm b/contrib/perl5/lib/ExtUtils/MM_OS2.pm index 8bddb42..5d6034c 100644 --- a/contrib/perl5/lib/ExtUtils/MM_OS2.pm +++ b/contrib/perl5/lib/ExtUtils/MM_OS2.pm @@ -15,6 +15,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -27,14 +28,46 @@ $self->{BASEEXT}.def: Makefile.PL Mksymlists("NAME" => "', $self->{NAME}, '", "DLBASE" => "',$self->{DLBASE}, '", "DL_FUNCS" => ',neatvalue($funcs), + ', "FUNCLIST" => ',neatvalue($funclist), ', "IMPORTS" => ',neatvalue($imports), ', "VERSION" => "',$self->{VERSION}, '", "DL_VARS" => ', neatvalue($vars), ');\' '); } + if (%{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp"; + my ($name, $exp); + while (($name, $exp)= each %{$self->{IMPORTS}}) { + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print IMP "$name $lib $id ?\n"; + } + close IMP or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + unlink <tmp_imp/*>; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } join('',@m); } +sub static_lib { + my($self) = @_; + my $old = $self->ExtUtils::MM_Unix::static_lib(); + return $old unless %{$self->{IMPORTS}}; + + my @chunks = split /\n{2,}/, $old; + shift @chunks unless length $chunks[0]; # Empty lines at the start + $chunks[0] .= <<'EOC'; + + $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@ +EOC + return join "\n\n". '', @chunks; +} + sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,/+,.,g; diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm index 9a96504..38bb061 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm @@ -8,7 +8,7 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.12601 $, 10; +$VERSION = substr q$Revision: 1.12602 $, 10; # $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $ Exporter::import('ExtUtils::MakeMaker', @@ -19,7 +19,7 @@ $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; -$Is_PERL_OBJECT = 1 if $Config{'ccflags'} =~ /-DPERL_OBJECT/; +$Is_PERL_OBJECT = $Config{'ccflags'} =~ /-DPERL_OBJECT/; if ($Is_VMS = $^O eq 'VMS') { require VMS::Filespec; @@ -84,10 +84,10 @@ sub canonpath { if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) { $node = $1; } - $path =~ s|/+|/|g ; # xx////xx -> xx/xx + $path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx + $path =~ s|(?<=[^/])/$|| ; # xx/ -> xx "$node$path"; } @@ -233,6 +233,7 @@ sub ExtUtils::MM_Unix::tools_other ; sub ExtUtils::MM_Unix::top_targets ; sub ExtUtils::MM_Unix::writedoc ; sub ExtUtils::MM_Unix::xs_c ; +sub ExtUtils::MM_Unix::xs_cpp ; sub ExtUtils::MM_Unix::xs_o ; sub ExtUtils::MM_Unix::xsubpp_version ; @@ -374,9 +375,9 @@ sub cflags { $self->{uc $_} ||= $cflags{$_} } - if ($self->{CAPI} && $Is_PERL_OBJECT == 1) { + if ($self->{CAPI} && $Is_PERL_OBJECT) { $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//; - $self->{CCFLAGS} .= '-DPERL_CAPI'; + $self->{CCFLAGS} .= ' -DPERL_CAPI '; if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) { # Turn off C++ mode of the MSC compiler $self->{CCFLAGS} =~ s/-TP(\s|$)//; @@ -818,7 +819,7 @@ ci : =item dist_core (o) -Defeines the targets dist, tardist, zipdist, uutardist, shdist +Defines the targets dist, tardist, zipdist, uutardist, shdist =cut @@ -915,6 +916,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); push(@m," @@ -931,7 +933,8 @@ static :: $self->{BASEEXT}.exp $self->{BASEEXT}.exp: Makefile.PL ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ', - neatvalue($funcs),', "DL_VARS" => ', neatvalue($vars), ');\' + neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist), + ', "DL_VARS" => ', neatvalue($vars), ');\' '); join('',@m); @@ -2018,7 +2021,7 @@ uninstall_from_sitedirs :: =item installbin (o) -Defines targets to install EXE_FILES. +Defines targets to make and to install EXE_FILES. =cut @@ -2045,7 +2048,7 @@ EXE_FILES = @{$self->{EXE_FILES}} } : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \ -e "MY->fixin(shift)" }).qq{ -all :: @to +pure_all :: @to $self->{NOECHO}\$(NOOP) realclean :: @@ -2347,7 +2350,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ - -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@ + -e "writemain(grep s#.*/auto/##, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ }; push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain @@ -2746,10 +2749,13 @@ sub ppd { push(@m, "\t\@\$(PERL) -e \"print qq{<SOFTPKG NAME=\\\"$self->{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}"); push(@m, ". qq{\\t<TITLE>$self->{DISTNAME}</TITLE>\\n}"); my $abstract = $self->{ABSTRACT}; + $abstract =~ s/\n/\\n/sg; $abstract =~ s/</</g; $abstract =~ s/>/>/g; push(@m, ". qq{\\t<ABSTRACT>$abstract</ABSTRACT>\\n}"); my ($author) = $self->{AUTHOR}; + $author =~ s/</</g; + $author =~ s/>/>/g; $author =~ s/@/\\@/g; push(@m, ". qq{\\t<AUTHOR>$author</AUTHOR>\\n}"); push(@m, ". qq{\\t<IMPLEMENTATION>\\n}"); @@ -2757,9 +2763,11 @@ sub ppd { foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { my $pre_req = $prereq; $pre_req =~ s/::/-/g; - push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" />\\n}"); + my ($dep_ver) = join ",", (split (/\./, $self->{PREREQ_PM}{$prereq}), (0) x 4) [0 .. 3]; + push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" VERSION=\\\"$dep_ver\\\" />\\n}"); } push(@m, ". qq{\\t\\t<OS NAME=\\\"\$(OSNAME)\\\" />\\n}"); + push(@m, ". qq{\\t\\t<ARCHITECTURE NAME=\\\"$Config{'archname'}\\\" />\\n}"); my ($bin_location) = $self->{BINARY_LOCATION}; $bin_location =~ s/\\/\\\\/g; if ($self->{PPM_INSTALL_SCRIPT}) { @@ -2783,7 +2791,7 @@ Returns the attribute C<PERM_RW> or the string C<644>. Used as the string that is passed to the C<chmod> command to set the permissions for read/writeable files. MakeMaker chooses C<644> because it has turned out in the past that -relying on the umask provokes hard-to-track bugreports. +relying on the umask provokes hard-to-track bug reports. When the return value is used by the perl function C<chmod>, it is interpreted as an octal value. @@ -2889,13 +2897,18 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { push @m, " -all :: $self->{PL_FILES}->{$plfile} +all :: $target $self->{NOECHO}\$(NOOP) -$self->{PL_FILES}->{$plfile} :: $plfile - \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile +$target :: $plfile + \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile $target "; + } } join "", @m; } @@ -2943,7 +2956,11 @@ form Foo/Bar and replaces the slash with C<::>. Returns the replacement. sub replace_manpage_separator { my($self,$man) = @_; - $man =~ s,/+,::,g; + if ($^O eq 'uwin') { + $man =~ s,/+,.,g; + } else { + $man =~ s,/+,::,g; + } $man; } @@ -3304,7 +3321,7 @@ sub tool_xsubpp { } } - $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; + my $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; return qq{ XSUBPPDIR = $xsdir @@ -3454,7 +3471,7 @@ Version_check: =item writedoc -Obsolete, depecated method. Not used since Version 5.21. +Obsolete, deprecated method. Not used since Version 5.21. =cut @@ -3478,7 +3495,22 @@ sub xs_c { return '' unless $self->needs_linking(); ' .xs.c: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c +'; +} + +=item xs_cpp (o) + +Defines the suffix rules to compile XS files to C++. + +=cut + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp '; } @@ -3509,6 +3541,7 @@ and Win32 do. sub perl_archive { + return '$(PERL_INC)' . "/$Config{libperl}" if $^O eq "beos"; return ""; } diff --git a/contrib/perl5/lib/ExtUtils/MM_VMS.pm b/contrib/perl5/lib/ExtUtils/MM_VMS.pm index d7e59c2..8f8ac17 100644 --- a/contrib/perl5/lib/ExtUtils/MM_VMS.pm +++ b/contrib/perl5/lib/ExtUtils/MM_VMS.pm @@ -3,7 +3,7 @@ # This package is inserted into @ISA of MakeMaker's MM before the # built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS. # -# Author: Charles Bailey bailey@genetics.upenn.edu +# Author: Charles Bailey bailey@newman.upenn.edu package ExtUtils::MM_VMS; @@ -14,7 +14,7 @@ use VMS::Filespec; use File::Basename; use vars qw($Revision); -$Revision = '5.42 (31-Mar-1997)'; +$Revision = '5.52 (12-Sep-1998)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; @@ -829,7 +829,7 @@ sub cflags { $quals =~ s/ -$type$def\s*//; $def =~ s/"/""/g; if ($type eq 'D') { $definestr .= qq["$def",]; } - elsif ($type eq 'I') { $flagincstr .= ',' . $self->fixpath($def,1); } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } else { $undefstr .= qq["$def",]; } } } @@ -869,7 +869,7 @@ sub cflags { my(@includes) = split(/\s+/,$self->{INC}); foreach (@includes) { s/^-I//; - $incstr .= ', '.$self->fixpath($_,1); + $incstr .= ','.$self->fixpath($_,1); } } $quals .= "$incstr)"; @@ -1322,6 +1322,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); unless ($self->{SKIPHASH}{'dynamic'}) { @@ -1343,7 +1344,8 @@ $(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt $(BASEEXT).opt : Makefile.PL $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" - ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ], - neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),')" + neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars), + q[, 'FUNCLIST' => ],neatvalue($funclist),')" $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); @@ -1389,7 +1391,7 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep push @m, ' $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) - $(NOECHO) If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' + If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; @@ -1441,7 +1443,7 @@ $(INST_STATIC) : $(NOECHO) $(NOOP) ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); - my(@m); + my(@m,$lib); push @m,' # Rely on suffix rule for update action $(OBJECT) : $(INST_ARCHAUTODIR).exists @@ -1463,7 +1465,10 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); } - push(@m,"\t",'$(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;"',"\n"); + foreach $lib (split $self->{EXTRALIBS}) { + $lib = '""' if $lib eq '"'; + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); } @@ -1530,15 +1535,20 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { - my $vmsplfile = vmsify($plfile); - my $vmsfile = vmsify($self->{PL_FILES}->{$plfile}); - push @m, " + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { + my $vmsplfile = vmsify($plfile); + my $vmsfile = vmsify($target); + push @m, " all :: $vmsfile \$(NOECHO) \$(NOOP) $vmsfile :: $vmsplfile -",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile $vmsfile "; + } } join "", @m; } @@ -2188,7 +2198,8 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } - my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir); + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); # The front matter of the linkcommand... $linkcmd = join ' ', $Config{'ld'}, @@ -2251,28 +2262,46 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) # (e.g. Intuit::DWIM will precede Intuit, so unresolved # references from [.intuit.dwim]dwim.obj can be found # in [.intuit]intuit.olb). - for (sort keys %olbs) { + for (sort { length($a) <=> length($b) } keys %olbs) { next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; my($dir) = $self->fixpath($_,1); my($extralibs) = $dir . "extralibs.ld"; my($extopt) = $dir . $olbs{$_}; $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need if (-f $extralibs ) { + my %seenthis; open LIST,$extralibs or warn $!,next; - push @$extra, <LIST>; + while (<LIST>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } close LIST; } + # Get full name of extension for ExtUtils::Miniperl if (-f $extopt) { open OPT,$extopt or die $!; while (<OPT>) { next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; - # ExtUtils::Miniperl expects Unix paths - (my($pkg) = "$1_$1$self->{LIB_EXT}") =~ s#_*#/#g; + my $pkg = $1; + $pkg =~ s#__*#::#g; push @staticpkgs,$pkg; } - push @staticopts, $extopt; } } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; ($shrtarget,$targdir) = fileparse($target); @@ -2281,11 +2310,11 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $target = "Perlshr.$Config{'dlext'}" unless $target; $tmp = "[]" unless $tmp; $tmp = $self->fixpath($tmp,1); - if (@$extra) { - $extralist = join(' ',@$extra); - $extralist =~ s/[,\s\n]+/, /g; - } - else { $extralist = ''; } + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary for us (but skip PerlShr; + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split +($self->ext())[2]; if ($libperl) { unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { print STDOUT "Warning: $libperl not found\n"; @@ -2309,19 +2338,22 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) MAP_TARGET = ',$self->fixpath($target,0),' MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd -MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' -# We use the linker options files created with each extension, rather than -#specifying the object files directly on the command line. -MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '',' -MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : ''," +MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," MAP_EXTRA = $extralist MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; - push @m,' -$(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt",' - $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",' + push @m,"\n${tmp}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmp}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + +push @m,' +$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say" @@ -2329,13 +2361,17 @@ $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt" $(NOECHO) $(SAY) "To remove the intermediate files, say $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) map_clean" '; - push @m,' -',"${tmp}perlmain.c",' : $(MAKEFILE) - $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) -'; + push @m,"\n${tmp}perlmain.c : \$(MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmp}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmp}Writemain.tmp\n]; + } + push @m,' + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" ',$tmp,'Writemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) ',"${tmp}Writemain.tmp\n"; push @m, q[ -# More from the 255-char line length limit +# Still more from the 255-char line length limit doc_inst_perl : $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp @@ -2358,7 +2394,7 @@ clean :: map_clean map_clean : \$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE) - \$(RM_F) ${tmp}PerlShr.Opt \$(MAP_TARGET) + \$(RM_F) ${tmp}Makeaperl.Opt ${tmp}PerlShr.Opt \$(MAP_TARGET) "; join '', @m; diff --git a/contrib/perl5/lib/ExtUtils/MM_Win32.pm b/contrib/perl5/lib/ExtUtils/MM_Win32.pm index a1226b5..4070b2e 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Win32.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Win32.pm @@ -33,6 +33,7 @@ $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; $GCC = 1 if $Config{'cc'} =~ /^gcc/i; $DMAKE = 1 if $Config{'make'} =~ /^dmake/i; $NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +$PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; sub dlsyms { @@ -40,6 +41,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -52,6 +54,7 @@ $self->{BASEEXT}.def: Makefile.PL -e "Mksymlists('NAME' => '!, $self->{NAME}, q!', 'DLBASE' => '!,$self->{DLBASE}, q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars), q!);" !); @@ -445,11 +448,18 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp }); - } else { - push(@m, $BORLAND ? - q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} : - q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)} - ); + } elsif ($BORLAND) { + push(@m, + q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,} + .($DMAKE ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) } + .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)} + : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) } + .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))}) + .q{,$(RESFILES)}); + } else { # VC + push(@m, + q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } + .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); } push @m, ' $(CHMOD) 755 $@ @@ -463,7 +473,7 @@ sub perl_archive { my ($self) = @_; if($OBJ) { - if ($self->{CAPI} eq 'TRUE') { + if ($self->{CAPI}) { return '$(PERL_INC)\perlCAPI$(LIB_EXT)'; } } @@ -524,10 +534,11 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib(qw[ }. - ($NMAKE ? '<<pmfiles.dat' - : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)'). - q{ ],'}.$autodir.q{')" + -e "pm_to_blib(}. + ($NMAKE ? 'qw[ <<pmfiles.dat ],' + : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],' + : '{ qw[$(PM_TO_BLIB)] },' + ).q{'}.$autodir.q{')" }. ($NMAKE ? q{ $(PM_TO_BLIB) << diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm index 5b7bb0b..08a1c66 100644 --- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm +++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm @@ -2,7 +2,7 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$Version = $VERSION = "5.4301"; +$VERSION = "5.4302"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) ($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//; @@ -35,9 +35,7 @@ use vars qw( # @ISA = qw(Exporter); @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); -@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists - $Version); - # $Version in mixed case will go away! +@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists); # # Dummy package MM inherits actual methods from OS-specific @@ -73,10 +71,6 @@ $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; -# This is for module authors to query, so they can enable 'CAPI' => 'TRUE' -# in their Makefile.pl -$CAPI_support = 1; - require ExtUtils::MM_Unix; if ($Is_VMS) { @@ -192,7 +186,7 @@ sub prompt ($;$) { } else { print "$def\n"; } - return $ans || $def; + return ($ans ne '') ? $ans : $def; } sub eval_in_subdirs { @@ -241,29 +235,23 @@ sub full_setup { @Attrib_help = qw/ - AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION LICENSE_HREF CAPI - C CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS - EXE_FILES EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H - INC INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H IMPORTS + INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB - INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIB LIBS + INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIB LIBPERL_A LIBS LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB - NAME NEEDS_LINKING NOECHO NORECURS OBJECT OPTIMIZE PERL PERLMAINCC + NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PMLIBDIRS PREFIX + PL_FILES PM PMLIBDIRS PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean - tool_autosplit PPM_INSTALL_SCRIPT PPM_INSTALL_EXEC - - IMPORTS - - installpm + tool_autosplit /; - # IMPORTS is used under OS/2 - - # ^^^ installpm is deprecated, will go about Summer 96 + # IMPORTS is used under OS/2 and Win32 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These @@ -428,6 +416,7 @@ sub ExtUtils::MakeMaker::new { } my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits { # no strict; print "Blessing Object into class [$newclass]\n" if $Verbose>=2; @@ -450,9 +439,17 @@ sub ExtUtils::MakeMaker::new { unless $self->file_name_is_absolute($self->{$key}) || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } - $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + if (exists $self->{PARENT}->{CAPI} + and not exists $self->{CAPI}) + { + # inherit, but only if already unspecified + $self->{CAPI} = $self->{PARENT}->{CAPI}; + } + } } else { - parse_args($self,@ARGV); + parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV); } $self->{NAME} ||= $self->guess_name; @@ -487,6 +484,9 @@ END $self->init_dirscan(); $self->init_others(); + my($argv) = neatvalue(\@ARGV); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; push @{$self->{RESULT}}, <<END; # This Makefile is for the $self->{NAME} extension to perl. @@ -497,6 +497,8 @@ END # # ANY CHANGES MADE HERE WILL BE LOST! # +# MakeMaker ARGV: $argv +# # MakeMaker Parameters: END @@ -541,7 +543,6 @@ END } push @{$self->{RESULT}}, "\n# End."; - pop @Parent; $self; } @@ -1026,7 +1027,7 @@ This will replace the string specified by $Config{prefix} in all $Config{install*} values. Note, that in both cases the tilde expansion is done by MakeMaker, not -by perl by default, nor by make. Conflicts between parmeters LIB, +by perl by default, nor by make. Conflicts between parameters LIB, PREFIX and the various INSTALL* arguments are resolved so that XXX @@ -1176,12 +1177,33 @@ recommends it (or you know what you're doing). The following attributes can be specified as arguments to WriteMakefile() or as NAME=VALUE pairs on the command line: -=cut +=over 2 -# The following "=item C" is used by the attrib_help routine -# likewise the "=back" below. So be careful when changing it! +=item AUTHOR -=over 2 +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + +=item ABSTRACT + +One line description of the module. Will be included in PPD file. + +=item ABSTRACT_FROM + +Name of the file that contains the package description. MakeMaker looks +for a line in the POD matching /^($package\s-\s)(.*)/. This is typically +the first line in the "=head1 NAME" section. $2 becomes the abstract. + +=item BINARY_LOCATION + +Used when creating PPD files for binary packages. It can be set to a +full or relative path or URL to the binary archive for a particular +architecture. For example: + + perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz + +builds a PPD package that references a binary of the C<Agent> package, +located in the C<x86> directory relative to the PPD itself. =item C @@ -1189,6 +1211,14 @@ Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. +=item CAPI + +Switch to force usage of the Perl C API even when compiling for PERL_OBJECT. + +Note that this attribute is passed through to any recursive build, +but if and only if the submodule's Makefile.PL itself makes no mention +of the 'CAPI' attribute. + =item CCFLAGS String that will be included in the compiler call command line between @@ -1237,12 +1267,12 @@ NAME above. =item DL_FUNCS -Hashref of symbol names for routines to be made available as -universal symbols. Each key/value pair consists of the package name -and an array of routine names in that package. Used only under AIX -(export lists) and VMS (linker options) at present. The routine -names supplied will be expanded in the same way as XSUB names are -expanded by the XS() macro. Defaults to +Hashref of symbol names for routines to be made available as universal +symbols. Each key/value pair consists of the package name and an +array of routine names in that package. Used only under AIX, OS/2, +VMS and Win32 at present. The routine names supplied will be expanded +in the same way as XSUB names are expanded by the XS() macro. +Defaults to {"$(NAME)" => ["boot_$(NAME)" ] } @@ -1251,12 +1281,14 @@ e.g. {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], "NetconfigPtr" => [ 'DESTROY'] } +Please see the L<ExtUtils::Mksymlists> documentation for more information +about the DL_FUNCS, DL_VARS and FUNCLIST attributes. + =item DL_VARS -Array of symbol names for variables to be made available as -universal symbols. Used only under AIX (export lists) and VMS -(linker options) at present. Defaults to []. (e.g. [ qw( -Foo_version Foo_numstreams Foo_tree ) ]) +Array of symbol names for variables to be made available as universal symbols. +Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. +(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) =item EXCLUDE_EXT @@ -1265,7 +1297,7 @@ is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more details. (e.g. [ qw( Socket POSIX ) ] ) This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL EXCLUDE_EXT='Socket Safe' +command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' =item EXE_FILES @@ -1273,13 +1305,6 @@ Ref to array of executable files. The files will be copied to the INST_SCRIPT directory. Make realclean will delete them from there again. -=item NO_VC - -In general any generated Makefile checks for the current version of -MakeMaker and the version the Makefile was built under. If NO_VC is -set, the version check is neglected. Do not write this into your -Makefile.PL, use it interactively instead. - =item FIRST_MAKEFILE The name of the Makefile to be produced. Defaults to the contents of @@ -1290,13 +1315,21 @@ that will be produced for the MAP_TARGET. Perl binary able to run this extension. +=item FUNCLIST + +This provides an alternate means to specify function names to be +exported from the extension. Its value is a reference to an +array of function names to be exported by the extension. These +names are passed through unaltered to the linker options file. + =item H Ref to array of *.h file names. Similar to C. =item IMPORTS -IMPORTS is only used on OS/2. +This attribute is used to specify names to be imported into the +extension. It is only used on OS/2 and Win32. =item INC @@ -1315,7 +1348,7 @@ filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then only DynaLoader and the current extension will be included in the build. This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' +command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' =item INSTALLARCHLIB @@ -1353,14 +1386,14 @@ directory if INSTALLDIRS is set to perl. Used by 'make install' which copies files from INST_SCRIPT to this directory. -=item INSTALLSITELIB +=item INSTALLSITEARCH -Used by 'make install', which copies files from INST_LIB to this +Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to site (default). -=item INSTALLSITEARCH +=item INSTALLSITELIB -Used by 'make install', which copies files from INST_ARCHLIB to this +Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to site (default). =item INST_ARCHLIB @@ -1403,16 +1436,16 @@ defaults to "$(OBJECT)" and is used in the ld command to specify what files to link/load from (also see dynamic_lib below for how to specify ld flags) -=item LIBPERL_A - -The filename of the perllibrary that will be used together with this -extension. Defaults to libperl.a. - =item LIB LIB can only be set at C<perl Makefile.PL> time. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any +=item LIBPERL_A + +The filename of the perllibrary that will be used together with this +extension. Defaults to libperl.a. + =item LIBS An anonymous array of alternative library @@ -1497,6 +1530,13 @@ itself. Boolean. Attribute to inhibit descending into subdirectories. +=item NO_VC + +In general any generated Makefile checks for the current version of +MakeMaker and the version the Makefile was built under. If NO_VC is +set, the version check is neglected. Do not write this into your +Makefile.PL, use it interactively instead. + =item OBJECT List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long @@ -1532,7 +1572,7 @@ avoided, it may be undefined) =item PERM_RW -Desired Permission for read/writable files. Defaults to C<644>. +Desired permission for read/writable files. Defaults to C<644>. See also L<MM_Unix/perm_rw>. =item PERM_RWX @@ -1549,7 +1589,11 @@ and the basename of the file being the value. E.g. {'foobar.PL' => 'foobar'} The *.PL files are expected to produce output to the target files -themselves. +themselves. If multiple files can be generated from the same *.PL +file then the value in the hash can be a reference to an array of +target file names. E.g. + + {'foobar.PL' => ['foobar1','foobar2']} =item PM @@ -1569,6 +1613,15 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +=item PPM_INSTALL_EXEC + +Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) + +=item PPM_INSTALL_SCRIPT + +Name of the script that gets executed by the Perl Package Manager after +the installation of a package. + =item PREFIX Can be used to set the three INSTALL* attributes in one go (except for @@ -1703,10 +1756,6 @@ links the rest. Default is 'best'. {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} -=item installpm - -Deprecated as of MakeMaker 5.23. See L<ExtUtils::MM_Unix/pm_to_blib>. - =item linkext {LINKTYPE => 'static', 'dynamic' or ''} @@ -1733,12 +1782,6 @@ be linked. =back -=cut - -# bug in pod2html, so leave the =back - -# Don't delete this cut, MM depends on it! - =head2 Overriding MakeMaker Methods If you cannot achieve the desired Makefile behaviour by specifying @@ -1916,6 +1959,18 @@ in a subdirectory of some other distribution, or is listed as a dependency in a CPAN::Bundle, but the functionality is supported by different means on the current architecture). +=head1 ENVIRONMENT + +=over 8 + +=item PERL_MM_OPT + +Command line options used by C<MakeMaker-E<gt>new()>, and thus by +C<WriteMakefile()>. The string is split on whitespace, and the result +is processed before any actual command line arguments are processed. + +=back + =head1 SEE ALSO ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib, @@ -1925,7 +1980,7 @@ ExtUtils::Install, ExtUtils::Embed Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. -VMS support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 +VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Contact the makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if you have any questions. diff --git a/contrib/perl5/lib/ExtUtils/Manifest.pm b/contrib/perl5/lib/ExtUtils/Manifest.pm index 5557089..1a6dde7 100644 --- a/contrib/perl5/lib/ExtUtils/Manifest.pm +++ b/contrib/perl5/lib/ExtUtils/Manifest.pm @@ -298,7 +298,7 @@ but in doing so checks each line in an existing C<MANIFEST> file and includes any comments that are found in the existing C<MANIFEST> file in the new one. Anything between white space and an end of line within a C<MANIFEST> file is considered to be a comment. Filenames and -comments are seperated by one or more TAB characters in the +comments are separated by one or more TAB characters in the output. All files that match any regular expression in a file C<MANIFEST.SKIP> (if such a file exists) are ignored. @@ -317,7 +317,7 @@ Fullcheck() does both a manicheck() and a filecheck(). Skipcheck() lists all the files that are skipped due to your C<MANIFEST.SKIP> file. -Manifind() retruns a hash reference. The keys of the hash are the +Manifind() returns a hash reference. The keys of the hash are the files found below the current directory. Maniread($file) reads a named C<MANIFEST> file (defaults to diff --git a/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm index 35d5236..25c374c 100644 --- a/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm +++ b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm @@ -1,6 +1,6 @@ package ExtUtils::Mkbootstrap; -$VERSION = substr q$Revision: 1.13 $, 10; +$VERSION = substr q$Revision: 1.14 $, 10; # $Date: 1996/09/03 17:04:43 $ use Config; @@ -49,7 +49,7 @@ sub Mkbootstrap { print BS "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; print BS "# Do not edit this file, changes will be lost.\n"; print BS "# This file was automatically generated by the\n"; - print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$Version).\n"; + print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; print BS "\@DynaLoader::dl_resolve_using = "; # If @all contains names in the form -lxxx or -Lxxx then it's asking for # runtime library location so we automatically add a call to dl_findfile() diff --git a/contrib/perl5/lib/ExtUtils/Mksymlists.pm b/contrib/perl5/lib/ExtUtils/Mksymlists.pm index 0b92ca0..76535d9 100644 --- a/contrib/perl5/lib/ExtUtils/Mksymlists.pm +++ b/contrib/perl5/lib/ExtUtils/Mksymlists.pm @@ -19,10 +19,10 @@ sub Mksymlists { $spec{DL_VARS} = [] unless $spec{DL_VARS}; ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; $spec{DL_FUNCS} = { $spec{NAME} => [] } unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or - $spec{FUNCLIST}); - $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + @{$spec{FUNCLIST}}); if (defined $spec{DL_FUNCS}) { my($package); foreach $package (keys %{$spec{DL_FUNCS}}) { @@ -89,10 +89,10 @@ sub _write_os2 { print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; -my ($name, $exp); -while (($name, $exp)= each %{$data->{IMPORTS}}) { - print DEF " $name=$exp\n"; -} + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print DEF " $name=$exp\n"; + } } close DEF; } @@ -207,10 +207,13 @@ keys are recognized: =over -=item NAME +=item DLBASE -This gives the name of the extension (I<e.g.> Tk::Canvas) for which -the linker option file will be produced. +This item specifies the name by which the linker knows the +extension, which may be different from the name of the +extension itself (for instance, some linkers add an '_' to the +name of the extension). If it is not specified, it is derived +from the NAME attribute. It is presently used only by OS2 and Win32. =item DL_FUNCS @@ -219,7 +222,7 @@ from which it is usually taken. Its value is a reference to an associative array, in which each key is the name of a package, and each value is an a reference to an array of function names which should be exported by the extension. For instance, one might say -C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], +C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The function names should be identical to those in the XSUB code; C<Mksymlists> will alter the names written to the linker option @@ -243,7 +246,7 @@ be exported by the extension. This key can be used to specify the name of the linker option file (minus the OS-specific extension), if for some reason you do not want to use the default value, which is the last word of the NAME -attribute (I<e.g.> for Tk::Canvas, FILE defaults to 'Canvas'). +attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>). =item FUNCLIST @@ -251,14 +254,25 @@ This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. +Specifying a value for the FUNCLIST attribute suppresses automatic +generation of the bootstrap function for the package. To still create +the bootstrap name you have to specify the package name in the +DL_FUNCS hash: -=item DLBASE + Mksymlists({ NAME => $name , + FUNCLIST => [ $func1, $func2 ], + DL_FUNCS => { $pkg => [] } }); -This item specifies the name by which the linker knows the -extension, which may be different from the name of the -extension itself (for instance, some linkers add an '_' to the -name of the extension). If it is not specified, it is derived -from the NAME attribute. It is presently used only by OS2. + +=item IMPORTS + +This attribute is used to specify names to be imported into the +extension. It is currently only used by OS/2 and Win32. + +=item NAME + +This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which +the linker option file will be produced. =back @@ -269,7 +283,7 @@ can be used to provide additional information to the linker. =head1 AUTHOR -Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> +Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> =head1 REVISION diff --git a/contrib/perl5/lib/ExtUtils/typemap b/contrib/perl5/lib/ExtUtils/typemap index 28fd99c..b1ec063 100644 --- a/contrib/perl5/lib/ExtUtils/typemap +++ b/contrib/perl5/lib/ExtUtils/typemap @@ -1,12 +1,12 @@ # $Header$ # basic C types int T_IV -unsigned T_IV -unsigned int T_IV +unsigned T_UV +unsigned int T_UV long T_IV -unsigned long T_IV +unsigned long T_UV short T_IV -unsigned short T_IV +unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV @@ -34,7 +34,7 @@ I16 T_IV I8 T_IV U32 T_U_LONG U16 T_U_SHORT -U8 T_IV +U8 T_UV Result T_U_CHAR Boolean T_IV double T_DOUBLE @@ -73,6 +73,8 @@ T_CVREF croak(\"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT @@ -82,19 +84,19 @@ T_ENUM T_BOOL $var = (int)SvIV($arg) T_U_INT - $var = (unsigned int)SvIV($arg) + $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT - $var = (unsigned short)SvIV($arg) + $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG - $var = (unsigned long)SvIV($arg) + $var = (unsigned long)SvUV($arg) T_CHAR $var = (char)*SvPV($arg,PL_na) T_U_CHAR - $var = (unsigned char)SvIV($arg) + $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV @@ -191,6 +193,8 @@ T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET @@ -205,19 +209,19 @@ T_ENUM T_BOOL $arg = boolSV($var); T_U_INT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV diff --git a/contrib/perl5/lib/ExtUtils/xsubpp b/contrib/perl5/lib/ExtUtils/xsubpp index 523dabc..1ee7b29 100755 --- a/contrib/perl5/lib/ExtUtils/xsubpp +++ b/contrib/perl5/lib/ExtUtils/xsubpp @@ -776,7 +776,7 @@ while (<$FH>) { /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; if ($OBJ) { - s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; + s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; } print $_; } @@ -1254,30 +1254,37 @@ EOF } # print initialization routine -if ($WantCAPI) { + print Q<<"EOF"; -# ##ifdef __cplusplus #extern "C" ##endif +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##ifdef PERL_CAPI #XS(boot__CAPI_entry) -#[[ -# dXSARGS; -# char* file = __FILE__; -# +##else EOF -} else { +} + print Q<<"EOF"; -##ifdef __cplusplus -#extern "C" -##endif #XS(boot_$Module_cname) +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##endif /* PERL_CAPI */ +EOF +} + +print Q<<"EOF"; #[[ # dXSARGS; # char* file = __FILE__; # EOF -} print Q<<"EOF" if $WantVersionChk ; # XS_VERSION_BOOTCHECK ; @@ -1312,7 +1319,7 @@ EOF if ($WantCAPI) { print Q<<"EOF"; -# +##ifdef PERL_CAPI ##define XSCAPI(name) void name(CV* cv, void* pPerl) # ##ifdef __cplusplus @@ -1323,7 +1330,7 @@ print Q<<"EOF"; # SetCPerlObj(pPerl); # boot__CAPI_entry(cv); #]] -# +##endif /* PERL_CAPI */ EOF } diff --git a/contrib/perl5/lib/Fatal.pm b/contrib/perl5/lib/Fatal.pm index a1e5cff..d1d95af 100644 --- a/contrib/perl5/lib/Fatal.pm +++ b/contrib/perl5/lib/Fatal.pm @@ -111,11 +111,13 @@ EOS $code .= write_invocation($core, $call, $name, @protos); $code .= "}\n"; print $code if $Debug; - $code = eval($code); - die if $@; - local($^W) = 0; # to avoid: Subroutine foo redefined ... - no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... - *{$sub} = $code; + { + no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... + $code = eval("package $pkg; use Carp; $code"); + die if $@; + local($^W) = 0; # to avoid: Subroutine foo redefined ... + *{$sub} = $code; + } } 1; diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm index d0b3c89..e1da6b6 100644 --- a/contrib/perl5/lib/File/Copy.pm +++ b/contrib/perl5/lib/File/Copy.pm @@ -235,7 +235,7 @@ B<Note that passing in files as handles instead of names may lead to loss of information on some operating systems; it is recommended that you use file names whenever possible.> Files are opened in binary mode where -applicable. To get a consistent behavour when copying from a +applicable. To get a consistent behaviour when copying from a filehandle to a file, use C<binmode> on the filehandle. An optional third parameter can be used to specify the buffer @@ -274,7 +274,7 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) +=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2) If both arguments to C<copy> are not file handles, then C<copy> will perform a "system copy" of @@ -336,7 +336,7 @@ $! will be set if an error was encountered. =head1 AUTHOR File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, -and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. +and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. =cut diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm index 1305d21..7e67003 100644 --- a/contrib/perl5/lib/File/Find.pm +++ b/contrib/perl5/lib/File/Find.pm @@ -22,10 +22,10 @@ finddepth - traverse a directory structure depth-first =head1 DESCRIPTION The first argument to find() is either a hash reference describing the -operations to be performed for each file, or a code reference. If it -is a hash reference, then the value for the key C<wanted> should be a -code reference. This code reference is called I<the wanted() -function> below. +operations to be performed for each file, a code reference, or a string +that contains a subroutine name. If it is a hash reference, then the +value for the key C<wanted> should be a code reference. This code +reference is called I<the wanted() function> below. Currently the only other supported key for the above hash is C<bydepth>, in presense of which the walk over directories is @@ -177,6 +177,8 @@ sub finddir { --$subcount; next if $prune; + # Untaint $_, so that we can do a chdir + $_ = $1 if /^(.*)/; if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; &finddir($wanted,$name,$nlink, $bydepth); @@ -194,7 +196,7 @@ sub finddir { sub wrap_wanted { my $wanted = shift; - defined &$wanted ? {wanted => $wanted} : $wanted; + ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; } sub find { diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm index 39f1ba1..225ecab 100644 --- a/contrib/perl5/lib/File/Path.pm +++ b/contrib/perl5/lib/File/Path.pm @@ -88,7 +88,7 @@ in situations where security is an issue. =head1 AUTHORS Tim Bunce <F<Tim.Bunce@ig.co.uk>> and -Charles Bailey <F<bailey@genetics.upenn.edu>> +Charles Bailey <F<bailey@newman.upenn.edu>> =head1 REVISION @@ -135,8 +135,9 @@ sub mkpath { } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - # allow for another process to have created it meanwhile - croak "mkdir $path: $!" unless -d $path; + my $e = $!; + # allow for another process to have created it meanwhile + croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm index 5f3dbf5..616dcbc 100644 --- a/contrib/perl5/lib/File/Spec.pm +++ b/contrib/perl5/lib/File/Spec.pm @@ -91,7 +91,7 @@ but rather as class methods: File::Spec->catfile('a','b'); -For a reference of available functions, pleaes consult L<File::Spec::Unix>, +For a reference of available functions, please consult L<File::Spec::Unix>, which contains the entire set, and inherited by the modules for other platforms. For further information, please see L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. @@ -106,7 +106,7 @@ File::Spec::VMS, ExtUtils::MakeMaker Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS -support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 support by +support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder <F<schinder@pobox.com>>. diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm index 4968e24..63a9e12 100644 --- a/contrib/perl5/lib/File/Spec/Mac.pm +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -52,7 +52,7 @@ The fundamental requirement of this routine is that File::Spec->catdir(split(":",$path)) eq $path But because of the nature of Macintosh paths, some additional -possibilities are allowed to make using this routine give resonable results +possibilities are allowed to make using this routine give reasonable results for some common situations. Here are the rules that are used. Each argument has its trailing ":" removed. Each argument, except the first, has its leading ":" removed. They are then joined together by a ":". @@ -78,7 +78,7 @@ Under MacPerl, there is an additional ambiguity. Does the user intend that File::Spec->catfile("LWP","Protocol","http.pm") be relative or absolute? There's no way of telling except by checking for the -existance of LWP: or :LWP, and even there he may mean a dismounted volume or +existence of LWP: or :LWP, and even there he may mean a dismounted volume or a relative path in a different directory (like in @INC). So those checks aren't done here. This routine will treat this as absolute. diff --git a/contrib/perl5/lib/FindBin.pm b/contrib/perl5/lib/FindBin.pm index d6bd7b7..9e1c0a0 100644 --- a/contrib/perl5/lib/FindBin.pm +++ b/contrib/perl5/lib/FindBin.pm @@ -55,7 +55,10 @@ Workaround is to invoke perl as =head1 AUTHORS -Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> +FindBin is supported as part of the core perl distribution. Please send bug +reports to E<lt>F<perlbug@perl.org>E<gt> using the perlbug program included with perl. + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt> =head1 COPYRIGHT @@ -64,10 +67,6 @@ Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=head1 REVISION - -$Revision: 1.4 $ - =cut package FindBin; @@ -77,31 +76,13 @@ require Exporter; use Cwd qw(getcwd abs_path); use Config; use File::Basename; +use File::Spec; @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/); - -sub is_abs_path -{ - local $_ = shift if (@_); - if ($^O eq 'MSWin32' || $^O eq 'dos') - { - return m#^[a-z]:[\\/]#i; - } - elsif ($^O eq 'VMS') - { - # If it's a logical name, expand it. - $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_}; - return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/; - } - else - { - return m#^/#; - } -} +$VERSION = $VERSION = "1.42"; BEGIN { @@ -131,13 +112,12 @@ BEGIN && -f $script) { my $dir; - my $pathvar = 'PATH'; - - foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar})) + foreach $dir (File::Spec->path) { - if(-r "$dir/$script" && (!$IsWin32 || -x _)) + my $scr = File::Spec->catfile($dir, $script); + if(-r $scr && (!$IsWin32 || -x _)) { - $script = "$dir/$script"; + $script = $scr; if (-f $0) { @@ -160,7 +140,8 @@ BEGIN # Ensure $script contains the complete path incase we C<chdir> - $script = getcwd() . "/" . $script unless is_abs_path($script); + $script = File::Spec->catfile(getcwd(), $script) + unless File::Spec->file_name_is_absolute($script); ($Script,$Bin) = fileparse($script); @@ -172,9 +153,9 @@ BEGIN ($RealScript,$RealBin) = fileparse($script); last unless defined $linktext; - $script = (is_abs_path($linktext)) + $script = (File::Spec->file_name_is_absolute($linktext)) ? $linktext - : $RealBin . "/" . $linktext; + : File::Spec->catfile($RealBin, $linktext); } # Get absolute paths to directories diff --git a/contrib/perl5/lib/Getopt/Long.pm b/contrib/perl5/lib/Getopt/Long.pm index 1966ef3..c125ccf 100644 --- a/contrib/perl5/lib/Getopt/Long.pm +++ b/contrib/perl5/lib/Getopt/Long.pm @@ -6,13 +6,13 @@ package Getopt::Long; # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Jun 14 13:17:22 1998 -# Update Count : 705 +# Last Modified On: Fri Jan 8 14:48:43 1999 +# Update Count : 707 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1998 by Johan Vromans. +# This program is Copyright 1990,1999 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -35,7 +35,7 @@ BEGIN { require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = "2.17"; + $VERSION = "2.19"; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -547,6 +547,7 @@ sub FindOption ($$$$$$$) { # If bundling == 2, long options can override bundles. if ( $bundling == 2 and + defined ($rest) and defined ($type = $opctl->{$tryopt.$rest}) ) { print STDERR ("=> $starter$tryopt rebundled to ", "$starter$tryopt$rest\n") if $debug; @@ -1363,7 +1364,7 @@ Johan Vromans E<lt>jvromans@squirrel.nlE<gt> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1998 by Johan Vromans. +This program is Copyright 1990,1999 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 diff --git a/contrib/perl5/lib/Getopt/Std.pm b/contrib/perl5/lib/Getopt/Std.pm index c2cd123..390bf14 100644 --- a/contrib/perl5/lib/Getopt/Std.pm +++ b/contrib/perl5/lib/Getopt/Std.pm @@ -42,8 +42,7 @@ the argument or 1 if no argument is specified. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); - -# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ +$VERSION = $VERSION = '1.01'; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each @@ -145,7 +144,7 @@ sub getopts ($;$) { } } else { - print STDERR "Unknown option: $first\n"; + warn "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; diff --git a/contrib/perl5/lib/IPC/Open3.pm b/contrib/perl5/lib/IPC/Open3.pm index f1415e3..d079041 100644 --- a/contrib/perl5/lib/IPC/Open3.pm +++ b/contrib/perl5/lib/IPC/Open3.pm @@ -2,15 +2,15 @@ package IPC::Open3; use strict; no strict 'refs'; # because users pass me bareword filehandles -use vars qw($VERSION @ISA @EXPORT $Fh $Me); +use vars qw($VERSION @ISA @EXPORT $Me); require 5.001; require Exporter; use Carp; -use Symbol 'qualify'; +use Symbol qw(gensym qualify); -$VERSION = 1.0102; +$VERSION = 1.0103; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -94,7 +94,6 @@ C<cat -v> and continually read and write a line from it. # rdr or wtr are null # a system call fails -$Fh = 'FHOPEN000'; # package static in case called more than once $Me = 'open3 (bug)'; # you should never see this, it's always localized # Fatal.pm needs to be fixed WRT prototypes. @@ -140,9 +139,9 @@ sub _open3 { $dad_rdr = qualify $dad_rdr, $package; $dad_err = qualify $dad_err, $package; - my $kid_rdr = ++$Fh; - my $kid_wtr = ++$Fh; - my $kid_err = ++$Fh; + my $kid_rdr = gensym; + my $kid_wtr = gensym; + my $kid_err = gensym; xpipe $kid_rdr, $dad_wtr if !$dup_wtr; xpipe $dad_rdr, $kid_wtr if !$dup_rdr; @@ -154,7 +153,7 @@ sub _open3 { # save a copy of her stdout before I put something else there. if ($dad_rdr ne $dad_err && $dup_err && fileno($dad_err) == fileno(STDOUT)) { - my $tmp = ++$Fh; + my $tmp = gensym; xopen($tmp, ">&$dad_err"); $dad_err = $tmp; } @@ -163,24 +162,24 @@ sub _open3 { xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); } else { xclose $dad_wtr; - xopen \*STDIN, "<&$kid_rdr"; - xclose $kid_rdr; + xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); } else { xclose $dad_rdr; - xopen \*STDOUT, ">&$kid_wtr"; - xclose $kid_wtr; + xopen \*STDOUT, ">&=" . fileno $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - xopen \*STDERR, ">&$dad_err" + # I have to use a fileno here because in this one case + # I'm doing a dup but the filehandle might be a reference + # (from the special case above). + xopen \*STDERR, ">&" . fileno $dad_err if fileno(STDERR) != fileno($dad_err); } else { xclose $dad_err; - xopen \*STDERR, ">&$kid_err"; - xclose $kid_err; + xopen \*STDERR, ">&=" . fileno $kid_err; } } else { xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); @@ -194,23 +193,23 @@ sub _open3 { my @close; if ($dup_wtr) { - $kid_rdr = $dad_wtr; - push @close, \*{$kid_rdr}; + $kid_rdr = \*{$dad_wtr}; + push @close, $kid_rdr; } else { - push @close, \*{$dad_wtr}, \*{$kid_rdr}; + push @close, \*{$dad_wtr}, $kid_rdr; } if ($dup_rdr) { - $kid_wtr = $dad_rdr; - push @close, \*{$kid_wtr}; + $kid_wtr = \*{$dad_rdr}; + push @close, $kid_wtr; } else { - push @close, \*{$dad_rdr}, \*{$kid_wtr}; + push @close, \*{$dad_rdr}, $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - $kid_err = $dad_err ; - push @close, \*{$kid_err}; + $kid_err = \*{$dad_err}; + push @close, $kid_err; } else { - push @close, \*{$dad_err}, \*{$kid_err}; + push @close, \*{$dad_err}, $kid_err; } } else { $kid_err = $kid_wtr; @@ -218,13 +217,13 @@ sub _open3 { require IO::Pipe; $kidpid = eval { spawn_with_handles( [ { mode => 'r', - open_as => \*{$kid_rdr}, + open_as => $kid_rdr, handle => \*STDIN }, { mode => 'w', - open_as => \*{$kid_wtr}, + open_as => $kid_wtr, handle => \*STDOUT }, { mode => 'w', - open_as => \*{$kid_err}, + open_as => $kid_err, handle => \*STDERR }, ], \@close, @cmd); }; diff --git a/contrib/perl5/lib/Math/BigFloat.pm b/contrib/perl5/lib/Math/BigFloat.pm index 576f341..03bc2f4 100644 --- a/contrib/perl5/lib/Math/BigFloat.pm +++ b/contrib/perl5/lib/Math/BigFloat.pm @@ -301,7 +301,7 @@ floats as =item number format canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can -have inbedded whitespace. +have imbedded whitespace. =item Error returns 'NaN' diff --git a/contrib/perl5/lib/Math/BigInt.pm b/contrib/perl5/lib/Math/BigInt.pm index ef4af61..b61b884 100644 --- a/contrib/perl5/lib/Math/BigInt.pm +++ b/contrib/perl5/lib/Math/BigInt.pm @@ -258,9 +258,9 @@ sub bdiv { #(dividend: num_str, divisor: num_str) return num_str else { push(@x, 0); } - @q = (); ($v2,$v1) = @y[-2,-1]; + @q = (); ($v2,$v1) = ($y[-2] || 0, $y[-1]); while ($#x > $#y) { - ($u2,$u1,$u0) = @x[-3..-1]; + ($u2,$u1,$u0) = ($x[-3] || 0, $x[-2] || 0, $x[-1]); $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); if ($q) { @@ -400,8 +400,8 @@ In particular perl -MMath::BigInt=:constant -e 'print 2**100' -print the integer value of C<2**100>. Note that without convertion of -constants the expression 2**100 will be calculatted as floating point number. +print the integer value of C<2**100>. Note that without conversion of +constants the expression 2**100 will be calculated as floating point number. =head1 BUGS diff --git a/contrib/perl5/lib/Math/Complex.pm b/contrib/perl5/lib/Math/Complex.pm index e711c14..5b69039 100644 --- a/contrib/perl5/lib/Math/Complex.pm +++ b/contrib/perl5/lib/Math/Complex.pm @@ -14,7 +14,7 @@ use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); my ( $i, $ip2, %logn ); -$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.25 1998/02/05 16:07:37 jhi Exp $ =~ /(\d+\.\d+)/); +$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.26 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.\d+)/); @ISA = qw(Exporter); @@ -401,38 +401,21 @@ sub divide { } # -# _zerotozero -# -# Die on zero raised to the zeroth. -# -sub _zerotozero { - my $mess = "The zero raised to the zeroth power is not defined.\n"; - - my @up = caller(1); - - $mess .= "Died at $up[1] line $up[2].\n"; - - die $mess; -} - -# # (power) # # Computes z1**z2 = exp(z2 * log z1)). # sub power { my ($z1, $z2, $inverted) = @_; - my $z1z = $z1 == 0; - my $z2z = $z2 == 0; - _zerotozero if ($z1z and $z2z); if ($inverted) { - return 0 if ($z2z); - return 1 if ($z1z or $z2 == 1); + return 1 if $z1 == 0 || $z2 == 1; + return 0 if $z2 == 0 && Re($z1) > 0; } else { - return 0 if ($z1z); - return 1 if ($z2z or $z1 == 1); + return 1 if $z2 == 0 || $z1 == 1; + return 0 if $z1 == 0 && Re($z2) > 0; } - my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) : CORE::exp($z2 * CORE::log($z1)); + my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) + : CORE::exp($z2 * CORE::log($z1)); # If both arguments cartesian, return cartesian, else polar. return $z1->{c_dirty} == 0 && (not ref $z2 or $z2->{c_dirty} == 0) ? @@ -443,7 +426,7 @@ sub power { # (spaceship) # # Computes z1 <=> z2. -# Sorts on the real part first, then on the imaginary part. Thus 2-4i > 3+8i. +# Sorts on the real part first, then on the imaginary part. Thus 2-4i < 3+8i. # sub spaceship { my ($z1, $z2, $inverted) = @_; @@ -1273,7 +1256,7 @@ sub gcd { my ($a, $b) = @_; my $id = "$a $b"; - + unless (exists $gcd{$id}) { $gcd{$id} = _gcd($a, $b); $gcd{"$b $a"} = $gcd{$id}; @@ -1702,7 +1685,7 @@ Here are some examples: The division (/) and the following functions log ln log10 logn - tan sec csc cot + tan sec csc cot atan asec acsc acot tanh sech csch coth atanh asech acsch acoth diff --git a/contrib/perl5/lib/Math/Trig.pm b/contrib/perl5/lib/Math/Trig.pm index b7b5d5d..924286d 100644 --- a/contrib/perl5/lib/Math/Trig.pm +++ b/contrib/perl5/lib/Math/Trig.pm @@ -314,9 +314,11 @@ known as the I<radial> coordinate. The angle in the I<xy>-plane coordinate. The angle from the I<z>-axis is B<phi>, also known as the I<polar> coordinate. The `North Pole' is therefore I<0, 0, rho>, and the `Bay of Guinea' (think of the missing big chunk of Africa) I<0, -pi/2, rho>. +pi/2, rho>. In geographical terms I<phi> is latitude (northward +positive, southward negative) and I<theta> is longitude (eastward +positive, westward negative). -B<Beware>: some texts define I<theta> and I<phi> the other way round, +B<BEWARE>: some texts define I<theta> and I<phi> the other way round, some texts define the I<phi> to start from the horizontal plane, some texts use I<r> in place of I<rho>. @@ -374,13 +376,25 @@ by importing the C<great_circle_distance> function: use Math::Trig 'great_circle_distance' - $distance = great_circle_distance($theta0, $phi0, $theta1, $phi, [, $rho]); + $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]); The I<great circle distance> is the shortest distance between two points on a sphere. The distance is in C<$rho> units. The C<$rho> is optional, it defaults to 1 (the unit sphere), therefore the distance defaults to radians. +If you think geographically the I<theta> are longitudes: zero at the +Greenwhich meridian, eastward positive, westward negative--and the +I<phi> are latitudes: zero at the North Pole, northward positive, +southward negative. B<NOTE>: this formula thinks in mathematics, not +geographically: the I<phi> zero is at the North Pole, not at the +Equator on the west coast of Africa (Bay of Guinea). You need to +subtract your geographical coordinates from I<pi/2> (also known as 90 +degrees). + + $distance = great_circle_distance($lon0, pi/2 - $lat0, + $lon1, pi/2 - $lat1, $rho); + =head1 EXAMPLES To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N @@ -394,8 +408,8 @@ To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N $km = great_circle_distance(@L, @T, 6378); -The answer may be off by up to 0.3% because of the irregular (slightly -aspherical) form of the Earth. +The answer may be off by few percentages because of the irregular +(slightly aspherical) form of the Earth. =head1 BUGS diff --git a/contrib/perl5/lib/Net/hostent.pm b/contrib/perl5/lib/Net/hostent.pm index 96b090d..d586358 100644 --- a/contrib/perl5/lib/Net/hostent.pm +++ b/contrib/perl5/lib/Net/hostent.pm @@ -89,7 +89,7 @@ $h_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $host_obj-E<gt>aliases() }> would be simply @h_aliases. -The gethost() funtion is a simple front-end that forwards a numeric +The gethost() function is a simple front-end that forwards a numeric argument to gethostbyaddr() by way of Socket::inet_aton, and the rest to gethostbyname(). diff --git a/contrib/perl5/lib/Net/netent.pm b/contrib/perl5/lib/Net/netent.pm index b82447c..fbc6d98 100644 --- a/contrib/perl5/lib/Net/netent.pm +++ b/contrib/perl5/lib/Net/netent.pm @@ -92,7 +92,7 @@ $n_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $net_obj-E<gt>aliases() }> would be simply @n_aliases. -The getnet() funtion is a simple front-end that forwards a numeric +The getnet() function is a simple front-end that forwards a numeric argument to getnetbyaddr(), and the rest to getnetbyname(). diff --git a/contrib/perl5/lib/Pod/Html.pm b/contrib/perl5/lib/Pod/Html.pm index 5d2e07b..e71afa8 100644 --- a/contrib/perl5/lib/Pod/Html.pm +++ b/contrib/perl5/lib/Pod/Html.pm @@ -11,6 +11,8 @@ use Cwd; use Carp; +use locale; # make \w work right in non-ASCII lands + use strict; use Config; @@ -300,18 +302,20 @@ sub pod2html { open(HTML, ">$htmlfile") || die "$0: cannot open $htmlfile file for output: $!\n"; - # put a title in the HTML file - $title = ''; - TITLE_SEARCH: { - for (my $i = 0; $i < @poddata; $i++) { - if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { - for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s; - } - } + # put a title in the HTML file if one wasn't specified + if ($title eq '') { + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH + if ($title) = $para =~ /(\S+\s+-+.*\S)/s; + } + } - } - } + } + } + } if (!$title and $podfile =~ /\.pod$/) { # probably a split pod so take first =head[12] as title for (my $i = 0; $i < @poddata; $i++) { @@ -1371,9 +1375,6 @@ sub process_L { # LREF: a la HREF L<show this text|man/section> $linktext = $1 if s:^([^|]+)\|::; - # a :: acts like a / - s,::,/,; - # make sure sections start with a / s,^",/",g; s,^,/,g if (!m,/, && / /); @@ -1397,6 +1398,11 @@ sub process_L { if ($page eq "") { $link = "#" . htmlify(0,$section); $linktext = $section unless defined($linktext); + } elsif ( $page =~ /::/ ) { + $linktext = ($section ? "$section" : "$page"); + $page =~ s,::,/,g; + $link = "$htmlroot/$page.html"; + $link .= "#" . htmlify(0,$section) if ($section); } elsif (!defined $pages{$page}) { warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n"; $link = ""; diff --git a/contrib/perl5/lib/Pod/Text.pm b/contrib/perl5/lib/Pod/Text.pm index 67993db..549bab5 100644 --- a/contrib/perl5/lib/Pod/Text.pm +++ b/contrib/perl5/lib/Pod/Text.pm @@ -52,6 +52,8 @@ require Exporter; use vars qw($VERSION); $VERSION = "1.0203"; +use locale; # make \w work right in non-ASCII lands + $termcap=0; $opt_alt_format = 0; @@ -273,14 +275,14 @@ sub prepare_for_output { my $paratag = $_; $_ = <IN>; if (/^=/) { # tricked! - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($paratag); redo POD_DIRECTIVE; } &prepare_for_output; IP_output($paratag, $_); } else { - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($_, 0); } } @@ -368,7 +370,7 @@ sub fill { sub IP_output { local($tag, $_) = @_; - local($tag_indent) = $indent[$#index - 1] || $DEF_INDENT; + local($tag_indent) = $indent[$#indent - 1] || $DEF_INDENT; $tag_cols = $SCREEN - $tag_indent; $cols = $SCREEN - $indent; $tag =~ s/\s*$//; diff --git a/contrib/perl5/lib/SelfLoader.pm b/contrib/perl5/lib/SelfLoader.pm index a73f68a..311d953 100644 --- a/contrib/perl5/lib/SelfLoader.pm +++ b/contrib/perl5/lib/SelfLoader.pm @@ -133,7 +133,7 @@ is available for reading via the filehandle FOOBAR::DATA, where FOOBAR is the name of the current package when the C<__DATA__> token is reached. This works just the same as C<__END__> does in package 'main', but for other modules data after C<__END__> is not -automatically retreivable , whereas data after C<__DATA__> is. +automatically retrievable, whereas data after C<__DATA__> is. The C<__DATA__> token is not recognized in versions of perl prior to 5.001m. @@ -203,7 +203,7 @@ There is no need to inherit from the B<SelfLoader>. The B<SelfLoader> works similarly to the AutoLoader, but picks up the subs from after the C<__DATA__> instead of in the 'lib/auto' directory. -There is a maintainance gain in not needing to run AutoSplit on the module +There is a maintenance gain in not needing to run AutoSplit on the module at installation, and a runtime gain in not needing to keep opening and closing files to load subs. There is a runtime loss in needing to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and diff --git a/contrib/perl5/lib/Symbol.pm b/contrib/perl5/lib/Symbol.pm index 5ed6b26..a842c1c 100644 --- a/contrib/perl5/lib/Symbol.pm +++ b/contrib/perl5/lib/Symbol.pm @@ -46,7 +46,7 @@ C<Symbol::qualify> turns unqualified symbol names into qualified variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a second parameter, C<qualify> uses it as the default package; otherwise, it uses the package of its caller. Regardless, global -variable names (e.g. "STDOUT", "ENV", "SIG") are always qualfied with +variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with "main::". Qualification applies only to symbol names (strings). References are diff --git a/contrib/perl5/lib/Term/Complete.pm b/contrib/perl5/lib/Term/Complete.pm index 275aade..445dfca 100644 --- a/contrib/perl5/lib/Term/Complete.pm +++ b/contrib/perl5/lib/Term/Complete.pm @@ -5,7 +5,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(Complete); -# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 =head1 NAME @@ -13,8 +13,8 @@ Term::Complete - Perl word completion module =head1 SYNOPSIS - $input = complete('prompt_string', \@completion_list); - $input = complete('prompt_string', @completion_list); + $input = Complete('prompt_string', \@completion_list); + $input = Complete('prompt_string', @completion_list); =head1 DESCRIPTION @@ -56,7 +56,7 @@ Bell sounds when word completion fails. =head1 BUGS -The completion charater E<lt>tabE<gt> cannot be changed. +The completion character E<lt>tabE<gt> cannot be changed. =head1 AUTHOR @@ -72,7 +72,11 @@ CONFIG: { } sub Complete { - my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + my($prompt, @cmp_list, $cmp, $test, $l, @match); + my ($return, $r) = ("", 0); + + $return = ""; + $r = 0; $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @@ -90,17 +94,17 @@ sub Complete { # (TAB) attempt completion $_ eq "\t" && do { @match = grep(/^$return/, @cmp_lst); - $l = length($test = shift(@match)); unless ($#match < 0) { + $l = length($test = shift(@match)); foreach $cmp (@match) { until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { $l--; } } print("\a"); + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); } - print($test = substr($test, $r, $l - $r)); - $r = length($return .= $test); last CASE; }; @@ -113,8 +117,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef $r; - undef $return; + $r = 0; + $return = ""; print("\r\n"); redo LOOP; } diff --git a/contrib/perl5/lib/Term/ReadLine.pm b/contrib/perl5/lib/Term/ReadLine.pm index 470226d..e7cf00c 100644 --- a/contrib/perl5/lib/Term/ReadLine.pm +++ b/contrib/perl5/lib/Term/ReadLine.pm @@ -139,7 +139,7 @@ None =head1 ENVIRONMENT -The envrironment variable C<PERL_RL> governs which ReadLine clone is +The environment variable C<PERL_RL> governs which ReadLine clone is loaded. If the value is false, a dummy interface is used. If the value is true, it should be tail of the name of the package to use, such as C<Perl> or C<Gnu>. diff --git a/contrib/perl5/lib/Test.pm b/contrib/perl5/lib/Test.pm index 6f57415..7a0e59b 100644 --- a/contrib/perl5/lib/Test.pm +++ b/contrib/perl5/lib/Test.pm @@ -2,17 +2,19 @@ use strict; package Test; use Test::Harness 1.1601 (); use Carp; -use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish - qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish -$VERSION = '1.04'; +use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish + qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish +$VERSION = '1.122'; require Exporter; @ISA=('Exporter'); -@EXPORT= qw(&plan &ok &skip $ntest); +@EXPORT=qw(&plan &ok &skip); +@EXPORT_OK=qw($ntest $TESTOUT); $TestLevel = 0; # how many extra stack frames to skip $|=1; #$^W=1; ? $ntest=1; +$TESTOUT = *STDOUT{IO}; # Use of this variable is strongly discouraged. It is set mainly to # help test coverage analyzers know which test is running. @@ -35,9 +37,9 @@ sub plan { } my @todo = sort { $a <=> $b } keys %todo; if (@todo) { - print "1..$max todo ".join(' ', @todo).";\n"; + print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; } else { - print "1..$max\n"; + print $TESTOUT "1..$max\n"; } ++$planned; } @@ -47,9 +49,6 @@ sub to_value { (ref $v or '') eq 'CODE' ? $v->() : $v; } -# STDERR is NOT used for diagnostic output which should have been -# fixed before release. Is this appropriate? - sub ok ($;$$) { croak "ok: plan before you test!" if !$planned; my ($pkg,$file,$line) = caller($TestLevel); @@ -63,49 +62,49 @@ sub ok ($;$$) { $ok = $result; } else { $expected = to_value(shift); - # until regex can be manipulated like objects... my ($regex,$ignore); - if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or + if ((ref($expected)||'') eq 'Regexp') { + $ok = $result =~ /$expected/; + } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { $ok = $result =~ /$regex/; } else { $ok = $result eq $expected; } } - if ($todo{$ntest}) { - if ($ok) { - print "ok $ntest # Wow! ($context)\n"; - } else { - $diag = to_value(shift) if @_; - if (!$diag) { - print "not ok $ntest # (failure expected in $context)\n"; - } else { - print "not ok $ntest # (failure expected: $diag)\n"; - } - } + my $todo = $todo{$ntest}; + if ($todo and $ok) { + $context .= ' TODO?!' if $todo; + print $TESTOUT "ok $ntest # ($context)\n"; } else { - print "not " if !$ok; - print "ok $ntest\n"; + print $TESTOUT "not " if !$ok; + print $TESTOUT "ok $ntest\n"; if (!$ok) { my $detail = { 'repetition' => $repetition, 'package' => $pkg, - 'result' => $result }; + 'result' => $result, 'todo' => $todo }; $$detail{expected} = $expected if defined $expected; $diag = $$detail{diagnostic} = to_value(shift) if @_; + $context .= ' *TODO*' if $todo; if (!defined $expected) { if (!$diag) { - print STDERR "# Failed test $ntest in $context\n"; + print $TESTOUT "# Failed test $ntest in $context\n"; } else { - print STDERR "# Failed test $ntest in $context: $diag\n"; + print $TESTOUT "# Failed test $ntest in $context: $diag\n"; } } else { my $prefix = "Test $ntest"; - print STDERR "# $prefix got: '$result' ($context)\n"; + print $TESTOUT "# $prefix got: '$result' ($context)\n"; $prefix = ' ' x (length($prefix) - 5); + if ((ref($expected)||'') eq 'Regexp') { + $expected = 'qr/'.$expected.'/' + } else { + $expected = "'$expected'"; + } if (!$diag) { - print STDERR "# $prefix Expected: '$expected'\n"; + print $TESTOUT "# $prefix Expected: $expected\n"; } else { - print STDERR "# $prefix Expected: '$expected' ($diag)\n"; + print $TESTOUT "# $prefix Expected: $expected ($diag)\n"; } } push @FAILDETAIL, $detail; @@ -116,8 +115,10 @@ sub ok ($;$$) { } sub skip ($$;$$) { - if (to_value(shift)) { - print "ok $ntest # skip\n"; + my $whyskip = to_value(shift); + if ($whyskip) { + $whyskip = 'skip' if $whyskip =~ m/^\d+$/; + print $TESTOUT "ok $ntest # $whyskip\n"; ++ $ntest; 1; } else { @@ -141,7 +142,12 @@ __END__ use strict; use Test; - BEGIN { plan tests => 13, todo => [3,4] } + + # use a BEGIN block so we print our plan before MyModule is loaded + BEGIN { plan tests => 14, todo => [3,4] } + + # load your module... + use MyModule; ok(0); # failure ok(1); # success @@ -152,10 +158,11 @@ __END__ ok(0,1); # failure: '0' ne '1' ok('broke','fixed'); # failure: 'broke' ne 'fixed' ok('fixed','fixed'); # success: 'fixed' eq 'fixed' + ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ ok(sub { 1+1 }, 2); # success: '2' eq '2' ok(sub { 1+1 }, 3); # failure: '2' ne '3' - ok(0, int(rand(2)); # (just kidding! :-) + ok(0, int(rand(2)); # (just kidding :-) my @list = (0,0); ok @list, 3, "\@list=".join(',',@list); #extra diagnostics @@ -165,9 +172,9 @@ __END__ =head1 DESCRIPTION -Test::Harness expects to see particular output when it executes tests. -This module aims to make writing proper test scripts just a little bit -easier (and less error prone :-). +L<Test::Harness> expects to see particular output when it executes +tests. This module aims to make writing proper test scripts just a +little bit easier (and less error prone :-). =head1 TEST TYPES @@ -175,57 +182,64 @@ easier (and less error prone :-). =item * NORMAL TESTS -These tests are expected to succeed. If they don't, something's +These tests are expected to succeed. If they don't something's screwed up! =item * SKIPPED TESTS -Skip tests need a platform specific feature that might or might not be -available. The first argument should evaluate to true if the required -feature is NOT available. After the first argument, skip tests work +Skip is for tests that might or might not be possible to run depending +on the availability of platform specific features. The first argument +should evaluate to true (think "yes, please skip") if the required +feature is not available. After the first argument, skip works exactly the same way as do normal tests. =item * TODO TESTS -TODO tests are designed for maintaining an executable TODO list. -These tests are expected NOT to succeed (otherwise the feature they -test would be on the new feature list, not the TODO list). +TODO tests are designed for maintaining an B<executable TODO list>. +These tests are expected NOT to succeed. If a TODO test does succeed, +the feature in question should not be on the TODO list, now should it? -Packages should NOT be released with successful TODO tests. As soon +Packages should NOT be released with succeeding TODO tests. As soon as a TODO test starts working, it should be promoted to a normal test -and the newly minted feature should be documented in the release -notes. +and the newly working feature should be documented in the release +notes or change log. =back +=head1 RETURN VALUE + +Both C<ok> and C<skip> return true if their test succeeds and false +otherwise in a scalar context. + =head1 ONFAIL BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } -The test failures can trigger extra diagnostics at the end of the test -run. C<onfail> is passed an array ref of hash refs that describe each -test failure. Each hash will contain at least the following fields: -package, repetition, and result. (The file, line, and test number are -not included because their correspondance to a particular test is -fairly weak.) If the test had an expected value or a diagnostic -string, these will also be included. - -This optional feature might be used simply to print out the version of -your package and/or how to report problems. It might also be used to -generate extremely sophisticated diagnostics for a particular test -failure. It's not a panacea, however. Core dumps or other -unrecoverable errors will prevent the C<onfail> hook from running. -(It is run inside an END block.) Besides, C<onfail> is probably -over-kill in the majority of cases. (Your test code should be simpler +While test failures should be enough, extra diagnostics can be +triggered at the end of a test run. C<onfail> is passed an array ref +of hash refs that describe each test failure. Each hash will contain +at least the following fields: C<package>, C<repetition>, and +C<result>. (The file, line, and test number are not included because +their correspondance to a particular test is tenuous.) If the test +had an expected value or a diagnostic string, these will also be +included. + +The B<optional> C<onfail> hook might be used simply to print out the +version of your package and/or how to report problems. It might also +be used to generate extremely sophisticated diagnostics for a +particularly bizarre test failure. However it's not a panacea. Core +dumps or other unrecoverable errors prevent the C<onfail> hook from +running. (It is run inside an C<END> block.) Besides, C<onfail> is +probably over-kill in most cases. (Your test code should be simpler than the code it is testing, yes?) =head1 SEE ALSO -L<Test::Harness> and various test coverage analysis tools. +L<Test::Harness> and, perhaps, test coverage analysis tools. =head1 AUTHOR -Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (c) 1998 Joshua Nathaniel Pritikin. All rights reserved. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified diff --git a/contrib/perl5/lib/Test/Harness.pm b/contrib/perl5/lib/Test/Harness.pm index 9c61d3a..935e8f0 100644 --- a/contrib/perl5/lib/Test/Harness.pm +++ b/contrib/perl5/lib/Test/Harness.pm @@ -160,7 +160,7 @@ sub runtests { } else { push @failed, $next..$max; $failed = @failed; - (my $txt, $canon) = canonfailed($max,@failed); + (my $txt, $canon) = canonfailed($max,$skipped,@failed); $percent = 100*(scalar @failed)/$max; print "DIED. ",$txt; } @@ -173,7 +173,7 @@ sub runtests { } elsif ($ok == $max && $next == $max+1) { if ($max and $skipped + $bonus) { my @msg; - push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped") + push(@msg, "$skipped/$max subtest".($skipped>1?'s':'')." skipped") if $skipped; push(@msg, "$bonus subtest".($bonus>1?'s':''). " unexpectedly succeeded") @@ -191,7 +191,7 @@ sub runtests { push @failed, $next..$max; } if (@failed) { - my ($txt, $canon) = canonfailed($max,@failed); + my ($txt, $canon) = canonfailed($max,$skipped,@failed); print $txt; $failedtests{$test} = { canon => $canon, max => $max, failed => scalar @failed, @@ -300,7 +300,7 @@ sub corestatus { } sub canonfailed ($@) { - my($max,@failed) = @_; + my($max,$skipped,@failed) = @_; my %seen; @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; my $failed = @failed; @@ -330,7 +330,12 @@ sub canonfailed ($@) { } push @result, "\tFailed $failed/$max tests, "; - push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; + push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay"; + my $ender = 's' x ($skipped > 1); + my $good = $max - $failed - $skipped; + my $goodper = sprintf("%.2f",100*($good/$max)); + push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped; + push @result, "\n"; my $txt = join "", @result; ($txt, $canon); } diff --git a/contrib/perl5/lib/Text/ParseWords.pm b/contrib/perl5/lib/Text/ParseWords.pm index 2414f80..065c2f7 100644 --- a/contrib/perl5/lib/Text/ParseWords.pm +++ b/contrib/perl5/lib/Text/ParseWords.pm @@ -63,7 +63,7 @@ sub parse_line { ([\000-\377]*) # and the rest | # --OR-- ^((?:\\.|[^\\"'])*?) # an $unquoted text - (\Z(?!\n)|$delimiter|(?!^)(?=["'])) + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) # plus EOL, delimiter, or quote ([\000-\377]*) # the rest /x; # extended layout diff --git a/contrib/perl5/lib/Text/Wrap.pm b/contrib/perl5/lib/Text/Wrap.pm index 0fe7fb9..5f95edb 100644 --- a/contrib/perl5/lib/Text/Wrap.pm +++ b/contrib/perl5/lib/Text/Wrap.pm @@ -1,57 +1,65 @@ package Text::Wrap; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug); -use strict; -use Exporter; +require Exporter; -$VERSION = "97.02"; @ISA = qw(Exporter); -@EXPORT = qw(wrap); -@EXPORT_OK = qw($columns $tabstop fill); +@EXPORT = qw(wrap fill); +@EXPORT_OK = qw($columns $break $huge); -use Text::Tabs qw(expand unexpand $tabstop); +$VERSION = 98.112902; +use vars qw($VERSION $columns $debug $break $huge); +use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; + $columns = 76; # <= screen width + $debug = 0; + $break = '\s'; + $huge = 'wrap'; # alternatively: 'die' } +use Text::Tabs qw(expand unexpand); + sub wrap { - my ($ip, $xp, @t) = @_; - - my @rv; - my $t = expand(join(" ",@t)); - - my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; - my $nl = ""; - - $t =~ s/^\s+//; - while(length($t) > $ll) { - # remove up to a line length of things that - # aren't new lines and tabs. - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { - my ($l,$r) = ($1,$2); - $l =~ s/\s+$//; - print "WRAP $lead$l..($r)\n" if $debug; - push @rv, unexpand($lead . $l), "\n"; - - } elsif ($t =~ s/^([^\n]{$ll})//) { - print "SPLIT $lead$1..\n" if $debug; - push @rv, unexpand($lead . $1),"\n"; + my ($ip, $xp, @t) = @_; + + my $r = ""; + my $t = expand(join(" ",@t)); + my $lead = $ip; + my $ll = $columns - length(expand($ip)) - 1; + my $nll = $columns - length(expand($xp)) - 1; + my $nl = ""; + my $remainder = ""; + + while ($t !~ /^\s*$/) { + if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) { + $r .= unexpand($nl . $lead . $1); + $remainder = $2; + } elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) { + $r .= unexpand($nl . $lead . $1); + $remainder = "\n"; + } elsif ($huge eq 'die') { + die "couldn't wrap '$t'"; + } else { + die "This shouldn't happen"; + } + + $lead = $xp; + $ll = $nll; + $nl = "\n"; } - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $t =~ s/^\s+//; - } - print "TAIL $lead$t\n" if $debug; - push @rv, $lead.$t if $t ne ""; - return join '', @rv; -} + $r .= $remainder; + print "-----------$r---------\n" if $debug; + + print "Finish up with '$lead', '$t'\n" if $debug; + + $r .= $lead . $t if $t ne ""; + + print "-----------$r---------\n" if $debug;; + return $r; +} sub fill { @@ -83,26 +91,32 @@ Text::Wrap - line wrapping to form simple paragraphs use Text::Wrap print wrap($initial_tab, $subsequent_tab, @text); + print fill($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns $tabstop fill); + use Text::Wrap qw(wrap $columns $huge); $columns = 132; - $tabstop = 4; - - print fill($initial_tab, $subsequent_tab, @text); - print fill("", "", `cat book`); + $huge = 'die'; + $huge = 'wrap'; =head1 DESCRIPTION Text::Wrap::wrap() is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. +single paragraph at a time by breaking lines at word boundaries. Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. +all subsequent lines ($subsequent_tab) independently. + +Lines are wrapped at $Text::Wrap::columns columns. +$Text::Wrap::columns should be set to the full width of your output device. + +When words that are longer than $columns are encountered, they +are broken up. Previous versions of wrap() die()ed instead. +To restore the old (dying) behavior, set $Text::Wrap::huge to +'die'. Text::Wrap::fill() is a simple multi-paragraph formatter. It formats each paragraph separately and then joins them together when it's done. It -will destory any whitespace in the original text. It breaks text into +will destroy any whitespace in the original text. It breaks text into paragraphs by looking for whitespace after a newline. In other respects it acts like wrap(). @@ -111,15 +125,8 @@ it acts like wrap(). print wrap("\t","","This is a bit of text that forms a normal book-style paragraph"); -=head1 BUGS - -It's not clear what the correct behavior should be when Wrap() is -presented with a word that is longer than a line. The previous -behavior was to die. Now the word is now split at line-length. - =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. Updated by Jacqui Caren. +many many others. -=cut diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm index 4041b00..3f34c3b 100644 --- a/contrib/perl5/lib/Tie/Array.pm +++ b/contrib/perl5/lib/Tie/Array.pm @@ -176,23 +176,23 @@ provides the methods below. =item STORE this, index, value -Store datum I<value> into I<index> for the tied array assoicated with +Store datum I<value> into I<index> for the tied array associated with object I<this>. If this makes the array larger then class's mapping of C<undef> should be returned for new positions. =item FETCH this, index -Retrieve the datum in I<index> for the tied array assoicated with +Retrieve the datum in I<index> for the tied array associated with object I<this>. =item FETCHSIZE this -Returns the total number of items in the tied array assoicated with +Returns the total number of items in the tied array associated with object I<this>. (Equivalent to C<scalar(@array)>). =item STORESIZE this, count -Sets the total number of items in the tied array assoicated with +Sets the total number of items in the tied array associated with object I<this> to be I<count>. If this makes the array larger then class's mapping of C<undef> should be returned for new positions. If the array becomes smaller then entries beyond count should be @@ -205,7 +205,7 @@ Can be used to optimize allocation. This method need do nothing. =item CLEAR this -Clear (remove, delete, ...) all values from the tied array assoicated with +Clear (remove, delete, ...) all values from the tied array associated with object I<this>. =item DESTROY this @@ -227,7 +227,7 @@ and return it. =item UNSHIFT this, LIST -Insert LIST elements at the begining of the array, moving existing elements +Insert LIST elements at the beginning of the array, moving existing elements up to make room. =item SPLICE this, offset, length, LIST diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm index 7ed1896..2902efb 100644 --- a/contrib/perl5/lib/Tie/Hash.pm +++ b/contrib/perl5/lib/Tie/Hash.pm @@ -92,7 +92,7 @@ but may be omitted in favor of a simple default. =head1 MORE INFORMATION -The packages relating to various DBM-related implemetations (F<DB_File>, +The packages relating to various DBM-related implementations (F<DB_File>, F<NDBM_File>, etc.) show examples of general tied hashes, as does the L<Config> module. While these do not utilize B<Tie::Hash>, they serve as good working examples. diff --git a/contrib/perl5/lib/Tie/SubstrHash.pm b/contrib/perl5/lib/Tie/SubstrHash.pm index 44c2140..4b18a58 100644 --- a/contrib/perl5/lib/Tie/SubstrHash.pm +++ b/contrib/perl5/lib/Tie/SubstrHash.pm @@ -69,7 +69,7 @@ sub FETCH { sub STORE { local($self,$key,$val) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; - croak("Table is full") if $self[5] == $tsize; + croak("Table is full") if $$self[5] == $tsize; croak(qq/Value "$val" is not $vlen characters long./) if length($val) != $vlen; my $writeoffset; diff --git a/contrib/perl5/lib/Time/Local.pm b/contrib/perl5/lib/Time/Local.pm index eef412d..b2fba7c 100644 --- a/contrib/perl5/lib/Time/Local.pm +++ b/contrib/perl5/lib/Time/Local.pm @@ -17,16 +17,18 @@ Time::Local - efficiently compute time from local and GMT time =head1 DESCRIPTION -These routines are quite efficient and yet are always guaranteed to agree -with localtime() and gmtime(). We manage this by caching the start times -of any months we've seen before. If we know the start time of the month, -we can always calculate any time within the month. The start times -themselves are guessed by successive approximation starting at the -current time, since most dates seen in practice are close to the -current date. Unlike algorithms that do a binary search (calling gmtime -once for each bit of the time value, resulting in 32 calls), this algorithm -calls it at most 6 times, and usually only once or twice. If you hit -the month cache, of course, it doesn't call it at all. +These routines are quite efficient and yet are always guaranteed to +agree with localtime() and gmtime(), the most notable points being +that year is year-1900 and month is 0..11. We manage this by caching +the start times of any months we've seen before. If we know the start +time of the month, we can always calculate any time within the month. +The start times themselves are guessed by successive approximation +starting at the current time, since most dates seen in practice are +close to the current date. Unlike algorithms that do a binary search +(calling gmtime once for each bit of the time value, resulting in 32 +calls), this algorithm calls it at most 6 times, and usually only once +or twice. If you hit the month cache, of course, it doesn't call it +at all. timelocal is implemented using the same cache. We just assume that we're translating a GMT time, and then fudge it when we're done for the timezone diff --git a/contrib/perl5/lib/Time/gmtime.pm b/contrib/perl5/lib/Time/gmtime.pm index c1d11d7..9b823f6 100644 --- a/contrib/perl5/lib/Time/gmtime.pm +++ b/contrib/perl5/lib/Time/gmtime.pm @@ -69,7 +69,7 @@ still overrides your core functions.) Access these fields as variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The gmctime() funtion provides a way of getting at the +The gmctime() function provides a way of getting at the scalar sense of the original CORE::gmtime() function. To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/Time/localtime.pm b/contrib/perl5/lib/Time/localtime.pm index 9437752..18a36c7 100644 --- a/contrib/perl5/lib/Time/localtime.pm +++ b/contrib/perl5/lib/Time/localtime.pm @@ -65,7 +65,7 @@ variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The ctime() funtion provides a way of getting at the +The ctime() function provides a way of getting at the scalar sense of the original CORE::localtime() function. To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/User/grent.pm b/contrib/perl5/lib/User/grent.pm index deb0a8d..e4e226d 100644 --- a/contrib/perl5/lib/User/grent.pm +++ b/contrib/perl5/lib/User/grent.pm @@ -74,7 +74,7 @@ to $gr_gid if you import the fields. Array references are available as regular array variables, so C<@{ $group_obj-E<gt>members() }> would be simply @gr_members. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/User/pwent.pm b/contrib/perl5/lib/User/pwent.pm index 32301ca..bb2dace 100644 --- a/contrib/perl5/lib/User/pwent.pm +++ b/contrib/perl5/lib/User/pwent.pm @@ -84,7 +84,7 @@ variables named with a preceding C<pw_> in front their method names. Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import the fields. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/constant.pm b/contrib/perl5/lib/constant.pm index 464e20c..5d3dd91 100644 --- a/contrib/perl5/lib/constant.pm +++ b/contrib/perl5/lib/constant.pm @@ -20,6 +20,18 @@ constant - Perl pragma to declare constants print "This line does nothing" unless DEBUGGING; + # references can be declared constant + use constant CHASH => { foo => 42 }; + use constant CARRAY => [ 1,2,3,4 ]; + use constant CPSEUDOHASH => [ { foo => 1}, 42 ]; + use constant CCODE => sub { "bite $_[0]\n" }; + + print CHASH->{foo}; + print CARRAY->[$i]; + print CPSEUDOHASH->{foo}; + print CCODE->("me"); + print CHASH->[10]; # compile-time error + =head1 DESCRIPTION This will declare a symbol to be a constant with the given scalar @@ -86,6 +98,8 @@ constants at compile time, allowing for way cool stuff like this. print E2BIG, "\n"; # something like "Arg list too long" print 0+E2BIG, "\n"; # "7" +Errors in dereferencing constant references are trapped at compile-time. + =head1 TECHNICAL NOTE In the current implementation, scalar constants are actually diff --git a/contrib/perl5/lib/diagnostics.pm b/contrib/perl5/lib/diagnostics.pm index 78bf445..b9aaba5 100755 --- a/contrib/perl5/lib/diagnostics.pm +++ b/contrib/perl5/lib/diagnostics.pm @@ -27,7 +27,7 @@ Aa a program: =head2 The C<diagnostics> Pragma This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them with the more +perl compiler and the perl interpreter, augmenting them with the more explicative and endearing descriptions found in L<perldiag>. Like the other pragmata, it affects the compilation phase of your program rather than merely the execution phase. diff --git a/contrib/perl5/lib/fields.pm b/contrib/perl5/lib/fields.pm index db2eea7..54602a6 100644 --- a/contrib/perl5/lib/fields.pm +++ b/contrib/perl5/lib/fields.pm @@ -32,7 +32,7 @@ does so by updating the %FIELDS hash in the calling package. If a typed lexical variable holding a reference is used to access a hash element and the %FIELDS hash of the given type exists, then the operation is turned into an array access at compile time. The %FIELDS -hash map from hash element names to the array indices. If the hash +hash maps from hash element names to the array indices. If the hash element is not present in the %FIELDS hash, then a compile-time error is signaled. @@ -57,7 +57,7 @@ constructor like this does the job: { my $class = shift; no strict 'refs'; - my $self = bless [\%{"$class\::FIELDS"], $class; + my $self = bless [\%{"$class\::FIELDS"}], $class; $self; } diff --git a/contrib/perl5/lib/overload.pm b/contrib/perl5/lib/overload.pm index 43fef8a..f06b49c 100644 --- a/contrib/perl5/lib/overload.pm +++ b/contrib/perl5/lib/overload.pm @@ -167,13 +167,6 @@ overload - Package for overloading perl operations ... $strval = overload::StrVal $b; -=head1 CAVEAT SCRIPTOR - -Overloading of operators is a subject not to be taken lightly. -Neither its precise implementation, syntax, nor semantics are -100% endorsed by Larry Wall. So any of these may be changed -at some point in the future. - =head1 DESCRIPTION =head2 Declaration of overloaded functions @@ -274,7 +267,7 @@ value of their arguments, and may leave it as is. The result is going to be assigned to the value in the left-hand-side if different from this value. -This allows for the same method to be used as averloaded C<+=> and +This allows for the same method to be used as overloaded C<+=> and C<+>. Note that this is I<allowed>, but not recommended, since by the semantic of L<"Fallback"> Perl will call the method for C<+> anyway, if C<+=> is not overloaded. @@ -283,7 +276,7 @@ if C<+=> is not overloaded. B<Warning.> Due to the presense of assignment versions of operations, routines which may be called in assignment context may create -self-referencial structures. Currently Perl will not free self-referential +self-referential structures. Currently Perl will not free self-referential structures until cycles are C<explicitly> broken. You may get problems when traversing your structures too. @@ -537,7 +530,7 @@ C<'='> was overloaded with C<\&clone>. =back -Same behaviour is triggered by C<$b = $a++>, which is consider a synonim for +Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for C<$b = $a; ++$a>. =head1 MAGIC AUTOGENERATION @@ -748,7 +741,7 @@ There is no size penalty for data if overload is not used. The only size penalty if overload is used in some package is that I<all> the packages acquire a magic during the next C<bless>ing into the package. This magic is three-words-long for packages without -overloading, and carries the cache tabel if the package is overloaded. +overloading, and carries the cache table if the package is overloaded. Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the @@ -760,8 +753,8 @@ to be changed are constant (but this is not enforced). =head1 Metaphor clash -One may wonder why the semantic of overloaded C<=> is so counterintuive. -If it I<looks> counterintuive to you, you are subject to a metaphor +One may wonder why the semantic of overloaded C<=> is so counter intuitive. +If it I<looks> counter intuitive to you, you are subject to a metaphor clash. Here is a Perl object metaphor: @@ -868,7 +861,7 @@ Put this in F<symbolic.pm> in your Perl library directory: This module is very unusual as overloaded modules go: it does not provide any usual overloaded operators, instead it provides the L<Last Resort> operator C<nomethod>. In this example the corresponding -subroutine returns an object which encupsulates operations done over +subroutine returns an object which encapsulates operations done over the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new symbolic 3> contains C<['+', 2, ['n', 3]]>. @@ -955,7 +948,7 @@ compare an object to 0. In fact, it is easier to write a numeric conversion routine. Here is the text of F<symbolic.pm> with such a routine added (and -slightly modifed str()): +slightly modified str()): package symbolic; # Primitive symbolic calculator use overload @@ -994,7 +987,7 @@ slightly modifed str()): } All the work of numeric conversion is done in %subr and num(). Of -course, %subr is not complete, it contains only operators used in teh +course, %subr is not complete, it contains only operators used in the example below. Here is the extra-credit question: why do we need an explicit recursion in num()? (Answer is at the end of this section.) @@ -1024,7 +1017,7 @@ mutator methods (C<++>, C<-=> and so on), does not do deep copying (not required without mutators!), and implements only those arithmetic operations which are used in the example. -To implement most arithmetic operattions is easy, one should just use +To implement most arithmetic operations is easy, one should just use the tables of operations, and change the code which fills %subr to my %subr = ( 'n' => sub {$_[0]} ); @@ -1102,8 +1095,8 @@ the argument of num(). If you wonder why defaults for conversion are different for str() and num(), note how easy it was to write the symbolic calculator. This simplicity is due to an appropriate choice of defaults. One extra -note: due to teh explicit recursion num() is more fragile than sym(): -we need to explicitly check for the type of $a and $b. If componets +note: due to the explicit recursion num() is more fragile than sym(): +we need to explicitly check for the type of $a and $b. If components $a and $b happen to be of some related type, this may lead to problems. =head2 I<Really> symbolic calculator diff --git a/contrib/perl5/lib/perl5db.pl b/contrib/perl5/lib/perl5db.pl index 099a49b..4d05e6d 100644 --- a/contrib/perl5/lib/perl5db.pl +++ b/contrib/perl5/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.0401; +$VERSION = 1.0402; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -235,7 +235,11 @@ $pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; +&pager((defined($ENV{PAGER}) + ? $ENV{PAGER} + : ($^O eq 'os2' + ? 'cmd /c more' + : 'more'))) unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; @@ -361,7 +365,7 @@ sub DB { # _After_ the perl program is compiled, $single is set to 1: if ($single and not $second_time++) { if ($runnonstop) { # Disable until signal - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } $single = 0; @@ -412,11 +416,11 @@ EOP $was_signal = $signal; $signal = 0; if ($single || ($trace & 1) || $was_signal) { - $term || &setterm; if ($emacs) { $position = "\032\032$filename:$line:0\n"; print $LINEINFO $position; } elsif ($package eq 'DB::fake') { + $term || &setterm; print_help(<<EOP); Debugged program terminated. Use B<q> to quit or B<R> to restart, use B<O> I<inhibit_exit> to avoid stopping after program termination, @@ -439,7 +443,7 @@ EOP $position = "$prefix$line$infix$dbline[$line]$after"; } if ($frame) { - print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; } else { print $LINEINFO $position; } @@ -450,7 +454,7 @@ EOP $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { - print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; } else { print $LINEINFO $incr_pos; } @@ -463,7 +467,7 @@ EOP foreach $evalarg (@$pre) { &eval; } - print $OUT $#stack . " levels deep in subroutine calls!\n" + print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; $incr = -1; # for backward motion. @@ -640,8 +644,9 @@ EOP $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; - last if $signal; + $i++, last if $signal; } + print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; } $start = $i; # remember in case they want more $start = $max if $start > $max; @@ -879,14 +884,14 @@ EOP } $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { end_report(), next CMD if $finished and $level <= 1; - $stack[$#stack] |= 1; - $doret = $option{PrintRet} ? $#stack - 1 : -2; + $stack[$stack_depth] |= 1; + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { print $OUT "Warning: some settings and command-line options may be lost!\n"; @@ -1169,24 +1174,26 @@ sub sub { if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { $al = " for $$sub"; } - push(@stack, $single); + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + $#stack = $stack_depth; + $stack[-1] = $single; $single &= 1; - $single |= 4 if $#stack == $deep; + $single |= 4 if $stack_depth == $deep; ($frame & 4 - ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "), # Why -1? But it works! :-( print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame; + : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - if ($doret eq $#stack or $frame & 16) { - my $fh = ($doret eq $#stack ? $OUT : $LINEINFO); - print $fh ' ' x $#stack if $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh ' ' x $stack_depth if $frame & 16; print $fh "list context return from $sub:\n"; dumpit($fh, \@ret ); $doret = -2; @@ -1198,14 +1205,14 @@ sub sub { } else { &$sub; undef $ret; }; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - if ($doret eq $#stack or $frame & 16 and defined wantarray) { - my $fh = ($doret eq $#stack ? $OUT : $LINEINFO); - print $fh (' ' x $#stack) if $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh (' ' x $stack_depth) if $frame & 16; print $fh (defined wantarray ? "scalar context return from $sub: " : "void context return from $sub\n"); @@ -1226,7 +1233,6 @@ sub save { sub eval { my @res; { - local (@stack) = @stack; # guard against recursive debugging my $otrace = $trace; my $osingle = $single; my $od = $^D; @@ -1284,7 +1290,7 @@ sub postponed { $filename =~ s/^_<//; $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename}; - print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame; + print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame; return unless $postponed_file{$filename}; $had_breakpoints{$filename}++; #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic @@ -1432,7 +1438,6 @@ sub system { sub setterm { local $frame = 0; local $doret = -2; - local @stack = @stack; # Prevent growth by failing `use'. eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { @@ -1747,13 +1752,7 @@ sub list_versions { } $version{$file} .= $INC{$file}; } - do 'dumpvar.pl' unless defined &main::dumpValue; - if (defined &main::dumpValue) { - local $frame = 0; - &main::dumpValue(\%version); - } else { - print $OUT "dumpvar.pl not available.\n"; - } + dumpit($OUT,\%version); } sub sethelp { @@ -2073,6 +2072,7 @@ BEGIN { # This does not compile, alas. # @stack and $doret are needed in sub sub, which is called for DB::postponed. # Triggers bug (?) in perl is we postpone this until runtime: @postponed = @stack = (0); + $stack_depth = 0; # Localized $#stack $doret = -2; $frame = 0; } |