diff options
author | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-10-16 11:09:25 +0000 |
---|---|---|
committer | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-10-16 11:09:25 +0000 |
commit | d58bf5aa3d3631a46847733b1ff1985b30140228 (patch) | |
tree | 406c095d697ae0ae82bbf187e5c65151bd41232a /lib | |
parent | c7848ba184fac8eca4125f4296d6e09fee2c1846 (diff) | |
parent | 50e27ac33704d6fb34d4be7cfb426b2097b27505 (diff) | |
download | perl-d58bf5aa3d3631a46847733b1ff1985b30140228.tar.gz |
Merge maint-5.004 branch (5.004_04) with mainline.
p4raw-id: //depot/perl@137
Diffstat (limited to 'lib')
-rw-r--r-- | lib/AutoLoader.pm | 14 | ||||
-rw-r--r-- | lib/CPAN.pm | 1414 | ||||
-rw-r--r-- | lib/CPAN/FirstTime.pm | 4 | ||||
-rw-r--r-- | lib/Carp.pm | 2 | ||||
-rw-r--r-- | lib/Cwd.pm | 44 | ||||
-rw-r--r-- | lib/English.pm | 2 | ||||
-rw-r--r-- | lib/ExtUtils/Install.pm | 34 | ||||
-rw-r--r-- | lib/ExtUtils/Liblist.pm | 51 | ||||
-rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 17 | ||||
-rwxr-xr-x | lib/ExtUtils/xsubpp | 4 | ||||
-rw-r--r-- | lib/File/DosGlob.pm | 63 | ||||
-rw-r--r-- | lib/File/Find.pm | 4 | ||||
-rw-r--r-- | lib/FileHandle.pm | 5 | ||||
-rw-r--r-- | lib/Getopt/Long.pm | 33 | ||||
-rw-r--r-- | lib/Getopt/Std.pm | 8 | ||||
-rw-r--r-- | lib/Math/Complex.pm | 424 | ||||
-rw-r--r-- | lib/Sys/Hostname.pm | 13 | ||||
-rw-r--r-- | lib/Sys/Syslog.pm | 18 | ||||
-rw-r--r-- | lib/Test/Harness.pm | 13 | ||||
-rw-r--r-- | lib/Time/Local.pm | 3 | ||||
-rw-r--r-- | lib/autouse.pm | 8 | ||||
-rw-r--r-- | lib/base.pm | 49 | ||||
-rw-r--r-- | lib/blib.pm | 1 | ||||
-rwxr-xr-x | lib/diagnostics.pm | 2 | ||||
-rw-r--r-- | lib/getopt.pl | 4 | ||||
-rw-r--r-- | lib/perl5db.pl | 51 | ||||
-rw-r--r-- | lib/vars.pm | 55 |
27 files changed, 1468 insertions, 872 deletions
diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index c45483b02d..2773a90f10 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -1,6 +1,5 @@ package AutoLoader; -use Carp; use vars qw(@EXPORT @EXPORT_OK); BEGIN { @@ -42,7 +41,9 @@ AUTOLOAD { } if ($@){ $@ =~ s/ at .*\n//; - croak $@; + my $error = $@; + require Carp; + Carp::croak($error); } } } @@ -83,7 +84,11 @@ sub import { $path ="auto/$calldir/autosplit.ix"; eval { require $path; }; } - carp $@ if ($@); + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } } } @@ -169,6 +174,7 @@ Instead, they should define their own AUTOLOAD subroutines along these lines: use AutoLoader; + use Carp; sub AUTOLOAD { my $constname; @@ -183,7 +189,7 @@ lines: croak "Your vendor has not defined constant $constname"; } } - eval "sub $AUTOLOAD { $val }"; + *$AUTOLOAD = sub { $val }; # same as: eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 8271076bef..11af0a6885 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,12 +1,17 @@ package CPAN; -use vars qw{$Try_autoload - $META $Signal $Cwd $End $Suppress_readline %Dontload}; +use vars qw{$Try_autoload $Revision + $META $Signal $Cwd $End + $Suppress_readline %Dontload + $Frontend + }; -$VERSION = '1.27'; +$VERSION = '1.3102'; -# $Id: CPAN.pm,v 1.160 1997/07/28 12:21:56 k Exp $ +# $Id: CPAN.pm,v 1.202 1997/09/23 18:30:36 k Exp k $ -# my $version = substr q$Revision: 1.160 $, 10; # only used during development +# only used during development: +$Revision = ""; +# $Revision = "[".substr(q$Revision: 1.202 $, 10)."]"; use Carp (); use Config (); @@ -43,14 +48,19 @@ END { $End++; &cleanup; } $CPAN::DEBUG ||= 0; $CPAN::Signal ||= 0; +$CPAN::Frontend ||= "CPAN::Shell"; package CPAN; use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); -@CPAN::ISA = qw(CPAN::Debug Exporter MM); # the MM class from - # MakeMaker, gives us - # catfile and catdir +@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? @EXPORT = qw( autobundle bundle expand force get @@ -69,14 +79,12 @@ sub AUTOLOAD { my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); if ($ok) { goto &$AUTOLOAD; - } else { - warn "not OK: $@"; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD"); } - warn "CPAN doesn't know how to autoload $AUTOLOAD :-( -Nothing Done. -"; - sleep 1; - CPAN::Shell->h; + $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }. + qq{Type ? for help. +}); } } @@ -103,11 +111,13 @@ sub shell { ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; - print qq{ -cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) -Readline support $rl_avail + $CPAN::Frontend->myprint( + qq{ +cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision) +ReadLine support $rl_avail -} unless $CPAN::Config->{'inhibit_startup_message'} ; +}) unless $CPAN::Config->{'inhibit_startup_message'} ; + my($continuation) = ""; while () { if ($Suppress_readline) { print $prompt; @@ -116,10 +126,17 @@ Readline support $rl_avail } else { last unless defined ($_ = $term->readline($prompt)); } + $_ = "$continuation$_" if $continuation; s/^\s+//; next if /^$/; $_ = 'h' if $_ eq '?'; - if (/^\!/) { + if (/^q(?:uit)?$/i) { + last; + } elsif (s/\\$//s) { + chomp; + $continuation = $_; + $prompt = " > "; + } elsif (/^\!/) { s/^\!//; my($eval) = $_; package CPAN::Eval; @@ -128,8 +145,8 @@ Readline support $rl_avail CPAN->debug("eval[$eval]") if $CPAN::DEBUG; eval($eval); warn $@ if $@; - } elsif (/^q(?:uit)?$/i) { - last; + $continuation = ""; + $prompt = "cpan> "; } elsif (/./) { my(@line); if ($] < 5.00322) { # parsewords had a bug until recently @@ -142,17 +159,19 @@ Readline support $rl_avail my $command = shift @line; eval { CPAN::Shell->$command(@line) }; warn $@ if $@; + chdir $cwd; + $CPAN::Frontend->myprint("\n"); + $continuation = ""; + $prompt = "cpan> "; } } continue { - &cleanup, die "Goodbye\n" if $Signal; - chdir $cwd; - print "\n"; + &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal; } } package CPAN::CacheMgr; use vars qw($Du); -@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); use File::Find; package CPAN::Config; @@ -166,7 +185,7 @@ use vars qw(%can $dot_cpan); ); package CPAN::FTP; -use vars qw($Ua); +use vars qw($Ua $Thesite $Themethod); @CPAN::FTP::ISA = qw(CPAN::Debug); package CPAN::Complete; @@ -200,30 +219,29 @@ use vars qw($AUTOLOAD $redef @ISA); #-> sub CPAN::Shell::AUTOLOAD ; sub AUTOLOAD { my($autoload) = $AUTOLOAD; + my $class = shift(@_); $autoload =~ s/.*:://; if ($autoload =~ /^w/) { if ($CPAN::META->has_inst('CPAN::WAIT')) { - CPAN::WAIT->wh; + CPAN::WAIT->$autoload(@_); } else { - print STDERR qq{ + $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 install CPAN::WAIT -} +}); } } else { my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); if ($ok) { goto &$AUTOLOAD; - } else { - warn "not OK: $@"; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $autoload"); } - warn "CPAN::Shell doesn't know how to autoload $autoload :-( -Nothing Done. -"; - sleep 1; - CPAN::Shell->h; + $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }. + qq{Type ? for help. +}); } } @@ -269,17 +287,11 @@ sub try_dot_al { $ok = 1; } $@ = $save; - my $lm = Carp::longmess(); +# my $lm = Carp::longmess(); # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug return $ok; } -# This should be left to a runtime evaluation -eval {require CPAN::WAIT;}; -unless ($@) { - unshift @ISA, "CPAN::WAIT"; -} - #### autoloader is experimental #### to try it we have to set $Try_autoload and uncomment #### the use statement and uncomment the __END__ below @@ -289,7 +301,8 @@ unless ($@) { # $Try_autoload = 1; if ($CPAN::Try_autoload) { - for my $p (qw( + my $p; + for $p (qw( CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module @@ -340,7 +353,7 @@ sub all { #-> sub CPAN::checklock ; sub checklock { my($self) = @_; - my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock"); + my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock"); if (-f $lockfile && -M _ > 0) { my $fh = FileHandle->new($lockfile); my $other = <$fh>; @@ -348,20 +361,23 @@ sub checklock { if (defined $other && $other) { chomp $other; return if $$==$other; # should never happen - print qq{There seems to be running another CPAN process }. - qq{($other). Trying to contact...\n}; + $CPAN::Frontend->mywarn( + qq{ +There seems to be running another CPAN process ($other). Contacting... +}); if (kill 0, $other) { - Carp::croak qq{Other job is running.\n}. - qq{You may want to kill it and delete the lockfile, }. - qq{maybe. On UNIX try:\n}. - qq{ kill $other\n}. - qq{ rm $lockfile\n}; + $CPAN::Frontend->mydie(qq{Other job is running. +You may want to kill it and delete the lockfile, maybe. On UNIX try: + kill $other + rm $lockfile +}); } elsif (-w $lockfile) { my($ans) = ExtUtils::MakeMaker::prompt (qq{Other job not responding. Shall I overwrite }. qq{the lockfile? (Y/N)},"y"); - print("Ok, bye\n"), exit unless $ans =~ /^y/i; + $CPAN::Frontend->myexit("Ok, bye\n") + unless $ans =~ /^y/i; } else { Carp::croak( qq{Lockfile $lockfile not writeable by you. }. @@ -379,7 +395,7 @@ sub checklock { if ($! =~ /Permission/) { my $incc = $INC{'CPAN/Config.pm'}; my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); - print qq{ + $CPAN::Frontend->myprint(qq{ Your configuration suggests that CPAN.pm should use a working directory of @@ -396,17 +412,20 @@ this variable in either or $myincc -}; +}); } - Carp::croak "Could not open >$lockfile: $!"; + $CPAN::Frontend->mydie("Could not open >$lockfile: $!"); } - print $fh $$, "\n"; + $fh->print($$, "\n"); $self->{LOCK} = $lockfile; $fh->close; - $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; }; + $SIG{'TERM'} = sub { + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + }; $SIG{'INT'} = sub { my $s = $Signal == 2 ? "a second" : "another"; - &cleanup, die "Got $s SIGINT" if $Signal; + &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal; $Signal = 1; }; $SIG{'__DIE__'} = \&cleanup; @@ -445,43 +464,38 @@ sub has_inst { return 0; } my $file = $mod; + my $obj; $file =~ s|::|/|g; $file =~ s|/|\\|g if $^O eq 'MSWin32'; $file .= ".pm"; - if (exists $INC{$file} && $INC{$file}) { + if ($INC{$file}) { # warn "$file in %INC"; #debug return 1; - } elsif ( my($obj) = CPAN::Shell->expand('Module',$mod) ) { - if ($obj->inst_file) { - require $file; - print "CPAN: $mod successfully required\n"; - - if ($mod eq "CPAN::WAIT") { - push @CPAN::Shell::ISA, CPAN::WAIT unless $@; - } - warn $@ if $@; - return $@ ? 0 : 1; - } elsif ($mod eq "MD5"){ - print qq{ - CPAN: MD5 security checks disabled because MD5 not installed. - Please consider installing the MD5 module - -}; - sleep 2; - } } elsif (eval { require $file }) { - # we can still have luck, if the program is fed with a bogus - # database or what + # 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; + } return 1; } elsif ($mod eq "Net::FTP") { warn qq{ Please, install Net::FTP as soon as possible. CPAN.pm installs it for you if you just type install Bundle::libnet - Thank you. }; sleep 2; + } elsif ($mod eq "MD5"){ + $CPAN::Frontend->myprint(qq{ + CPAN: MD5 security checks disabled because MD5 not installed. + Please consider installing the MD5 module. + +}); + sleep 2; } return 0; } @@ -510,7 +524,7 @@ sub cleanup { return unless defined $META->{'LOCK'}; return unless -f $META->{'LOCK'}; unlink $META->{'LOCK'}; - print STDERR "Lockfile removed.\n"; + $CPAN::Frontend->mywarn("Lockfile removed.\n"); } package CPAN::CacheMgr; @@ -570,11 +584,11 @@ sub entries { for ($dh->read) { next if $_ eq "." || $_ eq ".."; if (-f $_) { - push @entries, $CPAN::META->catfile($dir,$_); + push @entries, MM->catfile($dir,$_); } elsif (-d _) { - push @entries, $CPAN::META->catdir($dir,$_); + push @entries, MM->catdir($dir,$_); } else { - print STDERR "Warning: weird direntry in $dir: $_\n"; + $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); } } chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); @@ -603,8 +617,12 @@ sub disk_usage { $self->{DU} += $Du/1024/1024; if ($self->{DU} > $self->{'MAX'} ) { my($toremove) = shift @{$self->{FIFO}}; - printf "...Hold on a sec... cleaning from cache (%.1f>%.1f MB): $toremove\n", - $self->{DU}, $self->{'MAX'}; + $CPAN::Frontend->myprint(sprintf( + "...Hold on a sec... ". + "cleaning from cache ". + "(%.1f>%.1f MB): $toremove\n", + $self->{DU}, $self->{'MAX'}) + ); $self->force_clean_cache($toremove); } $self->{DU}; @@ -658,23 +676,17 @@ sub debug { ($caller) = caller(0); $caller =~ s/.*:://; $arg = "" unless defined $arg; - my $rest = join ":", map { defined $_ ? $_ : "UNDEF" } @rest; -# print "caller[$caller]\n"; -# print "func[$func]\n"; -# print "line[$line]\n"; -# print "rest[@rest]\n"; -# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]\n"; -# print "CPAN::DEBUG[$CPAN::DEBUG]\n"; + my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest; if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ if ($arg and ref $arg) { eval { require Data::Dumper }; if ($@) { - print $arg->as_string; + $CPAN::Frontend->myprint($arg->as_string); } else { - print Data::Dumper::Dumper($arg); + $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg)); } } else { - print "Debug($caller:$func,$line,[$rest]): $arg\n" + $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n"); } } } @@ -709,17 +721,18 @@ sub edit { } elsif (@args) { $CPAN::Config->{$o} = [@args]; } else { - print( - " $o ", - ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), - "\n" + $CPAN::Frontend->myprint( + join "", + " $o ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), + "\n" ); } } else { $CPAN::Config->{$o} = $args[0] if defined $args[0]; - print " $o "; - print defined $CPAN::Config->{$o} ? - $CPAN::Config->{$o} : "UNDEFINED"; + $CPAN::Frontend->myprint(" $o " . + (defined $CPAN::Config->{$o} ? + $CPAN::Config->{$o} : "UNDEFINED")); } } } @@ -755,7 +768,7 @@ EOF $msg ||= "\n"; my($fh) = FileHandle->new; open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; - print $fh qq[$msg\$CPAN::Config = \{\n]; + $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { $fh->print( " '$_' => ", @@ -764,13 +777,13 @@ EOF ); } - print $fh "};\n1;\n__END__\n"; + $fh->print("};\n1;\n__END__\n"); close $fh; #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); #chmod $mode, $configpm; ###why was that so? $self->defaults; - print "commit: wrote $configpm\n"; + $CPAN::Frontend->myprint("commit: wrote $configpm\n"); 1; } @@ -798,10 +811,13 @@ sub init { sub load { my($self) = shift; my(@miss); - eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems - unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++; - eval {require CPAN::MyConfig;}; # where you can override system wide settings + eval {require CPAN::Config;}; # We eval because of some + # MakeMaker problems + unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++; + eval {require CPAN::MyConfig;}; # where you can override + # system wide settings return unless @miss = $self->not_loaded; + # XXX better check for arrayrefs too require CPAN::FirstTime; my($configpm,$fh,$redo,$theycalled); $redo ||= ""; @@ -856,14 +872,14 @@ sub load { } } local($") = ", "; - print qq{ + $CPAN::Frontend->myprint(qq{ We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -} if $redo && ! $theycalled; - print qq{ +}) if $redo && ! $theycalled; + $CPAN::Frontend->myprint(qq{ $configpm initialized. -}; +}); sleep 2; CPAN::FirstTime::init($configpm); } @@ -890,7 +906,7 @@ sub unload { *h = \&help; #-> sub CPAN::Config::help ; sub help { - print <<EOF; + $CPAN::Frontend->myprint(qq{ Known options: defaults reload default config values from disk commit commit session changes to disk @@ -906,7 +922,7 @@ You may edit key values in the follow fashion: o conf urllist unshift ftp://ftp.foo.bar/ -EOF +}); undef; #don't reprint CPAN::Config } @@ -914,6 +930,17 @@ EOF sub cpl { my($word,$line,$pos) = @_; $word ||= ""; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@words) = split " ", substr($line,0,$pos+1); + if ( + $words[2] =~ /list$/ && @words == 3 + || + $words[2] =~ /list$/ && @words == 4 && length($word) + ) { + return grep /^\Q$word\E/, qw(splice shift unshift pop push); + } elsif (@words >= 4) { + return (); + } my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); return grep /^\Q$word\E/, @o_conf; } @@ -924,9 +951,9 @@ package CPAN::Shell; sub h { my($class,$about) = @_; if (defined $about) { - print "Detailed help not yet implemented\n"; + $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); } else { - print q{ + $CPAN::Frontend->myprint(q{ command arguments description a string authors b or display bundles @@ -949,34 +976,34 @@ h or ? display this menu o various set and query options ! perl-code eval a perl command q quit the shell subroutine -}; +}); } } #-> sub CPAN::Shell::a ; -sub a { print shift->format_result('Author',@_);} +sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} #-> sub CPAN::Shell::b ; sub b { my($self,@which) = @_; CPAN->debug("which[@which]") if $CPAN::DEBUG; my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - $bdir = $CPAN::META->catdir($incdir,"Bundle"); + $bdir = MM->catdir($incdir,"Bundle"); if ($dh = DirHandle->new($bdir)) { # may fail my($entry); for $entry ($dh->read) { - next if -d $CPAN::META->catdir($bdir,$entry); + next if -d MM->catdir($bdir,$entry); next unless $entry =~ s/\.pm$//; $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); } } } - print $self->format_result('Bundle',@which); + $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); } #-> sub CPAN::Shell::d ; -sub d { print shift->format_result('Distribution',@_);} +sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; -sub m { print shift->format_result('Module',@_);} +sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} #-> sub CPAN::Shell::i ; sub i { @@ -993,7 +1020,7 @@ sub i { $result[0]->as_string : join "", map {$_->as_glimpse} @result; $result ||= "No objects found of any type for argument @args\n"; - print $result; + $CPAN::Frontend->myprint($result); } #-> sub CPAN::Shell::o ; @@ -1005,24 +1032,32 @@ sub o { shift @o_what if @o_what && $o_what[0] eq 'help'; if (!@o_what) { my($k,$v); - print "CPAN::Config options:\n"; + $CPAN::Frontend->myprint("CPAN::Config options:\n"); for $k (sort keys %CPAN::Config::can) { $v = $CPAN::Config::can{$k}; - printf " %-18s %s\n", $k, $v; + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); } - print "\n"; + $CPAN::Frontend->myprint("\n"); for $k (sort keys %$CPAN::Config) { $v = $CPAN::Config->{$k}; if (ref $v) { - printf " %-18s\n", $k; - print map {"\t$_\n"} @{$v}; + $CPAN::Frontend->myprint( + join( + "", + sprintf( + " %-18s\n", + $k + ), + map {"\t$_\n"} @{$v} + ) + ); } else { - printf " %-18s %s\n", $k, $v; + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); } } - print "\n"; + $CPAN::Frontend->myprint("\n"); } elsif (!CPAN::Config->edit(@o_what)) { - print qq[Type 'o conf' to view configuration edit options\n\n]; + $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]); } } elsif ($o_type eq 'debug') { my(%valid); @@ -1047,31 +1082,32 @@ sub o { $CPAN::DEBUG |= $CPAN::DEBUG{$_}; $known = 1; } - print "unknown argument [$what]\n" unless $known; + $CPAN::Frontend->myprint("unknown argument [$what]\n") + unless $known; } } } else { - print "Valid options for debug are ". - join(", ",sort(keys %CPAN::DEBUG), 'all'). + $CPAN::Frontend->myprint("Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). qq{ or a number. Completion works on the options. }. - qq{Case is ignored.\n\n}; + qq{Case is ignored.\n\n}); } if ($CPAN::DEBUG) { - print "Options set for debugging:\n"; + $CPAN::Frontend->myprint("Options set for debugging:\n"); my($k,$v); for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { $v = $CPAN::DEBUG{$k}; - printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG; + $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG; } } else { - print "Debugging turned off completely.\n"; + $CPAN::Frontend->myprint("Debugging turned off completely.\n"); } } else { - print qq{ + $CPAN::Frontend->myprint(qq{ Known options: conf set or get configuration variables debug set or get debugging options -}; +}); } } @@ -1091,19 +1127,20 @@ sub reload { if ( $_[0] =~ /Subroutine \w+ redefined/ ) { ++$redef; local($|) = 1; - print "."; + $CPAN::Frontend->myprint("."); return; } warn @_; }; eval <$fh>; warn $@ if $@; - print "\n$redef subroutines redefined\n"; + $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); } elsif ($command =~ /index/) { CPAN::Index->force_reload; } else { - print qq{cpan re-evals the CPAN.pm file\n}; - print qq{index re-reads the index files\n}; + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files +}); } } @@ -1111,18 +1148,19 @@ sub reload { sub _binary_extensions { my($self) = shift @_; my(@result,$module,%seen,%need,$headerdone); + my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$}; for $module ($self->expand('Module','/./')) { my $file = $module->cpan_file; next if $file eq "N/A"; next if $file =~ /^Contact Author/; - next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/; + next if $file =~ / $isaperl /xo; next unless $module->xs_file; local($|) = 1; - print "."; + $CPAN::Frontend->myprint("."); push @result, $module; } # print join " | ", @result; - print "\n"; + $CPAN::Frontend->myprint("\n"); return @result; } @@ -1131,14 +1169,15 @@ sub recompile { my($self) = shift @_; my($module,@module,$cpan_file,%dist); @module = $self->_binary_extensions(); - for $module (@module){ # we force now and compile later, so we don't do it twice + for $module (@module){ # we force now and compile later, so we + # don't do it twice $cpan_file = $module->cpan_file; my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->force; $dist{$cpan_file}++; } for $cpan_file (sort keys %dist) { - print " CPAN: Recompiling $cpan_file\n\n"; + $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->install; $CPAN::Signal = 0; # it's tempting to reset Signal, so we can @@ -1156,13 +1195,14 @@ sub _u_r_common { Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; my(@args) = @_; @args = '/./' unless @args; - my(@result,$module,%seen,%need,$headerdone,$version_zeroes); - $version_zeroes = 0; + my(@result,$module,%seen,%need,$headerdone, + $version_undefs,$version_zeroes); + $version_undefs = $version_zeroes = 0; my $sprintf = "%-25s %9s %9s %s\n"; for $module ($self->expand('Module',@args)) { my $file = $module->cpan_file; next unless defined $file; # ?? - my($latest) = $module->cpan_version || 0; + my($latest) = $module->cpan_version; my($inst_file) = $module->inst_file; my($have); if ($inst_file){ @@ -1171,8 +1211,15 @@ sub _u_r_common { } elsif ($what eq "r") { $have = $module->inst_version; local($^W) = 0; - $version_zeroes++ unless $have; + if ($have eq "undef"){ + $version_undefs++; + } elsif ($have == 0){ + $version_zeroes++; + } next if $have >= $latest; +# to be pedantic we should probably say: +# && !($have eq "undef" && $latest ne "undef" && $latest gt ""); +# to catch the case where CPAN has a version 0 and we have a version undef } elsif ($what eq "u") { next; } @@ -1198,30 +1245,38 @@ sub _u_r_common { next if $file =~ /^Contact/; } unless ($headerdone++){ - print "\n"; - printf( + $CPAN::Frontend->myprint("\n"); + $CPAN::Frontend->myprint(sprintf( $sprintf, "Package namespace", "installed", "latest", "in CPAN file" - ); + )); } $latest = substr($latest,0,8) if length($latest) > 8; $have = substr($have,0,8) if length($have) > 8; - printf $sprintf, $module->id, $have, $latest, $file; + $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file); $need{$module->id}++; } unless (%need) { if ($what eq "u") { - print "No modules found for @args\n"; + $CPAN::Frontend->myprint("No modules found for @args\n"); } elsif ($what eq "r") { - print "All modules are up to date for @args\n"; + $CPAN::Frontend->myprint("All modules are up to date for @args\n"); } } - if ($what eq "r" && $version_zeroes) { - my $s = $version_zeroes > 1 ? "s have" : " has"; - print qq{$version_zeroes installed module$s no version number to compare\n}; + if ($what eq "r") { + if ($version_zeroes) { + my $s_has = $version_zeroes > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. + qq{a version number of 0\n}); + } + if ($version_undefs) { + my $s_has = $version_undefs > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. + qq{parseable version number\n}); + } } @result; } @@ -1240,10 +1295,10 @@ sub u { sub autobundle { my($self) = shift; my(@bundle) = $self->_u_r_common("a",@_); - my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); unless (-d $todir) { - print "Couldn't mkdir $todir for some reason\n"; + $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); return; } my($y,$m,$d) = (localtime)[5,4,3]; @@ -1251,10 +1306,10 @@ sub autobundle { $m++; my($c) = 0; my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; - my($to) = $CPAN::META->catfile($todir,"$me.pm"); + my($to) = MM->catfile($todir,"$me.pm"); while (-f $to) { $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; - $to = $CPAN::META->catfile($todir,"$me.pm"); + $to = MM->catfile($todir,"$me.pm"); } my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; $fh->print( @@ -1278,8 +1333,8 @@ sub autobundle { "by the autobundle routine in CPAN.pm.\n", ); $fh->close; - print "\nWrote bundle file - $to\n\n"; + $CPAN::Frontend->myprint("\nWrote bundle file + $to\n\n"); } #-> sub CPAN::Shell::expand ; @@ -1341,6 +1396,67 @@ sub format_result { $result; } +# The only reason for this method is currently to have a reliable +# debugging utility that reveals which output is going through which +# channel. No, I don't like the colors ;-) +sub print_ornamented { + my($self,$what,$ornament) = @_; + my $longest = 0; + my $ornamenting = 0; # turn the colors on + + if ($ornamenting) { + unless (defined &color) { + if ($CPAN::META->has_inst("Term::ANSIColor")) { + import Term::ANSIColor "color"; + } else { + *color = sub { return "" }; + } + } + for my $line (split /\n/, $what) { + $longest = length($line) if length($line) > $longest; + } + my $sprintf = "%-" . $longest . "s"; + while ($what){ + $what =~ s/(.*\n?)//m; + my $line = $1; + last unless $line; + my($nl) = chomp $line ? "\n" : ""; + # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n"; + print color($ornament), sprintf($sprintf,$line), color("reset"), $nl; + } + } else { + print $what; + } +} + +sub myprint { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); +} + +sub myexit { + my($self,$what) = @_; + $self->myprint($what); + exit; +} + +sub mywarn { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_yellow'); +} + +sub myconfess { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + Carp::confess "died"; +} + +sub mydie { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + die "\n"; +} + #-> sub CPAN::Shell::rematein ; sub rematein { shift; @@ -1378,15 +1494,20 @@ sub rematein { $obj->$meth(); } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); - print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n"; + $CPAN::Frontend->myprint( + join "", + "Don't be silly, you can't $meth ", + $obj->fullname, + " ;-)\n" + ); } else { - print qq{Warning: Cannot $meth $s, don\'t know what it is. + $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. Try the command i /$s/ to find objects with similar identifiers. -}; +}); } } } @@ -1425,7 +1546,6 @@ sub ftp_get { warn "Couldn't login on $host"; return; } - # print qq[Going to ->cwd("$dir")\n]; unless ( $ftp->cwd($dir) ){ warn "Couldn't cwd $dir"; return; @@ -1440,6 +1560,22 @@ sub ftp_get { return 1; } +sub is_reachable { + my($self,$url) = @_; + return 1; # we can't simply roll our own, firewalls may break ping + return 0 unless $url; + return 1 if substr($url,0,4) eq "file"; + return 1 unless $url =~ m|://([^/]+)|; + my $host = $1; + require Net::Ping; + return 1 unless $Net::Ping::VERSION >= 2; + my $p; + eval {$p = Net::Ping->new("icmp");}; + eval {$p = Net::Ping->new("tcp");} if $@; + $CPAN::Frontend->mydie($@) if $@; + return $p->ping($host, 3); +} + #-> sub CPAN::FTP::localize ; # sorry for the ugly code here, I'll clean it up as soon as Net::FTP # is in the core @@ -1451,7 +1587,7 @@ sub localize { $self->debug("file[$file] aslocal[$aslocal] force[$force]") if $CPAN::DEBUG; - return $aslocal if -f $aslocal && -r _ && ! $force; + return $aslocal if -f $aslocal && -r _ && !($force & 1); my($restore) = 0; if (-f $aslocal){ rename $aslocal, "$aslocal.bak"; @@ -1460,10 +1596,10 @@ sub localize { my($aslocal_dir) = File::Basename::dirname($aslocal); File::Path::mkpath($aslocal_dir); - print STDERR qq{Warning: You are not allowed to write into }. + $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. qq{directory "$aslocal_dir". - I\'ll continue, but if you face any problems, they may be due - to insufficient permissions.\n} unless -w $aslocal_dir; + I\'ll continue, but if you encounter problems, they may be due + 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')) { @@ -1482,12 +1618,78 @@ sub localize { # Try the list of urls for each single object. We keep a record # where we did get a file from + my(@reordered,$last); +#line 1621 + $last = $#{$CPAN::Config->{urllist}}; + if ($force & 2) { # local cpans probably out of date, don't reorder + @reordered = (0..$last); + } else { + @reordered = + sort { + (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") + <=> + (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") + or + defined($Thesite) + and + ($b == $Thesite) + <=> + ($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) { + @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/); + } else { + @levels = qw/easy hard hardest/; + } + for $level (@levels) { + my $method = "host$level"; + my @host_seq = $level eq "easy" ? + @reordered : 0..$last; # reordered has CDROM up front + my $ret = $self->$method(\@host_seq,$file,$aslocal); + if ($ret) { + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } + } + my(@mess); + push @mess, + qq{Please check, if the URLs I found in your configuration file \(}. + join(", ", @{$CPAN::Config->{urllist}}). + qq{\) are valid. The urllist can be edited.}, + qq{E.g. with ``o conf urllist push ftp://myurl/''}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); + sleep 2; + $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); + if ($restore) { + rename "$aslocal.bak", $aslocal; + $CPAN::Frontend->myprint("Trying to get away with old file:\n" . + $self->ls($aslocal)); + return $aslocal; + } + return; +} + +sub hosteasy { + my($self,$host_seq,$file,$aslocal) = @_; my($i); - for $i (0..$#{$CPAN::Config->{urllist}}) { + HOSTEASY: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); + sleep 2; + next; + } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; - $self->debug("localizing[$url]") if $CPAN::DEBUG; + $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; if ($CPAN::META->has_inst('LWP')) { @@ -1495,27 +1697,51 @@ sub localize { my $u = URI::URL->new($url); $l = $u->path; } else { # works only on Unix, is poorly constructed, but - # hopefully better than nothing. - # RFC 1738 says fileurl BNF is - # fileurl = "file://" [ host | "localhost" ] "/" fpath - # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code + # hopefully better than nothing. + # RFC 1738 says fileurl BNF is + # 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 } - return $l if -f $l && -r _; + if ( -f $l && -r _) { + $Thesite = $i; + return $l; + } # Maybe mirror has compressed it? if (-f "$l.gz") { $self->debug("found compressed $l.gz") if $CPAN::DEBUG; system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal"); - return $aslocal if -f $aslocal; + if ( -f $aslocal) { + $Thesite = $i; + return $aslocal; + } } } - if ($CPAN::META->has_inst('LWP')) { - print "Fetching $url with LWP\n"; + $CPAN::Frontend->myprint("Fetching with LWP: + $url +"); my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { + $Thesite = $i; return $aslocal; + } elsif ($url !~ /\.gz$/) { + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint("Fetching with LWP: + $gzurl +"); + $res = $Ua->mirror($gzurl, "$aslocal.gz"); + if ($res->is_success && + system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) { + $Thesite = $i; + return $aslocal; + } else { + next HOSTEASY ; + } + } else { + next HOSTEASY ; } } if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { @@ -1523,202 +1749,259 @@ sub localize { my($host,$dir,$getfile) = ($1,$2,$3); if ($CPAN::META->has_inst('Net::FTP')) { $dir =~ s|/+|/|g; - $self->debug("Going to fetch file [$getfile] - from dir [$dir] - on host [$host] - as local [$aslocal]") if $CPAN::DEBUG; - CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; - warn "Net::FTP failed for some reason\n"; + $CPAN::Frontend->myprint("Fetching with Net::FTP: + $aslocal +"); + $self->debug("getfile[$getfile]dir[$dir]host[$host]" . + "aslocal[$aslocal]") if $CPAN::DEBUG; + if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { + $Thesite = $i; + return $aslocal; + } + if ($aslocal !~ /\.gz$/) { + my $gz = "$aslocal.gz"; + $CPAN::Frontend->myprint("Fetching with Net::FTP + $gz +"); + if (CPAN::FTP->ftp_get($host, + $dir, + "$getfile.gz", + $gz) && + system("$CPAN::Config->{gzip} -d $gz")==0 ){ + $Thesite = $i; + return $aslocal; + } + } + next HOSTEASY; } } + } +} - # 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... +sub hosthard { + my($self,$host_seq,$file,$aslocal) = @_; - my($funkyftp); - # does ncftp handle http? - for $funkyftp ($CPAN::Config->{'lynx'},$CPAN::Config->{'ncftp'}) { + # 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); + HOSTHARD: for $i (@$host_seq) { + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + my($host,$dir,$getfile); + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + ($host,$dir,$getfile) = ($1,$2,$3); + } else { + next HOSTHARD; # who said, we could ftp anything except ftp? + } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; + my($f,$funkyftp); + for $f ('lynx','ncftp') { + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; next if $funkyftp =~ /^\s*$/; my($want_compressed); - print( - qq{ -Trying with $funkyftp to get - $url -}); - $want_compressed = $aslocal =~ s/\.gz//; + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; my($source_switch) = ""; $source_switch = "-source" if $funkyftp =~ /\blynx$/; $source_switch = "-c" if $funkyftp =~ /\bncftp$/; - my($system) = "$funkyftp $source_switch '$url' > $aslocal"; + $CPAN::Frontend->myprint( + qq{ +Trying with "$funkyftp $source_switch" to get + $url +}); + my($system) = "$funkyftp $source_switch '$url' > ". + "$aslocal_uncompressed"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && - -s $aslocal # lynx returns 0 on my system even if it fails + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails ) { - if ($want_compressed) { - $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; + if ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed"; if (system($system) == 0) { - rename $aslocal, "$aslocal.gz"; + rename $aslocal_uncompressed, $aslocal; } else { - $system = "$CPAN::Config->{'gzip'} $aslocal"; + $system = + "$CPAN::Config->{'gzip'} $aslocal_uncompressed"; system($system); } - return "$aslocal.gz"; - } else { - $system = "$CPAN::Config->{'gzip'} -dt $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 + $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 + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz"; + $CPAN::Frontend->mywarn("system[$system]"); if (system($system) == 0) { - $system = "$CPAN::Config->{'gzip'} -d $aslocal"; + $system = "$CPAN::Config->{'gzip'} -dc ". + "$aslocal_uncompressed.gz > $aslocal"; + $CPAN::Frontend->mywarn("system[$system]"); system($system); } else { - # should be fine, eh? + rename $aslocal_uncompressed, $aslocal; } +#line 1739 + $Thesite = $i; return $aslocal; } } else { my $estatus = $wstatus >> 8; - my $size = -s $aslocal; - print qq{ + my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; + $CPAN::Frontend->myprint(qq{ System call "$system" -returned status $estatus (wstat $wstatus), left -$aslocal with size $size -}; +returned status $estatus (wstat $wstatus)$size +}); } } + } +} - if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { - my($host,$dir,$getfile) = ($1,$2,$3); - my($netrcfile,$fh); - if (-x $CPAN::Config->{'ftp'}) { - my $timestamp = 0; - my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, - $ctime,$blksize,$blocks) = stat($aslocal); - $timestamp = $mtime ||= 0; - - my($netrc) = CPAN::FTP::netrc->new; - my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; - - my $targetfile = File::Basename::basename($aslocal); - my(@dialog); - push( - @dialog, - "lcd $aslocal_dir", - "cd /", - map("cd $_", split "/", $dir), # RFC 1738 - "bin", - "get $getfile $targetfile", - "quit" - ); - if (! $netrc->netrc) { - CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; - } elsif ($netrc->hasdefault || $netrc->contains($host)) { - CPAN->debug( - sprint( - "hasdef[%d]cont($host)[%d]", - $netrc->hasdefault, - $netrc->contains($host) - ) - ) if $CPAN::DEBUG; - if ($netrc->protected) { - print( - qq{ +sub hosthardest { + my($self,$host_seq,$file,$aslocal) = @_; + + my($i); + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + HOSTHARDEST: for $i (@$host_seq) { + unless (length $CPAN::Config->{'ftp'}) { + $CPAN::Frontend->myprint("No external ftp command available\n\n"); + last HOSTHARDEST; + } + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; + unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + next; + } + my($host,$dir,$getfile) = ($1,$2,$3); + my($netrcfile,$fh); + my $timestamp = 0; + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, + $ctime,$blksize,$blocks) = stat($aslocal); + $timestamp = $mtime ||= 0; + my($netrc) = CPAN::FTP::netrc->new; + my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; + my $targetfile = File::Basename::basename($aslocal); + my(@dialog); + push( + @dialog, + "lcd $aslocal_dir", + "cd /", + map("cd $_", split "/", $dir), # RFC 1738 + "bin", + "get $getfile $targetfile", + "quit" + ); + if (! $netrc->netrc) { + CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; + } elsif ($netrc->hasdefault || $netrc->contains($host)) { + CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", + $netrc->hasdefault, + $netrc->contains($host))) if $CPAN::DEBUG; + if ($netrc->protected) { + $CPAN::Frontend->myprint(qq{ Trying with external ftp to get $url As this requires some features that are not thoroughly tested, we\'re not sure, that we get it right.... } - ); - my $fh = FileHandle->new; - $fh->open("|$CPAN::Config->{'ftp'}$verbose $host") - or die "Couldn't open ftp: $!"; - # pilot is blind now - CPAN->debug("dialog [".(join "|",@dialog)."]") - if $CPAN::DEBUG; - foreach (@dialog) { $fh->print("$_\n") } - $fh->close; # Wait for process to complete - my $wstatus = $?; - my $estatus = $wstatus >> 8; - print qq{ -Subprocess "|$CPAN::Config->{'ftp'}$verbose $host" - returned status $estatus (wstat $wstatus) -} if $wstatus; - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); - $mtime ||= 0; - if ($mtime > $timestamp) { - print "GOT $aslocal\n"; - return $aslocal; - } else { - print "Hmm... Still failed!\n"; - } - } else { - warn "Your $netrcfile is not correctly protected.\n"; - } - } else { - warn "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. - print qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}; - unshift( - @dialog, - "open $host", - "user anonymous $Config::Config{'cf_email'}" - ); - CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG; - $fh = FileHandle->new; - $fh->open("|$CPAN::Config->{'ftp'}$verbose -n") or - die "Cannot fork: $!\n"; - foreach (@dialog) { $fh->print("$_\n") } - $fh->close; - my $wstatus = $?; - my $estatus = $wstatus >> 8; - print qq{ -Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" - returned status $estatus (wstat $wstatus) -} if $wstatus; + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host", + @dialog); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); $mtime ||= 0; if ($mtime > $timestamp) { - print "GOT $aslocal\n"; + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; return $aslocal; } else { - print "Bad luck... Still failed!\n"; + $CPAN::Frontend->myprint("Hmm... Still failed!\n"); } + } else { + $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. + qq{correctly protected.\n}); } - sleep 2; + } else { + $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host + nor does it have a default entry\n"); } - - print "Can't access URL $url.\n\n"; - my(@mess,$mess); - push @mess, "LWP" unless CPAN->has_inst('LWP'); - push @mess, "Net::FTP" unless CPAN->has_inst('Net::FTP'); - my($ext); - for $ext (qw/lynx ncftp ftp/) { - $CPAN::Config->{$ext} ||= ""; - push @mess, "an external $ext" unless -x $CPAN::Config->{$ext}; + + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' + # then and login manually to host, using e-mail as + # password. + $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}); + unshift( + @dialog, + "open $host", + "user anonymous $Config::Config{'cf_email'}" + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog); + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; + return $aslocal; + } else { + $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); } - $mess = qq{Either get }. - join(" or ",@mess). - qq{ or check, if the URL found in your configuration file, }. - $CPAN::Config->{urllist}[$i]. - qq{, is valid.}; - print Text::Wrap::wrap("","",$mess), "\n"; - } - print "Cannot fetch $file\n"; - if ($restore) { - rename "$aslocal.bak", $aslocal; - print "Trying to get away with old file:\n"; - print $self->ls($aslocal); - return $aslocal; + $CPAN::Frontend->myprint("Can't access URL $url.\n\n"); + sleep 2; } - return; +} + +sub talk_ftp { + my($self,$command,@dialog) = @_; + my $fh = FileHandle->new; + $fh->open("|$command") or die "Couldn't open ftp: $!"; + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; # Wait for process to complete + my $wstatus = $?; + my $estatus = $wstatus >> 8; + $CPAN::Frontend->myprint(qq{ +Subprocess "|$command" + returned status $estatus (wstat $wstatus) +}) if $wstatus; + } # find2perl needs modularization, too, all the following is stolen @@ -1811,7 +2094,6 @@ sub new { my($t) = shift @tokens; if ($t eq "default"){ $hasdefault++; - # warn "saw a default entry before tokens[@tokens]"; last NETRC; } last TOKEN if $t eq "macdef"; @@ -1923,7 +2205,7 @@ sub cpl_option { CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; my(@ok) = qw(conf debug); return @ok if @words == 1; - return grep /^\Q$word\E/, @ok if @words == 2 && $word; + return grep /^\Q$word\E/, @ok if @words == 2 && length($word); if (0) { } elsif ($words[1] eq 'index') { return (); @@ -1948,34 +2230,38 @@ sub reload { my($cl,$force) = @_; my $time = time; - # XXX check if a newer one is available. (We currently read it from time to time) + # XXX check if a newer one is available. (We currently read it + # from time to time) for ($CPAN::Config->{index_expire}) { $_ = 0.001 unless $_ > 0.001; } - return if $last_time + $CPAN::Config->{index_expire}*86400 > $time; + return if $last_time + $CPAN::Config->{index_expire}*86400 > $time + and ! $force; my($debug,$t2); $last_time = $time; + my $needshort = $^O eq "dos"; + $cl->rd_authindex($cl->reload_x( - "authors/01mailrc.txt.gz", - "01mailrc.gz", - $force)); + "authors/01mailrc.txt.gz", + $needshort ? "01mailrc.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", - "02packag.gz", - $force)); + "modules/02packages.details.txt.gz", + $needshort ? "02packag.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", - "03mlist.gz", - $force)); + "modules/03modlist.data.gz", + $needshort ? "03mlist.gz" : "", + $force)); $t2 = time; $debug .= "03[".($t2 - $time)."]"; $time = $t2; @@ -1985,24 +2271,23 @@ sub reload { #-> sub CPAN::Index::reload_x ; sub reload_x { my($cl,$wanted,$localname,$force) = @_; - $force ||= 0; + $force |= 2; # means we're dealing with an index here CPAN::Config->load; # we should guarantee loading wherever we rely # on Config XXX - my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'}, + $localname ||= $wanted; + my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'}, $localname); if ( -f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && - !$force + !($force & 1) ) { my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; -# use Devel::Symdump; -# print Devel::Symdump->isa_tree, "\n"; $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. qq{day$s. I\'ll use that.}); return $abs_wanted; } else { - $force ||= 1; + $force |= 1; # means we're quite serious about it. } return CPAN::FTP->localize($wanted,$abs_wanted,$force); } @@ -2010,12 +2295,14 @@ sub reload_x { #-> sub CPAN::Index::rd_authindex ; sub rd_authindex { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - print "Going to read $index_target\n"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = FileHandle->new("$pipe|"); while (<$fh>) { chomp; - my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + my($userid,$fullname,$email) = + /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; next unless $userid && $fullname && $email; # instantiate an author object @@ -2030,8 +2317,9 @@ sub rd_authindex { #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - print "Going to read $index_target\n"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = FileHandle->new("$pipe|"); while (<$fh>) { last if /^\s*$/; @@ -2039,7 +2327,6 @@ sub rd_modpacks { while (<$fh>) { chomp; my($mod,$version,$dist) = split; -$dist = '' unless defined $dist; ### $version =~ s/^\+//; # if it as a bundle, instatiate a bundle object @@ -2048,16 +2335,16 @@ $dist = '' unless defined $dist; if ($mod eq 'CPAN') { local($^W)= 0; if ($version > $CPAN::VERSION){ - print qq{ + $CPAN::Frontend->myprint(qq{ There\'s a new CPAN.pm version (v$version) available! You might want to try install CPAN reload cpan - without quitting the current session. It should be a seemless upgrade + without quitting the current session. It should be a seamless upgrade while we are running... -}; +}); sleep 2; - print qq{\n}; + $CPAN::Frontend->myprint(qq{\n}); } last if $CPAN::Signal; } elsif ($mod =~ /^Bundle::(.*)/) { @@ -2066,16 +2353,19 @@ $dist = '' unless defined $dist; if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); -### $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); + # Let's make it a module too, because bundles have so much + # in common with modules + $CPAN::META->instance('CPAN::Module',$mod); + # 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. # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { # next; - } else { + + } + else { # instantiate a module object $id = $CPAN::META->instance('CPAN::Module',$mod); -### $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist) -### if $id->cpan_version ne $version || $id->cpan_file ne $dist; # good speed in here } if ($id->cpan_file ne $dist){ @@ -2106,8 +2396,9 @@ $dist = '' unless defined $dist; #-> sub CPAN::Index::rd_modlist ; sub rd_modlist { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - print "Going to read $index_target\n"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = FileHandle->new("$pipe|"); my $eval; while (<$fh>) { @@ -2224,11 +2515,11 @@ sub get { my @e; exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } my($local_file); my($local_wanted) = - CPAN->catfile( + MM->catfile( $CPAN::Config->{keep_source_where}, "authors", "id", @@ -2236,7 +2527,9 @@ sub get { ); $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); + $local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) + or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); $self->{localfile} = $local_file; my $builddir = $CPAN::META->{cachemgr}->dir; $self->debug("doing chdir $builddir") if $CPAN::DEBUG; @@ -2255,7 +2548,9 @@ sub get { mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; chdir "tmp"; $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ + if (! $local_file) { + Carp::croak "bad download, can't do anything :-(\n"; + } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ $self->untar_me($local_file); } elsif ( $local_file =~ /\.zip$/i ) { $self->unzip_me($local_file); @@ -2274,19 +2569,19 @@ sub get { my ($distdir,$packagedir); if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; - $packagedir = $CPAN::META->catdir($builddir,$distdir); - -d $packagedir and print "Removing previously used $packagedir\n"; + $packagedir = MM->catdir($builddir,$distdir); + -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n"); File::Path::rmtree($packagedir); rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); } else { my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; $pragmatic_dir =~ s/\W_//g; $pragmatic_dir++ while -d "../$pragmatic_dir"; - $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir); + $packagedir = MM->catdir($builddir,$pragmatic_dir); File::Path::mkpath($packagedir); my($f); for $f (@readdir) { # is already without "." and ".." - my $to = $CPAN::META->catdir($packagedir,$f); + my $to = MM->catdir($packagedir,$f); rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); } } @@ -2297,12 +2592,12 @@ sub get { if $CPAN::DEBUG; File::Path::rmtree("tmp"); if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ - print "Going to unlink $local_file\n"; + $CPAN::Frontend->myprint("Going to unlink $local_file\n"); unlink $local_file or Carp::carp "Couldn't unlink $local_file"; } - my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL"); + my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); unless (-f $makefilepl) { - my($configure) = $CPAN::META->catfile($packagedir,"Configure"); + my($configure) = MM->catfile($packagedir,"Configure"); if (-f $configure) { # do we have anything to do? $self->{'configure'} = $configure; @@ -2319,8 +2614,8 @@ qq{# This Makefile.PL has been autogenerated by the module CPAN.pm WriteMakefile(NAME => q[$cf]); }); - print qq{Package comes without Makefile.PL.\n}. - qq{ Writing one on our own (calling it $cf)\n}; + $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.\n}. + qq{ Writing one on our own (calling it $cf)\n}); } } } @@ -2355,7 +2650,8 @@ sub pm2dir_me { $self->{archived} = "pm"; my $to = File::Basename::basename($local_file); $to =~ s/\.(gz|Z)$//; - my $system = "$CPAN::Config->{gzip} --decompress --stdout $local_file > $to"; + my $system = "$CPAN::Config->{gzip} --decompress --stdout ". + "$local_file > $to"; if (system($system) == 0) { $self->{unwrapped} = "YES"; } else { @@ -2377,14 +2673,14 @@ sub new { sub look { my($self) = @_; if ( $CPAN::Config->{'shell'} ) { - print qq{ + $CPAN::Frontend->myprint(qq{ Trying to open a subshell in the build directory... -}; +}); } else { - print qq{ + $CPAN::Frontend->myprint(qq{ Your configuration does not define a value for subshells. Please define it with "o conf shell <your shell>" -}; +}); return; } my $dist = $self->id; @@ -2394,8 +2690,9 @@ Please define it with "o conf shell <your shell>" $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $pwd = CPAN->$getcwd(); chdir($dir); - print qq{Working directory is $dir.\n}; - system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error"; + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + system($CPAN::Config->{'shell'}) == 0 + or $CPAN::Frontend->mydie("Subprocess shell error"); chdir($pwd); } @@ -2407,19 +2704,29 @@ sub readme { $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; my($local_file); my($local_wanted) = - CPAN->catfile( + MM->catfile( $CPAN::Config->{keep_source_where}, "authors", "id", split("/","$sans.readme"), ); $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted); + $local_file = CPAN::FTP->localize("authors/id/$sans.readme", + $local_wanted) + or $CPAN::Frontend->mydie(qq{No $sans.readme found});; my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; $fh_pager->open("|$CPAN::Config->{'pager'}") or die "Could not open pager $CPAN::Config->{'pager'}: $!"; my $fh_readme = FileHandle->new; - $fh_readme->open($local_file) or die "Could not open $local_file: $!"; + $fh_readme->open($local_file) + or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); + $CPAN::Frontend->myprint(qq{ +Displaying file + $local_file +with pager "$CPAN::Config->{'pager'}" +}); + sleep 2; $fh_pager->print(<$fh_readme>); } @@ -2430,32 +2737,36 @@ sub verifyMD5 { my @e; $self->{MD5_STATUS} ||= ""; $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } my($lc_want,$lc_file,@local,$basename); @local = split("/",$self->{ID}); pop @local; push @local, "CHECKSUMS"; $lc_want = - CPAN->catfile($CPAN::Config->{keep_source_where}, + MM->catfile($CPAN::Config->{keep_source_where}, "authors", "id", @local); local($") = "/"; if ( - -f $lc_want + -s $lc_want && $self->MD5_check_file($lc_want) ) { return $self->{MD5_STATUS} = "OK"; } $lc_file = CPAN::FTP->localize("authors/id/@local", - $lc_want,'force>:-{'); + $lc_want,1); unless ($lc_file) { $local[-1] .= ".gz"; $lc_file = CPAN::FTP->localize("authors/id/@local", - "$lc_want.gz",'force>:-{'); - my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); - system(@system) == 0 or die "Could not uncompress $lc_file"; - $lc_file =~ s/\.gz$//; + "$lc_want.gz",1); + if ($lc_file) { + my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); + system(@system) == 0 or die "Could not uncompress $lc_file"; + $lc_file =~ s/\.gz$//; + } else { + return; + } } $self->MD5_check_file($lc_file); } @@ -2464,11 +2775,11 @@ sub verifyMD5 { sub MD5_check_file { my($self,$chk_file) = @_; my($cksum,$file,$basename); - $file = $self->{localfile}; + $file = $self->{localfile}; $basename = File::Basename::basename($file); my $fh = FileHandle->new; - local($/); if (open $fh, $chk_file){ + local($/); my $eval = <$fh>; close $fh; my($comp) = Safe->new(); @@ -2494,22 +2805,23 @@ sub MD5_check_file { binmode $fh && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) ){ - print "Checksum for $file ok\n"; + $CPAN::Frontend->myprint("Checksum for $file ok\n"); return $self->{MD5_STATUS} = "OK"; } else { - print qq{Checksum mismatch for distribution file. }. - qq{Please investigate.\n\n}; - print $self->as_string; - print $CPAN::META->instance( - 'CPAN::Author', - $self->{CPAN_USERID} - )->as_string; + $CPAN::Frontend->myprint(qq{Checksum mismatch for }. + qq{distribution file. }. + qq{Please investigate.\n\n}. + $self->as_string, + $CPAN::META->instance( + 'CPAN::Author', + $self->{CPAN_USERID} + )->as_string); my $wrap = qq{I\'d recommend removing $file. It seems to be a bogus file. Maybe you have configured your \`urllist\' with a bad URL. Please check this array with \`o conf urllist\', and retry.}; - print Text::Wrap::wrap("","",$wrap); - print "\n\n"; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); + $CPAN::Frontend->myprint("\n\n"); sleep 3; return; } @@ -2517,9 +2829,11 @@ retry.}; } else { $self->{MD5_STATUS} ||= ""; if ($self->{MD5_STATUS} eq "NIL") { - print "\nNo md5 checksum for $basename in local $chk_file."; - print "Removing $chk_file\n"; - unlink $chk_file or print "Could not unlink: $!"; + $CPAN::Frontend->myprint(qq{ +No md5 checksum for $basename in local $chk_file. +Removing $chk_file +}); + unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!"); sleep 1; } $self->{MD5_STATUS} = "NIL"; @@ -2556,12 +2870,13 @@ sub perl { my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $pwd = CPAN->$getcwd(); - my $candidate = $CPAN::META->catfile($pwd,$^X); + my $candidate = MM->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { my ($component,$perl_name); DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { - PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) { + PATH_COMPONENT: foreach $component (MM->path(), + $Config::Config{'binexp'}) { next unless defined($component) && $component; my($abs) = MM->catfile($component,$perl_name); if (MM->maybe_command($abs)) { @@ -2577,8 +2892,7 @@ sub perl { #-> sub CPAN::Distribution::make ; sub make { my($self) = @_; - $self->debug($self->id) if $CPAN::DEBUG; - print "Running make\n"; + $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id); $self->get; EXCUSE: { my @e; @@ -2595,9 +2909,9 @@ sub make { defined $self->{'make'} and push @e, "Has already been processed within this session"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - print "\n CPAN.pm: Going to build ".$self->id."\n\n"; + $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); my $builddir = $self->dir; chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; @@ -2629,7 +2943,7 @@ sub make { exec $system; } } else { - print "Cannot fork: $!"; + $CPAN::Frontend->myprint("Cannot fork: $!"); return; } }; @@ -2637,7 +2951,7 @@ sub make { if ($@){ kill 9, $pid; waitpid $pid, 0; - print $@; + $CPAN::Frontend->myprint($@); $self->{writemakefile} = "NO - $@"; $@ = ""; return; @@ -2654,12 +2968,12 @@ sub make { return if $CPAN::Signal; $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; if (system($system) == 0) { - print " $system -- OK\n"; + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'make'} = "YES"; } else { $self->{writemakefile} = "YES"; $self->{'make'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } } @@ -2668,7 +2982,7 @@ sub test { my($self) = @_; $self->make; return if $CPAN::Signal; - print "Running make test\n"; + $CPAN::Frontend->myprint("Running make test\n"); EXCUSE: { my @e; exists $self->{'make'} or push @e, @@ -2679,34 +2993,37 @@ sub test { push @e, "Oops, make had returned bad status"; exists $self->{'build_dir'} or push @e, "Has no own directory"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - 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; + 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; my $system = join " ", $CPAN::Config->{'make'}, "test"; if (system($system) == 0) { - print " $system -- OK\n"; + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'make_test'} = "YES"; } else { $self->{'make_test'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } } #-> sub CPAN::Distribution::clean ; sub clean { my($self) = @_; - print "Running make clean\n"; + $CPAN::Frontend->myprint("Running make clean\n"); EXCUSE: { my @e; exists $self->{'build_dir'} or push @e, "Has no own directory"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + 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; my $system = join " ", $CPAN::Config->{'make'}, "clean"; if (system($system) == 0) { - print " $system -- OK\n"; + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->force; } else { # Hmmm, what to do if make clean failed? @@ -2718,7 +3035,7 @@ sub install { my($self) = @_; $self->test; return if $CPAN::Signal; - print "Running make install\n"; + $CPAN::Frontend->myprint("Running make install\n"); EXCUSE: { my @e; exists $self->{'build_dir'} or push @e, "Has no own directory"; @@ -2730,7 +3047,8 @@ sub install { $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; - push @e, "make test had returned bad status, won't install without force" + push @e, "make test had returned bad status, ". + "won't install without force" if exists $self->{'make_test'} and $self->{'make_test'} eq 'NO' and ! $self->{'force_update'}; @@ -2739,26 +3057,30 @@ sub install { $self->{'install'} eq "YES" ? "Already done" : "Already tried without success"; - print join "", map {" $_\n"} @e and return if @e; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - 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; - my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}; + 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; + my $system = join(" ", $CPAN::Config->{'make'}, + "install", $CPAN::Config->{make_install_arg}); my($pipe) = FileHandle->new("$system 2>&1 |"); my($makeout) = ""; while (<$pipe>){ - print; + $CPAN::Frontend->myprint($_); $makeout .= $_; } $pipe->close; if ($?==0) { - print " $system -- OK\n"; + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'install'} = "YES"; } else { $self->{'install'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); if ($makeout =~ /permission/s && $> > 0) { - print " You may have to su to root to install the package\n"; + $CPAN::Frontend->myprint(qq{ You may have to su }. + qq{to root to install the package\n}); } } } @@ -2782,19 +3104,26 @@ sub as_string { 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; - my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'}); + 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::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); - File::Path::mkpath($todir); - my($me,$from,$to); - ($me = $self->id) =~ s/.*://; - $from = $self->find_bundle_file($dist->{'build_dir'},"$me.pm"); - $to = $CPAN::META->catfile($todir,"$me.pm"); - File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!"); + 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; @@ -2804,7 +3133,8 @@ sub contains { my $inpod = 0; $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; + $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : + /^=head1\s+CONTENTS/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -2821,9 +3151,10 @@ sub contains { #-> sub CPAN::Bundle::find_bundle_file sub find_bundle_file { my($self,$where,$what) = @_; - my $bu = $CPAN::META->catfile($where,$what); + $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; + my $bu = MM->catfile($where,$what); return $bu if -f $bu; - my $manifest = $CPAN::META->catfile($where,"MANIFEST"); + my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; @@ -2832,17 +3163,24 @@ sub find_bundle_file { ExtUtils::Manifest::mkmanifest(); chdir $cwd; } - my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!"); + my $fh = FileHandle->new($manifest) + or Carp::croak("Couldn't open $manifest: $!"); local($/) = "\n"; while (<$fh>) { next if /^\s*\#/; my($file) = /(\S+)/; - if ($file =~ m|Bundle/$what$|) { + if ($file =~ m|\Q$what\E$|) { $bu = $file; - return $CPAN::META->catfile($where,$bu); + 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); + } } } - Carp::croak("Could't find a Bundle file in $where"); + Carp::croak("Couldn't find a Bundle file in $where"); } #-> sub CPAN::Bundle::inst_file ; @@ -2850,7 +3188,12 @@ sub inst_file { my($self) = @_; my($me,$inst_file); ($me = $self->id) =~ s/.*://; - $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm"); +## my(@me,$inst_file); +## @me = split /::/, $self->id; +## $me[-1] .= ".pm"; + $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, + "Bundle", "$me.pm"); +## "Bundle", @me); return $self->{'INST_FILE'} = $inst_file if -f $inst_file; # $inst_file = $self->SUPER::inst_file; @@ -2862,15 +3205,18 @@ sub inst_file { sub rematein { my($self,$meth) = @_; $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; + 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); for $s ($self->contains) { my($type) = $s =~ m|/| ? 'CPAN::Distribution' : $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; if ($type eq 'CPAN::Distribution') { - warn qq{ + $CPAN::Frontend->mywarn(qq{ The Bundle }.$self->id.qq{ contains explicitly a file $s. -}; +}); sleep 3; } $CPAN::META->instance($type,$s)->$meth(); @@ -2900,7 +3246,8 @@ sub clean { shift->rematein('clean',@_); } #-> sub CPAN::Bundle::readme ; sub readme { my($self) = @_; - my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; + my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ +No File found for bundle } . $self->id . qq{\n}), return; $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; $CPAN::META->instance('CPAN::Distribution',$file)->readme; } @@ -2913,7 +3260,8 @@ sub as_glimpse { my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; + push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, + $self->cpan_file); join "", @m; } @@ -2927,25 +3275,34 @@ sub as_string { local($^W) = 0; push @m, $class, " id = $self->{ID}\n"; my $sprintf = " %-12s %s\n"; - push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description}; + push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description}) + if $self->{description}; my $sprintf2 = " %-12s %s (%s)\n"; my($userid); if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ - push @m, sprintf( - $sprintf2, - 'CPAN_USERID', - $userid, - CPAN::Shell->expand('Author',$userid)->fullname - ) - } - push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION}; - push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE}; + my $author; + if ($author = CPAN::Shell->expand('Author',$userid)) { + push @m, sprintf( + $sprintf2, + 'CPAN_USERID', + $userid, + $author->fullname + ); + } + } + push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) + if $self->{CPAN_VERSION}; + push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE}) + if $self->{CPAN_FILE}; my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; my(%statd,%stats,%statl,%stati); - @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,; - @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; + @statd{qw,? i c a b R M S,} = qw,unknown idea + 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,; + @stati{qw,? f r O,} = qw,unknown functions + references+ties object-oriented,; $statd{' '} = 'unknown'; $stats{' '} = 'unknown'; $statl{' '} = 'unknown'; @@ -2964,12 +3321,14 @@ sub as_string { ) if $self->{statd}; my $local_file = $self->inst_file; if ($local_file && ! exists $self->{MANPAGE}) { - my $fh = FileHandle->new($local_file) or Carp::croak("Couldn't open $local_file: $!"); + my $fh = FileHandle->new($local_file) + or Carp::croak("Couldn't open $local_file: $!"); my $inpod = 0; my(@result); local $/ = "\n"; while (<$fh>) { - $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod; + $inpod = /^=(?!head1\s+NAME)/ ? 0 : + /^=head1\s+NAME/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -2981,10 +3340,13 @@ sub as_string { } my($item); for $item (qw/MANPAGE CONTAINS/) { - push @m, sprintf $sprintf, $item, $self->{$item} if exists $self->{$item}; + push @m, sprintf($sprintf, $item, $self->{$item}) + if exists $self->{$item}; } - push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)"; - push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file; + push @m, sprintf($sprintf, 'INST_FILE', + $local_file || "(not installed)"); + push @m, sprintf($sprintf, 'INST_VERSION', + $self->inst_version) if $local_file; join "", @m, "\n"; } @@ -2995,10 +3357,17 @@ sub cpan_file { unless (defined $self->{'CPAN_FILE'}) { CPAN::Index->reload; } - if (defined $self->{'CPAN_FILE'}){ + if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){ return $self->{'CPAN_FILE'}; - } elsif (defined $self->{'userid'}) { - return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname + } elsif (exists $self->{'userid'} && defined $self->{'userid'}) { + my $fullname = $CPAN::META->instance(CPAN::Author, + $self->{'userid'})->fullname; + unless (defined $fullname) { + $CPAN::Frontend->mywarn(qq{Full name of author }. + qq{$self->{userid} not known}); + return "Contact Author $self->{userid}"; + } + return "Contact Author $self->{userid} ($fullname)" } else { return "N/A"; } @@ -3007,7 +3376,20 @@ sub cpan_file { *name = \&cpan_file; #-> sub CPAN::Module::cpan_version ; -sub cpan_version { shift->{'CPAN_VERSION'} } +sub cpan_version { + my $self = shift; + $self->{'CPAN_VERSION'} = 'undef' + unless defined $self->{'CPAN_VERSION'}; # I believe this is + # always a bug in the + # index and should be + # reported as such, + # but usually I find + # out such an error + # and do not want to + # provoke too many + # bugreports + $self->{'CPAN_VERSION'}; +} #-> sub CPAN::Module::force ; sub force { @@ -3053,8 +3435,13 @@ sub install { 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'}) { - print $self->id, " is up to date.\n"; + if ($inst_file + && + $have >= $latest + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); } else { $doit = 1; } @@ -3071,7 +3458,7 @@ sub inst_file { @packpath = split /::/, $self->{ID}; $packpath[-1] .= ".pm"; foreach $dir (@INC) { - my $pmfile = CPAN->catfile($dir,@packpath); + my $pmfile = MM->catfile($dir,@packpath); if (-f $pmfile){ return $pmfile; } @@ -3087,7 +3474,7 @@ sub xs_file { push @packpath, $packpath[-1]; $packpath[-1] .= "." . $Config::Config{'dlext'}; foreach $dir (@INC) { - my $xsfile = CPAN->catfile($dir,'auto',@packpath); + my $xsfile = MM->catfile($dir,'auto',@packpath); if (-f $xsfile){ return $xsfile; } @@ -3098,12 +3485,10 @@ sub xs_file { #-> sub CPAN::Module::inst_version ; sub inst_version { my($self) = @_; - my $parsefile = $self->inst_file or return 0; + my $parsefile = $self->inst_file or return; local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; - my $have = MM->parse_version($parsefile); - $have ||= 0; + my $have = MM->parse_version($parsefile) || "undef"; $have =~ s/\s+//g; - $have ||= 0; $have; } @@ -3257,7 +3642,8 @@ the package CPAN::Shell. If you enter the shell command, all your input is split by the Text::ParseWords::shellwords() routine which acts like most shells do. The first word is being interpreted as the method to be called and the rest of the words are treated as arguments -to this method. +to this method. Continuation lines are supported if a line ends with a +literal backslash. =head2 autobundle @@ -3287,7 +3673,7 @@ perl breaks binary compatibility. If one of the modules that CPAN uses is in turn depending on binary compatibility (so you cannot run CPAN commands), then you should try the CPAN::Nox module for recovery. -=head2 The 4 C<CPAN::*> Classes: Author, Bundle, Module, Distribution +=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution Although it may be considered internal, the class hierarchie does matter for both users and programmer. CPAN.pm deals with above @@ -3318,12 +3704,12 @@ BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if you would like to install version 1.23_90, you need to know where the distribution file resides on CPAN relative to the authors/id/ directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz, -so he would have to say +so you would have to say install BAR/Foo-1.23_90.tar.gz The first example will be driven by an object of the class -CPAN::Module, the second by an object of class Distribution. +CPAN::Module, the second by an object of class CPAN::Distribution. =head2 ProgrammerE<39>s interface @@ -3365,7 +3751,8 @@ functionalities that are available in the shell. # list all modules on my disk that have no VERSION number for $mod (CPAN::Shell->expand("Module","/./")){ next unless $mod->inst_file; - next if $mod->inst_version; + # MakeMaker convention for undefined $VERSION: + next unless $mod->inst_version eq "undef"; print "No VERSION in ", $mod->id, "\n"; } @@ -3423,10 +3810,6 @@ your @INC path. The autobundle() command which is available in the shell interface does that for you by including all currently installed modules in a snapshot bundle file. -There is a meaningless Bundle::Demo available on CPAN. Try to install -it, it usually does no harm, just demonstrates what the Bundle -interface looks like. - =head2 Prerequisites If you have a local mirror of CPAN and can access all files with @@ -3550,6 +3933,21 @@ works like the corresponding perl commands. =back +=head2 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 +C<file> URLs, CPAN always tries to get files from there first. This +feature is disabled for index files. So the recommendation for the +owner of a CD-ROM with CPAN contents is: include your local, possibly +outdated CD-ROM as a C<file> URL at the end of urllist, e.g. + + o conf urllist push file://localhost/CDROM/CPAN + +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. + =head1 SECURITY There's no strong security layer in CPAN.pm. CPAN.pm helps you to @@ -3568,11 +3966,11 @@ oneliners. =head1 BUGS we should give coverage for _all_ of the CPAN and not just the -__PAUSE__ part, right? In this discussion CPAN and PAUSE have become +PAUSE part, right? In this discussion CPAN and PAUSE have become equal -- but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/. -Future development should be directed towards a better intergration of +Future development should be directed towards a better integration of the other parts. =head1 AUTHOR diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 3e572d67ae..3fa21c6727 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -15,7 +15,7 @@ use ExtUtils::MakeMaker qw(prompt); use FileHandle (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.20 $, 10; +$VERSION = substr q$Revision: 1.21 $, 10; =head1 NAME @@ -210,7 +210,7 @@ the default and recommended setting. if (@{$CPAN::Config->{urllist}||[]}) { print qq{ I found a list of URLs in CPAN::Config and will use this. -You can change it later with the 'o conf' command. +You can change it later with the 'o conf urllist' command. } } elsif ( diff --git a/lib/Carp.pm b/lib/Carp.pm index 351f83bdf5..685a7933d0 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -53,7 +53,7 @@ $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; -@ISA = Exporter; +@ISA = ('Exporter'); @EXPORT = qw(confess croak carp); @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode diff --git a/lib/Cwd.pm b/lib/Cwd.pm index efcfeca261..3bd0085c73 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -26,14 +26,22 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The fastcwd() function looks the same as getcwd(), but runs faster. -It's also more dangerous because you might conceivably chdir() out of a -directory that you can't chdir() back into. +It's also more dangerous because it might conceivably chdir() you out +of a directory that it can't chdir() you back into. If fastcwd +encounters a problem it will return undef but will probably leave you +in a different directory. For a measure of extra security, if +everything appears to have worked, the fastcwd() function will check +that it leaves you in the same directory that it started in. If it has +changed it will C<die> with the message "Unstable directory path, +current directory changed unexpectedly". That should never happen. The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without -the trailing line terminator). It is recommended that cwd (or another -*cwd() function) is used in I<all> code to ensure portability. +the trailing line terminator). + +It is recommended that cwd (or another *cwd() function) is used in +I<all> code to ensure portability. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See @@ -101,7 +109,7 @@ sub getcwd } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { - $dir = ''; + $dir = undef; } else { @@ -125,9 +133,9 @@ sub getcwd while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } - $cwd = "$dir/$cwd"; + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; closedir(PARENT); - } while ($dir); + } while (defined $dir); chop($cwd) unless $cwd eq '/'; # drop the trailing / $cwd; } @@ -140,33 +148,45 @@ sub getcwd # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. + +# List of metachars taken from do_exec() in doio.c +my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n"); sub fastcwd { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); - ($cdev, $cino) = stat('.'); + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); - chdir('..'); + chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.'); + opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); + last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; - last unless defined $direntry; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); + return undef unless defined $direntry; # should never happen unshift(@path, $direntry); } - chdir($path = '/' . join('/', @path)); + $path = '/' . join('/', @path); + # At this point $path may be tainted (if tainting) and chdir would fail. + # To be more useful we untaint it then check that we landed where we started. + $path = $1 if $path =~ /^(.*)$/; # untaint + chdir($path) || return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; $path; } diff --git a/lib/English.pm b/lib/English.pm index 0cf62bd3b6..bbb6bd7b28 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -92,7 +92,7 @@ sub import { *OSNAME ); -# The ground of all being. +# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) *ARG = *_ ; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index ff5dbf1517..4400858e89 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -34,6 +34,7 @@ sub install { use File::Copy qw(copy); use File::Find qw(find); use File::Path qw(mkpath); + use File::Compare qw(compare); my(%hash) = %$hash; my(%pack, %write, $dir, $warn_permissions); @@ -96,7 +97,7 @@ sub install { my $diff = 0; if ( -f $targetfile && -s _ == $size) { # We have a good chance, we can skip this one - $diff = my_cmp($_,$targetfile); + $diff = compare($_,$targetfile); } else { print "$_ differs\n" if $verbose>1; $diff++; @@ -166,32 +167,6 @@ sub install_default { },1,0,0); } -sub my_cmp { - my($one,$two) = @_; - local(*F,*T); - my $diff = 0; - open T, $two or return 1; - open F, $one or Carp::croak("Couldn't open $one: $!"); - my($fr, $tr, $fbuf, $tbuf, $size); - $size = 1024; - # print "Reading $one\n"; - while ( $fr = read(F,$fbuf,$size)) { - unless ( - $tr = read(T,$tbuf,$size) and - $tbuf eq $fbuf - ){ - # print "diff "; - $diff++; - last; - } - # print "$fr/$tr "; - } - # print "\n"; - close F; - close T; - $diff; -} - sub uninstall { my($fil,$verbose,$nonono) = @_; die "no packlist file found: $fil" unless -f $fil; @@ -226,7 +201,7 @@ sub inc_uninstall { my $diff = 0; if ( -f $targetfile && -s _ == -s $file) { # We have a good chance, we can skip this one - $diff = my_cmp($file,$targetfile); + $diff = compare($file,$targetfile); } else { print "#$file and $targetfile differ\n" if $verbose>1; $diff++; @@ -253,6 +228,7 @@ sub pm_to_blib { use File::Basename qw(dirname); use File::Copy qw(copy); use File::Path qw(mkpath); + use File::Compare qw(compare); use AutoSplit; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first @@ -272,7 +248,7 @@ sub pm_to_blib { mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (my_cmp($_,$fromto->{$_})){ + unless (compare($_,$fromto->{$_})){ print "Skip $fromto->{$_} (unchanged)\n"; next; } diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index fed25ae13b..d821e83729 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -24,7 +24,7 @@ sub _unix_os2_ext { $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; - print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; @@ -34,7 +34,6 @@ sub _unix_os2_ext { # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl - # its home is in <distribution>/ext/util my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; @@ -49,12 +48,12 @@ sub _unix_os2_ext { if ($thislib =~ s/^(-[LR])//){ # save path flag type my($ptype) = $1; unless (-d $thislib){ - print STDOUT "$ptype$thislib ignored, directory does not exist\n" + warn "$ptype$thislib ignored, directory does not exist\n" if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { - print STDOUT "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -65,7 +64,7 @@ sub _unix_os2_ext { # Handle possible library arguments. unless ($thislib =~ s/^-l//){ - print STDOUT "Unrecognized argument in LIBS ignored: '$thislib'\n"; + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; next; } @@ -125,10 +124,10 @@ sub _unix_os2_ext { # # , the compilation tools expand the environment variables.) } else { - print STDOUT "$thislib not found in $thispth\n" if $verbose; + warn "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'-l$thislib' found at $fullname\n" if $verbose; + warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; @@ -174,7 +173,7 @@ sub _unix_os2_ext { } last; # found one here so don't bother looking further } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for -l$thislib\n" unless $found_lib>0; } @@ -202,7 +201,7 @@ sub _win32_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } - print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + warn "Potential libraries are '$potential_libs':\n" if $verbose; # compute $extralibs from $potential_libs @@ -218,13 +217,13 @@ sub _win32_ext { # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { - print STDOUT "-L$thislib ignored, directory does not exist\n" + warn "-L$thislib ignored, directory does not exist\n" if $verbose; next; } elsif (-d $thislib) { unless ($self->file_name_is_absolute($thislib)) { - print STDOUT "Warning: -L$thislib changed to -L$pwd/$thislib\n"; + warn "Warning: -L$thislib changed to -L$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -238,22 +237,22 @@ sub _win32_ext { my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$thislib")) { - print STDOUT "$thislib not found in $thispth\n" if $verbose; + warn "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'$thislib' found at $fullname\n" if $verbose; + warn "'$thislib' found at $fullname\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); last; } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for '$thislib'\n" unless $found_lib>0; } return ('','','','') unless $found; $lib = join(' ',@extralibs); - print "Result: $lib\n" if $verbose; + warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } @@ -275,7 +274,7 @@ sub _vms_ext { 'Xmu' => 'DECW$XMULIBSHR'); if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } - print STDOUT "Potential libraries are '$potential_libs'\n" if $verbose; + warn "Potential libraries are '$potential_libs'\n" if $verbose; # First, sort out directories and library names in the input foreach $lib (split ' ',$potential_libs) { @@ -292,11 +291,11 @@ sub _vms_ext { # path in a logical name.) foreach $dir (@dirs) { unless (-d $dir) { - print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1; + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; $dir = ''; next; } - print STDOUT "Resolving directory $dir\n" if $verbose; + warn "Resolving directory $dir\n" if $verbose; if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } else { $dir = $self->catdir($cwd,$dir); } } @@ -321,24 +320,24 @@ sub _vms_ext { push(@variants,"lib$lib") if $lib !~ /[:>\]]/; } push(@variants,$lib); - print STDOUT "Looking for $lib\n" if $verbose; + warn "Looking for $lib\n" if $verbose; foreach $variant (@variants) { foreach $dir (@dirs) { my($type); $name = "$dir$variant"; - print "\tChecking $name\n" if $verbose > 2; + warn "\tChecking $name\n" if $verbose > 2; if (-f ($test = VMS::Filespec::rmsexpand($name))) { # It's got its own suffix, so we'll have to figure out the type if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } elsif ($test =~ /(?:$obj_ext|obj)$/i) { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; $type = 'obj'; } else { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Unknown library type for $test; assuming shared\n"; $type = 'sh'; } @@ -357,7 +356,7 @@ sub _vms_ext { elsif (not length($ctype) and # If we've got a lib already, don't bother ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."Plain object file $test found in library list\n"; $type = 'obj'; $name = $test unless $test =~ /obj;?\d*$/i; @@ -370,11 +369,11 @@ sub _vms_ext { if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; - print STDOUT "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } - print STDOUT "Note (probably harmless): " + warn "Note (probably harmless): " ."No library found for $lib\n"; } @@ -387,7 +386,7 @@ sub _vms_ext { push(@libs, map { "$_/Library" } sort keys %olb); push(@libs, map { "$_/Share" } sort keys %sh); $lib = join(' ',@libs); - print "Result: $lib\n" if $verbose; + warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 85b0c1bbe5..4f7a9e8137 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1127,7 +1127,12 @@ sub fixin { # stolen from the pink Camel book, more or less # Now look (in reverse) for interpreter in absolute PATH (unless perl). if ($cmd eq "perl") { - $interpreter = $Config{perlpath}; + if ($Config{startperl} =~ m,^\#!.*/perl,) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } else { + $interpreter = $Config{perlpath}; + } } else { my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; $interpreter = ''; @@ -2935,11 +2940,13 @@ sub test { if (!$tests && -d 't') { $tests = $Is_Win32 ? join(' ', <t\\*.t>) : 't/*.t'; } + # note: 'test.pl' name is also hardcoded in init_dirscan() my(@m); push(@m," TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl +TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) @@ -2953,8 +2960,8 @@ test :: \$(TEST_TYPE) push(@m, "\n"); push(@m, "test_dynamic :: pure_all\n"); - push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests; - push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('$(FULLPERL)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('$(FULLPERL)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_dynamic :: pure_all\n"); @@ -2966,8 +2973,8 @@ test :: \$(TEST_TYPE) if ($self->needs_linking()) { push(@m, "test_static :: pure_all \$(MAP_TARGET)\n"); - push(@m, $self->test_via_harness('./$(MAP_TARGET)', $tests)) if $tests; - push(@m, $self->test_via_script('./$(MAP_TARGET)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n"); push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)')); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index ac1378dce2..04de166ad6 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -87,7 +87,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9504"; +$XSUBPP_version = "1.9505"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -294,7 +294,7 @@ sub print_section { do { $_ = shift(@line) } while !/\S/ && @line; print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") - if $WantLineNumbers && !/^\s*#\s*line\b/; + if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { print "$_\n"; } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index e0887d122c..4597c71564 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -100,16 +100,55 @@ sub doglob { } # -# this can be used to override CORE::glob -# by saying C<use File::DosGlob 'glob';>. +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. # -sub glob { doglob(1,@_) } + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my $pat = shift; + my $cxix = shift; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + $entries{$cxix} = [doglob(1,$pat)]; + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} sub import { my $pkg = shift; my $callpkg = caller(0); my $sym = shift; - *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} + if defined($sym) and $sym eq 'glob'; } 1; @@ -125,11 +164,14 @@ perlglob.bat - a more capable perlglob.exe replacement =head1 SYNOPSIS require 5.004; - use File::DosGlob 'glob'; # override CORE::glob + + # override CORE::glob in current package + use File::DosGlob 'glob'; + @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; - # from the command line + # from the command line (overrides only in main::) > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" > perlglob ../pe*/*p? @@ -155,7 +197,10 @@ to standard output. While one may replace perlglob.exe with this, usage by overriding CORE::glob via importation should be much more efficient, because it avoids launching a separate process, and is therefore strongly -recommended. +recommended. Note that it is currently possible to override +builtins like glob() only on a per-package basis, not "globally". +Thus, every namespace that wants to override glob() must explicitly +request the override. See L<perlsub>. Extending it to csh patterns is left as an exercise to the reader. @@ -178,6 +223,10 @@ Gurusamy Sarathy <gsar@umich.edu> =item * +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + A few dir-vs-file optimizations result in glob importation being 10 times faster than using perlglob.exe, and using perlglob.bat is only twice as slow as perlglob.exe (GSAR 28-MAY-97) diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 1d565f2871..033cfe5e9d 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -65,6 +65,10 @@ that don't resolve: -l && !-e && print "bogus link: $File::Find::name\n"; } +=head1 BUGS + +There is no way to make find or finddepth follow symlinks. + =cut @ISA = qw(Exporter); diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 0264b61f15..455fc63917 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -69,7 +69,8 @@ import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; sub import { my $pkg = shift; my $callpkg = caller; - Exporter::export $pkg, $callpkg, @_; + require Exporter; + Exporter::export($pkg, $callpkg, @_); # # If the Fcntl extension is available, @@ -77,7 +78,7 @@ sub import { # eval { require Fcntl; - Exporter::export 'Fcntl', $callpkg; + Exporter::export('Fcntl', $callpkg); }; } diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index b0bcf6b810..2b05300404 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,12 +2,12 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.10 1997-04-18 22:21:10+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.11 1997-09-17 12:23:51+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Wed Apr 16 16:27:33 1997 -# Update Count : 597 +# Last Modified On: Wed Sep 17 12:20:10 1997 +# Update Count : 608 # Status : Released =head1 NAME @@ -56,8 +56,9 @@ value. With a command line of "--size 24" this will cause the variable $offset to get the value 24. Alternatively, the first argument to GetOptions may be a reference to -a HASH describing the linkage for the options. The following call is -equivalent to the example above: +a HASH describing the linkage for the options, or an object whose +class is based on a HASH. The following call is equivalent to the +example above: %optctl = ("size" => \$offset); GetOptions(\%optctl, "size=i"); @@ -525,7 +526,7 @@ BEGIN { require 5.003; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.10 $ =~ /(\d+)\.(\d+)/); + $VERSION = sprintf("%d.%02d", q$Revision: 2.11 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -576,7 +577,7 @@ sub GetOptions { $genprefix = $gen_prefix; # so we can call the same module many times $error = 0; - print STDERR ('GetOptions $Revision: 2.10 $ ', + print STDERR ('GetOptions $Revision: 2.11 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -591,9 +592,13 @@ sub GetOptions { if $debug; # Check for ref HASH as first argument. + # First argument may be an object. It's OK to use this as long + # as it is really a hash underneath. $userlinkage = undef; - if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) { + if ( ref($optionlist[0]) and + "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) { $userlinkage = shift (@optionlist); + print STDERR ("=> user linkage: $userlinkage\n") if $debug; } # See if the first element of the optionlist contains option @@ -1145,7 +1150,11 @@ $find_option = sub { elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer if ( $arg !~ /^-?[0-9]+$/ ) { if ( defined $optarg || $mand eq "=" ) { - return 0 if $passthrough; + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return 0; + } print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (number expected)\n"); $error++; @@ -1165,7 +1174,11 @@ $find_option = sub { elsif ( $type eq "f" ) { # real number, int is also ok if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { if ( defined $optarg || $mand eq "=" ) { - return 0 if $passthrough; + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return 0; + } print STDERR ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); $error++; diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index fee0d33e8f..27882935f9 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -67,7 +67,7 @@ sub getopt ($;$) { $$hash{$first} = $rest; } else { - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; push( @EXPORT, "\$opt_$first" ); } } @@ -76,7 +76,7 @@ sub getopt ($;$) { $$hash{$first} = 1; } else { - eval "\$opt_$first = 1;"; + ${"opt_$first"} = 1; push( @EXPORT, "\$opt_$first" ); } if ($rest ne '') { @@ -116,7 +116,7 @@ sub getopts ($;$) { $$hash{$first} = $rest; } else { - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; push( @EXPORT, "\$opt_$first" ); } } @@ -125,7 +125,7 @@ sub getopts ($;$) { $$hash{$first} = 1; } else { - eval "\$opt_$first = 1"; + ${"opt_$first"} = 1; push( @EXPORT, "\$opt_$first" ); } if($rest eq '') { diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 33c60231aa..64477fa7f3 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1,26 +1,29 @@ -# $RCSFile$ # # Complex numbers and associated mathematical functions -# -- Raphael Manfredi, September 1996 -# -- Jarkko Hietaniemi, March-April 1997 +# -- Raphael Manfredi September 1996 +# -- Jarkko Hietaniemi March-October 1997 +# -- Daniel S. Lewart September-October 1997 +# require Exporter; package Math::Complex; +$VERSION = 1.05; + +# $Id: Complex.pm,v 1.2 1997/10/15 10:08:39 jhi Exp $ + use strict; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $package $display - $i $logn %logn); + $i $ip2 $logn %logn); @ISA = qw(Exporter); -$VERSION = 1.01; - my @trig = qw( pi - sin cos tan + tan csc cosec sec cot cotan asin acos atan acsc acosec asec acot acotan @@ -32,7 +35,7 @@ my @trig = qw( @EXPORT = (qw( i Re Im arg - sqrt exp log ln + sqrt log ln log10 logn cbrt root cplx cplxe ), @@ -99,8 +102,11 @@ sub make { sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; - $theta += pi() if $rho < 0; - $self->{'polar'} = [abs($rho), $theta]; + if ($rho < 0) { + $rho = -$rho; + $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); + } + $self->{'polar'} = [$rho, $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; return $self; @@ -133,18 +139,30 @@ sub cplxe { # # pi # -# The number defined as 2 * pi = 360 degrees +# The number defined as pi = 180 degrees # - use constant pi => 4 * atan2(1, 1); # -# log2inv +# pit2 # -# Used in log10(). +# The full circle +# +use constant pit2 => 2 * pi; + # +# pip2 +# +# The quarter circle +# +use constant pip2 => pi / 2; -use constant log10inv => 1 / log(10); +# +# uplog10 +# +# Used in log10(). +# +use constant uplog10 => 1 / log(10); # # i @@ -155,7 +173,7 @@ sub i () { return $i if ($i); $i = bless {}; $i->{'cartesian'} = [0, 1]; - $i->{'polar'} = [1, pi/2]; + $i->{'polar'} = [1, pip2]; $i->{c_dirty} = 0; $i->{p_dirty} = 0; return $i; @@ -242,15 +260,28 @@ sub minus { # Computes z1*z2. # sub multiply { - my ($z1, $z2, $regular) = @_; - my ($r1, $t1) = @{$z1->polar}; - $z2 = cplxe(abs($z2), $z2 >= 0 ? 0 : pi) unless ref $z2; - my ($r2, $t2) = @{$z2->polar}; - unless (defined $regular) { - $z1->set_polar([$r1 * $r2, $t1 + $t2]); + my ($z1, $z2, $regular) = @_; + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t = $t1 + $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + unless (defined $regular) { + $z1->set_polar([$r1 * $r2, $t]); return $z1; + } + return (ref $z1)->emake($r1 * $r2, $t); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + my ($x2, $y2) = @{$z2->cartesian}; + return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2); + } else { + return (ref $z1)->make($x1*$z2, $y1*$z2); + } } - return (ref $z1)->emake($r1 * $r2, $t1 + $t2); } # @@ -268,7 +299,7 @@ sub _divbyzero { } my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -281,20 +312,45 @@ sub _divbyzero { # sub divide { my ($z1, $z2, $inverted) = @_; - my ($r1, $t1) = @{$z1->polar}; - $z2 = cplxe(abs($z2), $z2 >= 0 ? 0 : pi) unless ref $z2; - my ($r2, $t2) = @{$z2->polar}; - unless (defined $inverted) { - _divbyzero "$z1/0" if ($r2 == 0); - $z1->set_polar([$r1 / $r2, $t1 - $t2]); - return $z1; - } - if ($inverted) { + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t; + if ($inverted) { _divbyzero "$z2/0" if ($r1 == 0); - return (ref $z1)->emake($r2 / $r1, $t2 - $t1); - } else { + $t = $t2 - $t1; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r2 / $r1, $t); + } else { _divbyzero "$z1/0" if ($r2 == 0); - return (ref $z1)->emake($r1 / $r2, $t1 - $t2); + $t = $t1 - $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r1 / $r2, $t); + } + } else { + my ($d, $x2, $y2); + if ($inverted) { + ($x2, $y2) = @{$z1->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z2/0" if $d == 0; + return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + ($x2, $y2) = @{$z2->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z1/0" if $d == 0; + my $u = ($x1*$x2 + $y1*$y2)/$d; + my $v = ($y1*$x2 - $x1*$y2)/$d; + return (ref $z1)->make($u, $v); + } else { + _divbyzero "$z1/0" if $z2 == 0; + return (ref $z1)->make($x1/$z2, $y1/$z2); + } + } } } @@ -307,7 +363,7 @@ 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; @@ -330,14 +386,7 @@ sub power { return 0 if ($z1z); return 1 if ($z2z or $z1 == 1); } - $z2 = cplx($z2) unless ref $z2; - unless (defined $inverted) { - my $z3 = exp($z2 * log $z1); - $z1->set_cartesian([@{$z3->cartesian}]); - return $z1; - } - return exp($z2 * log $z1) unless $inverted; - return exp($z1 * log $z2); + return $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1); } # @@ -364,7 +413,8 @@ sub negate { my ($z) = @_; if ($z->{c_dirty}) { my ($r, $t) = @{$z->polar}; - return (ref $z)->emake($r, pi + $t); + $t = ($t <= 0) ? $t + pi : $t - pi; + return (ref $z)->emake($r, $t); } my ($re, $im) = @{$z->cartesian}; return (ref $z)->make(-$re, -$im); @@ -392,9 +442,8 @@ sub conjugate { # sub abs { my ($z) = @_; - return abs($z) unless ref $z; my ($r, $t) = @{$z->polar}; - return abs($r); + return $r; } # @@ -406,6 +455,8 @@ sub arg { my ($z) = @_; return ($z < 0 ? pi : 0) unless ref $z; my ($r, $t) = @{$z->polar}; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } return $t; } @@ -416,7 +467,9 @@ sub arg { # sub sqrt { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + return $z >= 0 ? sqrt($z) : cplx(0, sqrt(-$z)) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return cplx($re < 0 ? (0, sqrt(-$re)) : (sqrt($re), 0)) if $im == 0; my ($r, $t) = @{$z->polar}; return (ref $z)->emake(sqrt($r), $t/2); } @@ -428,9 +481,10 @@ sub sqrt { # sub cbrt { my ($z) = @_; - return cplx($z, 0) ** (1/3) unless ref $z; + return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) + unless ref $z; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake($r**(1/3), $t/3); + return (ref $z)->emake(exp(log($r)/3), $t/3); } # @@ -442,7 +496,7 @@ sub _rootbad { my $mess = "Root $_[0] not defined, root must be positive integer.\n"; my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -464,7 +518,7 @@ sub root { my ($r, $t) = ref $z ? @{$z->polar} : (abs($z), $z >= 0 ? 0 : pi); my @root; my $k; - my $theta_inc = 2 * pi / $n; + my $theta_inc = pit2 / $n; my $rho = $r ** (1/$n); my $theta; my $complex = ref($z) || $package; @@ -505,7 +559,6 @@ sub Im { # sub exp { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; return (ref $z)->emake(exp($x), $y); } @@ -513,7 +566,7 @@ sub exp { # # _logofzero # -# Die on division by zero. +# Die on logarithm of zero. # sub _logofzero { my $mess = "$_[0]: Logarithm of zero.\n"; @@ -525,7 +578,7 @@ sub _logofzero { } my @up = caller(1); - + $mess .= "Died at $up[1] line $up[2].\n"; die $mess; @@ -538,11 +591,14 @@ sub _logofzero { # sub log { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($x, $y) = @{$z->cartesian}; + unless (ref $z) { + _logofzero("log") if $z == 0; + return $z > 0 ? log($z) : cplx(log(-$z), pi); + } my ($r, $t) = @{$z->polar}; - $t -= 2 * pi if ($t > pi() and $x < 0); - $t += 2 * pi if ($t < -pi() and $x < 0); + _logofzero("log") if $r == 0; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } return (ref $z)->make(log($r), $t); } @@ -560,11 +616,7 @@ sub ln { Math::Complex::log(@_) } # sub log10 { - my ($z) = @_; - - return log(cplx($z, 0)) * log10inv unless ref $z; - my ($r, $t) = @{$z->polar}; - return (ref $z)->make(log($r) * log10inv, $t * log10inv); + return Math::Complex::log($_[0]) * uplog10; } # @@ -587,7 +639,6 @@ sub logn { # sub cos { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = exp($y); my $ey_1 = 1 / $ey; @@ -602,7 +653,6 @@ sub cos { # sub sin { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; my ($x, $y) = @{$z->cartesian}; my $ey = exp($y); my $ey_1 = 1 / $ey; @@ -656,7 +706,7 @@ sub cosec { Math::Complex::csc(@_) } # # cot # -# Computes cot(z) = 1 / tan(z). +# Computes cot(z) = cos(z) / sin(z). # sub cot { my ($z) = @_; @@ -678,21 +728,20 @@ sub cotan { Math::Complex::cot(@_) } # Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)). # sub acos { - my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return atan2(sqrt(1 - $re * $re), $re) - if ($im == 0 and abs($re) <= 1.0); - my $acos = ~i * log($z + sqrt($z*$z - 1)); - if ($im == 0 || - (abs($re) < 1 && abs($im) < 1) || - (abs($re) > 1 && abs($im) > 1 - && !($re > 1 && $im > 1) - && !($re < -1 && $im < -1))) { - # this rule really, REALLY, must be simpler - return -$acos; - } - return $acos; + my $z = $_[0]; + return atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2(sqrt(1-$beta*$beta), $beta); + my $v = log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); } # @@ -701,12 +750,20 @@ sub acos { # Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)). # sub asin { - my ($z) = @_; - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return atan2($re, sqrt(1 - $re * $re)) - if ($im == 0 and abs($re) <= 1.0); - return ~i * log(i * $z + sqrt(1 - $z*$z)); + my $z = $_[0]; + return atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2($beta, sqrt(1-$beta*$beta)); + my $v = -log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); } # @@ -716,10 +773,12 @@ sub asin { # sub atan { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + return atan2($z, 1) unless ref $z; _divbyzero "atan(i)" if ( $z == i); _divbyzero "atan(-i)" if (-$z == i); - return i/2*log((i + $z) / (i - $z)); + my $log = log((i + $z) / (i - $z)); + $ip2 = 0.5 * i unless defined $ip2; + return $ip2 * $log; } # @@ -730,16 +789,7 @@ sub atan { sub asec { my ($z) = @_; _divbyzero "asec($z)", $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && abs($re) >= 1.0) { - my $ire = 1 / $re; - return atan2(sqrt(1 - $ire * $ire), $ire); - } - my $asec = acos(1 / $z); - return ~$asec if $re < 0 && $re > -1 && $im == 0; - return -$asec if $im && !($re > 0 && $im > 0) && !($re < 0 && $im < 0); - return $asec; + return acos(1 / $z); } # @@ -750,15 +800,7 @@ sub asec { sub acsc { my ($z) = @_; _divbyzero "acsc($z)", $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && abs($re) >= 1.0) { - my $ire = 1 / $re; - return atan2($ire, sqrt(1 - $ire * $ire)); - } - my $acsc = asin(1 / $z); - return ~$acsc if $re < 0 && $re > -1 && $im == 0; - return $acsc; + return asin(1 / $z); } # @@ -775,8 +817,7 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; - _divbyzero "acot($z)" if ($z == 0); - $z = cplx($z, 0) unless ref $z; + return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z; _divbyzero "acot(i)", if ( $z == i); _divbyzero "acot(-i)" if (-$z == i); return atan(1 / $z); @@ -796,15 +837,14 @@ sub acotan { Math::Complex::acot(@_) } # sub cosh { my ($z) = @_; - my $real; + my $ex; unless (ref $z) { - $z = cplx($z, 0); - $real = 1; + $ex = exp($z); + return ($ex + 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - my $ex = exp($x); + $ex = exp($x); my $ex_1 = 1 / $ex; - return cplx(0.5 * ($ex + $ex_1), 0) if $real; return (ref $z)->make(cos($y) * ($ex + $ex_1)/2, sin($y) * ($ex - $ex_1)/2); } @@ -816,15 +856,14 @@ sub cosh { # sub sinh { my ($z) = @_; - my $real; + my $ex; unless (ref $z) { - $z = cplx($z, 0); - $real = 1; + $ex = exp($z); + return ($ex - 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - my $ex = exp($x); + $ex = exp($x); my $ex_1 = 1 / $ex; - return cplx(0.5 * ($ex - $ex_1), 0) if $real; return (ref $z)->make(cos($y) * ($ex - $ex_1)/2, sin($y) * ($ex + $ex_1)/2); } @@ -894,14 +933,19 @@ sub cotanh { Math::Complex::coth(@_) } # # acosh # -# Computes the arc hyperbolic cosine acosh(z) = log(z +- sqrt(z*z-1)). +# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)). # sub acosh { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; + unless (ref $z) { + return log($z + sqrt($z*$z-1)) if $z >= 1; + $z = cplx($z, 0); + } my ($re, $im) = @{$z->cartesian}; - return log($re + sqrt(cplx($re*$re - 1, 0))) - if ($im == 0 && $re < 0); + if ($im == 0) { + return cplx(log($re + sqrt($re*$re - 1)), 0) if $re >= 1; + return cplx(0, atan2(sqrt(1-$re*$re), $re)) if abs($re) <= 1; + } return log($z + sqrt($z*$z - 1)); } @@ -912,7 +956,6 @@ sub acosh { # sub asinh { my ($z) = @_; - $z = cplx($z, 0) unless ref $z; return log($z + sqrt($z*$z + 1)); } @@ -923,14 +966,13 @@ sub asinh { # sub atanh { my ($z) = @_; + unless (ref $z) { + return log((1 + $z)/(1 - $z))/2 if abs($z) < 1; + $z = cplx($z, 0); + } _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); _logofzero 'atanh(-1)' if ($z == -1); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && $re > 1) { - return cplx(atanh(1 / $re), pi/2); - } - return log((1 + $z) / (1 - $z)) / 2; + return 0.5 * log((1 + $z) / (1 - $z)); } # @@ -941,12 +983,6 @@ sub atanh { sub asech { my ($z) = @_; _divbyzero 'asech(0)', $z if ($z == 0); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 && $re < 0) { - my $ire = 1 / $re; - return log($ire + sqrt(cplx($ire*$ire - 1, 0))); - } return acosh(1 / $z); } @@ -975,13 +1011,12 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; + unless (ref $z) { + return log(($z + 1)/($z - 1))/2 if abs($z) > 1; + $z = cplx($z, 0); + } _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); _logofzero 'acoth(-1)' if ($z == -1); - $z = cplx($z, 0) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - if ($im == 0 and abs($re) < 1) { - return cplx(acoth(1/$re) , pi/2); - } return log((1 + $z) / ($z - 1)) / 2; } @@ -999,17 +1034,23 @@ sub acotanh { Math::Complex::acoth(@_) } # sub atan2 { my ($z1, $z2, $inverted) = @_; - my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0); - my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); - my $tan; - if (defined $inverted && $inverted) { # atan(z2/z1) - return pi * ($re2 > 0 ? 1 : -1) if $re1 == 0 && $im1 == 0; - $tan = $z2 / $z1; + my ($re1, $im1, $re2, $im2); + if ($inverted) { + ($re1, $im1) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + ($re2, $im2) = @{$z1->cartesian}; } else { - return pi * ($re1 > 0 ? 1 : -1) if $re2 == 0 && $im2 == 0; - $tan = $z1 / $z2; + ($re1, $im1) = @{$z1->cartesian}; + ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + } + if ($im2 == 0) { + return cplx(atan2($re1, $re2), 0) if $im1 == 0; + return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; } - return atan($tan); + my $w = atan($z1/$z2); + my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0); + $u += pi if $re2 < 0; + $u -= pit2 if $u > pi; + return cplx($u, $v); } # @@ -1017,7 +1058,7 @@ sub atan2 { # ->display_format # # Set (fetch if no argument) display format for all complex numbers that -# don't happen to have overrriden it via ->display_format +# don't happen to have overridden it via ->display_format # # When called as a method, this actually sets the display format for # the current object. @@ -1076,16 +1117,17 @@ sub stringify_cartesian { my $z = shift; my ($x, $y) = @{$z->cartesian}; my ($re, $im); + my $eps = 1e-14; - $x = int($x + ($x < 0 ? -1 : 1) * 1e-14) - if int(abs($x)) != int(abs($x) + 1e-14); - $y = int($y + ($y < 0 ? -1 : 1) * 1e-14) - if int(abs($y)) != int(abs($y) + 1e-14); + $x = int($x + ($x < 0 ? -1 : 1) * $eps) + if int(abs($x)) != int(abs($x) + $eps); + $y = int($y + ($y < 0 ? -1 : 1) * $eps) + if int(abs($y)) != int(abs($y) + $eps); - $re = "$x" if abs($x) >= 1e-14; - if ($y == 1) { $im = 'i' } - elsif ($y == -1) { $im = '-i' } - elsif (abs($y) >= 1e-14) { $im = $y . "i" } + $re = "$x" if abs($x) >= $eps; + if ($y == 1) { $im = 'i' } + elsif ($y == -1) { $im = '-i' } + elsif (abs($y) >= $eps) { $im = $y . "i" } my $str = ''; $str = $re if defined $re; @@ -1110,10 +1152,9 @@ sub stringify_polar { return '[0,0]' if $r <= $eps; - my $tpi = 2 * pi; - my $nt = $t / $tpi; - $nt = ($nt - int($nt)) * $tpi; - $nt += $tpi if $nt < 0; # Range [0, 2pi] + my $nt = $t / pit2; + $nt = ($nt - int($nt)) * pit2; + $nt += pit2 if $nt < 0; # Range [0, 2pi] if (abs($nt) <= $eps) { $theta = 0 } elsif (abs(pi-$nt) <= $eps) { $theta = 'pi' } @@ -1131,9 +1172,9 @@ sub stringify_polar { # Okay, number is not a real. Try to identify pi/n and friends... # - $nt -= $tpi if $nt > pi; + $nt -= pit2 if $nt > pi; my ($n, $k, $kpi); - + for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); if (abs($kpi/$n - $nt) <= $eps) { @@ -1164,7 +1205,7 @@ Math::Complex - complex numbers and associated mathematical functions =head1 SYNOPSIS use Math::Complex; - + $z = Math::Complex->make(5, 6); $t = 4 - 3*i + $z; $j = cplxe(1, 2*pi/3); @@ -1241,7 +1282,7 @@ between this form and the cartesian form C<a + bi> is immediate: which is also expressed by this formula: - z = rho * exp(i * theta) = rho * (cos theta + i * sin theta) + z = rho * exp(i * theta) = rho * (cos theta + i * sin theta) In other words, it's the projection of the vector onto the I<x> and I<y> axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta> @@ -1251,8 +1292,8 @@ noted C<abs(z)>. The polar notation (also known as the trigonometric representation) is much more handy for performing multiplications and divisions of complex numbers, whilst the cartesian notation is better -suited for additions and substractions. Real numbers are on the I<x> -axis, and therefore I<theta> is zero. +suited for additions and subtractions. Real numbers are on the I<x> +axis, and therefore I<theta> is zero or I<pi>. All the common operations that can be performed on a real number have been defined to work on complex numbers as well, and are merely @@ -1261,8 +1302,8 @@ they keep their natural meaning when there is no imaginary part, provided the number is within their definition set. For instance, the C<sqrt> routine which computes the square root of -its argument is only defined for positive real numbers and yields a -positive real number (it is an application from B<R+> to B<R+>). +its argument is only defined for non-negative real numbers and yields a +non-negative real number (it is an application from B<R+> to B<R+>). If we allow it to return a complex number, then it can be extended to negative real numbers to become an application from B<R> to B<C> (the set of complex numbers): @@ -1275,10 +1316,9 @@ the following definition: sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2) -Indeed, a negative real number can be noted C<[x,pi]> -(the modulus I<x> is always positive, so C<[x,pi]> is really C<-x>, a -negative number) -and the above definition states that +Indeed, a negative real number can be noted C<[x,pi]> (the modulus +I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative +number) and the above definition states that sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i @@ -1342,7 +1382,6 @@ the following (overloaded) operations are supported on complex numbers: log(z1) = log(r1) + i*t1 sin(z1) = 1/2i (exp(i * z1) - exp(-i * z1)) cos(z1) = 1/2 (exp(i * z1) + exp(-i * z1)) - abs(z1) = r1 atan2(z1, z2) = atan(z1/z2) The following extra operations are supported on both real and complex @@ -1363,7 +1402,7 @@ numbers: cot(z) = 1 / tan(z) asin(z) = -i * log(i*z + sqrt(1-z*z)) - acos(z) = -i * log(z + sqrt(z*z-1)) + acos(z) = -i * log(z + i*sqrt(1-z*z)) atan(z) = i/2 * log((i+z) / (i-z)) acsc(z) = asin(1 / z) @@ -1377,7 +1416,7 @@ numbers: csch(z) = 1 / sinh(z) sech(z) = 1 / cosh(z) coth(z) = 1 / tanh(z) - + asinh(z) = log(z + sqrt(z*z+1)) acosh(z) = log(z + sqrt(z*z-1)) atanh(z) = 1/2 * log((1+z) / (1-z)) @@ -1423,21 +1462,21 @@ if you know the cartesian form of the number, or $z = 3 + 4*i; -if you like. To create a number using the trigonometric form, use either: +if you like. To create a number using the polar form, use either: $z = Math::Complex->emake(5, pi/3); $x = cplxe(5, pi/3); instead. The first argument is the modulus, the second is the angle -(in radians, the full circle is 2*pi). (Mnmemonic: C<e> is used as a -notation for complex numbers in the trigonometric form). +(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a +notation for complex numbers in the polar form). It is possible to write: $x = cplxe(-3, pi/4); but that will be silently converted into C<[3,-3pi/4]>, since the modulus -must be positive (it represents the distance to the origin in the complex +must be non-negative (it represents the distance to the origin in the complex plane). =head1 STRINGIFICATION @@ -1534,17 +1573,8 @@ argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. =head1 BUGS Saying C<use Math::Complex;> exports many mathematical routines in the -caller environment and even overrides some (C<sin>, C<cos>, C<sqrt>, -C<log>, C<exp>). This is construed as a feature by the Authors, -actually... ;-) - -The code is not optimized for speed, although we try to use the cartesian -form for addition-like operators and the trigonometric form for all -multiplication-like operators. - -The arg() routine does not ensure the angle is within the range [-pi,+pi] -(a side effect caused by multiplication and division using the trigonometric -representation). +caller environment and even overrides some (C<sqrt>, C<log>). +This is construed as a feature by the Authors, actually... ;-) All routines expect to be given real or complex numbers. Don't attempt to use BigFloat, since Perl has currently no rule to disambiguate a '+' @@ -1555,6 +1585,8 @@ operation (for instance) between two overloaded entities. Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and Jarkko Hietaniemi <F<jhi@iki.fi>>. +Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. + =cut # eof diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index d23310a5af..95f9a99a7a 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -78,6 +78,19 @@ sub hostname { syscall(&main::SYS_gethostname, $host, 65) == 0; } + # method 2a - syscall using systeminfo instead of gethostname + # -- needed on systems like Solaris + || eval { + local $SIG{__DIE__}; + { + package main; + require "sys/syscall.ph"; + require "sys/systeminfo.ph"; + } + $host = "\0" x 65; ## preload scalar + syscall(&main::SYS_systeminfo, &main::SI_HOSTNAME, $host, 65) != -1; + } + # method 3 - trusty old hostname command || eval { local $SIG{__DIE__}; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index f6d9c3547e..709f5785f5 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -54,15 +54,16 @@ is replaced with C<"$!"> (the latest error message). Sets log mask I<$mask_priority> and returns the old mask. -=item setlogsock $sock_type +=item setlogsock $sock_type (added in 5.004_03) Sets the socket type to be used for the next call to C<openlog()> or C<syslog()>. -A value of 'unix' will connect to the UNIX domain socket returned -by C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect -to an INET socket returned by getservbyname(). -Any other value croaks. +A value of 'unix' will connect to the UNIX domain socket returned by +C<_PATH_LOG> in F<syslog.ph>. If F<syslog.ph> fails to define +C<_PATH_LOG>, C<setlogsock> returns C<undef>; otherwise a true value is +returned. A value of 'inet' will connect to an INET socket returned by +getservbyname(). Any other value croaks. The default is for the INET socket to be used. @@ -135,12 +136,17 @@ sub setlogmask { sub setlogsock { local($setsock) = shift; if (lc($setsock) eq 'unix') { - $sock_unix = 1; + if (defined &_PATH_LOG) { + $sock_unix = 1; + } else { + return undef; + } } elsif (lc($setsock) eq 'inet') { undef($sock_unix); } else { croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; } + return 1; } sub syslog { diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 24e9148ff2..f5fc3d8cc5 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -19,11 +19,11 @@ $VERSION = "1.1502"; format STDOUT_TOP = Failed Test Status Wstat Total Fail Failed List of failed ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- . format STDOUT = -@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< { $curtest->{name}, $curtest->{estat}, $curtest->{wstat}, @@ -32,6 +32,8 @@ format STDOUT = $curtest->{percent}, $curtest->{canon} } +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $curtest->{canon} . @@ -110,7 +112,8 @@ sub runtests { : $wstatus >> 8); if ($wstatus) { my ($failed, $canon, $percent) = ('??', '??'); - print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n"; + printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n", + $wstatus,$wstatus; print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; if (corestatus($wstatus)) { # until we have a wait module if ($have_devel_corestack) { @@ -321,6 +324,10 @@ The global variable $Test::Harness::verbose is exportable and can be used to let runtests() display the standard output of the script without altering the behavior otherwise. +The global variable $Test::Harness::switches is exportable and can be +used to set perl command line options used for running the test +script(s). The default value is C<-w>. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index d2d70dab20..eef412d46d 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -107,7 +107,9 @@ sub cheat { @g = gmtime($guess); $year += $YearFix if $year < $epoch; $lastguess = ""; + $counter = 0; while ($diff = $year - $g[5]) { + croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; $guess += $diff * (363 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ @@ -116,6 +118,7 @@ sub cheat { $lastguess = $thisguess; } while ($diff = $month - $g[4]) { + croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; $guess += $diff * (27 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ diff --git a/lib/autouse.pm b/lib/autouse.pm index a15d08abc5..ab95a19d8a 100644 --- a/lib/autouse.pm +++ b/lib/autouse.pm @@ -49,9 +49,9 @@ sub import { } my $load_sub = sub { - unless ($INC{pm}) { - require $pm; - die $@ if $@; + unless ($INC{$pm}) { + eval {require $pm}; + die if $@; vet_import $module; } *$closure_import_func = \&{"${module}::$closure_func"}; @@ -73,7 +73,7 @@ sub vet_import ($) { my $module = shift; if (my $import = $module->can('import')) { croak "autoused module has unique import() method" - unless defined(\&Exporter::import) + unless defined(&Exporter::import) && $import == \&Exporter::import; } } diff --git a/lib/base.pm b/lib/base.pm new file mode 100644 index 0000000000..e20a64bc9a --- /dev/null +++ b/lib/base.pm @@ -0,0 +1,49 @@ +=head1 NAME + +base - Establish IS-A relationship with base class at compile time + +=head1 SYNOPSIS + + package Baz; + + use base qw(Foo Bar); + +=head1 DESCRIPTION + +Roughly similar in effect to + + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + +This module was introduced with Perl 5.004_04. + +=head1 BUGS + +Needs proper documentation! + +=cut + +package base; + +sub import { + my $class = shift; + + foreach my $base (@_) { + unless (defined %{"$base\::"}) { + eval "require $base"; + unless (defined %{"$base\::"}) { + require Carp; + Carp::croak("Base class package \"$base\" is empty.\n", + "\t(Perhaps you need to 'use' the module ", + "which defines that package first.)"); + } + } + } + + push @{caller(0) . '::ISA'}, @_; +} + +1; diff --git a/lib/blib.pm b/lib/blib.pm index 2dd7802f4b..9e0f6c07c3 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -47,7 +47,6 @@ sub import my $dir = getcwd; if (@_) { - print join(',',@_),"\n"; $dir = shift; $dir =~ s/blib$//; $dir =~ s,/+$,,; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 10016f3bb7..78bf4457cb 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -175,6 +175,8 @@ if ($^O eq 'VMS') { @trypod = ("$archlib/pod/perldiag.pod", "$privlib/pod/perldiag-$].pod", "$privlib/pod/perldiag.pod"); +# handy for development testing of new warnings etc +unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; ($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; $DEBUG ||= 0; diff --git a/lib/getopt.pl b/lib/getopt.pl index a6023c80bc..f871e41850 100644 --- a/lib/getopt.pl +++ b/lib/getopt.pl @@ -24,10 +24,10 @@ sub Getopt { shift(@ARGV); $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1;"; + ${"opt_$first"} = 1; if ($rest ne '') { $ARGV[0] = "-$rest"; } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 469ebff023..d5dbfbdd68 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.00; +$VERSION = 1.01; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -808,9 +808,11 @@ sub DB { last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { end_report(), next CMD if $finished and $level <= 1; - $i = $1; + $subname = $i = $1; if ($i =~ /\D/) { # subroutine name - ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/); + $subname = $package."::".$subname + unless $subname =~ /::/; + ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; @@ -1128,7 +1130,11 @@ sub sub { $doret = -2 if $doret eq $#stack or $frame & 16; @ret; } else { - $ret = &$sub; + if (defined wantarray) { + $ret = &$sub; + } else { + &$sub; undef $ret; + }; $single |= pop(@stack); ($frame & 4 ? ( (print $LINEINFO ' ' x $#stack, "out "), @@ -1178,8 +1184,8 @@ sub postponed_sub { my $offset = $1 || 0; # Filename below can contain ':' my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); - $i += $offset; if ($i) { + $i += $offset; local *dbline = $main::{'_<' . $file}; local $^W = 0; # != 0 is magical below $had_breakpoints{$file}++; @@ -1822,18 +1828,15 @@ sub dbwarn { local $doret = -2; local $SIG{__WARN__} = ''; local $SIG{__DIE__} = ''; - eval { require Carp }; # If error/warning during compilation, - # require may be broken. - warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return - unless defined &Carp::longmess; - #&warn("Entering dbwarn\n"); + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"), + return unless defined &Carp::longmess; my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("Warning in dbwarn\n"); &warn($mess); - #&warn("Exiting dbwarn\n"); } sub dbdie { @@ -1842,28 +1845,24 @@ sub dbdie { local $SIG{__DIE__} = ''; local $SIG{__WARN__} = ''; my $i = 0; my $ineval = 0; my $sub; - #&warn("Entering dbdie\n"); - if ($dieLevel != 2) { - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; - } - { + if ($dieLevel > 2) { local $SIG{__WARN__} = \&dbwarn; - &warn(@_) if $dieLevel > 2; # Ineval is false during destruction? - } - #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2; - die @_ if $ineval and $dieLevel < 2; + &warn(@_); # Yell no matter what + return; + } + if ($dieLevel < 2) { + die @_ if $^S; # in eval propagate } - eval { require Carp }; # If error/warning during compilation, - # require may be broken. - die(@_, "\nUnrecoverable error") unless defined &Carp::longmess; + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") + unless defined &Carp::longmess; # We do not want to debug this chunk (automatic disabling works # inside DB::DB, but not in Carp). my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("dieing loudly in dbdie\n"); die $mess; } diff --git a/lib/vars.pm b/lib/vars.pm index e007baa7b9..5723ac6c2c 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -1,5 +1,39 @@ package vars; +require 5.002; + +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + +sub import { + my $callpack = caller; + my ($pack, @imports, $sym, $ch) = @_; + foreach $sym (@imports) { + if ($sym =~ /::/) { + require Carp; + Carp::croak("Can't declare another package's variables"); + } + ($ch, $sym) = unpack('a1a*', $sym); + *{"${callpack}::$sym"} = + ( $ch eq "\$" ? \$ {"${callpack}::$sym"} + : $ch eq "\@" ? \@ {"${callpack}::$sym"} + : $ch eq "\%" ? \% {"${callpack}::$sym"} + : $ch eq "\*" ? \* {"${callpack}::$sym"} + : $ch eq "\&" ? \& {"${callpack}::$sym"} + : do { + require Carp; + Carp::croak("'$ch$sym' is not a valid variable name\n"); + }); + } +}; + +1; +__END__ + =head1 NAME vars - Perl pragma to predeclare global variable names @@ -30,24 +64,3 @@ later-loaded routines. See L<perlmod/Pragmatic Modules>. =cut - -require 5.002; -use Carp; - -sub import { - my $callpack = caller; - my ($pack, @imports, $sym, $ch) = @_; - foreach $sym (@imports) { - croak "Can't declare another package's variables" if $sym =~ /::/; - ($ch, $sym) = unpack('a1a*', $sym); - *{"${callpack}::$sym"} = - ( $ch eq "\$" ? \$ {"${callpack}::$sym"} - : $ch eq "\@" ? \@ {"${callpack}::$sym"} - : $ch eq "\%" ? \% {"${callpack}::$sym"} - : $ch eq "\*" ? \* {"${callpack}::$sym"} - : $ch eq "\&" ? \& {"${callpack}::$sym"} - : croak "'$ch$sym' is not a valid variable name\n"); - } -}; - -1; |