diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-03-09 11:57:19 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-03-09 11:57:19 +1200 |
commit | 68dc074516a6859e3424b48d1647bcb08b1a1a7d (patch) | |
tree | 125011c6d8e4a04727ff97166dc19199809958e4 /lib | |
parent | 699e6cd4da8c333ef83554732e73ab6734463b5d (diff) | |
download | perl-68dc074516a6859e3424b48d1647bcb08b1a1a7d.tar.gz |
[inseparable changes from match from perl-5.003_93 to perl-5.003_94]
BUILD PROCESS
Subject: Don't use db 2.x, we're not yet ready for it
From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
Files: Configure
Subject: Warn if #! command is longer than 32 chars
From: Chip Salzenberg <chip@perl.com>
Files: Configure
Subject: patches re perl -wc install{perl,man}
Date: Tue, 11 Mar 97 13:13:16 GMT
From: Robin Barker <rmb1@cise.npl.co.uk>
Files: installman installperl
I got the new installhtml from CPAN
(TOMC/scripts/pod2html-v2.0beta.shar.gz)
I had problems getting the system call to splitpod at line 376 to work.
1. splitroot was not being found
2. splitroot was not finding its library
3. I changed htmlroot to podroot at line 175 to match the documentation.
p5p-msgid: 3180.9703270906@tempest.cise.npl.co.uk
private-msgid: 21544.9703111313@tempest.cise.npl.co.uk
Subject: 3_93 doesn't install pods
Date: Sun, 16 Mar 1997 02:21:35 -0500
From: Spider Boardman <spider@orb.nashua.nh.us>
Files: installperl
Msg-ID: 199703160721.CAA08339@Orb.Nashua.NH.US
(applied based on p5p patch as commit 43506a616735d616e03d277d64fbae1e864024bf)
Subject: When installing, use File::Copy instead of `cp`
From: Chip Salzenberg <chip@perl.com>
Files: installperl
Subject: Make hint files' warnings more visible
Date: Thu, 20 Mar 1997 23:18:03 +0100 (MET)
From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
Files: hints/3b1.sh hints/apollo.sh hints/cxux.sh hints/dcosx.sh hints/dgux.sh hints/esix4.sh hints/freebsd.sh hints/hpux.sh hints/irix_4.sh hints/mips.sh hints/next_3_0.sh hints/os2.sh hints/qnx.sh hints/sco_2_3_3.sh hints/sco_2_3_4.sh hints/solaris_2.sh hints/ultrix_4.sh hints/utekv.sh
private-msgid: 199703202218.XAA09041@bombur2.uio.no
CORE LANGUAGE CHANGES
Subject: Defer creation of array and hash elements as parameters
From: Chip Salzenberg <chip@perl.com>
Files: dump.c global.sym mg.c op.c op.h perl.h pp.c pp_hot.c proto.h sv.c
Subject: New special literal: __PACKAGE__
From: Chip Salzenberg <chip@perl.com>
Files: keywords.pl pod/perldata.pod toke.c
Subject: Abort compilation at C<BEGIN{}> or C<use> after errors
From: Chip Salzenberg <chip@perl.com>
Files: op.c pod/perldiag.pod t/pragma/subs.t
Subject: allow C<substr 'hello', -10>
Date: Mon, 10 Mar 1997 15:55:44 -0800
From: David Dyck <dcd@tc.fluke.com>
Files: pp.c
Msg-ID: 97Mar10.155517pst.35716-2@gateway.fluke.com
(applied based on p5p patch as commit 77f720bf92f3d0100352416caeedd57936807ff2)
Subject: Regularize C<x % y>, esp. when y is negative
From: Chip Salzenberg <chip@perl.com>
Files: pp.c
Subject: Flush before C<flock(FOO, LOCK_UN)>
From: Chip Salzenberg <chip@perl.com>
Files: pod/perldelta.pod pod/perlfunc.pod pp_sys.c
Subject: Close loopholes in prototype mismatch warning
From: Chip Salzenberg <chip@perl.com>
Files: op.c sv.c toke.c
Subject: Warn on C<while ($x = each %y) {}>
From: Chip Salzenberg <chip@perl.com>
Files: op.c pod/perldiag.pod
Subject: Don't warn on C<print $fh func()>
From: Chip Salzenberg <chip@perl.com>
Files: toke.c
CORE PORTABILITY
Subject: Don't say 'static var = 1'
Date: Sun, 9 Mar 1997 15:19:57 +0200 (EET)
From: Jarkko Hietaniemi <jhi@iki.fi>
Files: malloc.c
private-msgid: 199703091319.PAA24714@alpha.hut.fi
Subject: HP/UX hint comments
Date: Fri, 21 Mar 1997 15:43:07 -0500 (EST)
From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
Files: hints/hpux.sh
private-msgid: Pine.SOL.3.95q.970321153918.28770B-100000@fractal.lafayette.
Subject: VMS update
Date: Tue, 11 Mar 1997 22:00:55 -0500 (EST)
From: Charles Bailey <bailey@hmivax.humgen.upenn.edu>
Files: lib/ExtUtils/MM_VMS.pm lib/Test/Harness.pm t/op/taint.t utils/perlbug.PL vms/descrip.mms
Msg-ID: 1997Mar11.220056.1873182@hmivax.humgen.upenn.edu
(applied based on p5p patch as commit 2b5725676da60b49978f38b85bb7f8ee20b4cb55)
Subject: vmsish.t and related patches
Date: Fri, 21 Mar 1997 01:32:47 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: MANIFEST perl.h vms/descrip.mms vms/ext/vmsish.t vms/vms.c
private-msgid: 01IGQW3IP1KK005VFB@hmivax.humgen.upenn.edu
Subject: Win32 update (four patches)
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: MANIFEST README.win32 lib/AutoSplit.pm lib/Cwd.pm lib/ExtUtils/Command.pm lib/ExtUtils/Install.pm lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm lib/File/Basename.pm lib/File/Path.pm mg.c t/comp/cpp.t t/comp/script.t t/harness t/io/argv.t t/io/dup.t t/io/fs.t t/io/inplace.t t/lib/filehand.t t/lib/io_dup.t t/lib/io_sel.t t/lib/io_taint.t t/op/closure.t t/op/exec.t t/op/glob.t t/op/goto.t t/op/magic.t t/op/misc.t t/op/rand.t t/op/split.t t/op/stat.t t/op/sysio.t t/op/taint.t t/pragma/strict.t t/pragma/subs.t t/pragma/warning.t util.c win32/*
DOCUMENTATION
Subject: perlfaq.pod
Date: Mon, 17 Mar 1997 16:01:40 -0700
From: Tom Christiansen <tchrist@jhereg.perl.com>
Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod pod/perlfaq*.pod pod/roffitall
private-msgid: 199703172301.QAA12566@jhereg.perl.com
Subject: *.pod changes based on the FAQ
Date: Mon, 17 Mar 1997 09:50:14 -0700 (MST)
From: Nat Torkington <gnat@frii.com>
Files: pod/perldata.pod pod/perlfunc.pod pod/perlipc.pod pod/perlop.pod pod/perlre.pod pod/perlrun.pod pod/perlsec.pod pod/perlvar.pod
Msg-ID: 199703171650.JAA02655@elara.frii.com
(applied based on p5p patch as commit 3c10ad8e31f7d77e71c048b1746912f41cb540f0)
Subject: Document that $. is not reset on implicit open
From: Chip Salzenberg <chip@perl.com>
Files: pod/perldelta.pod
Subject: Re: Embedding success with _93
Date: Tue, 11 Mar 1997 17:55:05 -0500
From: Doug MacEachern <dougm@opengroup.org>
Files: pod/perldelta.pod
Msg-ID: 199703112255.RAA22775@postman.osf.org
(applied based on p5p patch as commit 63a6ff3a1dc8d86edb4d8a7ec1548205e32a7114)
Subject: Patch to document illegal characters
Date: Fri, 14 Mar 1997 09:08:10 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: pod/perldiag.pod pod/perltrap.pod
private-msgid: Pine.GSO.3.96.970314090558.15346J-100000@kelly.teleport.com
Subject: Document trap with //o and closures
Date: Mon, 10 Mar 1997 18:08:08 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: pod/perltrap.pod
Msg-ID: 01IGCHWRNSEU00661G@hmivax.humgen.upenn.edu
(applied based on p5p patch as commit a54cb1465fdb400848f23705a6f130bb5c34ab70)
Subject: Illegal character in input
Date: Mon, 10 Mar 1997 15:21:21 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: pod/perldiag.pod
private-msgid: Pine.GSO.3.95q.970310151512.22489a-100000@kelly.teleport.com
Subject: Patch for docs Re: Lost backslash
Date: Wed, 19 Mar 1997 07:28:57 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: pod/perlop.pod
private-msgid: Pine.GSO.3.96.970319071438.24834G-100000@kelly.teleport.com
Subject: XSUB's doc fix
Date: Mon, 10 Mar 1997 11:42:06 -0500
From: Roderick Schertler <roderick@argon.org>
Files: pod/perlcall.pod pod/perlguts.pod pod/perlxstut.pod
Msg-ID: 28804.858012126@eeyore.ibcinc.com
(applied based on p5p patch as commit 5f43237038ea7a4151d3bf65aeeecd56ceb78a6a)
Subject: Document return from do FILE
Date: Tue, 18 Mar 1997 14:50:10 +0000
From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
Files: pod/perlfunc.pod
Msg-ID: E0w70DK-0001yJ-00@ursa.cus.cam.ac.uk
(applied based on p5p patch as commit ba8d5fb439878113de8abc9b52d2af237d30fb3c)
Subject: Document $^M in perlvar
Date: Thu, 20 Mar 97 21:08:33 GMT
From: Robin Barker <rmb1@cise.npl.co.uk>
Files: pod/perlvar.pod
private-msgid: 6153.9703202108@tempest.cise.npl.co.uk
Subject: typos in pods of 5.003_93
Date: 19 Mar 1997 10:39:38 -0600
From: Jim Meyering <meyering@asic.sc.ti.com>
Files: pod/perlfunc.pod pod/perlguts.pod pod/perlre.pod pod/perltoot.pod pod/perlxs.pod
Msg-ID: wpgendbzvhx.fsf@asic.sc.ti.com
(applied based on p5p patch as commit 76a9873e006cf8f48f57062b2a0dd40b5ed45a95)
Subject: Re: Updates to pod punctuations
Date: Fri, 14 Mar 1997 17:00:12 -0500
From: Larry W. Virden <lvirden@cas.org>
Files: pod/*.pod
private-msgid: 9703141700.AA22911@cas.org
Subject: clarify example in perlfunc
Date: Thu, 20 Mar 1997 19:46:01 +0200 (EET)
From: Jarkko Hietaniemi <jhi@iki.fi>
Files: pod/perlfunc.pod
private-msgid: 199703201746.TAA25195@alpha.hut.fi
Subject: Regularize headings in DB_File documentation
From: Chip Salzenberg <chip@perl.com>
Files: ext/DB_File/DB_File.pm
LIBRARY AND EXTENSIONS
Subject: New module: autouse.pm
Date: Thu, 20 Mar 1997 19:34:30 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: MANIFEST lib/autouse.pm
Msg-ID: 199703210034.TAA13469@monk.mps.ohio-state.edu
(applied based on p5p patch as commit 6757905eccb6dd0440ef65e8128a277a20f7d943)
Subject: Refresh DB_File to 1.12
Date: Wed, 12 Mar 97 15:51:14 GMT
From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
Msg-ID: 9703121551.AA07435@claudius.bfsec.bt.co.uk
(applied based on p5p patch as commit b3deed9189f963e9994815307931f9084f60d1d9)
Subject: In File::Path, some systems can't remove read-only files
From: Chip Salzenberg <chip@perl.com>
Files: lib/File/Path.pm
Subject: Fix bugs revealed by prototype warnings
From: Chip Salzenberg <chip@perl.com>
Files: ext/Opcode/Opcode.pm lib/ExtUtils/MakeMaker.pm lib/Getopt/Long.pm
Subject: Problems with SKIP in makemaker
Date: Thu, 20 Mar 1997 23:13:31 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: lib/ExtUtils/MM_Unix.pm
Msg-ID: 199703210413.XAA21601@monk.mps.ohio-state.edu
(applied based on p5p patch as commit 970322a2e8024294ada6e8d1a027cb98f1f48ee3)
Subject: In Exporter, don't C<require Carp> at file scope
From: Chip Salzenberg <chip@perl.com>
Files: lib/Exporter.pm
Subject: fix for Exporter's $SIG{__WARN__} handler
Date: Thu, 13 Mar 1997 18:40:51 -0500
From: Roderick Schertler <roderick@argon.org>
Files: lib/Exporter.pm
Msg-ID: 2282.858296451@eeyore.ibcinc.com
(applied based on p5p patch as commit 2768ea1aeef34f42d096f198fbe629c8374ca429)
Subject: Don't try to substr() refs in Carp
From: Chip Salzenberg <chip@perl.com>
Files: lib/Carp.pm
Subject: Re: NUL in die and other messages
Date: Fri, 21 Mar 1997 09:58:17 +0000
From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
Files: lib/Carp.pm
Msg-ID: E0w815V-0005xs-00@ursa.cus.cam.ac.uk
(applied based on p5p patch as commit 52a267c574cb66c4bc35601dcf148a1d7a3bc557)
OTHER CORE CHANGES
Subject: Guard against buffer overflow in yyerror() and related funcs
From: Chip Salzenberg <chip@perl.com>
Files: toke.c
Subject: For bin compat, rename calllist() and he_{,delay}free
From: Chip Salzenberg <chip@perl.com>
Files: global.sym hv.c op.c perl.c pod/perlguts.pod proto.h
Subject: Fix C<print> on tied default handle
From: Chip Salzenberg <chip@perl.com>
Files: pp_hot.c
Subject: Fix C<local($a, undef, $b) = (1,2,3)>
From: Chip Salzenberg <chip@perl.com>
Files: op.c
Subject: Improve diagnostic on C<@a++>, C<--%a>, @a =~ s/a/b/
From: Chip Salzenberg <chip@perl.com>
Files: pp.c pp_hot.c
Subject: Don't warn on C<$x{y} .= "z"> when %x is tied
From: Chip Salzenberg <chip@perl.com>
Files: pp_hot.c
Subject: Eliminate 'unreachable code' warnings
From: Chip Salzenberg <chip@perl.com>
Files: ext/POSIX/POSIX.xs mg.c pp_ctl.c toke.c
Subject: printf format corrections for -DDEBUGGING
Date: Wed, 19 Mar 1997 12:42:50 -0500
From: Roderick Schertler <roderick@argon.org>
Files: doop.c malloc.c op.c pp_ctl.c regexec.c sv.c x2p/str.c x2p/util.c
Msg-ID: 26592.858793370@eeyore.ibcinc.com
(applied based on p5p patch as commit e125f273e351a19a92b69d6244af55abbbf0a26d)
Subject: Warn about missing -DMULTIPLICITY if likely a problem
Date: Wed, 19 Mar 1997 18:45:53 -0500
From: Doug MacEachern <dougm@opengroup.org>
Files: perl.c
Msg-ID: 199703192345.SAA15070@postman.osf.org
(applied based on p5p patch as commit 71aeea1753924e6e19c2461e241e3f7d8a570e90)
Diffstat (limited to 'lib')
-rw-r--r-- | lib/AutoSplit.pm | 29 | ||||
-rw-r--r-- | lib/Carp.pm | 22 | ||||
-rw-r--r-- | lib/Cwd.pm | 4 | ||||
-rw-r--r-- | lib/Exporter.pm | 42 | ||||
-rw-r--r-- | lib/ExtUtils/Command.pm | 212 | ||||
-rw-r--r-- | lib/ExtUtils/Install.pm | 11 | ||||
-rw-r--r-- | lib/ExtUtils/MM_OS2.pm | 11 | ||||
-rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 125 | ||||
-rw-r--r-- | lib/ExtUtils/MM_VMS.pm | 5 | ||||
-rw-r--r-- | lib/ExtUtils/MM_Win32.pm | 493 | ||||
-rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 15 | ||||
-rw-r--r-- | lib/ExtUtils/Mksymlists.pm | 28 | ||||
-rw-r--r-- | lib/File/Basename.pm | 19 | ||||
-rw-r--r-- | lib/File/Path.pm | 33 | ||||
-rw-r--r-- | lib/Getopt/Long.pm | 2 | ||||
-rw-r--r-- | lib/Test/Harness.pm | 12 | ||||
-rw-r--r-- | lib/autouse.pm | 165 |
17 files changed, 1116 insertions, 112 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index f7b8eee76d..ab634b2330 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -5,6 +5,7 @@ require Exporter; use Config; use Carp; +use File::Path qw(mkpath); @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @@ -154,12 +155,7 @@ sub autosplit_file{ $filename = VMS::Filespec::unixify($filename); # may have dirs } unless (-d $autodir){ - local($", @p)="/"; - foreach(split(/\//,$autodir)){ - push(@p, $_); - next if -d "@p/"; - mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!"; - } + mkpath($autodir,0,0755); # We should never need to create the auto dir here. installperl # (or similar) should have done it. Expecting it to exist is a valuable # sanity check against autosplitting into some random directory by mistake. @@ -193,14 +189,20 @@ sub autosplit_file{ $package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; $modpname =~ s#::#/#g; - my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + my($modpname) = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } - die "Package $package does not match filename $filename" - unless ($filename =~ m/$modpname.pm$/ or + die "Package $package ($modpname.pm) does not match filename $filename" + unless ($filename =~ m/\Q$modpname.pm\E$/ or ($^O eq "msdos") or $Is_VMS && $filename =~ m/$modpname.pm/i); + my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ @@ -215,12 +217,7 @@ sub autosplit_file{ if $Verbose; unless (-d "$autodir/$modpname"){ - local($", @p)="/"; - foreach(split(/\//,"$autodir/$modpname")){ - push(@p, $_); - next if -d "@p/"; - mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; - } + mkpath("$autodir/$modpname",0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 diff --git a/lib/Carp.pm b/lib/Carp.pm index ec08d30c19..c0cfe08d44 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -68,9 +68,16 @@ sub longmess { } for (@a) { $_ = "undef", next unless defined $_; - s/'/\\'/g; - substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + if (ref $_) { + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + $_ = "'$_'" unless /^-?[\d.]+$/; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } @@ -81,7 +88,10 @@ sub longmess { } $error = "called"; } - $mess || $error; + # this kludge circumvents die's incorrect handling of NUL + my $msg = \($mess || $error); + $$msg =~ tr/\0//d; + $$msg; } sub shortmess { # Short-circuit &longmess if called via multiple packages @@ -113,7 +123,9 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages if(defined @{$pack . "::ISA"}); } else { - return "$error at $file line $line\n"; + # this kludge circumvents die's incorrect handling of NUL + (my $msg = "$error at $file line $line\n") =~ tr/\0//d; + return $msg; } } continue { diff --git a/lib/Cwd.pm b/lib/Cwd.pm index e93cf1a0a9..f924a59647 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -230,6 +230,7 @@ sub chdir { sub _vms_cwd { return $ENV{'DEFAULT'} } + sub _os2_cwd { $ENV{'PWD'} = `cmd /c cd`; chop $ENV{'PWD'}; @@ -237,6 +238,8 @@ sub _os2_cwd { return $ENV{'PWD'}; } +*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; + sub _msdos_cwd { $ENV{'PWD'} = `command /c cd`; chop $ENV{'PWD'}; @@ -255,6 +258,7 @@ sub _msdos_cwd { } elsif ($^O eq 'NT' or $^O eq 'MSWin32') { # We assume that &_NT_cwd is defined as an XSUB or in the core. + *cwd = \&_NT_cwd; *getcwd = \&_NT_cwd; *fastcwd = \&_NT_cwd; *fastgetcwd = \&_NT_cwd; diff --git a/lib/Exporter.pm b/lib/Exporter.pm index abdb1e788b..7b03732790 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,21 +2,31 @@ package Exporter; require 5.001; +# +# We go to a lot of trouble not to 'require Carp' at file scope, +# because Carp requires Exporter, and something has to give. +# + $ExportLevel = 0; $Verbose = 0 unless $Verbose; -require Carp; - sub export { # First make import warnings look like they're coming from the "use". local $SIG{__WARN__} = sub { my $text = shift; - $text =~ s/ at \S*Exporter.pm line \d+.*\n//; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::carp($text); + if ($text =~ s/ at \S*Exporter.pm line \d+.*\n//) { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::carp($text); + } + else { + warn $text; + } }; local $SIG{__DIE__} = sub { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") if $_[0] =~ /^Unable to create sub named "(.*?)::"/; }; @@ -103,7 +113,10 @@ sub export { } } } - Carp::croak("Can't continue after import errors") if $oops; + if ($oops) { + require Carp; + Carp::croak("Can't continue after import errors"); + } } else { @imports = @exports; @@ -127,7 +140,10 @@ sub export { warn qq["$sym" is not implemented by the $pkg module ], "on this architecture"; } - Carp::croak("Can't continue after import errors") if @failed; + if (@failed) { + require Carp; + Carp::croak("Can't continue after import errors"); + } } } @@ -145,7 +161,7 @@ sub export { $type eq '@' ? \@{"${pkg}::$sym"} : $type eq '%' ? \%{"${pkg}::$sym"} : $type eq '*' ? *{"${pkg}::$sym"} : - Carp::croak("Can't export symbol: $type$sym"); + do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; } } @@ -165,8 +181,11 @@ sub _push_tags { push(@{"${pkg}::$var"}, map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) } (@$syms) ? @$syms : keys %export_tags); - # This may change to a die one day - Carp::carp("Some names are not tags") if $nontag and $^W; + if ($nontag and $^W) { + # This may change to a die one day + require Carp; + Carp::carp("Some names are not tags"); + } } sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) } @@ -188,6 +207,7 @@ sub require_version { $version ||= "(undef)"; my $file = $INC{"$pkg.pm"}; $file &&= " ($file)"; + require Carp; Carp::croak("$pkg $wanted required--this is only version $version$file") } $version; @@ -246,7 +266,7 @@ In other files which wish to use ModuleName: =head1 DESCRIPTION The Exporter module implements a default C<import> method which -many modules choose inherit rather than implement their own. +many modules choose to inherit rather than implement their own. Perl automatically calls the C<import> method when processing a C<use> statement for a module. Modules and C<use> are documented diff --git a/lib/ExtUtils/Command.pm b/lib/ExtUtils/Command.pm new file mode 100644 index 0000000000..8c4fd7a916 --- /dev/null +++ b/lib/ExtUtils/Command.pm @@ -0,0 +1,212 @@ +package ExtUtils::Command; +use strict; +# use AutoLoader; +use File::Copy; +use File::Compare; +use File::Basename; +use File::Path qw(rmtree); +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'; + +=head1 NAME + +ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. + +=head1 SYNOPSYS + + 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 + +The module is used in Win32 port to replace common UNIX commands. +Most commands are wrapers on generic modules File::Path and File::Basename. + +=over 4 + +=item cat + +Concatenates all files menthion on command line to STDOUT. + +=cut + +sub cat () +{ + print while (<>); +} + +=item eqtime src dst + +Sets modified time of dst to that of src + +=cut + +sub eqtime +{ + my ($src,$dst) = @ARGV; + open(F,">$dst"); + close(F); + utime((stat($src))[8,9],$dst); +} + +=item rm_f files.... + +Removes directories - recursively (even if readonly) + +=cut + +sub rm_rf +{ + rmtree([@ARGV],0,0); +} + +=item rm_f files.... + +Removes files (even if readonly) + +=cut + +sub rm_f +{ + foreach (@ARGV) + { + next unless -e $_; + chmod(0777,$_); + next if (-f $_ and unlink($_)); + die "Cannot delete $_:$!"; + } +} + +=item touch files ... + +Makes files exist, with current timestamp + +=cut + +sub touch +{ + while (@ARGV) + { + my $file = shift(@ARGV); + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + } +} + +=item mv source... destination + +Moves source to destination. +Multiple sources are allowed if destination is an existing directory. + +=cut + +sub mv +{ + my $dst = pop(@ARGV); + if (-d $dst) + { + while (@ARGV) + { + my $src = shift(@ARGV); + my $leaf = basename($src); + move($src,"$dst/$leaf"); # fixme + } + } + else + { + my $src = shift(@ARGV); + move($src,$dst) || die "Cannot move $src $dst:$!"; + } +} + +=item cp source... destination + +Copies source to destination. +Multiple sources are allowed if destination is an existing directory. + +=cut + +sub cp +{ + my $dst = pop(@ARGV); + if (-d $dst) + { + while (@ARGV) + { + my $src = shift(@ARGV); + my $leaf = basename($src); + copy($src,"$dst/$leaf"); # fixme + } + } + else + { + copy(shift,$dst); + } +} + +=item chmod mode files... + +Sets UNIX like permissions 'mode' on all the files. + +=cut + +sub chmod +{ + chmod(@ARGV) || die "Cannot chmod ".join(' ',@ARGV).":$!"; +} + +=item mkpath directory... + +Creates directory, including any parent directories. + +=cut + +sub mkpath +{ + File::Path::mkpath([@ARGV],1,0777); +} + +=item test_f file + +Tests if a file exists + +=cut + +sub test_f +{ + exit !-f shift(@ARGV); +} + +1; +__END__ + +=back + +=head1 BUGS + +eqtime does not work right on Win32 due to problems with utime() built-in +command. + +Should probably be Auto/Self loaded. + +=head1 SEE ALSO + +ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32 + +=head1 AUTHOR + +Nick Ing-Simmons <F<nick@ni-s.u-net.com>>. + +=cut + diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index a88bd9975e..71f553bcbf 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -233,6 +233,17 @@ sub pm_to_blib { # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first + if (!ref($fromto) && -r $fromto) + { + # Win32 has severe command line length limitations, but + # can generate temporary files on-the-fly + # so we pass name of file here - eval it to get hash + open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!"; + my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}'; + eval $str; + close(FROMTO); + } + my $umask = umask 0022 unless $Is_VMS; mkpath($autodir,0,0755); foreach (keys %$fromto) { diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 1a1f8b16a0..65abfc2d99 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -54,6 +54,17 @@ sub file_name_is_absolute { $file =~ m{^([a-z]:)?[\\/]}i ; } +sub perl_archive +{ + return "\$(PERL_INC)/libperl\$(LIB_EXT)"; +} + +sub export_list +{ + my ($self) = @_; + return "$self->{BASEEXT}.def"; +} + 1; __END__ diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 465a075132..f4ee44f4b9 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -8,7 +8,7 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.113 $, 10; +$VERSION = substr q$Revision: 1.114 $, 10; # $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $ Exporter::import('ExtUtils::MakeMaker', @@ -176,6 +176,7 @@ sub ExtUtils::MM_Unix::dynamic ; sub ExtUtils::MM_Unix::dynamic_bs ; sub ExtUtils::MM_Unix::dynamic_lib ; sub ExtUtils::MM_Unix::exescan ; +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 ; @@ -201,6 +202,7 @@ sub ExtUtils::MM_Unix::nicetext ; sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; +sub ExtUtils::MM_Unix::perl_archive; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; @@ -395,7 +397,7 @@ clean :: '); # clean subdirectories first for $dir (@{$self->{DIR}}) { - push @m, "\t-cd $dir && test -f $self->{MAKEFILE} && \$(MAKE) clean\n"; + push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n"; } my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files @@ -409,7 +411,7 @@ clean :: push @m, "\t-$self->{RM_RF} @otherfiles\n"; # See realclean and ext/utils/make_ext for usage of Makefile.old push(@m, - "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old 2>/dev/null\n"); + "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old \$(DEV_NULL)\n"); push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; join("", @m); @@ -600,20 +602,11 @@ INST_BOOT = '; } - if ($Is_OS2) { - $tmp = "$self->{BASEEXT}.def"; - } else { - $tmp = ""; - } + $tmp = $self->export_list; push @m, " EXPORT_LIST = $tmp "; - - if ($Is_OS2) { - $tmp = "\$(PERL_INC)/libperl\$(LIB_EXT)"; - } else { - $tmp = ""; - } + $tmp = $self->perl_archive; push @m, " PERL_ARCHIVE = $tmp "; @@ -673,8 +666,7 @@ sub dir_target { foreach $dir (@dirs) { my($src) = $self->catfile($self->{PERL_INC},'perl.h'); my($targ) = $self->catfile($dir,'.exists'); - my($targdir) = $targ; # Necessary because catfile may have - $targdir =~ s:/?.exists$::; # adapted syntax of $dir to target OS + my($targdir) = dirname($targ); # Necessary because catfile may have adapted syntax of $dir to target OS next if $self->{DIR_TARGET}{$self}{$targdir}++; push @m, qq{ $targ :: $src @@ -713,7 +705,7 @@ sub dist { my($to_unix) = $attribs{TO_UNIX} || ($Is_OS2 ? "$self->{NOECHO}" - . 'test -f tmp.zip && $(RM) tmp.zip;' + . '$(TEST_F) tmp.zip && $(RM) tmp.zip;' . ' $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM) tmp.zip' : "$self->{NOECHO}\$(NOOP)"); @@ -757,20 +749,20 @@ distclean :: realclean distcheck push @m, q{ distcheck : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&fullcheck";' \\ - -e 'fullcheck();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\ + -e fullcheck }; push @m, q{ skipcheck : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&skipcheck";' \\ - -e 'skipcheck();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\ + -e skipcheck }; push @m, q{ manifest : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&mkmanifest";' \\ - -e 'mkmanifest();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\ + -e mkmanifest }; join "", @m; } @@ -786,8 +778,8 @@ sub dist_ci { my @m; push @m, q{ ci : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&maniread";' \\ - -e '@all = keys %{ maniread() };' \\ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\ + -e "@all = keys %{ maniread() };" \\ -e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\ -e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");' }; @@ -854,7 +846,7 @@ sub dist_dir { distdir : $(RM_RF) $(DISTVNAME) $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\ - -e 'manicopy(maniread(),"$(DISTVNAME)", "$(DIST_CP)");' + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" }; join "", @m; } @@ -955,8 +947,8 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".' $(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ - -e \'use ExtUtils::Mkbootstrap;\' \ - -e \'Mkbootstrap("$(BASEEXT)","$(BSLOADLIBS)");\' + -MExtUtils::Mkbootstrap \ + -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) $(CHMOD) 644 $@ @@ -1718,7 +1710,7 @@ usually solves this kind of problem. Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, NOOP, FIRST_MAKEFILE, -MAKEFILE, NOECHO, RM_F, RM_RF, TOUCH, CP, MV, CHMOD, UMASK_NULL +MAKEFILE, NOECHO, RM_F, RM_RF, TEST_F, TOUCH, CP, MV, CHMOD, UMASK_NULL =cut @@ -1776,10 +1768,12 @@ sub init_others { # --- Initialize Other Attributes $self->{RM_F} ||= "rm -f"; $self->{RM_RF} ||= "rm -rf"; $self->{TOUCH} ||= "touch"; + $self->{TEST_F} ||= "test -f"; $self->{CP} ||= "cp"; $self->{MV} ||= "mv"; $self->{CHMOD} ||= "chmod"; $self->{UMASK_NULL} ||= "umask 0"; + $self->{DEV_NULL} ||= "> /dev/null 2>&1"; } =item install (o) @@ -2196,8 +2190,8 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c push @m, qq{ $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ - }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ - writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@t && mv $@t $@ + }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ + -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@ }; @@ -2250,11 +2244,12 @@ $(OBJECT) : $(FIRST_MAKEFILE) }.$self->{MAKEFILE}.q{ : Makefile.PL $(CONFIGDEP) }.$self->{NOECHO}.q{echo "Makefile out-of-date with respect to $?" }.$self->{NOECHO}.q{echo "Cleaning current config before rebuilding Makefile..." - -}.$self->{NOECHO}.q{mv }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{ - -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean >/dev/null 2>&1 || true + -}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{ + -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{ - }.$self->{NOECHO}.q{echo ">>> Your Makefile has been rebuilt. <<<" - }.$self->{NOECHO}.q{echo ">>> Please rerun the make command. <<<"; false + }.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <==" + }.$self->{NOECHO}.q{echo "==> Please rerun the make command. <==" + false # To change behavior to :: would be nice, but would break Tk b9.02 # so you find such a warning below the dist target. @@ -2554,7 +2549,7 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e 'pm_to_blib({qw{$(PM_TO_BLIB)}},"}.$autodir.q{")' + -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -2647,7 +2642,7 @@ sub realclean { realclean purge :: clean '); # realclean subdirectories first (already cleaned) - my $sub = "\t-cd %s && test -f %s && \$(MAKE) %s realclean\n"; + my $sub = "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n"; foreach(@{$self->{DIR}}){ push(@m, sprintf($sub,$_,"$self->{MAKEFILE}.old","-f $self->{MAKEFILE}.old")); push(@m, sprintf($sub,$_,"$self->{MAKEFILE}",'')); @@ -2845,7 +2840,7 @@ testdb :: testdb_\$(LINKTYPE) test :: \$(TEST_TYPE) "); - push(@m, map("\t$self->{NOECHO}cd $_ && test -f $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n", + push(@m, map("\t$self->{NOECHO}cd $_ && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n", @{$self->{DIR}})); push(@m, "\t$self->{NOECHO}echo 'No tests defined for \$(NAME) extension.'\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; @@ -2936,27 +2931,23 @@ sub tools_other { SHELL = $bin_sh }; - for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TOUCH UMASK_NULL / ) { + for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { push @m, "$_ = $self->{$_}\n"; } - push @m, q{ # The following is a portable way to say mkdir -p # To see which directories are created, change the if 0 to if 1 -MKPATH = $(PERL) -wle '$$"="/"; foreach $$p (@ARGV){' \\ --e 'next if -d $$p; my(@p); foreach(split(/\//,$$p)){' \\ --e 'push(@p,$$_); next if -d "@p/"; print "mkdir @p" if 0;' \\ --e 'mkdir("@p",0777)||die $$! } } exit 0;' +MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath # This helps us to minimize the effect of the .exists files A yet # better solution would be to have a stable file in the perl # distribution with a timestamp of zero. But this solution doesn't # need any changes to the core distribution and works with older perls -EQUALIZE_TIMESTAMP = $(PERL) -we 'open F, ">$$ARGV[1]"; close F;' \\ --e 'utime ((stat("$$ARGV[0]"))[8,9], $$ARGV[1])' +EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime }; + return join "", @m if $self->{PARENT}; push @m, q{ @@ -2971,7 +2962,7 @@ UNINST=0 VERBINST=1 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ --e 'install({@ARGV},"$(VERBINST)",0,"$(UNINST)");' +-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ -e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ @@ -3110,10 +3101,15 @@ sub top_targets { my(@m); push @m, ' #all :: config $(INST_PM) subdirs linkext manifypods +'; + push @m, ' all :: pure_all manifypods '.$self->{NOECHO}.'$(NOOP) - +' + unless $self->{SKIPHASH}{'all'}; + + push @m, ' pure_all :: config pm_to_blib subdirs linkext '.$self->{NOECHO}.'$(NOOP) @@ -3168,7 +3164,7 @@ help: Version_check: }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -MExtUtils::MakeMaker=Version_check \ - -e 'Version_check("$(MM_VERSION)")' + -e "Version_check('$(MM_VERSION)')" }; join('',@m); @@ -3200,7 +3196,7 @@ sub xs_c { return '' unless $self->needs_linking(); ' .xs.c: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && mv $*.tc $@ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@ '; } @@ -3216,11 +3212,38 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o return '' unless $self->needs_linking(); ' .xs$(OBJ_EXT): - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && mv xstmp.c $*.c + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } +=item perl_archive + +This is internal method that returns path to libperl.a equivalent +to be linked to dynamic extensions. UNIX does not have one but OS2 +and Win32 do. + +=cut + +sub perl_archive +{ + return ""; +} + +=item export_list + +This is internal method that returns name of a file that is +passed to linker to define symbols to be exported. +UNIX does not have one but OS2 and Win32 do. + +=cut + +sub export_list +{ + return ""; +} + + 1; =back diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 0e2897c1ad..23e8fdbe7d 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -1051,7 +1051,10 @@ EOM $command = "$self->{PERL} $xsubpp $file"; print "Running: $command\n" if $Verbose; my $text = `$command` ; - warn "Running '$command' exits with status " . $? unless ($? & 1); + if ($?) { + use vmsish 'status'; + warn "Running '$command' exits with status $?"; + } unlink $file ; # gets 1.2 -> 1.92 and 2.000a1 diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm new file mode 100644 index 0000000000..d001901f37 --- /dev/null +++ b/lib/ExtUtils/MM_Win32.pm @@ -0,0 +1,493 @@ +package ExtUtils::MM_Win32; + +=head1 NAME + +ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over + +=cut + +#use Config; +#use Cwd; +use File::Basename; +require Exporter; + +Exporter::import('ExtUtils::MakeMaker', + qw( $Verbose &neatvalue)); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` +unshift @MM::ISA, 'ExtUtils::MM_Win32'; + +sub dlsyms { + my($self,%attribs) = @_; + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; + my(@m); + (my $boot = $self->{NAME}) =~ s/:/_/g; + + if (not $self->{SKIPHASH}{'dynamic'}) { + push(@m," +$self->{BASEEXT}.def: Makefile.PL +", + q! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \\ + -e "Mksymlists('NAME' => '!, $self->{NAME}, + q!', 'DLBASE' => '!,$self->{DLBASE}, + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars), q!);" +!); + } + join('',@m); +} + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + +sub maybe_command { + my($self,$file) = @_; + return "$file.exe" if -e "$file.exe"; + return; +} + +sub file_name_is_absolute { + my($self,$file) = @_; + $file =~ m{^([a-z]:)?[\\/]}i ; +} + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + my($name, $dir); + if ($trace >= 2){ + print "Looking for perl $ver by these names: +@$names +in these dirs: +@$dirs +"; + } + foreach $dir (@$dirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + foreach $name (@$names){ + my ($abs, $val); + if ($self->file_name_is_absolute($name)) { # /foo/bar + $abs = $name; + } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo + $abs = $self->catfile($dir, $name); + } else { # foo/bar + $abs = $self->canonpath($self->catfile($self->curdir, $name)); + } + print "Checking $abs\n" if ($trace >= 2); + next unless $self->maybe_command($abs); + print "Executing $abs\n" if ($trace >= 2); + $val = `$abs -e "require $ver;" 2>&1`; + if ($? == 0) { + print "Using PERL=$abs\n" if $trace; + return $abs; + } elsif ($trace >= 2) { + print "Result: `$val'\n"; + } + } + } + print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + +sub catdir { + my $self = shift; + my @args = @_; + for (@args) { + # append a slash to each argument unless it has one there + $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + } + my $result = $self->canonpath(join('', @args)); + $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + for ($dir) { + $_ .= "\\" unless substr($_,length($_)-1,1) eq "\\"; + } + return $dir.$file; +} + +sub init_others +{ + my ($self) = @_; + &ExtUtils::MM_Unix::init_others; + $self->{'TOUCH'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e touch'; + $self->{'CHMOD'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e chmod'; + $self->{'CP'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp'; + $self->{'RM_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f'; + $self->{'RM_RF'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf'; + $self->{'MV'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv'; + $self->{'NOOP'} = 'rem'; + $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f'; + $self->{'LD'} = 'link'; + $self->{'DEV_NULL'} = '> NUL'; + # $self->{'NOECHO'} = ''; # till we have it working +} + +sub path { + local $^W = 1; + my($self) = @_; + my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; + my @path = split(';',$path); + foreach(@path) { $_ = '.' if $_ eq '' } + @path; +} + +=item static_lib (o) + +Defines how to produce the *.a (or equivalent) files. + +=cut + +sub static_lib { + my($self) = @_; +# Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC +# return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my(@m); + push(@m, <<'END'); +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists + $(RM_RF) $@ +END + # If this extension has it's own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB}; + + push @m, +q{ lib -nologo -out:$@ $(OBJECT) + }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld + $(CHMOD) 755 $@ +}; + +# Old mechanism - still available: + + push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs}."\n\n" + if $self->{PERL_SRC}; + + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('', "\n",@m); +} + + + +=item dynamic_lib (o) + +Defines how to produce the *.so (or equivalent) files. + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($ldfrom) = '$(LDFROM)'; + my(@m); + push(@m,' +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +OTHERLDFLAGS = '.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' + +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +'); + + push(@m,' $(LD) -out:$@ $(LDDLFLAGS) '.$ldfrom. + ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)'); + push @m, ' + $(CHMOD) 755 $@ +'; + + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('',@m); +} + +sub perl_archive +{ + return '$(PERL_INC)\perl$(LIB_EXT)'; +} + +sub export_list +{ + my ($self) = @_; + return "$self->{BASEEXT}.def"; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my($self,$path) = @_; + $path =~ s|/|\\|g; + $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx + $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx + $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx + $path =~ s|\\$|| + unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx + $path .= '.' if $path =~ m#\\$#; + $path; +} + +=item perl_script + +Takes one argument, a file name, and returns the file name, if the +argument is likely to be a perl script. On MM_Unix this is true for +any ordinary, readable file. + +=cut + +sub perl_script { + my($self,$file) = @_; + return "$file.pl" if -r "$file.pl" && -f _; + return; +} + +=item pm_to_blib + +Defines target that copies all files in the hash PM to their +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> + +=cut + +sub pm_to_blib { + my $self = shift; + my($autodir) = $self->catdir('$(INST_LIB)','auto'); + return q{ +pm_to_blib: $(TO_INST_PM) + }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ + "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ + -e "pm_to_blib(qw{ <<pmfiles.dat },'}.$autodir.q{')" + }.q{ +$(PM_TO_BLIB) +<< + }.$self->{NOECHO}.q{$(TOUCH) $@ +}; +} + +=item test_via_harness (o) + +Helper method to write the test targets + +=cut + +sub test_via_harness { + my($self, $perl, $tests) = @_; + "\t$perl".q! -Mblib -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" !."$tests\n"; +} + +=item tool_autosplit (override) + +Use Win32 quoting on command line. + +=cut + +sub tool_autosplit{ + my($self, %attribs) = @_; + my($asl) = ""; + $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN}; + q{ +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MAutoSplit }.$asl.q{ -e "autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);" +}; +} + +=item tools_other (o) + +Win32 overrides. + +Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in +the Makefile. Also defines the perl programs MKPATH, +WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL. + +=cut + +sub tools_other { + my($self) = shift; + my @m; + my $bin_sh = $Config{sh} || 'cmd /c'; + push @m, qq{ +SHELL = $bin_sh +}; + + for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { + push @m, "$_ = $self->{$_}\n"; + } + + push @m, q{ +# The following is a portable way to say mkdir -p +# To see which directories are created, change the if 0 to if 1 +MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath + +# This helps us to minimize the effect of the .exists files A yet +# better solution would be to have a stable file in the perl +# distribution with a timestamp of zero. But this solution doesn't +# need any changes to the core distribution and works with older perls +EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime +}; + + + return join "", @m if $self->{PARENT}; + + push @m, q{ +# Here we warn users that an old packlist file was found somewhere, +# and that they should call some uninstall routine +WARN_IF_OLD_PACKLIST = $(PERL) -lwe "exit unless -f $$ARGV[0];" \\ +-e "print 'WARNING: I have found an old package in';" \\ +-e "print ' ', $$ARGV[0], '.';" \\ +-e "print 'Please make sure the two installations are not conflicting';" + +UNINST=0 +VERBINST=1 + +MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ +-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" + +DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \ +-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \ +-e "print '=over 4';" \ +-e "while (defined($$key = shift) and defined($$val = shift)){print '=item *';print 'C<', \"$$key: $$val\", '>';}" \ +-e "print '=back';" + +UNINSTALL = $(PERL) -MExtUtils::Install \ +-e "uninstall($$ARGV[0],1,1); print \"\nUninstall is deprecated. Please check the";" \ +-e "print \" packlist above carefully.\n There may be errors. Remove the\";" \ +-e "print \" appropriate files manually.\n Sorry for the inconveniences.\n\"" +}; + + return join "", @m; +} + +=item manifypods (o) + +We don't want manpage process. XXX add pod2html support later. + +=cut + +sub manifypods { + return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n"; +} + +=item dist_ci (o) + +Same as MM_Unix version (changes command-line quoting). + +=cut + +sub dist_ci { + my($self) = shift; + my @m; + push @m, q{ +ci : + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\ + -e "@all = keys %{ maniread() };" \\ + -e "print(\"Executing $(CI) @all\n\"); system(\"$(CI) @all\");" \\ + -e "print(\"Executing $(RCS_LABEL) ...\n\"); system(\"$(RCS_LABEL) @all\");" +}; + join "", @m; +} + +=item dist_core (o) + +Same as MM_Unix version (changes command-line quoting). + +=cut + +sub dist_core { + my($self) = shift; + my @m; + push @m, q{ +dist : $(DIST_DEFAULT) + }.$self->{NOECHO}.q{$(PERL) -le "print \"Warning: Makefile possibly out of date with $$vf\" if " \ + -e "-e ($$vf=\"$(VERSION_FROM)\") and -M $$vf < -M \"}.$self->{MAKEFILE}.q{\";" + +tardist : $(DISTVNAME).tar$(SUFFIX) + +zipdist : $(DISTVNAME).zip + +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) + +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(POSTOP) + +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) \\ + $(DISTVNAME).tar$(SUFFIX) > \\ + $(DISTVNAME).tar$(SUFFIX)_uu + +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(POSTOP) +}; + join "", @m; +} + +=item pasthru (o) + +Defines the string that is passed to recursive make calls in +subdirectories. + +=cut + +sub pasthru { + my($self) = shift; + return "PASTHRU = /nologo" +} + + + +1; +__END__ + +=back + +=cut + diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index bf0b0d202e..eb49f3e55f 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -68,9 +68,10 @@ package ExtUtils::MakeMaker; # # Now we can can pull in the friends # -$Is_VMS = $^O eq 'VMS'; -$Is_OS2 = $^O eq 'os2'; -$Is_Mac = $^O eq 'MacOS'; +$Is_VMS = $^O eq 'VMS'; +$Is_OS2 = $^O eq 'os2'; +$Is_Mac = $^O eq 'MacOS'; +$Is_Win32 = $^O eq 'MSWin32'; require ExtUtils::MM_Unix; @@ -84,6 +85,9 @@ if ($Is_OS2) { if ($Is_Mac) { require ExtUtils::MM_Mac; } +if ($Is_Win32) { + require ExtUtils::MM_Win32; +} # The SelfLoader would bring a lot of overhead for MakeMaker, because # we know for sure we will use most of the autoloaded functions once @@ -150,7 +154,7 @@ sub ExtUtils::MakeMaker::mksymlists ; sub ExtUtils::MakeMaker::neatvalue ; sub ExtUtils::MakeMaker::selfdocument ; sub ExtUtils::MakeMaker::WriteMakefile ; -sub ExtUtils::MakeMaker::prompt ; +sub ExtUtils::MakeMaker::prompt ($;$) ; 1; @@ -449,9 +453,10 @@ sub ExtUtils::MakeMaker::new { $self->init_main(); if (! $self->{PERL_SRC} ) { - my($pthinks) = $INC{'Config.pm'}; + my($pthinks) = $self->canonpath($INC{'Config.pm'}); $pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS; if ($pthinks ne $self->catfile($Config{archlibexp},'Config.pm')){ + print "Have $pthinks expected ",$self->catfile($Config{archlibexp},'Config.pm'),"\n"; $pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!; print STDOUT <<END; diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 4c6814cbcb..fd609152c3 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -49,6 +49,7 @@ sub Mksymlists { if ($osname eq 'aix') { _write_aix(\%spec); } elsif ($osname eq 'VMS') { _write_vms(\%spec) } elsif ($osname eq 'os2') { _write_os2(\%spec) } + elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } else { croak("Don't know how to create linker option file for $osname\n"); } } @@ -93,6 +94,33 @@ while (($name, $exp)= each %{$data->{IMPORTS}}) { close DEF; } +sub _write_win32 { + my($data) = @_; + + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open(DEF,">$data->{FILE}.def") + or croak("Can't create $data->{FILE}.def: $!\n"); + print DEF "LIBRARY $data->{DLBASE}\n"; + print DEF "CODE LOADONCALL\n"; + print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; + print DEF "EXPORTS\n "; + print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + if (%{$data->{IMPORTS}}) { + print DEF "IMPORTS\n"; + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print DEF " $name=$exp\n"; + } + } + close DEF; +} + sub _write_vms { my($data) = @_; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 6abfcd2cb4..0442aed8c5 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -34,7 +34,7 @@ pieces using the syntax of different operating systems. You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings -"VMS", "MSDOS", "MacOS", or "AmigaOS", the file specification +"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification syntax of that operating system is used in future calls to fileparse(), basename(), and dirname(). If it contains none of these substrings, UNIX syntax is used. This pattern matching is @@ -44,7 +44,7 @@ they assume you are using UNIX emulation and apply the UNIX syntax rules instead, for that function call only. If the argument passed to it contains one of the substrings "VMS", -"MSDOS", "MacOS", "AmigaOS", "os2", or "RISCOS", then the pattern +"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern matching for suffix removal is performed without regard for case, since those systems are not case-sensitive when opening existing files (though some of them preserve case on file creation). @@ -128,7 +128,7 @@ require Exporter; @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); #use strict; #use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); -$VERSION = "2.4"; +$VERSION = "2.5"; # fileparse_set_fstype() - specify OS-based rules used in future @@ -141,7 +141,7 @@ sub fileparse_set_fstype { my @old = ($Fileparse_fstype, $Fileparse_igncase); if (@_) { $Fileparse_fstype = $_[0]; - $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS)/i); + $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i); } wantarray ? @old : $old[0]; } @@ -173,6 +173,10 @@ sub fileparse { ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); $dirpath = './' unless $dirpath; } + elsif ($fstype =~ /^MSWin32/i) { + ($dirpath,$basename) = ($fullname =~ /^(.*[:\\\/])?(.*)/); + $dirpath .= ".\\" unless $dirpath =~ /[\\\/]$/; + } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); $dirpath = './' unless $dirpath; @@ -223,6 +227,13 @@ sub dirname { $dirname =~ s/([^:])[\\\/]*$/$1/; } } + elsif ($fstype =~ /MSWin32/i) { + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } elsif ($fstype =~ /AmigaOS/i) { if ( $dirname =~ /:$/) { return $dirname } chop $dirname; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 2e35303bb3..137e7bb1ce 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -83,20 +83,24 @@ Charles Bailey E<lt>F<bailey@genetics.upenn.edu>E<gt> =head1 REVISION -This module was last revised 14-Feb-1996, for perl 5.002. $VERSION is -1.01. +This module was last revised 14-Feb-1996, for perl 5.002. +$VERSION is 1.0101. =cut -$VERSION = "1.01"; # That's my hobby-horse, A.K. - require 5.000; use Carp; +use File::Basename; require Exporter; + +use vars qw( $VERSION @ISA @EXPORT ); +$VERSION = "1.0101"; @ISA = qw( Exporter ); @EXPORT = qw( mkpath rmtree ); -$Is_VMS = $^O eq 'VMS'; +my $Is_VMS = $^O eq 'VMS'; +my $force_writeable = ($^O eq 'os2' || $^O eq 'msdos' || $^O eq 'MSWin32' + || $^O eq 'amigaos'); sub mkpath { my($paths, $verbose, $mode) = @_; @@ -107,16 +111,13 @@ sub mkpath { $mode = 0777 unless defined($mode); $paths = [$paths] unless ref $paths; my(@created); - foreach $path (@$paths){ + foreach $path (@$paths) { next if -d $path; - my(@p); - foreach(split(/\//, $path)){ - push(@p, $_); - next if -d "@p/"; - print "mkdir @p\n" if $verbose; - mkdir("@p",$mode) || croak "mkdir @p: $!"; - push(@created, "@p"); - } + my $parent = dirname($path); + push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + print "mkdir $path\n" if $verbose; + mkdir($path,$mode) || croak "mkdir $path: $!"; + push(@created, $path); } @created; } @@ -144,6 +145,8 @@ sub rmtree { print "skipped $root\n" if $verbose; next; } + chmod 0777, $root or carp "Can't make directory $root writeable: $!" + if $force_writeable; print "rmdir $root\n" if $verbose; (rmdir $root && ++$count) or carp "Can't remove directory $root: $!"; } @@ -153,6 +156,8 @@ sub rmtree { print "skipped $root\n" if $verbose; next; } + chmod 0666, $root or carp "Can't make file $root writeable: $!" + if $force_writeable; print "unlink $root\n" if $verbose; while (-e $root || -l $root) { # delete all versions under VMS (unlink($root) && ++$count) diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index ec4ccd98e9..740b83fe54 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -535,7 +535,7 @@ BEGIN { use vars @EXPORT, @EXPORT_OK; # User visible variables. -use vars qw(&config $error $debug $major_version $minor_version); +use vars qw($error $debug $major_version $minor_version); # Deprecated visible variables. use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough); diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 1bc791be3e..6979a11549 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -11,7 +11,7 @@ use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest @ISA @EXPORT @EXPORT_OK); $have_devel_corestack = 0; -$VERSION = "1.1501"; +$VERSION = "1.1502"; @ISA=('Exporter'); @EXPORT= qw(&runtests); @@ -58,12 +58,13 @@ sub runtests { while ($test = shift(@tests)) { $te = $test; chop($te); + if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; } print "$te" . '.' x (20 - length($te)); my $fh = new FileHandle; $fh->open($test) or print "can't open $test. $!\n"; my $first = <$fh>; my $s = $switches; - $s .= " -T" if $first =~ /^#!.*\bperl.*-\w*T/; + $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/; $fh->close or print "can't close $test. $!\n"; my $cmd = "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; @@ -103,10 +104,13 @@ sub runtests { } $fh->close; # must close to reap child resource values my $wstatus = $?; - my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8; - if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) { + my $estatus = ($^O eq 'VMS' + ? eval 'use vmsish "status"; $estatus = $?' + : $wstatus >> 8); + if ($wstatus) { my ($failed, $canon, $percent) = ('??', '??'); print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n"; + print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; if (corestatus($wstatus)) { # until we have a wait module if ($have_devel_corestack) { Devel::CoreStack::stack($^X); diff --git a/lib/autouse.pm b/lib/autouse.pm new file mode 100644 index 0000000000..e2ef580392 --- /dev/null +++ b/lib/autouse.pm @@ -0,0 +1,165 @@ +package autouse; + +#use strict; # debugging only +use 5.003_90; # ->can, for my $var + +$autouse::VERSION = '0.03'; + +my $DEBUG = $ENV{AUTOUSE_DEBUG}; + +sub vet_import ($); + +sub croak { + require Carp; + Carp::croak(@_); +} + +sub import { + shift; + my $module = shift; + + (my $pm = $module) =~ s{::}{/}g; + $pm .= '.pm'; + if (exists $INC{$pm}) { + vet_import $module; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + # $Exporter::Verbose = 1; + return $module->import(map { (my $f = $_) =~ s/\(.*?\)$// } @_); + } + + # It is not loaded: need to do real work. + my $callpkg = caller(0); + print "autouse called from $callpkg\n" if $DEBUG; + + my $index; + for my $f (@_) { + my $proto; + $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//; + + my $closure_import_func = $func; # Full name + my $closure_func = $func; # Name inside package + my $index = index($func, '::'); + if ($index == -1) { + $closure_import_func = "${callpkg}::$func"; + } else { + $closure_func = substr $func, $index + 2; + croak "autouse into different package attempted" + unless substr($func, 0, $index) eq $module; + } + + my $load_sub = sub { + unless ($INC{pm}) { + require $pm; + die $@ if $@; + vet_import $module; + } + *$closure_import_func = \&{"${module}::$closure_func"}; + print "autousing $module; " + ."imported $closure_func as $closure_import_func\n" + if $DEBUG; + goto &$closure_import_func; + }; + + if (defined $proto) { + *$closure_import_func = eval "sub ($proto) { &\$load_sub }"; + } else { + *$closure_import_func = $load_sub; + } + } +} + +sub vet_import ($) { + my $module = shift; + if (my $import = $module->can('import')) { + croak "autoused module has unique import() method" + unless defined(\&Exporter::import) + && $import == \&Exporter::import; + } +} + +1; + +__END__ + +=head1 NAME + +autouse - postpone load of modules until a function is used + +=head1 SYNOPSIS + + use autouse 'Carp' => qw(carp croak); + carp "this carp was predeclared and autoused "; + +=head1 DESCRIPTION + +If the module C<Module> is already loaded, then the declaration + + use autouse 'Module' => qw(func1 func2($;$) Module::func3); + +is equivalent to + + use Module qw(func1 func2); + +if C<Module> defines func2() with prototype C<($;$)>, and func1() and +func3() have no prototypes. (At least if C<Module> uses C<Exporter>'s +C<import>, otherwise it is a fatal error.) + +If the module C<Module> is not loaded yet, then the above declaration +declares functions func1() and func2() in the current package, and +declares a function Module::func3(). When these functions are called, +they load the package C<Module> if needed, and substitute themselves +with the correct definitions. + +=head1 WARNING + +Using C<autouse> will move important steps of your program's execution +from compile time to runtime. This can + +=over + +=item * + +Break the execution of your program if the module you C<autouse>d has +some initialization which it expects to be done early. + +=item * + +hide bugs in your code since important checks (like correctness of +prototypes) is moved from compile time to runtime. In particular, if +the prototype you specified on C<autouse> line is wrong, you will not +find it out until the corresponding function is executed. This will be +very unfortunate for functions which are not always called (note that +for such functions C<autouse>ing gives biggest win, for a workaround +see below). + +=back + +To alleviate the second problem (partially) it is advised to write +your scripts like this: + + use Module; + use autouse Module => qw(carp($) croak(&$)); + carp "this carp was predeclared and autoused "; + +The first line ensures that the errors in your argument specification +are found early. When you ship your application you should comment +out the first line, since it makes the second one useless. + +=head1 BUGS + +If Module::func3() is autoused, and the module is loaded between the +C<autouse> directive and a call to Module::func3(), warnings about +redefinition would appear if warnings are enabled. + +If Module::func3() is autoused, warnings are disabled when loading the +module via autoused functions. + +=head1 AUTHOR + +Ilya Zakharevich (ilya@math.ohio-state.edu) + +=head1 SEE ALSO + +perl(1). + +=cut |