diff options
Diffstat (limited to 'lib')
38 files changed, 1375 insertions, 655 deletions
diff --git a/lib/Bundle/CPAN.pm b/lib/Bundle/CPAN.pm index 2a05deef59..062aab287d 100644 --- a/lib/Bundle/CPAN.pm +++ b/lib/Bundle/CPAN.pm @@ -1,6 +1,6 @@ package Bundle::CPAN; -$VERSION = '0.02'; +$VERSION = '0.03'; 1; @@ -16,17 +16,27 @@ C<perl -MCPAN -e 'install Bundle::CPAN'> =head1 CONTENTS -CPAN +MD5 + +Data::Dumper # Bundle::libnet may have problems to work without it + +Bundle::libnet + +Term::ReadKey + +Term::ReadLine::Perl # sorry, I'm discriminating the ::Gnu module CPAN::WAIT +CPAN + =head1 DESCRIPTION This bundle includes CPAN.pm as the base module and CPAN::WAIT, the first plugin for CPAN that was developed even before there was an API. After installing this bundle, it is recommended to quit the current -session and start again in a new process. +session and start again in a new process to enable Term::ReadLine. =head1 AUTHOR diff --git a/lib/CPAN.pm b/lib/CPAN.pm index c8b7b28301..8271076bef 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,11 +1,12 @@ package CPAN; -use vars qw{$META $Signal $Cwd $End $Suppress_readline}; +use vars qw{$Try_autoload + $META $Signal $Cwd $End $Suppress_readline %Dontload}; -$VERSION = '1.2401'; +$VERSION = '1.27'; -# $Id: CPAN.pm,v 1.139 1997/03/31 22:43:23 k Exp $ +# $Id: CPAN.pm,v 1.160 1997/07/28 12:21:56 k Exp $ -# my $version = substr q$Revision: 1.139 $, 10; # only used during development +# my $version = substr q$Revision: 1.160 $, 10; # only used during development use Carp (); use Config (); @@ -22,10 +23,6 @@ use Safe (); use Text::ParseWords (); use Text::Wrap; -my $getcwd; -$getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; -$Cwd = Cwd->$getcwd(); - END { $End++; &cleanup; } %CPAN::DEBUG = qw( @@ -55,15 +52,264 @@ use strict qw(vars); # MakeMaker, gives us # catfile and catdir -$META ||= new CPAN; # In case we reeval ourselves we - # need a || - -@EXPORT = qw( +@EXPORT = qw( autobundle bundle expand force get install make readme recompile shell test clean ); +#-> sub CPAN::AUTOLOAD ; +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + CPAN::Shell->$l(@_); + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; + } else { + warn "not OK: $@"; + } + warn "CPAN doesn't know how to autoload $AUTOLOAD :-( +Nothing Done. +"; + sleep 1; + CPAN::Shell->h; + } +} + +#-> sub CPAN::shell ; +sub shell { + $Suppress_readline ||= ! -t STDIN; + + my $prompt = "cpan> "; + local($^W) = 1; + unless ($Suppress_readline) { + require Term::ReadLine; +# import Term::ReadLine; + $term = Term::ReadLine->new('CPAN Monitor'); + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + + no strict; + $META->checklock(); + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + my $rl_avail = $Suppress_readline ? "suppressed" : + ($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 + +} unless $CPAN::Config->{'inhibit_startup_message'} ; + while () { + if ($Suppress_readline) { + print $prompt; + last unless defined ($_ = <> ); + chomp; + } else { + last unless defined ($_ = $term->readline($prompt)); + } + s/^\s+//; + next if /^$/; + $_ = 'h' if $_ eq '?'; + if (/^\!/) { + s/^\!//; + my($eval) = $_; + package CPAN::Eval; + use vars qw($import_done); + CPAN->import(':DEFAULT') unless $import_done++; + CPAN->debug("eval[$eval]") if $CPAN::DEBUG; + eval($eval); + warn $@ if $@; + } elsif (/^q(?:uit)?$/i) { + last; + } elsif (/./) { + my(@line); + if ($] < 5.00322) { # parsewords had a bug until recently + @line = split; + } else { + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next if $@; + } + $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; + my $command = shift @line; + eval { CPAN::Shell->$command(@line) }; + warn $@ if $@; + } + } continue { + &cleanup, die "Goodbye\n" if $Signal; + chdir $cwd; + print "\n"; + } +} + +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); +use File::Find; + +package CPAN::Config; +import ExtUtils::MakeMaker 'neatvalue'; +use vars qw(%can $dot_cpan); + +%can = ( + 'commit' => "Commit changes to disk", + 'defaults' => "Reload defaults from disk", + 'init' => "Interactive setting of all options", +); + +package CPAN::FTP; +use vars qw($Ua); +@CPAN::FTP::ISA = qw(CPAN::Debug); + +package CPAN::Complete; +@CPAN::Complete::ISA = qw(CPAN::Debug); + +package CPAN::Index; +use vars qw($last_time $date_of_03); +@CPAN::Index::ISA = qw(CPAN::Debug); +$last_time ||= 0; +$date_of_03 ||= 0; + +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); + +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::InfoObj); + +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); + +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Module); + +package CPAN::Module; +@CPAN::Module::ISA = qw(CPAN::InfoObj); +package CPAN::Shell; +use vars qw($AUTOLOAD $redef @ISA); +@CPAN::Shell::ISA = qw(CPAN::Debug); + +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + my($autoload) = $AUTOLOAD; + $autoload =~ s/.*:://; + if ($autoload =~ /^w/) { + if ($CPAN::META->has_inst('CPAN::WAIT')) { + CPAN::WAIT->wh; + } else { + print STDERR 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: $@"; + } + warn "CPAN::Shell doesn't know how to autoload $autoload :-( +Nothing Done. +"; + sleep 1; + CPAN::Shell->h; + } +} + +#-> CPAN::Shell::try_dot_al +sub try_dot_al { + my($class,$autoload) = @_; + return unless $CPAN::Try_autoload; + # I don't see how to re-use that from the AutoLoader... + my($name,$ok); + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; + $pkg =~ s|::|/|g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; + $name = undef unless (-r $name); + } + unless (defined $name) + { + $name = "auto/$autoload.al"; + $name =~ s|::|/|g; + } + } + my $save = $@; + eval {local $SIG{__DIE__};require $name}; + if ($@) { + if (substr($autoload,-9) eq '::DESTROY') { + *$autoload = sub {}; + $ok = 1; + } else { + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {local $SIG{__DIE__};require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + Carp::croak $@; + } else { + $ok = 1; + } + } + } else { + $ok = 1; + } + $@ = $save; + 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 +#### You also need AutoSplit 1.01 available. MakeMaker will +#### then build CPAN with all the AutoLoad stuff. +# use AutoLoader; +# $Try_autoload = 1; + +if ($CPAN::Try_autoload) { + for my $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 + )) { + *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; + } +} + + +package CPAN; + +$META ||= CPAN->new; # In case we reeval ourselves we + # need a || + +# Do this after you have set up the whole inheritance +CPAN::Config->load unless defined $CPAN::No_Config_is_ok; + +1; + +# __END__ # uncomment this and AutoSplit version 1.01 will split it #-> sub CPAN::autobundle ; sub autobundle; @@ -77,29 +323,11 @@ sub force; sub install; #-> sub CPAN::make ; sub make; -#-> sub CPAN::shell ; -sub shell; #-> sub CPAN::clean ; sub clean; #-> sub CPAN::test ; sub test; -#-> sub CPAN::AUTOLOAD ; -sub AUTOLOAD { - my($l) = $AUTOLOAD; - $l =~ s/.*:://; - my(%EXPORT); - @EXPORT{@EXPORT} = ''; - if (exists $EXPORT{$l}){ - CPAN::Shell->$l(@_); - } else { - warn "CPAN doesn't know how to autoload $AUTOLOAD :-( -Nothing Done. -"; - CPAN::Shell->h; - } -} - #-> sub CPAN::all ; sub all { my($mgr,$class) = @_; @@ -190,6 +418,12 @@ sub DESTROY { &cleanup; # need an eval? } +#-> sub CPAN::cwd ; +sub cwd {Cwd::cwd();} + +#-> sub CPAN::getcwd ; +sub getcwd {Cwd::getcwd();} + #-> sub CPAN::exists ; sub exists { my($mgr,$class,$id) = @_; @@ -199,71 +433,63 @@ sub exists { exists $META->{$class}{$id}; } -#-> sub CPAN::hasFTP ; -sub hasFTP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasFTP'} = $arg; - } elsif (not defined $self->{'hasFTP'}) { - eval {require Net::FTP;}; - $self->{'hasFTP'} = $@ ? 0 : 1; - } - return $self->{'hasFTP'}; -} +#-> sub CPAN::has_inst +sub has_inst { + my($self,$mod,$message) = @_; + Carp::croak("CPAN->has_inst() called without an argument") + unless defined $mod; + if (defined $message && $message eq "no") { + $Dontload{$mod}||=1; + return 0; + } elsif (exists $Dontload{$mod}) { + return 0; + } + my $file = $mod; + $file =~ s|::|/|g; + $file =~ s|/|\\|g if $^O eq 'MSWin32'; + $file .= ".pm"; + if (exists $INC{$file} && $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"; -#-> sub CPAN::hasLWP ; -sub hasLWP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasLWP'} = $arg; - } elsif (not defined $self->{'hasLWP'}) { - eval {require LWP;}; - $LWP::VERSION ||= 0; - $self->{'hasLWP'} = $LWP::VERSION >= 4.98; - } - return $self->{'hasLWP'}; -} + 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 -#-> sub CPAN::hasMD5 ; -sub hasMD5 { - my($self,$arg) = @_; - if (defined $arg) { - $self->{'hasMD5'} = $arg; - } elsif (not defined $self->{'hasMD5'}) { - eval {require MD5;}; - if ($@) { - print "MD5 security checks disabled because MD5 not installed. - Please consider installing the MD5 module\n"; - $self->{'hasMD5'} = 0; - } else { - $self->{'hasMD5'}++; +}; + sleep 2; } - } - return $self->{'hasMD5'}; -} + } elsif (eval { require $file }) { + # we can still have luck, if the program is fed with a bogus + # database or what + 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. -#-> sub CPAN::hasWAIT ; -sub hasWAIT { - my($self,$arg) = @_; - if (defined $arg) { - $self->{'hasWAIT'} = $arg; - } elsif (not defined $self->{'hasWAIT'}) { - eval {require CPAN::WAIT;}; - if ($@) { - $self->{'hasWAIT'} = 0; - } else { - $self->{'hasWAIT'} = 1; - } +}; + sleep 2; } - return $self->{'hasWAIT'}; + return 0; } #-> sub CPAN::instance ; sub instance { my($mgr,$class,$id) = @_; - ### CPAN::Index->reload; ### not faster: unless time - $CPAN::Index::last_time > 60; CPAN::Index->reload; - ### Carp::croak "instance called without class argument" unless $class; $id ||= ""; $META->{$class}{$id} ||= $class->new(ID => $id ); } @@ -285,96 +511,9 @@ sub cleanup { return unless -f $META->{'LOCK'}; unlink $META->{'LOCK'}; print STDERR "Lockfile removed.\n"; -# my $mess = Carp::longmess(@_); -# die @_; -} - -#-> sub CPAN::shell ; -sub shell { - $Suppress_readline ||= ! -t STDIN; - - my $prompt = "cpan> "; - local($^W) = 1; - unless ($Suppress_readline) { - require Term::ReadLine; -# import Term::ReadLine; - $term = new Term::ReadLine 'CPAN Monitor'; - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::complete'; - } - - no strict; - $META->checklock(); - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = Cwd->$getcwd(); - my $rl_avail = $Suppress_readline ? "suppressed" : - ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : - "available (get Term::ReadKey and Term::ReadLine::Perl ". - "or get Term::ReadLine::Gnu)"; - - print qq{ -cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) -Readline support $rl_avail - -} unless $CPAN::Config->{'inhibit_startup_message'} ; - while () { - if ($Suppress_readline) { - print $prompt; - last unless defined ($_ = <> ); - chomp; - } else { -# if (defined($CPAN::ANDK) && $CPAN::DEBUG) { # !$CPAN::ANDK++;$CPAN::DEBUG=1024 -# my($report,$item); -# $report = ""; -# for $item (qw/ReadLine IN OUT MinLine findConsole Features/) { -# $report .= sprintf "%-15s", $item; -# $report .= $term->$item() || ""; -# $report .= "\n"; -# } -# print $report; -# CPAN->debug($report); -# } - last unless defined ($_ = $term->readline($prompt)); - } - s/^\s//; - next if /^$/; - $_ = 'h' if $_ eq '?'; - if (/^\!/) { - s/^\!//; - my($eval) = $_; - package CPAN::Eval; - use vars qw($import_done); - CPAN->import(':DEFAULT') unless $import_done++; - CPAN->debug("eval[$eval]") if $CPAN::DEBUG; - eval($eval); - warn $@ if $@; - } elsif (/^q(?:uit)?$/i) { - last; - } elsif (/./) { - my(@line); - if ($] < 5.00322) { # parsewords had a bug until recently - @line = split; - } else { - eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next if $@; - } - $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; - my $command = shift @line; - eval { CPAN::Shell->$command(@line) }; - warn $@ if $@; - } - } continue { - &cleanup, die if $Signal; - chdir $cwd; - print "\n"; - } } package CPAN::CacheMgr; -use vars qw($Du); -@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); -use File::Find; #-> sub CPAN::CacheMgr::as_string ; sub as_string { @@ -419,11 +558,12 @@ sub dir { #-> sub CPAN::CacheMgr::entries ; sub entries { my($self,$dir) = @_; + return unless defined $dir; $self->debug("reading dir[$dir]") if $CPAN::DEBUG; $dir ||= $self->{ID}; my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my($cwd) = Cwd->$getcwd(); + my($cwd) = CPAN->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); @@ -517,10 +657,16 @@ sub debug { # eg readline ($caller) = caller(0); $caller =~ s/.*:://; -# print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; -# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; + $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"; if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ - if (ref $arg) { + if ($arg and ref $arg) { eval { require Data::Dumper }; if ($@) { print $arg->as_string; @@ -528,20 +674,12 @@ sub debug { print Data::Dumper::Dumper($arg); } } else { - print "Debug($caller:$func,$line,@rest): $arg\n" + print "Debug($caller:$func,$line,[$rest]): $arg\n" } } } package CPAN::Config; -import ExtUtils::MakeMaker 'neatvalue'; -use vars qw(%can); - -%can = ( - 'commit' => "Commit changes to disk", - 'defaults' => "Reload defaults from disk", - 'init' => "Interactive setting of all options", -); #-> sub CPAN::Config::edit ; sub edit { @@ -580,7 +718,8 @@ sub edit { } else { $CPAN::Config->{$o} = $args[0] if defined $args[0]; print " $o "; - print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; + print defined $CPAN::Config->{$o} ? + $CPAN::Config->{$o} : "UNDEFINED"; } } } @@ -608,8 +747,9 @@ Please specify a filename where to save the configuration or try my $msg = <<EOF unless $configpm =~ /MyConfig/; # This is CPAN.pm's systemwide configuration file. This file provides -# defaults for users, and the values can be changed in a per-user configuration -# file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm. +# defaults for users, and the values can be changed in a per-user +# configuration file. The user-config file is being looked for as +# ~/.cpan/CPAN/MyConfig.pm. EOF $msg ||= "\n"; @@ -654,7 +794,6 @@ sub init { 1; } -my $dot_cpan; #-> sub CPAN::Config::load ; sub load { my($self) = shift; @@ -664,8 +803,9 @@ sub load { eval {require CPAN::MyConfig;}; # where you can override system wide settings return unless @miss = $self->not_loaded; require CPAN::FirstTime; - my($configpm,$fh,$redo); + my($configpm,$fh,$redo,$theycalled); $redo ||= ""; + $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { $configpm = $INC{"CPAN/Config.pm"}; $redo++; @@ -720,7 +860,7 @@ sub load { We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -} if $redo ; +} if $redo && ! $theycalled; print qq{ $configpm initialized. }; @@ -770,8 +910,8 @@ EOF undef; #don't reprint CPAN::Config } -#-> sub CPAN::Config::complete ; -sub complete { +#-> sub CPAN::Config::cpl ; +sub cpl { my($word,$line,$pos) = @_; $word ||= ""; my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); @@ -779,34 +919,6 @@ sub complete { } package CPAN::Shell; -use vars qw($AUTOLOAD $redef @ISA); -@CPAN::Shell::ISA = qw(CPAN::Debug); -if ($CPAN::META->hasWAIT) { - unshift @ISA, "CPAN::WAIT"; -} -# private function ro re-eval this module (handy during development) -#-> sub CPAN::Shell::AUTOLOAD ; -sub AUTOLOAD { - my($autoload) = $AUTOLOAD; - $autoload =~ s/.*:://; - if ($autoload =~ /^w/) { - if ($CPAN::META->hasWAIT) { - CPAN::WAIT->wh; - return; - } else { - print STDERR qq{ -Commands starting with "w" require CPAN::WAIT to be installed. -Please consider installing CPAN::WAIT to use the fulltext index. -Type "install CPAN::WAIT" and restart CPAN.pm. -} - } - } else { - warn "CPAN::Shell doesn't know how to autoload $autoload :-( -Nothing Done. -"; - } - CPAN::Shell->h; -} #-> sub CPAN::Shell::h ; sub h { @@ -847,7 +959,7 @@ sub a { print shift->format_result('Author',@_);} sub b { my($self,@which) = @_; CPAN->debug("which[@which]") if $CPAN::DEBUG; - my($incdir,$bdir,$dh); + my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { $bdir = $CPAN::META->catdir($incdir,"Bundle"); if ($dh = DirHandle->new($bdir)) { # may fail @@ -1297,8 +1409,6 @@ sub clean { shift->rematein('clean',@_); } sub look { shift->rematein('look',@_); } package CPAN::FTP; -use vars qw($Ua); -@CPAN::FTP::ISA = qw(CPAN::Debug); #-> sub CPAN::FTP::ftp_get ; sub ftp_get { @@ -1331,15 +1441,22 @@ sub ftp_get { } #-> sub CPAN::FTP::localize ; +# sorry for the ugly code here, I'll clean it up as soon as Net::FTP +# is in the core sub localize { my($self,$file,$aslocal,$force) = @_; $force ||= 0; Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal; - $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG; + $self->debug("file[$file] aslocal[$aslocal] force[$force]") + if $CPAN::DEBUG; return $aslocal if -f $aslocal && -r _ && ! $force; - rename $aslocal, "$aslocal.bak" if -f $aslocal; + my($restore) = 0; + if (-f $aslocal){ + rename $aslocal, "$aslocal.bak"; + $restore++; + } my($aslocal_dir) = File::Basename::dirname($aslocal); File::Path::mkpath($aslocal_dir); @@ -1349,10 +1466,10 @@ sub localize { to insufficient permissions.\n} unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require LWP::UserAgent; unless ($Ua) { - $Ua = new LWP::UserAgent; + $Ua = LWP::UserAgent->new; my($var); $Ua->proxy('ftp', $var) if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'}; @@ -1373,12 +1490,12 @@ sub localize { $self->debug("localizing[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require URI::URL; - my $u = new URI::URL $url; + my $u = URI::URL->new($url); $l = $u->path; } else { # works only on Unix, is poorly constructed, but - # hopefully better than nothing. + # 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 @@ -1394,7 +1511,7 @@ sub localize { } } - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { print "Fetching $url with LWP\n"; my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { @@ -1404,7 +1521,7 @@ sub localize { if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # that's the nice and easy way thanks to Graham my($host,$dir,$getfile) = ($1,$2,$3); - if ($CPAN::META->hasFTP) { + if ($CPAN::META->has_inst('Net::FTP')) { $dir =~ s|/+|/|g; $self->debug("Going to fetch file [$getfile] from dir [$dir] @@ -1412,13 +1529,6 @@ sub localize { as local [$aslocal]") if $CPAN::DEBUG; CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; warn "Net::FTP failed for some reason\n"; - } else { - warn qq{ - Please, install Net::FTP as soon as possible. Just type - install Net::FTP - Thank you. - -} } } @@ -1430,7 +1540,7 @@ sub localize { # does ncftp handle http? for $funkyftp ($CPAN::Config->{'lynx'},$CPAN::Config->{'ncftp'}) { next unless defined $funkyftp; - next unless -x $funkyftp; + next if $funkyftp =~ /^\s*$/; my($want_compressed); print( qq{ @@ -1442,8 +1552,12 @@ Trying with $funkyftp to get $source_switch = "-source" if $funkyftp =~ /\blynx$/; $source_switch = "-c" if $funkyftp =~ /\bncftp$/; my($system) = "$funkyftp $source_switch '$url' > $aslocal"; + $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); - if (($wstatus = system($system)) == 0) { + if (($wstatus = system($system)) == 0 + && + -s $aslocal # lynx returns 0 on my system even if it fails + ) { if ($want_compressed) { $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; if (system($system) == 0) { @@ -1465,9 +1579,11 @@ Trying with $funkyftp to get } } else { my $estatus = $wstatus >> 8; + my $size = -s $aslocal; print qq{ System call "$system" -returned status $estatus (wstat $wstatus) +returned status $estatus (wstat $wstatus), left +$aslocal with size $size }; } } @@ -1581,8 +1697,8 @@ Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" print "Can't access URL $url.\n\n"; my(@mess,$mess); - push @mess, "LWP" unless CPAN->hasLWP; - push @mess, "Net::FTP" unless CPAN->hasFTP; + 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} ||= ""; @@ -1596,7 +1712,7 @@ Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" print Text::Wrap::wrap("","",$mess), "\n"; } print "Cannot fetch $file\n"; - if (-f "$aslocal.bak") { + if ($restore) { rename "$aslocal.bak", $aslocal; print "Trying to get away with old file:\n"; print $self->ls($aslocal); @@ -1615,7 +1731,7 @@ sub ls { my($perms,%user,%group); my $pname = $name; - if (defined $blocks) { + if ($blocks) { $blocks = int(($blocks + 1) / 2); } else { @@ -1728,10 +1844,9 @@ sub contains { } package CPAN::Complete; -@CPAN::Complete::ISA = qw(CPAN::Debug); -#-> sub CPAN::Complete::complete ; -sub complete { +#-> sub CPAN::Complete::cpl ; +sub cpl { my($word,$line,$pos) = @_; $word ||= ""; $line ||= ""; @@ -1753,44 +1868,44 @@ sub complete { } elsif ( $line !~ /^[\!abdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { - @return = completex('CPAN::Author',$word); + @return = cplx('CPAN::Author',$word); } elsif ($line =~ /^b\s/) { - @return = completex('CPAN::Bundle',$word); + @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { - @return = completex('CPAN::Distribution',$word); + @return = cplx('CPAN::Distribution',$word); } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { - @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word)); + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { - @return = complete_any($word); + @return = cpl_any($word); } elsif ($line =~ /^reload\s/) { - @return = complete_reload($word,$line,$pos); + @return = cpl_reload($word,$line,$pos); } elsif ($line =~ /^o\s/) { - @return = complete_option($word,$line,$pos); + @return = cpl_option($word,$line,$pos); } else { @return = (); } return @return; } -#-> sub CPAN::Complete::completex ; -sub completex { +#-> sub CPAN::Complete::cplx ; +sub cplx { my($class, $word) = @_; grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); } -#-> sub CPAN::Complete::complete_any ; -sub complete_any { +#-> sub CPAN::Complete::cpl_any ; +sub cpl_any { my($word) = shift; return ( - completex('CPAN::Author',$word), - completex('CPAN::Bundle',$word), - completex('CPAN::Distribution',$word), - completex('CPAN::Module',$word), + cplx('CPAN::Author',$word), + cplx('CPAN::Bundle',$word), + cplx('CPAN::Distribution',$word), + cplx('CPAN::Module',$word), ); } -#-> sub CPAN::Complete::complete_reload ; -sub complete_reload { +#-> sub CPAN::Complete::cpl_reload ; +sub cpl_reload { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; @@ -1800,8 +1915,8 @@ sub complete_reload { return grep /^\Q$word\E/, @ok if @words == 2 && $word; } -#-> sub CPAN::Complete::complete_option ; -sub complete_option { +#-> sub CPAN::Complete::cpl_option ; +sub cpl_option { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; @@ -1813,17 +1928,13 @@ sub complete_option { } elsif ($words[1] eq 'index') { return (); } elsif ($words[1] eq 'conf') { - return CPAN::Config::complete(@_); + return CPAN::Config::cpl(@_); } elsif ($words[1] eq 'debug') { return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; } } package CPAN::Index; -use vars qw($last_time $date_of_03); -@CPAN::Index::ISA = qw(CPAN::Debug); -$last_time ||= 0; -$date_of_03 ||= 0; #-> sub CPAN::Index::force_reload ; sub force_reload { @@ -1845,7 +1956,7 @@ sub reload { my($debug,$t2); $last_time = $time; - $cl->read_authindex($cl->reload_x( + $cl->rd_authindex($cl->reload_x( "authors/01mailrc.txt.gz", "01mailrc.gz", $force)); @@ -1853,7 +1964,7 @@ sub reload { $debug = "timing reading 01[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modpacks($cl->reload_x( + $cl->rd_modpacks($cl->reload_x( "modules/02packages.details.txt.gz", "02packag.gz", $force)); @@ -1861,7 +1972,7 @@ sub reload { $debug .= "02[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modlist($cl->reload_x( + $cl->rd_modlist($cl->reload_x( "modules/03modlist.data.gz", "03mlist.gz", $force)); @@ -1875,14 +1986,18 @@ sub reload { sub reload_x { my($cl,$wanted,$localname,$force) = @_; $force ||= 0; - CPAN::Config->load; # we should guarantee loading wherever we rely on Config XXX - my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname); + CPAN::Config->load; # we should guarantee loading wherever we rely + # on Config XXX + my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'}, + $localname); if ( -f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force ) { 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; @@ -1892,8 +2007,8 @@ sub reload_x { return CPAN::FTP->localize($wanted,$abs_wanted,$force); } -#-> sub CPAN::Index::read_authindex ; -sub read_authindex { +#-> sub CPAN::Index::rd_authindex ; +sub rd_authindex { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -1912,8 +2027,8 @@ sub read_authindex { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modpacks ; -sub read_modpacks { +#-> sub CPAN::Index::rd_modpacks ; +sub rd_modpacks { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -1924,6 +2039,7 @@ sub read_modpacks { while (<$fh>) { chomp; my($mod,$version,$dist) = split; +$dist = '' unless defined $dist; ### $version =~ s/^\+//; # if it as a bundle, instatiate a bundle object @@ -1987,8 +2103,8 @@ sub read_modpacks { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modlist ; -sub read_modlist { +#-> sub CPAN::Index::rd_modlist ; +sub rd_modlist { my($cl,$index_target) = @_; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; print "Going to read $index_target\n"; @@ -2018,7 +2134,6 @@ sub read_modlist { } package CPAN::InfoObj; -@CPAN::InfoObj::ISA = qw(CPAN::Debug); #-> sub CPAN::InfoObj::new ; sub new { my $this = bless {}, shift; %$this = @_; $this } @@ -2070,7 +2185,6 @@ sub author { } package CPAN::Author; -@CPAN::Author::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Author::as_glimpse ; sub as_glimpse { @@ -2095,7 +2209,6 @@ sub fullname { shift->{'FULLNAME'} } sub email { shift->{'EMAIL'} } package CPAN::Distribution; -@CPAN::Distribution::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Distribution::called_for ; sub called_for { @@ -2131,34 +2244,33 @@ sub get { my $packagedir; $self->debug("local_file[$local_file]") if $CPAN::DEBUG; - if ($CPAN::META->hasMD5) { + if ($CPAN::META->has_inst('MD5')) { + $self->debug("MD5 is installed, verifying"); $self->verifyMD5; + } else { + $self->debug("MD5 is NOT installed"); + } + $self->debug("Removing tmp") if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + 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){ + $self->untar_me($local_file); + } elsif ( $local_file =~ /\.zip$/i ) { + $self->unzip_me($local_file); + } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) { + $self->pm2dir_me($local_file); + } else { + $self->{archived} = "NO"; } - if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){ - $self->debug("Removing tmp") if $CPAN::DEBUG; - File::Path::rmtree("tmp"); - mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!"; + chdir ".."; + if ($self->{archived} ne 'NO') { chdir "tmp"; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - if ($local_file =~ /z$/i){ - $self->{archived} = "tar"; - if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")== 0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } elsif ($local_file =~ /zip$/i) { - $self->{archived} = "zip"; - if (system("$CPAN::Config->{unzip} $local_file") == 0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } # Let's check if the package has its own directory. - opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC?? - closedir DIR; + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? + $dh->close; my ($distdir,$packagedir); if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; @@ -2179,8 +2291,8 @@ sub get { } } $self->{'build_dir'} = $packagedir; - chdir ".."; + $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; File::Path::rmtree("tmp"); @@ -2198,22 +2310,59 @@ sub get { my $fh = FileHandle->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl"); my $cf = $self->called_for || "unknown"; - $fh->print(qq{ -# This Makefile.PL has been autogenerated by the module CPAN.pm + $fh->print( +qq{# This Makefile.PL has been autogenerated by the module CPAN.pm +# because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ + use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); + }); print qq{Package comes without Makefile.PL.\n}. qq{ Writing one on our own (calling it $cf)\n}; } } - } else { - $self->{archived} = "NO"; } return $self; } +sub untar_me { + my($self,$local_file) = @_; + $self->{archived} = "tar"; + my $system = "$CPAN::Config->{gzip} --decompress --stdout " . + "$local_file | $CPAN::Config->{tar} xvf -"; + if (system($system)== 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub unzip_me { + my($self,$local_file) = @_; + $self->{archived} = "zip"; + my $system = "$CPAN::Config->{unzip} $local_file"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub pm2dir_me { + my($self,$local_file) = @_; + $self->{archived} = "pm"; + my $to = File::Basename::basename($local_file); + $to =~ s/\.(gz|Z)$//; + my $system = "$CPAN::Config->{gzip} --decompress --stdout $local_file > $to"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + #-> sub CPAN::Distribution::new ; sub new { my($class,%att) = @_; @@ -2243,7 +2392,7 @@ Please define it with "o conf shell <your shell>" $dir = $self->dir; my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = Cwd->$getcwd(); + my $pwd = CPAN->$getcwd(); chdir($dir); print qq{Working directory is $dir.\n}; system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error"; @@ -2283,111 +2432,105 @@ sub verifyMD5 { $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; print join "", map {" $_\n"} @e and return if @e; } - my($local_file); - my(@local) = split("/",$self->{ID}); - my($basename) = pop @local; + my($lc_want,$lc_file,@local,$basename); + @local = split("/",$self->{ID}); + pop @local; push @local, "CHECKSUMS"; - my($local_wanted) = - CPAN->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - @local - ); + $lc_want = + CPAN->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @local); local($") = "/"; if ( - -f $local_wanted + -f $lc_want && - $self->MD5_check_file($local_wanted,$basename) + $self->MD5_check_file($lc_want) ) { return $self->{MD5_STATUS} = "OK"; } - $local_file = CPAN::FTP->localize( - "authors/id/@local", - $local_wanted, - 'force>:-{'); - my($checksum_pipe); - if ($local_file) { - # fine - } else { + $lc_file = CPAN::FTP->localize("authors/id/@local", + $lc_want,'force>:-{'); + unless ($lc_file) { $local[-1] .= ".gz"; - $local_file = CPAN::FTP->localize( - "authors/id/@local", - "$local_wanted.gz", - 'force>:-{' - ); - my $system = "$CPAN::Config->{gzip} --decompress $local_file"; - system($system) == 0 or die "Could not uncompress $local_file"; - $local_file =~ s/\.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$//; } - $self->MD5_check_file($local_file,$basename); + $self->MD5_check_file($lc_file); } #-> sub CPAN::Distribution::MD5_check_file ; sub MD5_check_file { - my($self,$lfile,$basename) = @_; - my($cksum); - my $fh = new FileHandle; - local($/) = undef; - if (open $fh, $lfile){ + my($self,$chk_file) = @_; + my($cksum,$file,$basename); + $file = $self->{localfile}; + $basename = File::Basename::basename($file); + my $fh = FileHandle->new; + local($/); + if (open $fh, $chk_file){ my $eval = <$fh>; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); - Carp::confess($@) if $@; - if ($cksum->{$basename}->{md5}) { - $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") - if $CPAN::DEBUG; - my $file = $self->{localfile}; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|"; - if ( - open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5}) - or - open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) - ){ - print "Checksum for $file ok\n"; - return $self->{MD5_STATUS} = "OK"; - } else { - print join( - "", - 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; - my $wrap = qq{I\'d recommend removing $self->{'localfile'}}. - qq{, put another URL at the top of the list of URLs to }. - qq{visit, and restart CPAN.pm. If all this doesn\'t help, }. - qq{please contact the author or your CPAN site admin}; - print Text::Wrap::wrap("","",$wrap); - print "\n\n"; - sleep 3; - return; - } - close $fh if fileno($fh); + if ($@) { + rename $chk_file, "$chk_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $chk_file for reading"; + } + if ($cksum->{$basename}->{md5}) { + $self->debug("Found checksum for $basename:" . + "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; + my $pipe = "$CPAN::Config->{gzip} --decompress ". + "--stdout $file|"; + if ( + open($fh, $file) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{md5}) + or + open($fh, $pipe) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) + ){ + print "Checksum for $file ok\n"; + return $self->{MD5_STATUS} = "OK"; } else { - $self->{MD5_STATUS} ||= ""; - if ($self->{MD5_STATUS} eq "NIL") { - print "\nNo md5 checksum for $basename in local $lfile."; - print "Removing $lfile\n"; - unlink $lfile or print "Could not unlink: $!"; - sleep 1; - } - $self->{MD5_STATUS} = "NIL"; + 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; + 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"; + sleep 3; return; } + close $fh if fileno($fh); } else { - Carp::carp "Could not open $lfile for reading"; + $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: $!"; + sleep 1; + } + $self->{MD5_STATUS} = "NIL"; + return; } } #-> sub CPAN::Distribution::eq_MD5 ; sub eq_MD5 { my($self,$fh,$expectMD5) = @_; - my $md5 = new MD5; + my $md5 = MD5->new; $md5->addfile($fh); my $hexdigest = $md5->hexdigest; $hexdigest eq $expectMD5; @@ -2412,7 +2555,7 @@ sub perl { my($self) = @_; my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $pwd = Cwd->$getcwd(); + my $pwd = CPAN->$getcwd(); my $candidate = $CPAN::META->catfile($pwd,$^X); $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { @@ -2626,7 +2769,6 @@ sub dir { } package CPAN::Bundle; -@CPAN::Bundle::ISA = qw(CPAN::Module); #-> sub CPAN::Bundle::as_string ; sub as_string { @@ -2656,7 +2798,7 @@ sub contains { $parsefile = $to; } my @result; - my $fh = new FileHandle; + my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; @@ -2685,7 +2827,7 @@ sub find_bundle_file { unless (-f $manifest) { require ExtUtils::Manifest; my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - my $cwd = Cwd->$getcwd(); + my $cwd = CPAN->$getcwd(); chdir $where; ExtUtils::Manifest::mkmanifest(); chdir $cwd; @@ -2710,7 +2852,7 @@ sub inst_file { ($me = $self->id) =~ s/.*://; $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm"); return $self->{'INST_FILE'} = $inst_file if -f $inst_file; -# $inst_file = +# $inst_file = $self->SUPER::inst_file; # return $self->{'INST_FILE'} = $inst_file if -f $inst_file; # return $self->{'INST_FILE'}; # even if undefined? @@ -2764,7 +2906,6 @@ sub readme { } package CPAN::Module; -@CPAN::Module::ISA = qw(CPAN::InfoObj); #-> sub CPAN::Module::as_glimpse ; sub as_glimpse { @@ -2966,10 +3107,10 @@ sub inst_version { $have; } -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +package CPAN; 1; + __END__ =head1 NAME @@ -3048,13 +3189,13 @@ item is displayed. If the search finds one item, we display the result of object-E<gt>as_string, but if we find more than one, we display each as object-E<gt>as_glimpse. E.g. - cpan> a ANDK + cpan> a ANDK Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König - cpan> a /andk/ + cpan> a /andk/ Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König @@ -3072,11 +3213,11 @@ be. Is it a distribution file (recognized by embedded slashes), this file is being processed. Is it a module, CPAN determines the distribution file where this module is included and processes that. -Any C<make>, C<test>, and C<readme> are run unconditionally. A +Any C<make>, C<test>, and C<readme> are run unconditionally. A install <distribution_file> -also is run unconditionally. But for +also is run unconditionally. But for install <module> @@ -3146,7 +3287,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 Classes: Authors, Bundles, Modules, Distributions +=head2 The 4 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 @@ -3177,7 +3318,7 @@ 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 say +so he would have to say install BAR/Foo-1.23_90.tar.gz @@ -3192,9 +3333,9 @@ functions in the calling package (C<install(...)>). There's currently only one class that has a stable interface, CPAN::Shell. All commands that are available in the CPAN shell are -methods of the class CPAN::Shell. The commands that produce listings -of modules (C<r>, C<autobundle>, C<u>) return a list of the IDs of all -modules within the list. +methods of the class CPAN::Shell. Each of the commands that produce +listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the +IDs of all modules within the list. =over 2 @@ -3202,13 +3343,15 @@ modules within the list. The IDs of all objects available within a program are strings that can be expanded to the corresponding real objects with the -C<CPAN::Shell-E<gt>expand()> method. Expand returns a list of -CPAN::Module objects according to the C<@things> arguments given. In -scalar context it only returns the first element of the list. +C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a +list of CPAN::Module objects according to the C<@things> arguments +given. In scalar context it only returns the first element of the +list. =item Programming Examples -This enables the programmer to do operations like these: +This enables the programmer to do operations that combine +functionalities that are available in the shell. # install everything that is outdated on my disk: perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' @@ -3219,8 +3362,17 @@ This enables the programmer to do operations like these: $obj->install; } + # 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; + print "No VERSION in ", $mod->id, "\n"; + } + =back +=head2 Methods in the four + =head2 Cache Manager Currently the cache manager only keeps track of the build directory diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 8ac180dc71..3e572d67ae 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.18 $, 10; +$VERSION = substr q$Revision: 1.20 $, 10; =head1 NAME @@ -126,20 +126,33 @@ those. }; - my(@path) = split($Config{path_sep},$ENV{PATH}); + my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; my $prog; for $prog (qw/gzip tar unzip make lynx ncftp ftp/){ - my $path = $CPAN::Config->{$prog} || find_exe($prog,[@path]) || $prog; + my $path = $CPAN::Config->{$prog} || ""; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } else { + $path = ''; + } + $path ||= find_exe($prog,[@path]); + warn "Warning: $prog not found in PATH\n" unless -e $path; $ans = prompt("Where is your $prog program?",$path) || $path; $CPAN::Config->{$prog} = $ans; } my $path = $CPAN::Config->{'pager'} || $ENV{PAGER} || find_exe("less",[@path]) || find_exe("more",[@path]) || "more"; - $ans = prompt("What is your favorite pager program?",$path) || $path; + $ans = prompt("What is your favorite pager program?",$path); $CPAN::Config->{'pager'} = $ans; - $path = $CPAN::Config->{'shell'} || $ENV{SHELL} || ""; - $ans = prompt("What is your favorite shell?",$path) || $path; + $path = $CPAN::Config->{'shell'}; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } + $path ||= $ENV{SHELL}; + $ans = prompt("What is your favorite shell?",$path); $CPAN::Config->{'shell'} = $ans; # @@ -185,7 +198,7 @@ the default and recommended setting. $default = $CPAN::Config->{inactivity_timeout} || 0; $CPAN::Config->{inactivity_timeout} = - prompt("Timout for inacivity during Makefile.PL?",$default); + prompt("Timeout for inacivity during Makefile.PL?",$default); # @@ -268,12 +281,11 @@ the \$CPAN::Config takes precedence. sub find_exe { my($exe,$path) = @_; - my($dir,$MY); - $MY = {}; - bless $MY, 'MY'; + my($dir); + #warn "in find_exe exe[$exe] path[@$path]"; for $dir (@$path) { - my $abs = $MY->catfile($dir,$exe); - if ($MY->maybe_command($abs)) { + my $abs = MM->catfile($dir,$exe); + if (MM->maybe_command($abs)) { return $abs; } } diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm index dc561977c4..23ad760b87 100644 --- a/lib/CPAN/Nox.pm +++ b/lib/CPAN/Nox.pm @@ -2,8 +2,8 @@ BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} use CPAN; -$CPAN::META->hasMD5(0); -$CPAN::META->hasLWP(0); +$CPAN::META->has_inst('MD5','no'); +$CPAN::META->has_inst('LWP','no'); @EXPORT = @CPAN::EXPORT; *AUTOLOAD = \&CPAN::AUTOLOAD; diff --git a/lib/Carp.pm b/lib/Carp.pm index c0cfe08d44..351f83bdf5 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -2,9 +2,12 @@ package Carp; =head1 NAME -carp - warn of errors (from perspective of caller) +carp - warn of errors (from perspective of caller) -croak - die of errors (from perspective of caller) +cluck - warn of errors with stack backtrace + (not exported by default) + +croak - die of errors (from perspective of caller) confess - die of errors with stack backtrace @@ -13,6 +16,9 @@ confess - die of errors with stack backtrace use Carp; croak "We're outta here!"; + use Carp qw(cluck); + cluck "This is how we got here!"; + =head1 DESCRIPTION The Carp routines are useful in your own modules because @@ -22,10 +28,24 @@ routine Foo() that has a carp() in it, then the carp() will report the error as occurring where Foo() was called, not where carp() was called. +=head2 Forcing a Stack Trace + +As a debugging aid, you can force Carp to treat a croak as a confess +and a carp as a cluck across I<all> modules. In other words, force a +detailed stack trace to be given. This can be very helpful when trying +to understand why, or from where, a warning or error is being generated. + +This feature is enabled by 'importing' the non-existant symbol +'verbose'. You would typically enable it by saying + + perl -MCarp=verbose script.pl + +or by including the string C<MCarp=verbose> in the L<PERL5OPT> +environment variable. + =cut -# This package implements handy routines for modules that wish to throw -# exceptions outside of the current package. +# This package is heavily used. Be small. Be fast. Be good. $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. @@ -35,6 +55,19 @@ $MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; @ISA = Exporter; @EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(cluck verbose); +@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +sub export_fail { + shift; + if ($_[0] eq 'verbose') { + local $^W = 0; + *shortmess = \&longmess; + shift; + } + return @_; +} + sub longmess { my $error = join '', @_; @@ -138,5 +171,6 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages sub confess { die longmess @_; } sub croak { die shortmess @_; } sub carp { warn shortmess @_; } +sub cluck { warn longmess @_; } 1; diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index eca2c6c5e3..09ab196254 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -146,9 +146,6 @@ sub struct { # Create accessor methods. - if ( $got_class && $CHECK_CLASS_MEMBERSHIP ) { - $out .= " use UNIVERSAL;\n"; - } my( $pre, $pst, $sel ); $cnt = 0; foreach $name (@methods){ diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 66459b8af0..3f42e407e0 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -108,7 +108,8 @@ sub export { last; } } elsif ($sym !~ s/^&// || !$exports{$sym}) { - warn qq["$sym" is not exported by the $pkg module]; + require Carp; + Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; } } @@ -137,8 +138,9 @@ sub export { if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { - warn qq["$sym" is not implemented by the $pkg module ], - "on this architecture"; + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); } if (@failed) { require Carp; @@ -165,6 +167,15 @@ sub export { } } +sub export_to_level +{ + my $pkg = shift; + my ($level, $junk) = (shift, shift); # need to get rid of first arg + # we know it already. + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); @@ -172,6 +183,7 @@ sub import { } + # Utility functions sub _push_tags { @@ -346,6 +358,53 @@ You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the specifications are being processed and what is actually being imported into modules. +=head2 Exporting without using Export's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Export's import method. The export_to_level +method looks like: + +MyPackage->export_to_level($where_to_export, @what_to_export); + +where $where_to_export is an integer telling how far up the calling stack +to export your symbols, and @what_to_export is an array telling what +symbols *to* export (usually this is @_). + +For example, suppose that you have a module, A, which already has an +import function: + +package A; + +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; # not a very useful import method +} + +and you want to Export symbol $A::b back to the module that called +package A. Since Exporter relies on the import method to work, via +inheritance, as it stands Exporter::import() will never get called. +Instead, say the following: + +package A; +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; + A->export_to_level(1, @_); +} + +This will export the symbols one level 'above' the current package - ie: to +the program or module that used package A. + +Note: Be careful not to modify '@_' at all before you call export_to_level +- or people using your package will get very unexplained results! + + =head2 Module Version Checking The Exporter module will convert an attempt to import a number from a diff --git a/lib/ExtUtils/Command.pm b/lib/ExtUtils/Command.pm index bdf32d4218..d37d0f3c25 100644 --- a/lib/ExtUtils/Command.pm +++ b/lib/ExtUtils/Command.pm @@ -10,7 +10,7 @@ require Exporter; use vars qw(@ISA @EXPORT $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); -$VERSION = '1.00'; +$VERSION = '1.01'; =head1 NAME @@ -18,16 +18,16 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 SYNOPSIS - perl -MExtUtils::command -e cat files... > destination - perl -MExtUtils::command -e mv source... destination - perl -MExtUtils::command -e cp source... destination - perl -MExtUtils::command -e touch files... - perl -MExtUtils::command -e rm_f file... - perl -MExtUtils::command -e rm_rf directories... - perl -MExtUtils::command -e mkpath directories... - perl -MExtUtils::command -e eqtime source destination - perl -MExtUtils::command -e chmod mode files... - perl -MExtUtils::command -e test_f file + perl -MExtUtils::Command -e cat files... > destination + perl -MExtUtils::Command -e mv source... destination + perl -MExtUtils::Command -e cp source... destination + perl -MExtUtils::Command -e touch files... + perl -MExtUtils::Command -e rm_f file... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e chmod mode files... + perl -MExtUtils::Command -e test_f file =head1 DESCRIPTION diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index 0db3ecfcc4..04ce1763da 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -17,11 +17,7 @@ use vars qw(@ISA @EXPORT $VERSION ); use strict; -$VERSION = sprintf("%d.%02d", q$Revision: 1.2501 $ =~ /(\d+)\.(\d+)/); -#for the namespace change -$Devel::embed::VERSION = "99.99"; - -sub Version { $VERSION; } +$VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&xsinit &ldopts @@ -35,6 +31,18 @@ sub Version { $VERSION; } $Verbose = 0; $lib_ext = $Config{lib_ext} || '.a'; +sub is_cmd { $0 eq '-e' } + +sub my_return { + my $val = shift; + if(is_cmd) { + print $val; + } + else { + return $val; + } +} + sub xsinit { my($file, $std, $mods) = @_; my($fh,@mods,%seen); @@ -213,24 +221,23 @@ sub ldopts { print STDERR "ldopts: '$linkage'\n" if $Verbose; return $linkage if scalar @_; - print "$linkage\n"; + my_return("$linkage\n"); } sub ccflags { - print " $Config{ccflags} "; + my_return(" $Config{ccflags} "); } sub ccdlflags { - print " $Config{ccdlflags} "; + my_return(" $Config{ccdlflags} "); } sub perl_inc { - print " -I$Config{archlibexp}/CORE "; + my_return(" -I$Config{archlibexp}/CORE "); } sub ccopts { - ccflags; - perl_inc; + ccflags . perl_inc; } sub canon { diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index bdf154375f..ff5dbf1517 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -1,14 +1,14 @@ package ExtUtils::Install; -$VERSION = substr q$Revision: 1.16 $, 10; -# $Date: 1996/12/17 00:31:26 $ +$VERSION = substr q$Revision: 1.19 $, 10; +# $Date: 1997/08/01 08:39:37 $ use Exporter; use Carp (); -use Config (); +use Config qw(%Config); use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); -@EXPORT = ('install','uninstall','pm_to_blib'); +@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; @@ -144,6 +144,28 @@ sub install { } } +sub install_default { + @_ < 2 or die "install_default should be called with 0 or 1 argument"; + my $FULLEXT = @_ ? shift : $ARGV[0]; + defined $FULLEXT or die "Do not know to where to write install log"; + my $INST_LIB = MM->catdir(MM->curdir,"blib","lib"); + my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch"); + my $INST_BIN = MM->catdir(MM->curdir,'blib','bin'); + my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script'); + my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1'); + my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3'); + install({ + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + },1,0,0); +} + sub my_cmp { my($one,$two) = @_; local(*F,*T); @@ -192,7 +214,7 @@ sub inc_uninstall { my $MY = {}; bless $MY, 'MY'; my %seen_dir = (); - foreach $dir (@INC, @PERL_ENV_LIB, @Config::Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { + foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = $MY->catfile($dir,$libdir,$file); @@ -333,6 +355,20 @@ be merged into the written file. The read and the written file may be identical, but on AFS it is quite likely, people are installing to a different directory than the one where the files later appear. +install_default() takes one or less arguments. If no arguments are +specified, it takes $ARGV[0] as if it was specified as an argument. +The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>. +This function calls install() with the same arguments as the defaults +the MakeMaker would use. + +The argumement-less form is convenient for install scripts like + + perl -MExtUtils::Install -e install_default Tk/Canvas + +Assuming this command is executed in a directory with populated F<blib> +directory, it will proceed as if the F<blib> was build by MakeMaker on +this machine. This is useful for binary distributions. + uninstall() takes as first argument a file containing filenames to be unlinked. The second argument is a verbose switch, the third is a no-don't-really-do-it-now switch. diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 9d15fe9edf..fed25ae13b 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -2,7 +2,7 @@ package ExtUtils::Liblist; use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.2201 $, 10; +$VERSION = substr q$Revision: 1.25 $, 10; use Config; use Cwd 'cwd'; @@ -15,7 +15,7 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $Verbose) = @_; + my($self,$potential_libs, $verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. @@ -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; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; @@ -50,7 +50,7 @@ sub _unix_os2_ext { my($ptype) = $1; unless (-d $thislib){ print STDOUT "$ptype$thislib ignored, directory does not exist\n" - if $Verbose; + if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { @@ -125,10 +125,10 @@ sub _unix_os2_ext { # # , the compilation tools expand the environment variables.) } else { - print STDOUT "$thislib not found in $thispth\n" if $Verbose; + print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose; + print STDOUT "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; @@ -183,7 +183,7 @@ sub _unix_os2_ext { } sub _win32_ext { - my($self, $potential_libs, $Verbose) = @_; + my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) @@ -202,7 +202,7 @@ sub _win32_ext { $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } - print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; # compute $extralibs from $potential_libs @@ -219,7 +219,7 @@ 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" - if $Verbose; + if $verbose; next; } elsif (-d $thislib) { @@ -238,10 +238,10 @@ 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; + print STDOUT "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'$thislib' found at $fullname\n" if $Verbose; + print STDOUT "'$thislib' found at $fullname\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); @@ -370,7 +370,7 @@ sub _vms_ext { if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; - print STDOUT "\tFound as $cand (really $ctest), type $ctype\n" if $verbose > 1; + print STDOUT "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } @@ -403,7 +403,7 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($self, $potential_libs, $Verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);> =head1 DESCRIPTION diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index f24c5d0eb2..85b0c1bbe5 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -8,8 +8,8 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.114 $, 10; -# $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $ +$VERSION = substr q$Revision: 1.118 $, 10; +# $Id: MM_Unix.pm,v 1.118 1997/08/01 09:42:52 k Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); @@ -181,6 +181,7 @@ sub ExtUtils::MM_Unix::export_list ; sub ExtUtils::MM_Unix::extliblist ; sub ExtUtils::MM_Unix::file_name_is_absolute ; sub ExtUtils::MM_Unix::find_perl ; +sub ExtUtils::MM_Unix::fixin ; sub ExtUtils::MM_Unix::force ; sub ExtUtils::MM_Unix::guess_name ; sub ExtUtils::MM_Unix::has_link_code ; @@ -1103,6 +1104,86 @@ specified by @ExtUtils::MakeMaker::MM_Sections. =over 2 +=item fixin + +Inserts the sharpbang or equivalent magic number to a script + +=cut + +sub fixin { # stolen from the pink Camel book, more or less + my($self,@files) = @_; + my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/; + my($file,$interpreter); + for $file (@files) { + local(*FIXIN); + local(*FIXOUT); + open(FIXIN, $file) or Carp::croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp(my $line = <FIXIN>); + next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + # Now figure out the interpreter name. + my($cmd,$arg) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + if ($cmd eq "perl") { + $interpreter = $Config{perlpath}; + } else { + my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; + $interpreter = ''; + my($dir); + foreach $dir (@absdirs) { + if ($self->maybe_command($cmd)) { + warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; + $interpreter = $self->catfile($dir,$cmd); + } + } + } + # Figure out how to invoke interpreter on this machine. + + my($shb) = ""; + if ($interpreter) { + print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + $shb .= qq{ +eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' + if 0; # not running under some shell +}; + } else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + next; + } + + unless ( rename($file, "$file.bak") ) { + warn "Can't modify $file"; + next; + } + unless ( open(FIXOUT,">$file") ) { + warn "Can't create new $file: $!\n"; + next; + } + my($dev,$ino,$mode) = stat FIXIN; + $mode = 0755 unless $dev; + chmod $mode, $file; + + # Print out the new #! line (or equivalent). + local $\; + undef $/; + print FIXOUT $shb, <FIXIN>; + close FIXIN; + close FIXOUT; + unlink "$file.bak"; + } continue { + chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; + } +} + =item force (o) Just writes FORCE: @@ -1280,7 +1361,6 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) # my $fh = new FileHandle; local *FH; my($ispod)=0; - # one day test, if $/ can be set to '' safely (is the bug fixed that was in 5.001m?) # if ($fh->open("<$name")) { if (open(FH,"<$name")) { # while (<$fh>) { @@ -1297,7 +1377,9 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $ispod = 1; } if( $ispod ) { - $manifypods{$name} = $self->catfile('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)'); + $manifypods{$name} = + $self->catfile('$(INST_MAN1DIR)', + basename($name).'.$(MAN1EXT)'); } } } @@ -1901,22 +1983,27 @@ sub installbin { $fromto{$from}=$to; } @to = values %fromto; - push(@m, " + push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} +FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ + -e "MY->fixin(shift)" + all :: @to + $self->{NOECHO}\$(NOOP) realclean :: $self->{RM_F} @to -"); +}); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " -$to: $from $self->{MAKEFILE} ".$self->catfile($todir,'.exists')." +$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to + \$(FIXIN) $to "; } join "", @m; @@ -2430,18 +2517,21 @@ sub parse_version { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; - next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; - \$$1=undef; do { + local $1$2; + \$$2=undef; do { $_ - }; \$$1 + }; \$$2 }; local($^W) = 0; - $result = eval($eval) || 0; + $result = eval($eval); die "Could not eval '$eval' in $parsefile: $@" if $@; + $result = "undef" unless defined $result; last; } close FH; @@ -2632,6 +2722,7 @@ sub processPL { foreach $plfile (sort keys %{$self->{PL_FILES}}) { push @m, " all :: $self->{PL_FILES}->{$plfile} + $self->{NOECHO}\$(NOOP) $self->{PL_FILES}->{$plfile} :: $plfile \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index da2a7638ca..dc3b4ceca6 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -96,7 +96,7 @@ sub fixpath { } my($fixedpath,$prefix,$name); - if ($path =~ m#^\$\(.+\)$# || $path =~ m#[/:>\]]#) { + if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])$/) { $fixedpath = vmspath($self->eliminate_macros($path)); } @@ -105,7 +105,9 @@ sub fixpath { } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { - my($vmspre) = vmspath($self->eliminate_macros("\$($prefix)")) || ''; # is it a dir or just a name? + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 6d1746c31f..5511e3d1e4 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -2,10 +2,10 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$Version = $VERSION = "5.4002"; +$Version = $VERSION = "5.42"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) -($Revision = substr(q$Revision: 1.211 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.216 $, 10)) =~ s/\s+$//; @@ -1157,6 +1157,11 @@ Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. +=item CCFLAGS + +String that will be included in the compiler call command line between +the arguments INC and OPTIMIZE. + =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from @@ -1257,6 +1262,10 @@ Perl binary able to run this extension. Ref to array of *.h file names. Similar to C. +=item IMPORTS + +IMPORTS is only used on OS/2. + =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> @@ -1564,15 +1573,17 @@ routine requires that the file named by VERSION_FROM contains one single line to compute the version number. The first line in the file that contains the regular expression - /\$(([\w\:\']*)\bVERSION)\b.*\=/ + /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B<after> the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; - ( $VERSION ) = '$Revision: 1.211 $ ' =~ /\$Revision:\s+([^\s]+)/; + *VERSION = \'1.01'; + ( $VERSION ) = '$Revision: 1.216 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; + *FOO::VERSION = \'1.11'; but these will fail: @@ -1580,9 +1591,16 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; -The file named in VERSION_FROM is added as a dependency to Makefile to -guarantee, that the Makefile contains the correct VERSION macro after -a change of the file. +The file named in VERSION_FROM is not added as a dependency to +Makefile. This is not really correct, but it would be a major pain +during development to have to rewrite the Makefile for any smallish +change in that file. If you want to make sure that the Makefile +contains the correct VERSION macro after any change of the file, you +would have to do something like + + depend => { Makefile => '$(VERSION_FROM)' } + +See attribute C<depend> below. =item XS diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 73dc81d069..350136455f 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -7,7 +7,7 @@ use Exporter; use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = substr q$Revision: 1.13 $, 10; +$VERSION = substr q$Revision: 1.16 $, 10; sub Mksymlists { my(%spec) = @_; @@ -106,16 +106,28 @@ sub _write_win32 { open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); - print DEF "LIBRARY $data->{DLBASE}\n"; + # put library name in quotes (it could be a keyword, like 'Alias') + print DEF "LIBRARY \"$data->{DLBASE}\"\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from different compilers + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 if ($Config::Config{'cc'} =~ /^bcc/i) { - for (@{$data->{DL_VARS}}) { $_ = "$_ = _$_" } - for (@{$data->{FUNCLIST}}) { $_ = "$_ = _$_" } + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "_$_", "$_ = _$_"; + } } - print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; - print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + else { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "$_", "_$_ = $_"; + } + } + print DEF join("\n ",@syms, "\n") if @syms; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; my ($name, $exp); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 6c83e1b2b0..ac1378dce2 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,7 +6,7 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs =head1 DESCRIPTION @@ -55,6 +55,10 @@ Disables the run time test that determines if the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. +=item B<-nolinenumbers> + +Prevents the inclusion of `#line' directives in the output. + =back =head1 ENVIRONMENT @@ -83,7 +87,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9402"; +$XSUBPP_version = "1.9504"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -96,7 +100,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; @@ -104,6 +108,7 @@ $except = ""; $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; +$WantLineNumbers = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -115,6 +120,8 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; + $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; + $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; @@ -239,13 +246,59 @@ sub check_keyword { } +if ($WantLineNumbers) { + { + package xsubpp::counter; + sub TIEHANDLE { + my ($class, $cfile) = @_; + my $buf = ""; + $SECTION_END_MARKER = "#line --- \"$cfile\""; + $line_no = 1; + bless \$buf; + } + + sub PRINT { + my $self = shift; + for (@_) { + $$self .= $_; + while ($$self =~ s/^([^\n]*\n)//) { + my $line = $1; + ++ $line_no; + $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; + print STDOUT $line; + } + } + } + + sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); + } + + sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print STDOUT $$self; + } + } + + my $cfile = $filename; + $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; + tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); + select PSEUDO_STDOUT; +} + sub print_section { - my $count = 0; - $_ = shift(@line) while !/\S/ && @line; + # the "do" is required for right semantics + do { $_ = shift(@line) } while !/\S/ && @line; + + print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") + if $WantLineNumbers && !/^\s*#\s*line\b/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - print line_directive() unless ($count++); print "$_\n"; } + print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } sub process_keyword($) @@ -255,7 +308,6 @@ sub process_keyword($) &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; - print line_directive(); } sub CASE_handler { @@ -332,7 +384,6 @@ sub OUTPUT_handler { unless defined($args_match{$outarg}); blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $var_types{$outarg} ; - print line_directive(); if ($outcode) { print "\t$outcode\n"; } else { @@ -650,7 +701,10 @@ print <<EOM ; */ EOM -print "#line 1 \"$filename\"\n"; + + +print("#line 1 \"$filename\"\n") + if $WantLineNumbers; while (<$FH>) { last if ($Module, $Package, $Prefix) = @@ -787,7 +841,9 @@ while (fetch_para()) { if (check_keyword("BOOT")) { &check_cpp; - push (@BootCode, $_, line_directive(), @line, "") ; + push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") + if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; + push (@BootCode, @line, "") ; next PARAGRAPH ; } @@ -1005,7 +1061,6 @@ EOF } elsif ($gotRETVAL || $wantRETVAL) { &generate_output($ret_type, 0, 'RETVAL'); } - print line_directive(); # do cleanup process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; @@ -1064,11 +1119,11 @@ EOF if ($ProtoThisXSUB) { $newXS = "newXSproto"; - if ($ProtoThisXSUB == 2) { + if ($ProtoThisXSUB eq 2) { # User has specified empty prototype $proto = ', ""' ; } - elsif ($ProtoThisXSUB != 1) { + elsif ($ProtoThisXSUB ne 1) { # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; } @@ -1135,8 +1190,9 @@ EOF if (@BootCode) { - print "\n /* Initialisation Section */\n" ; - print grep (s/$/\n/, @BootCode) ; + print "\n /* Initialisation Section */\n\n" ; + @line = @BootCode; + print_section(); print "\n /* End of Initialisation Section */\n\n" ; } @@ -1158,15 +1214,6 @@ sub output_init { eval qq/print " $init\\\n"/; } -sub line_directive -{ - # work out the line number - my $line_no = $line_no[@line_no - @line -1] ; - - return "#line $line_no \"$filename\"\n" ; - -} - sub Warn { # work out the line number diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm index a76eb1ff59..2f9c45c4c6 100644 --- a/lib/File/Compare.pm +++ b/lib/File/Compare.pm @@ -5,7 +5,6 @@ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); require Exporter; use Carp; -use UNIVERSAL qw(isa); $VERSION = '1.1001'; @ISA = qw(Exporter); @@ -34,7 +33,8 @@ sub compare { croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); - if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) { + if (ref($from) && + (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { *FROM = *$from; } elsif (ref(\$from) eq 'GLOB') { *FROM = $from; @@ -45,7 +45,8 @@ sub compare { $fromsize = -s FROM; } - if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) { + if (ref($to) && + (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { *TO = *$to; } elsif (ref(\$to) eq 'GLOB') { *TO = $to; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index b1baa207b3..e95168e24b 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -9,7 +9,6 @@ package File::Copy; use strict; use Carp; -use UNIVERSAL qw(isa); use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big © &syscopy &cp &mv); @@ -48,11 +47,13 @@ sub copy { my $from_a_handle = (ref($from) ? (ref($from) eq 'GLOB' - || isa($from, 'GLOB') || isa($from, 'IO::Handle')) + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) : (ref(\$from) eq 'GLOB')); my $to_a_handle = (ref($to) ? (ref($to) eq 'GLOB' - || isa($to, 'GLOB') || isa($to, 'IO::Handle')) + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) : (ref(\$to) eq 'GLOB')); if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 1faea50158..1d565f2871 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -78,18 +78,22 @@ sub find { # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; + $prune = 0; &$wanted; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; - &finddir($wanted,$fixtopdir,$topnlink); + if (!$prune) { + my $fixtopdir = $topdir; + $fixtopdir =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; + $fixtopdir =~ s/\\dir$// if $Is_NT; + &finddir($wanted,$fixtopdir,$topnlink); + } } else { warn "Can't cd to $topdir: $!\n"; @@ -169,7 +173,8 @@ sub finddepth { # compatibility. local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { @@ -190,6 +195,7 @@ sub finddepth { unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } + $name = $topdir; chdir $dir && &$wanted; } chdir $cwd; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index fe56ae5365..43856dfe7b 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -130,7 +130,10 @@ sub mkpath { my $parent = File::Basename::dirname($path); push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); print "mkdir $path\n" if $verbose; - mkdir($path,$mode) || croak "mkdir $path: $!"; + unless (mkdir($path,$mode)) { + # allow for another process to have created it meanwhile + croak "mkdir $path: $!" unless -d $path; + } push(@created, $path); } @created; diff --git a/lib/FileCache.pm b/lib/FileCache.pm index 4fd63315f9..e1c5ec4c8a 100644 --- a/lib/FileCache.pm +++ b/lib/FileCache.pm @@ -19,7 +19,7 @@ maximum. =head1 BUGS F<sys/param.h> lies with its C<NOFILE> define on some systems, -so you may have to set $cacheout::maxopen yourself. +so you may have to set $FileCache::cacheout_maxopen yourself. =cut diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 0b5d9edcb4..0264b61f15 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -93,6 +93,11 @@ sub pipe { ($r, $w); } +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + 1; __END__ diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 6961dc2f1c..580ca39785 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -1,14 +1,26 @@ -#-----------------------------------------------------------------------# -# NOTE! This module is deprecated (obsolete) after the Perl release # -# 5.003_06 as the functionality has been integrated into the Perl core. # -#-----------------------------------------------------------------------# - package I18N::Collate; =head1 NAME I18N::Collate - compare 8-bit scalar data according to the current locale + *** + + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale + + HAS BEEN DEPRECATED + + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. + + See the perllocale manual page for further information. + + *** + =head1 SYNOPSIS use I18N::Collate; @@ -116,16 +128,18 @@ sub new { warn <<___EOD___; *** - WARNING: starting from the Perl version 5.003_06 the I18N::Collate - interface for comparing 8-bit scalar data according to the current locale + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale HAS BEEN DEPRECATED - (that is, please do not use it anymore for any new applications and please - migrate the old applications away from it) because its functionality was - integrated into the Perl core language in the release 5.003_06. + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. - See pod/perllocale.pod for further information. + See the perllocale manual page for further information. *** ___EOD___ diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index 43caa03763..f6d45cee85 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -20,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS - $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH + $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH, 'some cmd and args', 'optarg', ...); =head1 DESCRIPTION diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 7a4617c65a..33c60231aa 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -511,6 +511,27 @@ sub exp { } # +# _logofzero +# +# Die on division by zero. +# +sub _logofzero { + my $mess = "$_[0]: Logarithm of zero.\n"; + + if (defined $_[1]) { + $mess .= "(Because in the definition of $_[0], the argument "; + $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "is 0)\n"; + } + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# # (log) # # Compute log(z). @@ -659,7 +680,19 @@ sub cotan { Math::Complex::cot(@_) } sub acos { my ($z) = @_; $z = cplx($z, 0) unless ref $z; - return ~i * log($z + (Re($z) * Im($z) > 0 ? 1 : -1) * sqrt($z*$z - 1)); + 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; } # @@ -670,6 +703,9 @@ sub acos { 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)); } @@ -681,7 +717,8 @@ sub asin { sub atan { my ($z) = @_; $z = cplx($z, 0) unless ref $z; - _divbyzero "atan($z)", "i - $z" if ($z == i); + _divbyzero "atan(i)" if ( $z == i); + _divbyzero "atan(-i)" if (-$z == i); return i/2*log((i + $z) / (i - $z)); } @@ -693,18 +730,35 @@ sub atan { sub asec { my ($z) = @_; _divbyzero "asec($z)", $z if ($z == 0); - return acos(1 / $z); + $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; } # # acsc # -# Computes the arc cosecant sec(z) = asin(1 / z). +# Computes the arc cosecant acsc(z) = asin(1 / z). # sub acsc { my ($z) = @_; _divbyzero "acsc($z)", $z if ($z == 0); - return asin(1 / $z); + $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; } # @@ -717,13 +771,15 @@ sub acosec { Math::Complex::acsc(@_) } # # acot # -# Computes the arc cotangent acot(z) = -i/2 log((i+z) / (z-i)) +# Computes the arc cotangent acot(z) = atan(1 / z) # sub acot { my ($z) = @_; + _divbyzero "acot($z)" if ($z == 0); $z = cplx($z, 0) unless ref $z; - _divbyzero "acot($z)", "$z - i" if ($z == i); - return i/-2 * log((i + $z) / ($z - i)); + _divbyzero "acot(i)", if ( $z == i); + _divbyzero "acot(-i)" if (-$z == i); + return atan(1 / $z); } # @@ -838,11 +894,14 @@ 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; + my ($re, $im) = @{$z->cartesian}; + return log($re + sqrt(cplx($re*$re - 1, 0))) + if ($im == 0 && $re < 0); return log($z + sqrt($z*$z - 1)); } @@ -864,10 +923,14 @@ sub asinh { # sub atanh { my ($z) = @_; - _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); + _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); + _logofzero 'atanh(-1)' if ($z == -1); $z = cplx($z, 0) unless ref $z; - my $cz = (1 + $z) / (1 - $z); - return log($cz) / 2; + my ($re, $im) = @{$z->cartesian}; + if ($im == 0 && $re > 1) { + return cplx(atanh(1 / $re), pi/2); + } + return log((1 + $z) / (1 - $z)) / 2; } # @@ -878,6 +941,12 @@ 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); } @@ -906,10 +975,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; - _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); + _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); + _logofzero 'acoth(-1)' if ($z == -1); $z = cplx($z, 0) unless ref $z; - my $cz = (1 + $z) / ($z - 1); - return log($cz) / 2; + 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; } # @@ -1295,7 +1368,7 @@ numbers: acsc(z) = asin(1 / z) asec(z) = acos(1 / z) - acot(z) = -i/2 * log((i+z) / (z-i)) + acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i)) sinh(z) = 1/2 (exp(z) - exp(-z)) cosh(z) = 1/2 (exp(z) + exp(-z)) @@ -1437,18 +1510,26 @@ The division (/) and the following functions acoth cannot be computed for all arguments because that would mean dividing -by zero. These situations cause fatal runtime errors looking like this +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this cot(0): Division by zero. (Because in the definition of cot(0), the divisor sin(0) is 0) Died at ... -For the C<csc>, C<cot>, C<asec>, C<acsc>, C<csch>, C<coth>, C<asech>, -C<acsch>, the argument cannot be C<0> (zero). For the C<atanh>, -C<acoth>, the argument cannot be C<1> (one). For the C<atan>, C<acot>, -the argument cannot be C<i> (the imaginary unit). For the C<tan>, -C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * pi>, where -I<k> is any integer. +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<atan>, C<acot>, the argument cannot be C<i> (the imaginary unit). +For the C<atan>, C<acoth>, the argument cannot be C<-i> (the negative +imaginary unit). For the C<tan>, C<sec>, C<tanh>, C<sech>, the +argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. =head1 BUGS diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index c9c045d15d..a1cbb07234 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -150,17 +150,24 @@ The following functions acoth cannot be computed for all arguments because that would mean dividing -by zero. These situations cause fatal runtime errors looking like this +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this cot(0): Division by zero. (Because in the definition of cot(0), the divisor sin(0) is 0) Died at ... -For the C<csc>, C<cot>, C<asec>, C<acsc>, C<csch>, C<coth>, C<asech>, -C<acsch>, the argument cannot be C<0> (zero). For the C<atanh>, -C<acoth>, the argument cannot be C<1> (one). For the C<tan>, C<sec>, -C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * pi>, where I<k> is -any integer. +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * +pi>, where I<k> is any integer. =head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm index dfca789817..96b090dae5 100644 --- a/lib/Net/hostent.pm +++ b/lib/Net/hostent.pm @@ -76,9 +76,9 @@ This module's default exports override the core gethostbyname() and gethostbyaddr() functions, replacing them with versions that return "Net::hostent" objects. This object has methods that return the similarly named structure field name from the C's hostent structure from F<netdb.h>; -namely name, aliases, addrtype, length, and addresses. The aliases and -addresses methods return array reference, the rest scalars. The addr -method is equivalent to the zeroth element in the addresses array +namely name, aliases, addrtype, length, and addr_list. The aliases and +addr_list methods return array reference, the rest scalars. The addr +method is equivalent to the zeroth element in the addr_list array reference. You may also import all the structure fields directly into your namespace diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 82453344d8..ffeb0b2136 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -761,7 +761,7 @@ sub scan_headings { # scan for =head directives, note their name, and build an index # pointing to each of them. foreach my $line (@data) { - if ($line =~ /^\s*=(head)([1-6])\s+(.*)/) { + if ($line =~ /^=(head)([1-6])\s+(.*)/) { ($tag,$which_head, $title) = ($1,$2,$3); chomp($title); $$sections{htmlify(0,$title)} = 1; @@ -788,7 +788,7 @@ sub scan_headings { # get rid of bogus lists $index =~ s,\t*<UL>\s*</UL>\n,,g; - $ignore = 1; # retore old value; + $ignore = 1; # restore old value; return $index; } diff --git a/lib/Shell.pm b/lib/Shell.pm index bb44b5398b..f4ef431cc5 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -21,7 +21,7 @@ AUTOLOAD { my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; eval qq { - sub $AUTOLOAD { + *$AUTOLOAD = sub { if (\@_ < 1) { `$cmd`; } diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index 92207acb2b..d23310a5af 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -39,7 +39,7 @@ sub hostname { if ($^O eq 'VMS') { # method 2 - no sockets ==> return DECnet node name - eval {my($test) = gethostbyname('me')}; # returns 'me' on most systems + eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] }; if ($@) { return $host = $ENV{'SYS$NODE'}; } # method 3 - has someone else done the job already? It's common for the @@ -69,6 +69,7 @@ sub hostname { # method 2 - syscall is preferred since it avoids tainting problems eval { + local $SIG{__DIE__}; { package main; require "syscall.ph"; @@ -79,16 +80,19 @@ sub hostname { # method 3 - trusty old hostname command || eval { + local $SIG{__DIE__}; $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) || eval { + local $SIG{__DIE__}; $host = `uname -n 2>/dev/null`; ## sysVish } # method 5 - Apollo pre-SR10 || eval { + local $SIG{__DIE__}; ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); } diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 9efcfbf3c4..f6d9c3547e 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -54,6 +54,19 @@ is replaced with C<"$!"> (the latest error message). Sets log mask I<$mask_priority> and returns the old mask. +=item setlogsock $sock_type + +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. + +The default is for the INET socket to be used. + + =item closelog Closes the log file. @@ -70,9 +83,12 @@ Note that C<openlog> now takes three arguments, just like C<openlog(3)>. closelog(); syslog('debug', 'this is the last test'); + + setlogsock('unix'); openlog("$program $$", 'ndelay', 'user'); syslog('notice', 'fooprogram: this is really done'); + setlogsock('inet'); $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) @@ -86,7 +102,9 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. +UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> +with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. =cut @@ -114,6 +132,17 @@ sub setlogmask { $oldmask; } +sub setlogsock { + local($setsock) = shift; + if (lc($setsock) eq 'unix') { + $sock_unix = 1; + } elsif (lc($setsock) eq 'inet') { + undef($sock_unix); + } else { + croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + } +} + sub syslog { local($priority) = shift; local($mask) = shift; @@ -172,7 +201,7 @@ sub syslog { $message = sprintf ($mask, @_); $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { @@ -203,12 +232,19 @@ sub connect { my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; + unless ( $sock_unix ) { + my $udp = getprotobyname('udp'); + my $syslog = getservbyname('syslog','udp'); + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); + socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } else { + my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; + socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "open: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 105e6dd536..b6923dd1e7 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -105,14 +105,33 @@ support reacher set of commands. All these commands are callable via method interface and have names which conform to standard conventions with the leading C<rl_> stripped. -The stub package included with the perl distribution allows two -additional methods: C<tkRunning> and C<ornaments>. The first one +The stub package included with the perl distribution allows some +additional methods: + +=over 12 + +=item C<tkRunning> + makes Tk event loop run when waiting for user input (i.e., during -C<readline> method), the second one makes the command line stand out -by using termcap data. The argument to C<ornaments> should be 0, 1, -or a string of a form "aa,bb,cc,dd". Four components of this string -should be names of I<terminal capacities>, first two will be issued to -make the prompt standout, last two to make the input line standout. +C<readline> method). + +=item C<ornaments> + +makes the command line stand out by using termcap data. The argument +to C<ornaments> should be 0, 1, or a string of a form +C<"aa,bb,cc,dd">. Four components of this string should be names of +I<terminal capacities>, first two will be issued to make the prompt +standout, last two to make the input line standout. + +=item C<newTTY> + +takes two arguments which are input filehandle and output filehandle. +Switches to use these filehandles. + +=back + +One can check whether the currently loaded ReadLine package supports +these methods by checking for corresponding C<Features>. =head1 EXPORTS @@ -206,12 +225,22 @@ sub new { bless [$FIN, $FOUT]; } } + +sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); +} + sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } sub Attribs { {} } -my %features = (tkRunning => 1, ornaments => 1); +my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 0119f9ddb8..d2d70dab20 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -48,11 +48,30 @@ BEGIN { $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - my $t = time; - my @lt = localtime($t); - my @gt = gmtime($t); +} + +sub timegm { + $ym = pack(C2, @_[5,4]); + $cheat = $cheat{$ym} || &cheat; + return -1 if $cheat<0 and $^O ne 'VMS'; + $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; +} + +sub timelocal { + my $t = &timegm; + my $tt = $t; + + my (@lt) = localtime($t); + my (@gt) = gmtime($t); + if ($t < $DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) { + # Wrap error, too early a date + # Try a safer date + $tt = $DAY; + @lt = localtime($tt); + @gt = gmtime($tt); + } - $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; + my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; my($lday,$gday) = ($lt[7],$gt[7]); if($lt[5] > $gt[5]) { @@ -65,20 +84,11 @@ BEGIN { $tzsec += ($gt[7] - $lt[7]) * $DAY; } - $tzsec += $HR if($lt[8]); -} - -sub timegm { - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0 and $^O ne 'VMS'; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; -} - -sub timelocal { - $time = &timegm + $tzsec; + $tzsec += $HR if($lt[8]); + + $time = $t + $tzsec; return -1 if $cheat<0 and $^O ne 'VMS'; - @test = localtime($time); + @test = localtime($time + ($tt - $t)); $time -= $HR if $test[2] != $_[2]; $time; } diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm index 6d832c4bea..dc02423029 100644 --- a/lib/UNIVERSAL.pm +++ b/lib/UNIVERSAL.pm @@ -1,7 +1,10 @@ package UNIVERSAL; +# UNIVERSAL should not contain any extra subs/methods beyond those +# that it exists to define. The use of Exporter below is a historical +# accident that should be fixed sometime. require Exporter; -@ISA = qw(Exporter); +*import = \&Exporter::import; @EXPORT_OK = qw(isa can); 1; @@ -13,12 +16,11 @@ UNIVERSAL - base class for ALL classes (blessed references) =head1 SYNOPSIS - use UNIVERSAL qw(isa); - - $yes = isa($ref, "HASH"); $io = $fd->isa("IO::Handle"); $sub = $obj->can('print'); + $yes = UNIVERSAL::isa($ref, "HASH"); + =head1 DESCRIPTION C<UNIVERSAL> is the base class which all bless references will inherit from, @@ -54,11 +56,11 @@ C<VERSION> can be called as either a static or object method call. =back -C<UNIVERSAL> also optionally exports the following subroutines +The C<isa> and C<can> methods can also be called as subroutines =over 4 -=item isa ( VAL, TYPE ) +=item UNIVERSAL::isa ( VAL, TYPE ) C<isa> returns I<true> if the first argument is a reference and either of the following statements is true. @@ -76,7 +78,7 @@ C<VAL> is a reference to a C<TYPE> of perl variable (er 'HASH') =back -=item can ( VAL, METHOD ) +=item UNIVERSAL::can ( VAL, METHOD ) If C<VAL> is a blessed reference which has a method called C<METHOD>, C<can> returns a reference to the subroutine. If C<VAL> is not @@ -85,4 +87,11 @@ I<undef> is returned. =back +These subroutines should I<not> be imported via S<C<use UNIVERSAL qw(...)>>. +If you want simple local access to them you can do + + *isa = \&UNIVERSAL::isa; + +to import isa into your package. + =cut diff --git a/lib/blib.pm b/lib/blib.pm index 8af1727d8f..2dd7802f4b 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -38,6 +38,8 @@ Nick Ing-Simmons nik@tiuk.ti.com use Cwd; +use vars qw($VERSION); +$VERSION = '1.00'; sub import { diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index 1fa8246da7..c32bc2fb5e 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -117,9 +117,9 @@ sub unwrap { # Check for reused addresses if (ref $v) { - ($address) = $v =~ /(0x[0-9a-f]+)/ ; + ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; if (defined $address) { - ($type) = $v =~ /=(.*?)\(/ ; + ($type) = $v =~ /=(.*?)\([^=]+$/ ; $address{$address}++ ; if ( $address{$address} > 1 ) { print "${sp}-> REUSED_ADDRESS\n" ; @@ -135,7 +135,7 @@ sub unwrap { } } - if ( ref $v eq 'HASH' or $type eq 'HASH') { + if ( UNIVERSAL::isa($v, 'HASH') ) { @sortKeys = sort keys(%$v) ; undef $more ; $tHashDepth = $#sortKeys ; @@ -168,7 +168,7 @@ sub unwrap { } print "$sp empty hash\n" unless @sortKeys; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { $tArrayDepth = $#{$v} ; undef $more ; $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 @@ -198,13 +198,13 @@ sub unwrap { } print "$sp empty array\n" unless @$v; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { print "$sp-> "; DumpElem $$v, $s; - } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) { + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { print "$sp-> "; dumpsub (0, $v); - } elsif (ref $v eq 'GLOB') { + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { print "$sp-> ",&stringify($$v,1),"\n"; if ($globPrint) { $s += 3; diff --git a/lib/ftp.pl b/lib/ftp.pl index e671348105..fd78162a40 100644 --- a/lib/ftp.pl +++ b/lib/ftp.pl @@ -88,15 +88,9 @@ # Initial revision # -eval { require 'chat2.pl' }; -die qq{$@ -The obsolete and problematic chat2.pl library has been removed from the -Perl distribution at the request of it's author. You can either get a -copy yourself or, preferably, fetch the new and much better Net::FTP -package from a CPAN ftp site. -} if $@ && $@ =~ /locate chat2.pl/; -die $@ if $@; -eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; +require 'chat2.pl'; # into main +eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" + || die "socket.ph missing: $!\n"; package ftp; diff --git a/lib/perl5db.pl b/lib/perl5db.pl index c09238d16c..469ebff023 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -296,6 +296,10 @@ if ($notty) { $console = "sys\$command"; } + if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) { + $console = undef; + } + # Around a bug: if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2 $console = undef; @@ -428,6 +432,7 @@ sub DB { @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), + ($term_pid == $$ or &resetterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { @@ -1062,7 +1067,7 @@ sub DB { $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; - } else { + } elsif ($term_pid == $$) { print $OUT "\n"; } } continue { # CMD: @@ -1386,6 +1391,29 @@ sub setterm { $term->SetHistory(@hist); } ornaments($ornaments) if defined $ornaments; + $term_pid = $$; +} + +sub resetterm { # We forked, so we need a different TTY + $term_pid = $$; + if (defined &get_fork_TTY) { + &get_fork_TTY; + } elsif (not defined $fork_TTY + and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' + and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { + # Possibly _inside_ XTERM + open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\ + sleep 10000000' |]; + $fork_TTY = <XT>; + chomp $fork_TTY; + } + if (defined $fork_TTY) { + TTY($fork_TTY); + undef $fork_TTY; + } else { + print $OUT "Forked, but do not know how to change a TTY.\n", + "Define \$DB::fork_TTY or get_fork_TTY().\n"; + } } sub readline { @@ -1511,8 +1539,21 @@ sub warn { } sub TTY { - if ($term) { - &warn("Too late to set TTY, enabled on next `R'!\n") if @_; + if (@_ and $term and $term->Features->{newTTY}) { + my ($in, $out) = shift; + if ($in =~ /,/) { + ($in, $out) = split /,/, $in, 2; + } else { + $out = $in; + } + open IN, $in or die "cannot open `$in' for read: $!"; + open OUT, ">$out" or die "cannot open `$out' for write: $!"; + $term->newTTY(\*IN, \*OUT); + $IN = \*IN; + $OUT = \*OUT; + return $tty = $in; + } elsif ($term and @_) { + &warn("Too late to set TTY, enabled on next `R'!\n"); } $tty = shift if @_; $tty or $console; |