diff options
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 |