diff options
author | 2008-09-29 17:35:51 +0000 | |
---|---|---|
committer | 2008-09-29 17:35:51 +0000 | |
commit | 7bfa9f444b545f1bc96a4b2919ed2583bf07c7ea (patch) | |
tree | a27ed65c25e4fb26d9bca8126dbdf2b189894d6a /gnu/usr.bin/perl/lib/ExtUtils | |
parent | import perl 5.10.0 from CPAN (diff) | |
download | wireguard-openbsd-7bfa9f444b545f1bc96a4b2919ed2583bf07c7ea.tar.xz wireguard-openbsd-7bfa9f444b545f1bc96a4b2919ed2583bf07c7ea.zip |
fix conflicts and merge in local changes to perl 5.10.0
Diffstat (limited to 'gnu/usr.bin/perl/lib/ExtUtils')
21 files changed, 2056 insertions, 2982 deletions
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm index ecd7813bb31..8c9a8d0b5b3 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm @@ -10,9 +10,9 @@ use File::Path qw(rmtree); require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); @ISA = qw(Exporter); -@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f chmod +@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod dos2unix); -$VERSION = '1.09'; +$VERSION = '1.13'; my $Is_VMS = $^O eq 'VMS'; @@ -22,27 +22,28 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 SYNOPSIS - perl -MExtUtils::Command -e cat files... > destination - perl -MExtUtils::Command -e mv source... destination - perl -MExtUtils::Command -e cp source... destination - perl -MExtUtils::Command -e touch files... - perl -MExtUtils::Command -e rm_f files... - perl -MExtUtils::Command -e rm_rf directories... - perl -MExtUtils::Command -e mkpath directories... - perl -MExtUtils::Command -e eqtime source destination - perl -MExtUtils::Command -e test_f file - perl -MExtUtils::Command -e chmod mode files... + 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 files... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e test_f file + perl -MExtUtils::Command -e test_d directory + perl -MExtUtils::Command -e chmod mode files... ... =head1 DESCRIPTION The module is used to replace common UNIX commands. In all cases the functions work from @ARGV rather than taking arguments. This makes -them easier to deal with in Makefiles. +them easier to deal with in Makefiles. Call them like this: perl -MExtUtils::Command -e some_command some files to work on -I<NOT> +and I<NOT> like this: perl -MExtUtils::Command -e 'some_command qw(some files to work on)' @@ -50,6 +51,9 @@ For that use L<Shell::Command>. Filenames with * and ? will be glob expanded. + +=head2 FUNCTIONS + =over 4 =cut @@ -259,13 +263,28 @@ sub mkpath test_f file -Tests if a file exists +Tests if a file exists. I<Exits> with 0 if it does, 1 if it does not (ie. +shell's idea of true and false). =cut sub test_f { - exit !-f $ARGV[0]; + exit(-f $ARGV[0] ? 0 : 1); +} + +=item test_d + + test_d directory + +Tests if a directory exists. I<Exits> with 0 if it does, 1 if it does +not (ie. shell's idea of true and false). + +=cut + +sub test_d +{ + exit(-d $ARGV[0] ? 0 : 1); } =item dos2unix @@ -304,7 +323,7 @@ sub dos2unix { =back -=head1 SEE ALSO +=head1 SEE ALSO Shell::Command which is these same functions but take arguments normally. @@ -313,7 +332,9 @@ Shell::Command which is these same functions but take arguments normally. Nick Ing-Simmons C<ni-s@cpan.org> -Currently maintained by Michael G Schwern C<schwern@pobox.com>. +Maintained by Michael G Schwern C<schwern@pobox.com> within the +ExtUtils-MakeMaker package and, as a separate CPAN package, by +Randy Kobes C<r.kobes@uwinnipeg.ca>. =cut diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm index 945a026b161..dc6d5e75d6f 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm @@ -1,4 +1,4 @@ -# $Id: Embed.pm,v 1.6 2003/12/03 03:02:37 millert Exp $ +# $Id: Embed.pm,v 1.1.1.1 2002/01/16 19:27:19 schwern Exp $ require 5.002; package ExtUtils::Embed; @@ -18,7 +18,8 @@ use vars qw(@ISA @EXPORT $VERSION ); use strict; -$VERSION = 1.26; +# This is not a dual-life module, so no need for development version numbers +$VERSION = '1.27'; @ISA = qw(Exporter); @EXPORT = qw(&xsinit &ldopts @@ -133,7 +134,9 @@ sub xsi_body { sub static_ext { unless (scalar @Extensions) { - @Extensions = sort split /\s+/, $Config{static_ext}; + my $static_ext = $Config{static_ext}; + $static_ext =~ s/^\s+//; + @Extensions = sort split /\s+/, $static_ext; unshift @Extensions, qw(DynaLoader); } @Extensions; @@ -225,11 +228,13 @@ sub ldopts { if ($^O eq 'MSWin32') { $libperl = $Config{libperl}; } - else { + elsif ($^O eq 'os390' && $Config{usedl}) { + # Nothing for OS/390 (z/OS) dynamic. + } else { $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/ ? "-l$1" : '') - || "-lperl"; + || "-lperl"; } my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE'); @@ -425,7 +430,7 @@ rather than print it to STDOUT. perl -MExtUtils::Embed -e ldopts -This will print arguments for linking with B<libperl.a>, B<DynaLoader> and +This will print arguments for linking with B<libperl> and extensions found in B<$Config{static_ext}>. This includes libraries found in B<$Config{libs}> and the first ModuleName.a library for each extension that is found by searching B<@INC> or the path @@ -439,17 +444,8 @@ are picked up from the B<extralibs.ld> file in the same directory. This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension. - - perl -MExtUtils::Embed -e ldopts -- DynaLoader - - -This will print arguments for linking with just the B<DynaLoader> extension -and B<libperl.a>. - - perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql - Any arguments after the second '--' token are additional linker arguments that will be examined for potential conflict. If there is no conflict, the additional arguments will be part of the output. diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm index 30740e07312..d60bc6cb815 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm @@ -1,28 +1,28 @@ package ExtUtils::Install; - use 5.00503; -use vars qw(@ISA @EXPORT $VERSION); -$VERSION = '1.33'; +use strict; -use Exporter; +use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config); +$VERSION = '1.44'; +$VERSION = eval $VERSION; + +use AutoSplit; use Carp (); use Config qw(%Config); -@ISA = ('Exporter'); -@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); -$Is_VMS = $^O eq 'VMS'; -$Is_MacPerl = $^O eq 'MacOS'; - -my $Inc_uninstall_warn_handler; - -# install relative to here - -my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; - +use Cwd qw(cwd); +use Exporter; +use ExtUtils::Packlist; +use File::Basename qw(dirname); +use File::Compare qw(compare); +use File::Copy; +use File::Find qw(find); +use File::Path; use File::Spec; -my $Curdir = File::Spec->curdir; -my $Updir = File::Spec->updir; +@ISA = ('Exporter'); +@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); + =head1 NAME ExtUtils::Install - install files from here to there @@ -37,7 +37,6 @@ ExtUtils::Install - install files from here to there pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); - =head1 DESCRIPTION Handles the installing and uninstalling of perl modules, scripts, man @@ -47,6 +46,233 @@ Both install() and uninstall() are specific to the way ExtUtils::MakeMaker handles the installation and deinstallation of perl modules. They are not designed as general purpose tools. +On some operating systems such as Win32 installation may not be possible +until after a reboot has occured. This can have varying consequences: +removing an old DLL does not impact programs using the new one, but if +a new DLL cannot be installed properly until reboot then anything +depending on it must wait. The package variable + + $ExtUtils::Install::MUST_REBOOT + +is used to store this status. + +If this variable is true then such an operation has occured and +anything depending on this module cannot proceed until a reboot +has occured. + +If this value is defined but false then such an operation has +ocurred, but should not impact later operations. + +=begin _private + +=item _chmod($$;$) + +Wrapper to chmod() for debugging and error trapping. + +=item _warnonce(@) + +Warns about something only once. + +=item _choke(@) + +Dies with a special message. + +=end _private + +=cut + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacPerl = $^O eq 'MacOS'; +my $Is_Win32 = $^O eq 'MSWin32'; +my $Is_cygwin = $^O eq 'cygwin'; +my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin); + +# *note* CanMoveAtBoot is only incidentally the same condition as below +# this needs not hold true in the future. +my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin) + ? (eval {require Win32API::File; 1} || 0) + : 0; + + +my $Inc_uninstall_warn_handler; + +# install relative to here + +my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; + +my $Curdir = File::Spec->curdir; +my $Updir = File::Spec->updir; + +sub _estr(@) { + return join "\n",'!' x 72,@_,'!' x 72,''; +} + +{my %warned; +sub _warnonce(@) { + my $first=shift; + my $msg=_estr "WARNING: $first",@_; + warn $msg unless $warned{$msg}++; +}} + +sub _choke(@) { + my $first=shift; + my $msg=_estr "ERROR: $first",@_; + Carp::croak($msg); +} + + +sub _chmod($$;$) { + my ( $mode, $item, $verbose )=@_; + $verbose ||= 0; + if (chmod $mode, $item) { + print "chmod($mode, $item)\n" if $verbose > 1; + } else { + my $err="$!"; + _warnonce "WARNING: Failed chmod($mode, $item): $err\n" + if -e $item; + } +} + +=begin _private + +=item _move_file_at_boot( $file, $target, $moan ) + +OS-Specific, Win32/Cygwin + +Schedules a file to be moved/renamed/deleted at next boot. +$file should be a filespec of an existing file +$target should be a ref to an array if the file is to be deleted +otherwise it should be a filespec for a rename. If the file is existing +it will be replaced. + +Sets $MUST_REBOOT to 0 to indicate a deletion operation has occured +and sets it to 1 to indicate that a move operation has been requested. + +returns 1 on success, on failure if $moan is false errors are fatal. +If $moan is true then returns 0 on error and warns instead of dies. + +=end _private + +=cut + + + +sub _move_file_at_boot { #XXX OS-SPECIFIC + my ( $file, $target, $moan )= @_; + Carp::confess("Panic: Can't _move_file_at_boot on this platform!") + unless $CanMoveAtBoot; + + my $descr= ref $target + ? "'$file' for deletion" + : "'$file' for installation as '$target'"; + + if ( ! $Has_Win32API_File ) { + + my @msg=( + "Cannot schedule $descr at reboot.", + "Try installing Win32API::File to allow operations on locked files", + "to be scheduled during reboot. Or try to perform the operation by", + "hand yourself. (You may need to close other perl processes first)" + ); + if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } + return 0; + } + my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); + $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() + unless ref $target; + + _chmod( 0666, $file ); + _chmod( 0666, $target ) unless ref $target; + + if (Win32API::File::MoveFileEx( $file, $target, $opts )) { + $MUST_REBOOT ||= ref $target ? 0 : 1; + return 1; + } else { + my @msg=( + "MoveFileEx $descr at reboot failed: $^E", + "You may try to perform the operation by hand yourself. ", + "(You may need to close other perl processes first).", + ); + if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } + } + return 0; +} + + +=begin _private + +=item _unlink_or_rename( $file, $tryhard, $installing ) + +OS-Specific, Win32/Cygwin + +Tries to get a file out of the way by unlinking it or renaming it. On +some OS'es (Win32 based) DLL files can end up locked such that they can +be renamed but not deleted. Likewise sometimes a file can be locked such +that it cant even be renamed or changed except at reboot. To handle +these cases this routine finds a tempfile name that it can either rename +the file out of the way or use as a proxy for the install so that the +rename can happen later (at reboot). + + $file : the file to remove. + $tryhard : should advanced tricks be used for deletion + $installing : we are not merely deleting but we want to overwrite + +When $tryhard is not true if the unlink fails its fatal. When $tryhard +is true then the file is attempted to be renamed. The renamed file is +then scheduled for deletion. If the rename fails then $installing +governs what happens. If it is false the failure is fatal. If it is true +then an attempt is made to schedule installation at boot using a +temporary file to hold the new file. If this fails then a fatal error is +thrown, if it succeeds it returns the temporary file name (which will be +a derivative of the original in the same directory) so that the caller can +use it to install under. In all other cases of success returns $file. +On failure throws a fatal error. + +=end _private + +=cut + + + +sub _unlink_or_rename { #XXX OS-SPECIFIC + my ( $file, $tryhard, $installing )= @_; + + _chmod( 0666, $file ); + unlink $file + and return $file; + my $error="$!"; + + _choke("Cannot unlink '$file': $!") + unless $CanMoveAtBoot && $tryhard; + + my $tmp= "AAA"; + ++$tmp while -e "$file.$tmp"; + $tmp= "$file.$tmp"; + + warn "WARNING: Unable to unlink '$file': $error\n", + "Going to try to rename it to '$tmp'.\n"; + + if ( rename $file, $tmp ) { + warn "Rename succesful. Scheduling '$tmp'\nfor deletion at reboot.\n"; + # when $installing we can set $moan to true. + # IOW, if we cant delete the renamed file at reboot its + # not the end of the world. The other cases are more serious + # and need to be fatal. + _move_file_at_boot( $tmp, [], $installing ); + return $file; + } elsif ( $installing ) { + _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor". + " installation as '$file' at reboot.\n"); + _move_file_at_boot( $tmp, $file ); + return $tmp; + } else { + _choke("Rename failed:$!", "Cannot procede."); + } + +} + + + =head2 Functions =over 4 @@ -54,7 +280,7 @@ perl modules. They are not designed as general purpose tools. =item B<install> install(\%from_to); - install(\%from_to, $verbose, $dont_execute, $uninstall_shadows); + install(\%from_to, $verbose, $dont_execute, $uninstall_shadows, $skip); Copies each directory tree of %from_to to its corresponding value preserving timestamps and permissions. @@ -68,7 +294,8 @@ on AFS it is quite likely that people are installing to a different directory than the one where the files later appear. If $verbose is true, will print out each file removed. Default is -false. This is "make install VERBINST=1" +false. This is "make install VERBINST=1". $verbose values going +up to 5 show increasingly more diagnostics output. If $dont_execute is true it will only print what it was going to do without actually doing it. Default is false. @@ -76,173 +303,493 @@ without actually doing it. Default is false. If $uninstall_shadows is true any differing versions throughout @INC will be uninstalled. This is "make install UNINST=1" +As of 1.37_02 install() supports the use of a list of patterns to filter +out files that shouldn't be installed. If $skip is omitted or undefined +then install will try to read the list from INSTALL.SKIP in the CWD. +This file is a list of regular expressions and is just like the +MANIFEST.SKIP file used by L<ExtUtils::Manifest>. + +A default site INSTALL.SKIP may be provided by setting then environment +variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there +isn't a distribution specific INSTALL.SKIP. If the environment variable +EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be +performed. + +If $skip is undefined then the skip file will be autodetected and used if it +is found. If $skip is a reference to an array then it is assumed +the array contains the list of patterns, if $skip is a true non reference it is +assumed to be the filename holding the list of patterns, any other value of +$skip is taken to mean that no install filtering should occur. + + =cut -sub install { - my($from_to,$verbose,$nonono,$inc_uninstall) = @_; +=begin _private + +=item _get_install_skip + +Handles loading the INSTALL.SKIP file. Returns an array of patterns to use. + +=cut + + + +sub _get_install_skip { + my ( $skip, $verbose )= @_; + if ($ENV{EU_INSTALL_IGNORE_SKIP}) { + print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" + if $verbose>2; + return []; + } + if ( ! defined $skip ) { + print "Looking for install skip list\n" + if $verbose>2; + for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) { + next unless $file; + print "\tChecking for $file\n" + if $verbose>2; + if (-e $file) { + $skip= $file; + last; + } + } + } + if ($skip && !ref $skip) { + print "Reading skip patterns from '$skip'.\n" + if $verbose; + if (open my $fh,$skip ) { + my @patterns; + while (<$fh>) { + chomp; + next if /^\s*(?:#|$)/; + print "\tSkip pattern: $_\n" if $verbose>3; + push @patterns, $_; + } + $skip= \@patterns; + } else { + warn "Can't read skip file:'$skip':$!\n"; + $skip=[]; + } + } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) { + print "Using array for skip list\n" + if $verbose>2; + } elsif ($verbose) { + print "No skip list found.\n" + if $verbose>1; + $skip= []; + } + warn "Got @{[0+@$skip]} skip patterns.\n" + if $verbose>3; + return $skip +} + +=item _have_write_access + +Abstract a -w check that tries to use POSIX::access() if possible. + +=cut + + +{ + my $has_posix; + sub _have_write_access { + my $dir=shift; + if (!defined $has_posix) { + $has_posix=eval "local $^W; require POSIX; 1" || 0; + } + if ($has_posix) { + return POSIX::access($dir, POSIX::W_OK()); + } else { + return -w $dir; + } + } +} + + +=item _can_write_dir(C<$dir>) + +Checks whether a given directory is writable, taking account +the possibility that the directory might not exist and would have to +be created first. + +Returns a list, containing: C<($writable, $determined_by, @create)> + +C<$writable> says whether whether the directory is (hypothetically) writable + +C<$determined_by> is the directory the status was determined from. It will be +either the C<$dir>, or one of its parents. + +C<@create> is a list of directories that would probably have to be created +to make the requested directory. It may not actually be correct on +relative paths with C<..> in them. But for our purposes it should work ok + +=cut + + +sub _can_write_dir { + my $dir=shift; + return + unless defined $dir and length $dir; + + my ($vol, $dirs, $file) = File::Spec->splitpath(File::Spec->rel2abs($dir),1); + my @dirs = File::Spec->splitdir($dirs); + my $path=''; + my @make; + while (@dirs) { + $dir = File::Spec->catdir($vol,@dirs); + next if ( $dir eq $path ); + if ( ! -e $dir ) { + unshift @make,$dir; + next; + } + if ( _have_write_access($dir) ) { + return 1,$dir,@make + } else { + return 0,$dir,@make + } + } continue { + pop @dirs; + } + return 0; +} + +=item _mkpath($dir,$show,$mode,$verbose,$fake) + +Wrapper around File::Path::mkpath() to handle errors. + +If $verbose is true and >1 then additional diagnostics will be produced, also +this will force $show to true. + +If $fake is true then the directory will not be created but a check will be +made to see whether it would be possible to write to the directory, or that +it would be possible to create the directory. + +If $fake is not true dies if the directory can not be created or is not +writable. + +=cut + +sub _mkpath { + my ($dir,$show,$mode,$verbose,$fake)=@_; + if ( $verbose && $verbose > 1 && ! -d $dir) { + $show= 1; + printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; + } + if (!$fake) { + if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) { + _choke("Can't create '$dir'","$@"); + } + + } + my ($can,$root,@make)=_can_write_dir($dir); + if (!$can) { + my @msg=( + "Can't create '$dir'", + $root ? "Do not have write permissions on '$root'" + : "Unknown Error" + ); + if ($fake) { + _warnonce @msg; + } else { + _choke @msg; + } + } elsif ($show and $fake) { + print "$_\n" for @make; + } +} + +=item _copy($from,$to,$verbose,$fake) + +Wrapper around File::Copy::copy to handle errors. + +If $verbose is true and >1 then additional dignostics will be emitted. + +If $fake is true then the copy will not actually occur. + +Dies if the copy fails. + +=cut + + +sub _copy { + my ( $from, $to, $verbose, $nonono)=@_; + if ($verbose && $verbose>1) { + printf "copy(%s,%s)\n", $from, $to; + } + if (!$nonono) { + File::Copy::copy($from,$to) + or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" ); + } +} + +=item _chdir($from) + +Wrapper around chdir to catch errors. + +If not called in void context returns the cwd from before the chdir. + +dies on error. + +=cut + +sub _chdir { + my ($dir)= @_; + my $ret; + if (defined wantarray) { + $ret= cwd; + } + chdir $dir + or _choke("Couldn't chdir to '$dir': $!"); + return $ret; +} + +=end _private + +=cut + +sub install { #XXX OS-SPECIFIC + my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_; $verbose ||= 0; $nonono ||= 0; - use Cwd qw(cwd); - use ExtUtils::Packlist; - use File::Basename qw(dirname); - use File::Copy qw(copy); - use File::Find qw(find); - use File::Path qw(mkpath); - use File::Compare qw(compare); + $skip= _get_install_skip($skip,$verbose); my(%from_to) = %$from_to; - my(%pack, $dir, $warn_permissions); + my(%pack, $dir, %warned); my($packlist) = ExtUtils::Packlist->new(); - # -w doesn't work reliably on FAT dirs - $warn_permissions++ if $^O eq 'MSWin32'; + local(*DIR); for (qw/read write/) { - $pack{$_}=$from_to{$_}; - delete $from_to{$_}; - } - my($source_dir_or_file); - foreach $source_dir_or_file (sort keys %from_to) { - #Check if there are files, and if yes, look if the corresponding - #target directory is writable for us - opendir DIR, $source_dir_or_file or next; - for (readdir DIR) { - next if $_ eq $Curdir || $_ eq $Updir || $_ eq ".exists"; - my $targetdir = install_rooted_dir($from_to{$source_dir_or_file}); - mkpath($targetdir) unless $nonono; - if (!$nonono && !-w $targetdir) { - warn "Warning: You do not have permissions to " . - "install into $from_to{$source_dir_or_file}" - unless $warn_permissions++; - } - } - closedir DIR; + $pack{$_}=$from_to{$_}; + delete $from_to{$_}; } my $tmpfile = install_rooted_file($pack{"read"}); $packlist->read($tmpfile) if (-f $tmpfile); my $cwd = cwd(); - + my @found_files; + my %check_dirs; + MOD_INSTALL: foreach my $source (sort keys %from_to) { - #copy the tree to the target directory without altering - #timestamp and permission and remember for the .packlist - #file. The packlist file contains the absolute paths of the - #install locations. AFS users may call this a bug. We'll have - #to reconsider how to add the means to satisfy AFS users also. + #copy the tree to the target directory without altering + #timestamp and permission and remember for the .packlist + #file. The packlist file contains the absolute paths of the + #install locations. AFS users may call this a bug. We'll have + #to reconsider how to add the means to satisfy AFS users also. - #October 1997: we want to install .pm files into archlib if - #there are any files in arch. So we depend on having ./blib/arch - #hardcoded here. + #October 1997: we want to install .pm files into archlib if + #there are any files in arch. So we depend on having ./blib/arch + #hardcoded here. - my $targetroot = install_rooted_dir($from_to{$source}); + my $targetroot = install_rooted_dir($from_to{$source}); my $blib_lib = File::Spec->catdir('blib', 'lib'); my $blib_arch = File::Spec->catdir('blib', 'arch'); - if ($source eq $blib_lib and - exists $from_to{$blib_arch} and - directory_not_empty($blib_arch)) { - $targetroot = install_rooted_dir($from_to{$blib_arch}); + if ($source eq $blib_lib and + exists $from_to{$blib_arch} and + directory_not_empty($blib_arch) + ){ + $targetroot = install_rooted_dir($from_to{$blib_arch}); print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; - } + } - chdir $source or next; - find(sub { - my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; - return unless -f _; + next unless -d $source; + _chdir($source); + # 5.5.3's File::Find missing no_chdir option + # XXX OS-SPECIFIC + # File::Find seems to always be Unixy except on MacPerl :( + my $current_directory= $Is_MacPerl ? $Curdir : '.'; + find(sub { + my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; + return if !-f _; my $origfile = $_; - return if $origfile eq ".exists"; - my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); - my $targetfile = File::Spec->catfile($targetdir, $origfile); + + return if $origfile eq ".exists"; + my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); + my $targetfile = File::Spec->catfile($targetdir, $origfile); my $sourcedir = File::Spec->catdir($source, $File::Find::dir); my $sourcefile = File::Spec->catfile($sourcedir, $origfile); - my $save_cwd = cwd; - chdir $cwd; # in case the target is relative - # 5.5.3's File::Find missing no_chdir option. - - my $diff = 0; - if ( -f $targetfile && -s _ == $size) { - # We have a good chance, we can skip this one - $diff = compare($sourcefile, $targetfile); - } else { - print "$sourcefile differs\n" if $verbose>1; - $diff++; - } - - if ($diff){ - if (-f $targetfile){ - forceunlink($targetfile) unless $nonono; - } else { - mkpath($targetdir,0,0755) unless $nonono; - print "mkpath($targetdir,0,0755)\n" if $verbose>1; - } - copy($sourcefile, $targetfile) unless $nonono; - print "Installing $targetfile\n"; - utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1; - print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; - $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - chmod $mode, $targetfile; - print "chmod($mode, $targetfile)\n" if $verbose>1; - } else { - print "Skipping $targetfile (unchanged)\n" if $verbose; - } - - if (defined $inc_uninstall) { - inc_uninstall($sourcefile,$File::Find::dir,$verbose, - $inc_uninstall ? 0 : 1); - } - - # Record the full pathname. - $packlist->{$targetfile}++; - - # File::Find can get confused if you chdir in here. - chdir $save_cwd; + for my $pat (@$skip) { + if ( $sourcefile=~/$pat/ ) { + print "Skipping $targetfile (filtered)\n" + if $verbose>1; + return; + } + } + # we have to do this for back compat with old File::Finds + # and because the target is relative + my $save_cwd = _chdir($cwd); + my $diff = 0; + if ( -f $targetfile && -s _ == $size) { + # We have a good chance, we can skip this one + $diff = compare($sourcefile, $targetfile); + } else { + $diff++; + } + $check_dirs{$targetdir}++ + unless -w $targetfile; + + push @found_files, + [ $diff, $File::Find::dir, $origfile, + $mode, $size, $atime, $mtime, + $targetdir, $targetfile, $sourcedir, $sourcefile, + + ]; + #restore the original directory we were in when File::Find + #called us so that it doesnt get horribly confused. + _chdir($save_cwd); + }, $current_directory ); + _chdir($cwd); + } + + foreach my $targetdir (sort keys %check_dirs) { + _mkpath( $targetdir, 0, 0755, $verbose, $nonono ); + } + foreach my $found (@found_files) { + my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, + $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found; + + my $realtarget= $targetfile; + if ($diff) { + if (-f $targetfile) { + print "_unlink_or_rename($targetfile)\n" if $verbose>1; + $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) + unless $nonono; + } elsif ( ! -d $targetdir ) { + _mkpath( $targetdir, 0, 0755, $verbose, $nonono ); + } + print "Installing $targetfile\n"; + _copy( $sourcefile, $targetfile, $verbose, $nonono, ); + #XXX OS-SPECIFIC + print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; + utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1; + + + $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + $mode = $mode | 0222 + if $realtarget ne $targetfile; + _chmod( $mode, $targetfile, $verbose ); + } else { + print "Skipping $targetfile (unchanged)\n" if $verbose; + } - # File::Find seems to always be Unixy except on MacPerl :( - }, $Is_MacPerl ? $Curdir : '.' ); - chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); + if ( $inc_uninstall ) { + inc_uninstall($sourcefile,$ffd, $verbose, + $nonono, + $realtarget ne $targetfile ? $realtarget : ""); + } + + # Record the full pathname. + $packlist->{$targetfile}++; } + if ($pack{'write'}) { - $dir = install_rooted_dir(dirname($pack{'write'})); - mkpath($dir,0,0755) unless $nonono; - print "Writing $pack{'write'}\n"; - $packlist->write(install_rooted_file($pack{'write'})) unless $nonono; + $dir = install_rooted_dir(dirname($pack{'write'})); + _mkpath( $dir, 0, 0755, $verbose, $nonono ); + print "Writing $pack{'write'}\n"; + $packlist->write(install_rooted_file($pack{'write'})) unless $nonono; + } + + _do_cleanup($verbose); +} + +=begin _private + +=item _do_cleanup + +Standardize finish event for after another instruction has occured. +Handles converting $MUST_REBOOT to a die for instance. + +=end _private + +=cut + +sub _do_cleanup { + my ($verbose) = @_; + if ($MUST_REBOOT) { + die _estr "Operation not completed! ", + "You must reboot to complete the installation.", + "Sorry."; + } elsif (defined $MUST_REBOOT & $verbose) { + warn _estr "Installation will be completed at the next reboot.\n", + "However it is not necessary to reboot immediately.\n"; } } +=begin _undocumented + +=item install_rooted_file( $file ) + +Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT +is defined. + +=item install_rooted_dir( $dir ) + +Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT +is defined. + +=end _undocumented + +=cut + + sub install_rooted_file { if (defined $INSTALL_ROOT) { - File::Spec->catfile($INSTALL_ROOT, $_[0]); + File::Spec->catfile($INSTALL_ROOT, $_[0]); } else { - $_[0]; + $_[0]; } } sub install_rooted_dir { if (defined $INSTALL_ROOT) { - File::Spec->catdir($INSTALL_ROOT, $_[0]); + File::Spec->catdir($INSTALL_ROOT, $_[0]); } else { - $_[0]; + $_[0]; } } +=begin _undocumented + +=item forceunlink( $file, $tryhard ) + +Tries to delete a file. If $tryhard is true then we will use whatever +devious tricks we can to delete the file. Currently this only applies to +Win32 in that it will try to use Win32API::File to schedule a delete at +reboot. A wrapper for _unlink_or_rename(). + +=end _undocumented + +=cut + sub forceunlink { - chmod 0666, $_[0]; - unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!") + my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC + _unlink_or_rename( $file, $tryhard ); } +=begin _undocumented + +=item directory_not_empty( $dir ) + +Returns 1 if there is an .exists file somewhere in a directory tree. +Returns 0 if there is not. + +=end _undocumented + +=cut sub directory_not_empty ($) { my($dir) = @_; my $files = 0; find(sub { - return if $_ eq ".exists"; - if (-f) { - $File::Find::prune++; - $files = 1; - } + return if $_ eq ".exists"; + if (-f) { + $File::Find::prune++; + $files = 1; + } }, $dir); return $files; } @@ -270,7 +817,7 @@ Consider its use discouraged. =cut sub install_default { - @_ < 2 or die "install_default should be called with 0 or 1 argument"; + @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument"); my $FULLEXT = @_ ? shift : $ARGV[0]; defined $FULLEXT or die "Do not know to where to write install log"; my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib"); @@ -280,17 +827,17 @@ sub install_default { my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1'); my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3'); install({ - read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", - write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", - $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? - $Config{installsitearch} : - $Config{installsitelib}, - $INST_ARCHLIB => $Config{installsitearch}, - $INST_BIN => $Config{installbin} , - $INST_SCRIPT => $Config{installscript}, - $INST_MAN1DIR => $Config{installman1dir}, - $INST_MAN3DIR => $Config{installman3dir}, - },1,0,0); + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? + $Config{installsitearch} : + $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + },1,0,0); } @@ -310,72 +857,97 @@ without actually doing it. Default is false. =cut sub uninstall { - use ExtUtils::Packlist; my($fil,$verbose,$nonono) = @_; $verbose ||= 0; $nonono ||= 0; - die "no packlist file found: $fil" unless -f $fil; + die _estr "ERROR: no packlist file found: '$fil'" + unless -f $fil; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first my ($packlist) = ExtUtils::Packlist->new($fil); foreach (sort(keys(%$packlist))) { - chomp; - print "unlink $_\n" if $verbose; - forceunlink($_) unless $nonono; + chomp; + print "unlink $_\n" if $verbose; + forceunlink($_,'tryhard') unless $nonono; } print "unlink $fil\n" if $verbose; - forceunlink($fil) unless $nonono; + forceunlink($fil, 'tryhard') unless $nonono; + _do_cleanup($verbose); } +=begin _undocumented + +=item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore) + +Remove shadowed files. If $ignore is true then it is assumed to hold +a filename to ignore. This is used to prevent spurious warnings from +occuring when doing an install at reboot. + +=end _undocumented + +=cut + sub inc_uninstall { - my($filepath,$libdir,$verbose,$nonono) = @_; + my($filepath,$libdir,$verbose,$nonono,$ignore) = @_; my($dir); + $ignore||=""; my $file = (File::Spec->splitpath($filepath))[2]; my %seen_dir = (); - my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} + my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp - privlibexp - sitearchexp - sitelibexp)}) { - next if $dir eq $Curdir; - next if $seen_dir{$dir}++; - my($targetfile) = File::Spec->catfile($dir,$libdir,$file); - next unless -f $targetfile; - - # The reason why we compare file's contents is, that we cannot - # know, which is the file we just installed (AFS). So we leave - # an identical file in place - my $diff = 0; - if ( -f $targetfile && -s _ == -s $filepath) { - # We have a good chance, we can skip this one - $diff = compare($filepath,$targetfile); - } else { - print "#$file and $targetfile differ\n" if $verbose>1; - $diff++; - } - - next unless $diff; - if ($nonono) { - if ($verbose) { - $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn; - $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. - $Inc_uninstall_warn_handler->add( + privlibexp + sitearchexp + sitelibexp)}) { + my $canonpath = File::Spec->canonpath($dir); + next if $canonpath eq $Curdir; + next if $seen_dir{$canonpath}++; + my $targetfile = File::Spec->catfile($canonpath,$libdir,$file); + next unless -f $targetfile; + + # The reason why we compare file's contents is, that we cannot + # know, which is the file we just installed (AFS). So we leave + # an identical file in place + my $diff = 0; + if ( -f $targetfile && -s _ == -s $filepath) { + # We have a good chance, we can skip this one + $diff = compare($filepath,$targetfile); + } else { + $diff++; + } + print "#$file and $targetfile differ\n" if $diff && $verbose > 1; + + next if !$diff or $targetfile eq $ignore; + if ($nonono) { + if ($verbose) { + $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new(); + $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. + $Inc_uninstall_warn_handler->add( File::Spec->catfile($libdir, $file), $targetfile ); - } - # if not verbose, we just say nothing - } else { - print "Unlinking $targetfile (shadowing?)\n"; - forceunlink($targetfile); - } + } + # if not verbose, we just say nothing + } else { + print "Unlinking $targetfile (shadowing?)\n" if $verbose; + forceunlink($targetfile,'tryhard'); + } } } +=begin _undocumented + +=item run_filter($cmd,$src,$dest) + +Filter $src using $cmd into $dest. + +=end _undocumented + +=cut + sub run_filter { my ($cmd, $src, $dest) = @_; local(*CMD, *SRC); @@ -384,7 +956,7 @@ sub run_filter { my $buf; my $sz = 1024; while (my $len = sysread(SRC, $buf, $sz)) { - syswrite(CMD, $buf, $len); + syswrite(CMD, $buf, $len); } close SRC; close CMD or die "Filter command '$cmd' failed for $src"; @@ -412,48 +984,43 @@ be prepended as a directory to each installed file (and directory). sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; - use File::Basename qw(dirname); - use File::Copy qw(copy); - use File::Path qw(mkpath); - use File::Compare qw(compare); - use AutoSplit; - - mkpath($autodir,0,0755); + _mkpath($autodir,0,0755); while(my($from, $to) = each %$fromto) { - if( -f $to && -s $from == -s $to && -M $to < -M $from ) { + if( -f $to && -s $from == -s $to && -M $to < -M $from ) { print "Skip $to (unchanged)\n"; next; } - # When a pm_filter is defined, we need to pre-process the source first - # to determine whether it has changed or not. Therefore, only perform - # the comparison check when there's no filter to be ran. - # -- RAM, 03/01/2001 + # When a pm_filter is defined, we need to pre-process the source first + # to determine whether it has changed or not. Therefore, only perform + # the comparison check when there's no filter to be ran. + # -- RAM, 03/01/2001 - my $need_filtering = defined $pm_filter && length $pm_filter && + my $need_filtering = defined $pm_filter && length $pm_filter && $from =~ /\.pm$/; - if (!$need_filtering && 0 == compare($from,$to)) { - print "Skip $to (unchanged)\n"; - next; - } - if (-f $to){ - forceunlink($to); - } else { - mkpath(dirname($to),0,0755); - } - if ($need_filtering) { - run_filter($pm_filter, $from, $to); - print "$pm_filter <$from >$to\n"; - } else { - copy($from,$to); - print "cp $from $to\n"; - } - my($mode,$atime,$mtime) = (stat $from)[2,8,9]; - utime($atime,$mtime+$Is_VMS,$to); - chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); - next unless $from =~ /\.pm$/; - _autosplit($to,$autodir); + if (!$need_filtering && 0 == compare($from,$to)) { + print "Skip $to (unchanged)\n"; + next; + } + if (-f $to){ + # we wont try hard here. its too likely to mess things up. + forceunlink($to); + } else { + _mkpath(dirname($to),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $from, $to); + print "$pm_filter <$from >$to\n"; + } else { + _copy( $from, $to ); + print "cp $from $to\n"; + } + my($mode,$atime,$mtime) = (stat $from)[2,8,9]; + utime($atime,$mtime+$Is_VMS,$to); + _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); + next unless $from =~ /\.pm$/; + _autosplit($to,$autodir); } } @@ -470,7 +1037,7 @@ locking (ie. Windows). So we wrap it and close the filehandle. =cut -sub _autosplit { +sub _autosplit { #XXX OS-SPECIFIC my $retval = autosplit(@_); close *AutoSplit::IN if defined *AutoSplit::IN{IO}; @@ -500,12 +1067,44 @@ sub DESTROY { } } $plural = $i>1 ? "all those files" : "this file"; - print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; + my $inst = (_invokant() eq 'ExtUtils::MakeMaker') + ? ( $Config::Config{make} || 'make' ).' install UNINST=1' + : './Build install uninst=1'; + print "## Running '$inst' will unlink $plural for you.\n"; } } -=back +=begin _private +=item _invokant + +Does a heuristic on the stack to see who called us for more intelligent +error messages. Currently assumes we will be called only by Module::Build +or by ExtUtils::MakeMaker. + +=end _private + +=cut + +sub _invokant { + my @stack; + my $frame = 0; + while (my $file = (caller($frame++))[1]) { + push @stack, (File::Spec->splitpath($file))[2]; + } + + my $builder; + my $top = pop @stack; + if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) { + $builder = 'Module::Build'; + } else { + $builder = 'ExtUtils::MakeMaker'; + } + return $builder; +} + + +=back =head1 ENVIRONMENT @@ -515,25 +1114,29 @@ sub DESTROY { Will be prepended to each install path. +=item B<EU_INSTALL_IGNORE_SKIP> + +Will prevent the automatic use of INSTALL.SKIP as the install skip file. + +=item B<EU_INSTALL_SITE_SKIPFILE> + +If there is no INSTALL.SKIP file in the make directory then this value +can be used to provide a default. + =back =head1 AUTHOR Original author lost in the mists of time. Probably the same as Makemaker. -Currently maintained by Michael G Schwern C<schwern@pobox.com> - -Send patches and ideas to C<makemaker@perl.org>. +Production release currently maintained by demerphq C<yves at cpan.org> Send bug reports via http://rt.cpan.org/. Please send your generated Makefile along with your report. -For more up-to-date information, see L<http://www.makemaker.org>. - - =head1 LICENSE -This program is free software; you can redistribute it and/or +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html> diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm index 4b098083d98..2991149fc7c 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm @@ -1,7 +1,9 @@ package ExtUtils::Liblist; -use vars qw($VERSION); -$VERSION = '1.01'; +use strict; + +use vars qw($VERSION @ISA); +$VERSION = '6.42'; use File::Spec; require ExtUtils::Liblist::Kid; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/META.yml b/gnu/usr.bin/perl/lib/ExtUtils/META.yml deleted file mode 100644 index 8ec3ced6582..00000000000 --- a/gnu/usr.bin/perl/lib/ExtUtils/META.yml +++ /dev/null @@ -1,14 +0,0 @@ -# http://module-build.sourceforge.net/META-spec.html -#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# -name: ExtUtils-MakeMaker -version: 6.28 -version_from: lib/ExtUtils/MakeMaker.pm -installdirs: perl -requires: - DirHandle: 0 - File::Basename: 0 - File::Spec: 0.8 - Pod::Man: 0 - -distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.28 diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Any.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Any.pm index e168bb7597e..3b6ff53ac19 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Any.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Any.pm @@ -2,8 +2,9 @@ package ExtUtils::MM_Any; use strict; use vars qw($VERSION @ISA); -$VERSION = '0.13'; +$VERSION = '6.42'; +use Carp; use File::Spec; BEGIN { @ISA = qw(File::Spec); } @@ -235,6 +236,24 @@ sub wraplist { } +=head3 maketext_filter + + my $filter_make_text = $mm->maketext_filter($make_text); + +The text of the Makefile is run through this method before writing to +disk. It allows systems a chance to make portability fixes to the +Makefile. + +By default it does nothing. + +This method is protected and not intended to be called outside of +MakeMaker. + +=cut + +sub maketext_filter { return $_[1] } + + =head3 cd I<Abstract> my $subdir_cmd = $MM->cd($subdir, @cmds); @@ -324,7 +343,28 @@ this is the max size of a shell command line. $self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes. +=head3 make + + my $make = $MM->make; + +Returns the make variant we're generating the Makefile for. This attempts +to do some normalization on the information from %Config or the user. +=cut + +sub make { + my $self = shift; + + my $make = lc $self->{MAKE}; + + # Truncate anything like foomake6 to just foomake. + $make =~ s/^(\w+make).*/$1/; + + # Turn gnumake into gmake. + $make =~ s/^gnu/g/; + + return $make; +} =head2 Targets @@ -626,7 +666,7 @@ confused or something gets snuck in before the real 'all' target. sub makemakerdflt_target { return <<'MAKE_FRAG'; -makemakerdflt: all +makemakerdflt : all $(NOECHO) $(NOOP) MAKE_FRAG @@ -654,10 +694,6 @@ sub manifypods_target { $dependencies .= " \\\n\t$name"; } - foreach my $name (keys %{$self->{MAN3PODS}}) { - $dependencies .= " \\\n\t$name" - } - my $manify = <<END; manifypods : pure_all $dependencies END @@ -686,10 +722,7 @@ Generate the metafile target. Writes the file META.yml YAML encoded meta-data about the module in the distdir. The format follows Module::Build's as closely as -possible. Additionally, we include: - - version_from - installdirs +possible. =cut @@ -697,29 +730,51 @@ sub metafile_target { my $self = shift; return <<'MAKE_FRAG' if $self->{NO_META}; -metafile: +metafile : $(NOECHO) $(NOOP) MAKE_FRAG my $prereq_pm = ''; foreach my $mod ( sort { lc $a cmp lc $b } keys %{$self->{PREREQ_PM}} ) { my $ver = $self->{PREREQ_PM}{$mod}; - $prereq_pm .= sprintf " %-30s %s\n", "$mod:", $ver; + $prereq_pm .= sprintf "\n %-30s %s", "$mod:", $ver; } - my $meta = <<YAML; -# http://module-build.sourceforge.net/META-spec.html -#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# -name: $self->{DISTNAME} -version: $self->{VERSION} -version_from: $self->{VERSION_FROM} -installdirs: $self->{INSTALLDIRS} -requires: -$prereq_pm -distribution_type: module -generated_by: ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION + my $author_value = defined $self->{AUTHOR} + ? "\n - $self->{AUTHOR}" + : undef; + + # Use a list to preserve order. + my @meta_to_mm = ( + name => $self->{DISTNAME}, + version => $self->{VERSION}, + abstract => $self->{ABSTRACT}, + license => $self->{LICENSE}, + author => $author_value, + generated_by => + "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", + distribution_type => $self->{PM} ? 'module' : 'script', + ); + + my $meta = "--- #YAML:1.0\n"; + + while( @meta_to_mm ) { + my($key, $val) = splice @meta_to_mm, 0, 2; + + $val = '~' unless defined $val; + + $meta .= sprintf "%-20s %s\n", "$key:", $val; + }; + + $meta .= <<"YAML"; +requires: $prereq_pm +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 YAML + $meta .= $self->{EXTRA_META} if $self->{EXTRA_META}; + my @write_meta = $self->echo($meta, 'META_new.yml'); return sprintf <<'MAKE_FRAG', join("\n\t", @write_meta); @@ -939,6 +994,28 @@ MAKE_FRAG Methods which help initialize the MakeMaker object and macros. +=head3 init_ABSTRACT + + $mm->init_ABSTRACT + +=cut + +sub init_ABSTRACT { + my $self = shift; + + if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) { + warn "Both ABSTRACT_FROM and ABSTRACT are set. ". + "Ignoring ABSTRACT_FROM.\n"; + return; + } + + if ($self->{ABSTRACT_FROM}){ + $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or + carp "WARNING: Setting ABSTRACT via file ". + "'$self->{ABSTRACT_FROM}' failed\n"; + } +} + =head3 init_INST $mm->init_INST; @@ -1001,12 +1078,12 @@ INSTALLDIRS) and *PREFIX. sub init_INSTALL { my($self) = shift; - if( $self->{ARGS}{INSTALLBASE} and $self->{ARGS}{PREFIX} ) { - die "Only one of PREFIX or INSTALLBASE can be given. Not both.\n"; + if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) { + die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n"; } - if( $self->{ARGS}{INSTALLBASE} ) { - $self->init_INSTALL_from_INSTALLBASE; + if( $self->{ARGS}{INSTALL_BASE} ) { + $self->init_INSTALL_from_INSTALL_BASE; } else { $self->init_INSTALL_from_PREFIX; @@ -1046,12 +1123,19 @@ sub init_INSTALL_from_PREFIX { $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)' unless $Config{installsitebin}; + $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)' + unless $Config{installsitescript}; unless( $Config{installvendorbin} ) { $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix} ? $Config{installbin} : ''; } + unless( $Config{installvendorscript} ) { + $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix} + ? $Config{installscript} + : ''; + } my $iprefix = $Config{installprefixexp} || $Config{installprefix} || @@ -1112,6 +1196,12 @@ sub init_INSTALL_from_PREFIX { script => { s => $iprefix, t => 'perl', d => 'bin' }, + vendorscript=> { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitescript => { s => $sprefix, + t => 'site', + d => 'bin' }, ); my %man_layouts = @@ -1219,9 +1309,9 @@ sub init_INSTALL_from_PREFIX { } -=head3 init_from_INSTALLBASE +=head3 init_from_INSTALL_BASE - $mm->init_from_INSTALLBASE + $mm->init_from_INSTALL_BASE =cut @@ -1234,11 +1324,11 @@ my %map = ( ); $map{script} = $map{bin}; -sub init_INSTALL_from_INSTALLBASE { +sub init_INSTALL_from_INSTALL_BASE { my $self = shift; @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} = - '$(INSTALLBASE)'; + '$(INSTALL_BASE)'; my %install; foreach my $thing (keys %map) { @@ -1247,14 +1337,13 @@ sub init_INSTALL_from_INSTALLBASE { my $key = "INSTALL".$dir.$uc_thing; $install{$key} ||= - $self->catdir('$(INSTALLBASE)', @{$map{$thing}}); + $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); } } # Adjust for variable quirks. $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH}; $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB}; - delete @install{qw(INSTALLVENDORSCRIPT INSTALLSITESCRIPT)}; foreach my $key (keys %install) { $self->{$key} ||= $install{$key}; @@ -1306,9 +1395,8 @@ sub init_VERSION { if ($self->{VERSION_FROM}){ $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}); if( $self->{VERSION} eq 'undef' ) { - require Carp; - Carp::carp("WARNING: Setting VERSION via file ". - "'$self->{VERSION_FROM}' failed\n"); + carp("WARNING: Setting VERSION via file ". + "'$self->{VERSION_FROM}' failed\n"); } } @@ -1361,8 +1449,7 @@ Defines at least these macros. MAKEFILE_OLD MAKE_APERL_FILE File used by MAKE_APERL - SHELL Program used to run - shell commands + SHELL Program used to run shell commands ECHO Print text adding a newline on the end RM_F Remove a file @@ -1375,7 +1462,7 @@ Defines at least these macros. file UMASK_NULL Nullify umask - DEV_NULL Supress all command output + DEV_NULL Suppress all command output =head3 init_DIRFILESEP I<Abstract> @@ -1435,7 +1522,19 @@ sub init_platform { } +=head3 init_MAKE + + $mm->init_MAKE +Initialize MAKE from either a MAKE environment variable or $Config{make}. + +=cut + +sub init_MAKE { + my $self = shift; + + $self->{MAKE} ||= $ENV{MAKE} || $Config{make}; +} =head2 Tools @@ -1628,7 +1727,7 @@ sub installvars { return qw(PRIVLIB SITELIB VENDORLIB ARCHLIB SITEARCH VENDORARCH BIN SITEBIN VENDORBIN - SCRIPT + SCRIPT SITESCRIPT VENDORSCRIPT MAN1DIR SITEMAN1DIR VENDORMAN1DIR MAN3DIR SITEMAN3DIR VENDORMAN3DIR ); diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm index 6bfb4a3f0eb..7d14ac701d4 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use ExtUtils::MakeMaker qw(neatvalue); use File::Spec; -$VERSION = '1.05'; +$VERSION = '6.42'; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm index fd1435fdce5..3ae9b2934ef 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm @@ -4,7 +4,6 @@ require 5.005_03; # Maybe further back, dunno use strict; -use Exporter (); use Carp; use ExtUtils::MakeMaker::Config; use File::Basename qw(basename dirname); @@ -14,13 +13,12 @@ use vars qw($VERSION @ISA $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_OSF $Is_IRIX $Is_NetBSD $Is_BSD $Is_SunOS4 $Is_Solaris $Is_SunOS $Is_Interix - $Verbose %pm %Config_Override ); use ExtUtils::MakeMaker qw($Verbose neatvalue); -$VERSION = '1.50'; +$VERSION = '6.42'; require ExtUtils::MM_Any; @ISA = qw(ExtUtils::MM_Any); @@ -37,8 +35,9 @@ BEGIN { $Is_SunOS4 = $^O eq 'sunos'; $Is_Solaris = $^O eq 'solaris'; $Is_SunOS = $Is_SunOS4 || $Is_Solaris; - $Is_BSD = $^O =~ /^(?:free|net|open)bsd$/ or - $^O eq 'bsdos' or $^O eq 'interix'; + $Is_BSD = ($^O =~ /^(?:free|net|open)bsd$/ or + grep( $^O eq $_, qw(bsdos interix dragonfly) ) + ); } BEGIN { @@ -131,37 +130,42 @@ sub c_o { my($self) = shift; return '' unless $self->needs_linking(); my(@m); + + my $command = '$(CCCMD)'; + my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)'; + if (my $cpp = $Config{cpprun}) { my $cpp_cmd = $self->const_cccmd; $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; - push @m, ' + push @m, qq{ .c.i: - '. $cpp_cmd . ' $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c > $*.i -'; + $cpp_cmd $flags \$*.c > \$*.i +}; } - push @m, ' + + push @m, qq{ .c.s: - $(CCCMD) -S $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c -'; - push @m, ' -.c$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c -'; - push @m, ' -.C$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.C -' if !$Is_OS2 and !$Is_Win32 and !$Is_Dos; #Case-specific - push @m, ' -.cpp$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.cpp + $command -S $flags \$*.c -.cxx$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.cxx +.c\$(OBJ_EXT): + $command $flags \$*.c -.cc$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.cc -'; - join "", @m; +.cpp\$(OBJ_EXT): + $command $flags \$*.cpp + +.cxx\$(OBJ_EXT): + $command $flags \$*.cxx + +.cc\$(OBJ_EXT): + $command $flags \$*.cc +}; + + push @m, qq{ +.C\$(OBJ_EXT): + $command \$*.C +} if !$Is_OS2 and !$Is_Win32 and !$Is_Dos; #Case-specific + + return join "", @m; } =item cflags (o) @@ -374,7 +378,7 @@ sub constants { INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR MAN1EXT MAN3EXT - INSTALLDIRS INSTALLBASE DESTDIR PREFIX + INSTALLDIRS INSTALL_BASE DESTDIR PREFIX PERLPREFIX SITEPREFIX VENDORPREFIX ), (map { ("INSTALL".$_, @@ -634,7 +638,7 @@ manifest : $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest veryclean : realclean - $(RM_F) *~ *.orig */*~ */*.orig + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old MAKE_FRAG @@ -928,7 +932,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP). my $libs = '$(LDLOADLIBS)'; - if (($Is_NetBSD || $Is_Interix) && $Config{'useshrplib'}) { + if (($Is_NetBSD || $Is_Interix) && $Config{'useshrplib'} eq 'true') { # Use nothing on static perl platforms, and to the flags needed # to link against the shared libperl library on shared perl # platforms. We peek at lddlflags to see if we need -Wl,-R @@ -1030,7 +1034,10 @@ WARNING print "Executing $abs\n" if ($trace >= 2); my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"}; - # To avoid using the unportable 2>&1 to supress STDERR, + $version_check = "$Config{run} $version_check" + if defined $Config{run} and length $Config{run}; + + # To avoid using the unportable 2>&1 to suppress STDERR, # we close it before running the command. # However, thanks to a thread library bug in many BSDs # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 ) @@ -1044,11 +1051,11 @@ WARNING open STDERR, '>&STDERR_COPY' if $stderr_duped; } - if ($val =~ /^VER_OK/) { + if ($val =~ /^VER_OK/m) { print "Using PERL=$abs\n" if $trace; return $abs; } elsif ($trace >= 2) { - print "Result: '$val'\n"; + print "Result: '$val' ".($? >> 8)."\n"; } } } @@ -1065,95 +1072,104 @@ Inserts the sharpbang or equivalent magic number to a set of @files. =cut -sub fixin { # stolen from the pink Camel book, more or less - my($self, @files) = @_; +sub fixin { # stolen from the pink Camel book, more or less + my ( $self, @files ) = @_; - my($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; + my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; for my $file (@files) { my $file_new = "$file.new"; my $file_bak = "$file.bak"; - local(*FIXIN); - local(*FIXOUT); - open(FIXIN, $file) or croak "Can't process '$file': $!"; - local $/ = "\n"; - chomp(my $line = <FIXIN>); - next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. - # Now figure out the interpreter name. - my($cmd,$arg) = split ' ', $line, 2; - $cmd =~ s!^.*/!!; - - # Now look (in reverse) for interpreter in absolute PATH (unless perl). + local (*FIXIN); + local (*FIXOUT); + open( FIXIN, $file ) or croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp( my $line = <FIXIN> ); + next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + # Now figure out the interpreter name. + my ( $cmd, $arg ) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). my $interpreter; - if ($cmd eq "perl") { - if ($Config{startperl} =~ m,^\#!.*/perl,) { + if ( $cmd eq "perl" ) { + if ( $Config{startperl} =~ m,^\#!.*/perl, ) { $interpreter = $Config{startperl}; $interpreter =~ s,^\#!,,; - } else { + } + else { $interpreter = $Config{perlpath}; } - } else { - my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; - $interpreter = ''; - my($dir); - foreach $dir (@absdirs) { - if ($self->maybe_command($cmd)) { - warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; - $interpreter = $self->catfile($dir,$cmd); - } - } - } - # Figure out how to invoke interpreter on this machine. - - my($shb) = ""; - if ($interpreter) { - print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; - # this is probably value-free on DOSISH platforms - if ($does_shbang) { - $shb .= "$Config{'sharpbang'}$interpreter"; - $shb .= ' ' . $arg if defined $arg; - $shb .= "\n"; - } - $shb .= qq{ + } + else { + my (@absdirs) + = reverse grep { $self->file_name_is_absolute } $self->path; + $interpreter = ''; + my ($dir); + foreach $dir (@absdirs) { + if ( $self->maybe_command($cmd) ) { + warn "Ignoring $interpreter in $file\n" + if $Verbose && $interpreter; + $interpreter = $self->catfile( $dir, $cmd ); + } + } + } + + # Figure out how to invoke interpreter on this machine. + + my ($shb) = ""; + if ($interpreter) { + print STDOUT "Changing sharpbang in $file to $interpreter" + if $Verbose; + + # this is probably value-free on DOSISH platforms + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + $shb .= qq{ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell -} unless $Is_Win32; # this won't work on win32, so don't - } else { - warn "Can't find $cmd in PATH, $file unchanged" - if $Verbose; - next; - } +} unless $Is_Win32; # this won't work on win32, so don't + } + else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + next; + } - unless ( open(FIXOUT,">$file_new") ) { - warn "Can't create new $file: $!\n"; - next; - } - - # Print out the new #! line (or equivalent). - local $\; - undef $/; - print FIXOUT $shb, <FIXIN>; - close FIXIN; - close FIXOUT; + unless ( open( FIXOUT, ">$file_new" ) ) { + warn "Can't create new $file: $!\n"; + next; + } + + # Print out the new #! line (or equivalent). + local $\; + local $/; + print FIXOUT $shb, <FIXIN>; + close FIXIN; + close FIXOUT; chmod 0666, $file_bak; unlink $file_bak; - unless ( _rename($file, $file_bak) ) { - warn "Can't rename $file to $file_bak: $!"; - next; - } - unless ( _rename($file_new, $file) ) { - warn "Can't rename $file_new to $file: $!"; - unless ( _rename($file_bak, $file) ) { - warn "Can't rename $file_bak back to $file either: $!"; - warn "Leaving $file renamed as $file_bak\n"; - } - next; - } - unlink $file_bak; - } continue { - close(FIXIN) if fileno(FIXIN); - system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; + unless ( _rename( $file, $file_bak ) ) { + warn "Can't rename $file to $file_bak: $!"; + next; + } + unless ( _rename( $file_new, $file ) ) { + warn "Can't rename $file_new to $file: $!"; + unless ( _rename( $file_bak, $file ) ) { + warn "Can't rename $file_bak back to $file either: $!"; + warn "Leaving $file renamed as $file_bak\n"; + } + next; + } + unlink $file_bak; + } + continue { + close(FIXIN) if fileno(FIXIN); + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; } } @@ -1182,7 +1198,7 @@ Writes an empty FORCE: target. sub force { my($self) = shift; '# Phony target to force checking subdirectories. -FORCE: +FORCE : $(NOECHO) $(NOOP) '; } @@ -1229,8 +1245,8 @@ sub has_link_code { =item init_dirscan -Scans the directory structure and initializes DIR, XS, XS_FILES, PM, -C, C_FILES, O_FILES, H, H_FILES, PL_FILES, MAN*PODS, EXE_FILES. +Scans the directory structure and initializes DIR, XS, XS_FILES, +C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES. Called by init_main. @@ -1238,8 +1254,7 @@ Called by init_main. sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; - my($name, %dir, %xs, %c, %h, %pl_files, %manifypods); - my %pm; + my($name, %dir, %xs, %c, %h, %pl_files, %pm); my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t); @@ -1283,6 +1298,142 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) } } + $self->{PL_FILES} ||= \%pl_files; + $self->{DIR} ||= [sort keys %dir]; + $self->{XS} ||= \%xs; + $self->{C} ||= [sort keys %c]; + $self->{H} ||= [sort keys %h]; + $self->{PM} ||= \%pm; + + my @o_files = @{$self->{C}}; + $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files]; +} + + +=item init_MANPODS + +Determines if man pages should be generated and initializes MAN1PODS +and MAN3PODS as appropriate. + +=cut + +sub init_MANPODS { + my $self = shift; + + # Set up names of manual pages to generate from pods + foreach my $man (qw(MAN1 MAN3)) { + if ( $self->{"${man}PODS"} + or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/ + ) { + $self->{"${man}PODS"} ||= {}; + } + else { + my $init_method = "init_${man}PODS"; + $self->$init_method(); + } + } +} + + +sub _has_pod { + my($self, $file) = @_; + + local *FH; + my($ispod)=0; + if (open(FH,"<$file")) { + while (<FH>) { + if (/^=(?:head\d+|item|pod)\b/) { + $ispod=1; + last; + } + } + close FH; + } else { + # If it doesn't exist yet, we assume, it has pods in it + $ispod = 1; + } + + return $ispod; +} + + +=item init_MAN1PODS + +Initializes MAN1PODS from the list of EXE_FILES. + +=cut + +sub init_MAN1PODS { + my($self) = @_; + + if ( exists $self->{EXE_FILES} ) { + foreach my $name (@{$self->{EXE_FILES}}) { + next unless $self->_has_pod($name); + + $self->{MAN1PODS}->{$name} = + $self->catfile("\$(INST_MAN1DIR)", + basename($name).".\$(MAN1EXT)"); + } + } +} + + +=item init_MAN3PODS + +Initializes MAN3PODS from the list of PM files. + +=cut + +sub init_MAN3PODS { + my $self = shift; + + my %manifypods = (); # we collect the keys first, i.e. the files + # we have to convert to pod + + foreach my $name (keys %{$self->{PM}}) { + if ($name =~ /\.pod\z/ ) { + $manifypods{$name} = $self->{PM}{$name}; + } elsif ($name =~ /\.p[ml]\z/ ) { + if( $self->_has_pod($name) ) { + $manifypods{$name} = $self->{PM}{$name}; + } + } + } + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + + # Remove "Configure.pm" and similar, if it's not the only pod listed + # To force inclusion, just name it "Configure.pod", or override + # MAN3PODS + foreach my $name (keys %manifypods) { + if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) { + delete $manifypods{$name}; + next; + } + my($manpagename) = $name; + $manpagename =~ s/\.p(od|m|l)\z//; + # everything below lib is ok + unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) { + $manpagename = $self->catfile( + split(/::/,$self->{PARENT_NAME}),$manpagename + ); + } + $manpagename = $self->replace_manpage_separator($manpagename); + $self->{MAN3PODS}->{$name} = + $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); + } +} + + +=item init_PM + +Initializes PMLIBDIRS and PM from PMLIBDIRS. + +=cut + +sub init_PM { + my $self = shift; + # Some larger extensions often wish to install a number of *.pm/pl # files into the library in various locations. @@ -1324,12 +1475,18 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) # Avoid $_ wherever possible: # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; - my ($pmlibdir); @{$self->{PMLIBDIRS}} = (); - foreach $pmlibdir (@pmlibdirs) { + my %dir = map { ($_ => $_) } @{$self->{DIR}}; + foreach my $pmlibdir (@pmlibdirs) { -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir; } + unless( $self->{PMLIBPARENTDIRS} ) { + @{$self->{PMLIBPARENTDIRS}} = ('lib'); + } + + return if $self->{PM} and $self->{ARGS}{PM}; + if (@{$self->{PMLIBDIRS}}){ print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n" if ($Verbose >= 2); @@ -1349,116 +1506,22 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my $prefix = $self->{INST_LIBDIR}; my $striplibpath; + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; $prefix = $self->{INST_LIB} - if ($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i; + if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W} + {$1}i; my($inst) = $self->catfile($prefix,$striplibpath); local($_) = $inst; # for backwards compatibility $inst = $self->libscan($inst); print "libscan($path) => '$inst'\n" if ($Verbose >= 2); return unless $inst; - $pm{$path} = $inst; + $self->{PM}{$path} = $inst; }, @{$self->{PMLIBDIRS}}); } - - $self->{PM} ||= \%pm; - $self->{PL_FILES} ||= \%pl_files; - - $self->{DIR} ||= [sort keys %dir]; - - $self->{XS} ||= \%xs; - $self->{C} ||= [sort keys %c]; - my @o_files = @{$self->{C}}; - $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files]; - - $self->{H} ||= [sort keys %h]; - - # Set up names of manual pages to generate from pods - my %pods; - foreach my $man (qw(MAN1 MAN3)) { - unless ($self->{"${man}PODS"}) { - $self->{"${man}PODS"} = {}; - $pods{$man} = 1 unless - $self->{"INST_${man}DIR"} =~ /^(none|\s*)$/; - } - } - - if ($pods{MAN1}) { - if ( exists $self->{EXE_FILES} ) { - foreach $name (@{$self->{EXE_FILES}}) { - local *FH; - my($ispod)=0; - if (open(FH,"<$name")) { - while (<FH>) { - if (/^=(?:head\d+|item|pod)\b/) { - $ispod=1; - last; - } - } - close FH; - } else { - # If it doesn't exist yet, we assume, it has pods in it - $ispod = 1; - } - next unless $ispod; - if ($pods{MAN1}) { - $self->{MAN1PODS}->{$name} = - $self->catfile("\$(INST_MAN1DIR)", basename($name).".\$(MAN1EXT)"); - } - } - } - } - if ($pods{MAN3}) { - my %manifypods = (); # we collect the keys first, i.e. the files - # we have to convert to pod - foreach $name (keys %{$self->{PM}}) { - if ($name =~ /\.pod\z/ ) { - $manifypods{$name} = $self->{PM}{$name}; - } elsif ($name =~ /\.p[ml]\z/ ) { - local *FH; - my($ispod)=0; - if (open(FH,"<$name")) { - while (<FH>) { - if (/^=head1\s+\w+/) { - $ispod=1; - last; - } - } - close FH; - } else { - $ispod = 1; - } - if( $ispod ) { - $manifypods{$name} = $self->{PM}{$name}; - } - } - } - - # Remove "Configure.pm" and similar, if it's not the only pod listed - # To force inclusion, just name it "Configure.pod", or override - # MAN3PODS - foreach $name (keys %manifypods) { - if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) { - delete $manifypods{$name}; - next; - } - my($manpagename) = $name; - $manpagename =~ s/\.p(od|m|l)\z//; - # everything below lib is ok - unless($manpagename =~ s!^\W*lib\W+!!s) { - $manpagename = $self->catfile( - split(/::/,$self->{PARENT_NAME}),$manpagename - ); - } - if ($pods{MAN3}) { - $manpagename = $self->replace_manpage_separator($manpagename); - $self->{MAN3PODS}->{$name} = - $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); - } - } - } } + =item init_DIRFILESEP Using / for Unix. Called by init_main. @@ -1528,24 +1591,17 @@ sub init_main { my $inc_carp_dir = dirname($INC{'Carp.pm'}); unless ($self->{PERL_SRC}){ - my($dir); - foreach $dir ($Updir, - $self->catdir($Updir,$Updir), - $self->catdir($Updir,$Updir,$Updir), - $self->catdir($Updir,$Updir,$Updir,$Updir), - $self->catdir($Updir,$Updir,$Updir,$Updir,$Updir)) - { - if ( - -f $self->catfile($dir,"config_h.SH") - && - -f $self->catfile($dir,"perl.h") - && - -f $self->catfile($dir,"lib","Exporter.pm") - ) { - $self->{PERL_SRC}=$dir ; - last; - } - } + foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting + my $dir = $self->catdir(($Updir) x $dir_count); + + if (-f $self->catfile($dir,"config_h.SH") && + -f $self->catfile($dir,"perl.h") && + -f $self->catfile($dir,"lib","Exporter.pm") + ) { + $self->{PERL_SRC}=$dir ; + last; + } + } } warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if @@ -1603,15 +1659,18 @@ from the perl source tree. and not $old){ # Maybe somebody tries to build an extension with an # uninstalled Perl outside of Perl build tree - my $found; + my $lib; for my $dir (@INC) { - $found = $dir, last if -e $self->catdir($dir, "Config.pm"); + $lib = $dir, last if -e $self->catdir($dir, "Config.pm"); } - if ($found) { - my $inc = dirname $found; + if ($lib) { + # Win32 puts its header files in /perl/src/lib/CORE. + # Unix leaves them in /perl/src. + my $inc = $Is_Win32 ? $self->catdir($lib, "CORE" ) + : dirname $lib; if (-e $self->catdir($inc, "perl.h")) { - $self->{PERL_LIB} = $found; - $self->{PERL_ARCHLIB} = $found; + $self->{PERL_LIB} = $lib; + $self->{PERL_ARCHLIB} = $lib; $self->{PERL_INC} = $inc; $self->{UNINSTALLED_PERL} = 1; print STDOUT <<EOP; @@ -2074,7 +2133,7 @@ pure_site_install :: $(INST_LIB) $(DESTINSTALLSITELIB) \ $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \ $(INST_BIN) $(DESTINSTALLSITEBIN) \ - $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \ + $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \ $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \ $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ @@ -2087,7 +2146,7 @@ pure_vendor_install :: $(INST_LIB) $(DESTINSTALLVENDORLIB) \ $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \ $(INST_BIN) $(DESTINSTALLVENDORBIN) \ - $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \ + $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \ $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \ $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) @@ -2480,7 +2539,7 @@ $tmp/perlmain.c: $makefilename}, q{ push @m, q{ -doc_inst_perl: +doc_inst_perl : $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) -$(NOECHO) $(DOC_INSTALL) \ @@ -2493,9 +2552,9 @@ doc_inst_perl: }; push @m, q{ -inst_perl: pure_inst_perl doc_inst_perl +inst_perl : pure_inst_perl doc_inst_perl -pure_inst_perl: $(MAP_TARGET) +pure_inst_perl : $(MAP_TARGET) }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{ clean :: map_clean @@ -2587,22 +2646,6 @@ sub needs_linking { return $self->{NEEDS_LINKING} = 0; } -=item nicetext - -misnamed method (will have to be changed). The MM_Unix method just -returns the argument without further processing. - -On VMS used to insure that colons marking targets are preceded by -space - most Unix Makes don't need this, but it's necessary under VMS -to distinguish the target delimiter from a colon appearing as part of -a filespec. - -=cut - -sub nicetext { - my($self,$text) = @_; - $text; -} =item parse_abstract @@ -2633,10 +2676,16 @@ sub parse_abstract { =item parse_version -parse a file and return what you think is $VERSION in this file set to. + my $version = MM->parse_version($file); + +Parse a $file and return what $VERSION is set to by the first assignment. It will return the string "undef" if it can't figure out what $VERSION -is. $VERSION should be for all to see, so our $VERSION or plain $VERSION -are okay, but my $VERSION is not. +is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION +are okay, but C<my $VERSION> is not. + +parse_version() will try to C<use version> before checking for C<$VERSION> so the following will work. + + $VERSION = qv(1.2.3); =cut @@ -2649,23 +2698,32 @@ sub parse_version { open(FH,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; while (<FH>) { - $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; - next if $inpod || /^\s*#/; - chop; - next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; - my $eval = qq{ - package ExtUtils::MakeMaker::_version; - no strict; - - local $1$2; - \$$2=undef; do { - $_ - }; \$$2 - }; + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if $inpod || /^\s*#/; + chop; + next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; + my $eval = qq{ + package ExtUtils::MakeMaker::_version; + no strict; + BEGIN { eval { + # Ensure any version() routine which might have leaked + # into this package has been deleted. Interferes with + # version->import() + undef *version; + require version; + "version"->import; + } } + + local $1$2; + \$$2=undef; + do { + $_ + }; \$$2 + }; local $^W = 0; - $result = eval($eval); - warn "Could not eval '$eval' in $parsefile: $@" if $@; - last; + $result = eval($eval); + warn "Could not eval '$eval' in $parsefile: $@" if $@; + last; } close FH; @@ -2690,7 +2748,7 @@ sub pasthru { $sep .= "\\\n\t"; foreach $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE - PREFIX INSTALLBASE) + PREFIX INSTALL_BASE) ) { next unless defined $self->{$key}; @@ -2787,7 +2845,6 @@ PERL_HDRS = \ $(PERL_INC)/regnodes.h \ $(PERL_INC)/scope.h \ $(PERL_INC)/sv.h \ - $(PERL_INC)/thrdvar.h \ $(PERL_INC)/thread.h \ $(PERL_INC)/unixish.h \ $(PERL_INC)/util.h @@ -2899,12 +2956,6 @@ for a binary distribution. sub ppd { my($self) = @_; - if ($self->{ABSTRACT_FROM}){ - $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or - carp "WARNING: Setting ABSTRACT via file ". - "'$self->{ABSTRACT_FROM}' failed\n"; - } - my ($pack_ver) = join ",", (split (/\./, $self->{VERSION}), (0)x4)[0..3]; my $abstract = $self->{ABSTRACT} || ''; @@ -2935,7 +2986,14 @@ PPD_OUT } - $ppd_xml .= sprintf <<'PPD_OUT', $Config{archname}; + my $archname = $Config{archname}; + if ($] >= 5.008) { + # archname did not change from 5.6 to 5.8, but those versions may + # not be not binary compatible so now we append the part of the + # version that changes when binary compatibility may change + $archname .= "-". substr($Config{version},0,3); + } + $ppd_xml .= sprintf <<'PPD_OUT', $archname; <OS NAME="$(OSNAME)" /> <ARCHITECTURE NAME="%s" /> PPD_OUT @@ -2964,7 +3022,7 @@ PPD_XML return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds; # Creates a PPD (Perl Package Description) for a binary distribution. -ppd: +ppd : %s PPD_OUT @@ -3042,8 +3100,8 @@ sub processPL { foreach my $target (@$list) { if( $Is_VMS ) { - $plfile = vmsify($plfile); - $target = vmsify($target); + $plfile = vmsify($self->eliminate_macros($plfile)); + $target = vmsify($self->eliminate_macros($target)); } # Normally a .PL file runs AFTER pm_to_blib so it can have @@ -3142,7 +3200,7 @@ sub oneliner { $switches = join ' ', @$switches; - return qq{\$(ABSPERLRUN) $switches -e $cmd}; + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; } @@ -3375,17 +3433,21 @@ TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) -test :: \$(TEST_TYPE) +test :: \$(TEST_TYPE) subdirs-test + +subdirs-test :: + \$(NOECHO) \$(NOOP) + "); foreach my $dir (@{ $self->{DIR} }) { - my $test = $self->oneliner(sprintf <<'CODE', $dir); -chdir '%s'; -system '$(MAKE) test $(PASTHRU)' - if -f '$(FIRST_MAKEFILE)'; -CODE + my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)'); + + push @m, <<END +subdirs-test :: + \$(NOECHO) $test - push(@m, "\t\$(NOECHO) $test\n"); +END } push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n") @@ -3579,7 +3641,7 @@ sub top_targets { pure_all :: config pm_to_blib subdirs linkext $(NOECHO) $(NOOP) -subdirs :: +subdirs :: $(MYEXTLIB) $(NOECHO) $(NOOP) config :: $(FIRST_MAKEFILE) blibdirs diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm index 7677420c6ae..3b47470264c 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm @@ -18,7 +18,7 @@ use File::Basename; # $Revision can't be on the same line or SVN/K gets confused use vars qw($Revision $VERSION @ISA); -$VERSION = '5.73'; +$VERSION = '6.42'; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @@ -283,7 +283,7 @@ sub maybe_command { =item pasthru (override) VMS has $(MMSQUALIFIERS) which is a listing of all the original command line -options. This is used in every invokation of make in the VMS Makefile so +options. This is used in every invocation of make in the VMS Makefile so PASTHRU should not be necessary. Using PASTHRU tends to blow commands past the 256 character limit. @@ -447,10 +447,20 @@ sub init_others { $self->{NOOP} = 'Continue'; $self->{NOECHO} ||= '@ '; - $self->{MAKEFILE} ||= 'Descrip.MMS'; + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS'; $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; - $self->{MAKEFILE_OLD} ||= '$(FIRST_MAKEFILE)_old'; + $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old'); +# +# If an extension is not specified, then MMS/MMK assumes an +# an extension of .MMS. If there really is no extension, +# then a trailing "." needs to be appended to specify a +# a null extension. +# + $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./; + $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./; + $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./; + $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./; $self->{MACROSTART} ||= '/Macro=('; $self->{MACROEND} ||= ')'; @@ -1269,8 +1279,7 @@ $(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h $(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h $(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h $(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h -$(OBJECT) : $(PERL_INC)thrdvar.h, $(PERL_INC)thread.h -$(OBJECT) : $(PERL_INC)util.h, $(PERL_INC)vmsish.h +$(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h ' if $self->{OBJECT}; @@ -1562,10 +1571,10 @@ map_clean : join '', @m; } - + # --- Output postprocessing section --- -=item nicetext (override) +=item maketext_filter (override) Insure that colons marking targets are preceded by space, in order to distinguish the target delimiter from a colon appearing as @@ -1573,11 +1582,11 @@ part of a filespec. =cut -sub nicetext { - my($self,$text) = @_; - return $text if $text =~ m/^\w+\s*=/; # leave macro defs alone - $text =~ s/([^\s:])(:+\s)/$1 $2/gs; - $text; +sub maketext_filter { + my($self, $text) = @_; + + $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg; + return $text; } =item prefixify (override) @@ -1722,7 +1731,7 @@ sub oneliner { # Switches must be quoted else they will be lowercased. $switches = join ' ', map { qq{"$_"} } @$switches; - return qq{\$(ABSPERLRUN) $switches -e $cmd}; + return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}; } diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm index 4998c74f59d..8975e31f739 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm @@ -24,19 +24,17 @@ use File::Basename; use File::Spec; use ExtUtils::MakeMaker qw( neatvalue ); -use vars qw(@ISA $VERSION $BORLAND $GCC $DMAKE $NMAKE); +use vars qw(@ISA $VERSION); require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); -$VERSION = '1.12'; +$VERSION = '6.42'; $ENV{EMXSHELL} = 'sh'; # to run `commands` -$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; -$GCC = 1 if $Config{'cc'} =~ /^gcc/i; -$DMAKE = 1 if $Config{'make'} =~ /^dmake/i; -$NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +my $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; +my $GCC = 1 if $Config{'cc'} =~ /^gcc/i; =head2 Overridden methods @@ -130,10 +128,12 @@ Using \ for Windows. sub init_DIRFILESEP { my($self) = shift; + my $make = $self->make; + # The ^ makes sure its not interpreted as an escape in nmake - $self->{DIRFILESEP} = $NMAKE ? '^\\' : - $DMAKE ? '\\\\' - : '\\'; + $self->{DIRFILESEP} = $make eq 'nmake' ? '^\\' : + $make eq 'dmake' ? '\\\\' + : '\\'; } =item B<init_others> @@ -236,7 +236,7 @@ sub special_targets { my $make_frag = $self->SUPER::special_targets; - $make_frag .= <<'MAKE_FRAG' if $DMAKE; + $make_frag .= <<'MAKE_FRAG' if $self->make eq 'dmake'; .USESHELL : MAKE_FRAG @@ -331,7 +331,8 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP). } elsif ($BORLAND) { push(@m, q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,} - .($DMAKE ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) } + .($self->make eq 'dmake' + ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) } .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)} : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) } .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))}) @@ -340,6 +341,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP). push(@m, q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); + + # VS2005 (aka VC 8) or higher, but not for 64-bit compiler from Platform SDK + if ($Config{ivsize} == 4 && $Config{cc} eq 'cl' and $Config{ccversion} =~ /^(\d+)/ and $1 >= 14) + { + push(@m, + q{ + mt -nologo -manifest $@.manifest -outputresource:$@;2 && del $@.manifest}); + } } push @m, ' $(CHMOD) $(PERM_RWX) $@ @@ -410,7 +419,7 @@ banner. sub pasthru { my($self) = shift; - return "PASTHRU = " . ($NMAKE ? "-nologo" : ""); + return "PASTHRU = " . ($self->make eq 'nmake' ? "-nologo" : ""); } @@ -434,7 +443,7 @@ sub oneliner { $switches = join ' ', @$switches; - return qq{\$(ABSPERLRUN) $switches -e $cmd}; + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; } @@ -449,7 +458,7 @@ sub quote_literal { # quotes; however it transforms {{ into { either inside and outside double # quotes. It also translates }} into }. The escaping below is not # 100% correct. - if( $DMAKE ) { + if( $self->make eq 'dmake' ) { $text =~ s/{/{{/g; $text =~ s/}}/}}}/g; } @@ -478,23 +487,24 @@ wants: another_command cd .. -B<NOTE> This cd can only go one level down. So far this sufficient for -what MakeMaker needs. +NOTE: This only works with simple relative directories. Throw it an absolute dir or something with .. in it and things will go wrong. =cut sub cd { my($self, $dir, @cmds) = @_; - return $self->SUPER::cd($dir, @cmds) unless $NMAKE; + return $self->SUPER::cd($dir, @cmds) unless $self->make eq 'nmake'; my $cmd = join "\n\t", map "$_", @cmds; + my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir)); + # No leading tab and no trailing newline makes for easier embedding. - my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs; cd %s %s - cd .. + cd %s MAKE_FRAG chomp $make_frag; @@ -527,6 +537,33 @@ sub os_flavor { } +=item cflags + +Defines the PERLDLL symbol if we are configured for static building since all +code destined for the perl5xx.dll must be compiled with the PERLDLL symbol +defined. + +=cut + +sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static'); + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; + +} + 1; __END__ diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm index 7613b685c68..5c6d96c3b6a 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm @@ -1,4 +1,4 @@ -# $Id: MakeMaker.pm,v 1.8 2006/03/28 19:23:06 millert Exp $ +# $Id: MakeMaker.pm,v 1.9 2008/09/29 17:36:11 millert Exp $ package ExtUtils::MakeMaker; BEGIN {require 5.005_03;} @@ -10,9 +10,9 @@ use File::Path; use vars qw( @ISA @EXPORT @EXPORT_OK - $VERSION $Verbose %Config + $VERSION $Verbose %Config @Prepend_parent @Parent - %Recognized_Att_Keys @Get_from_Config @MM_Sections @Overridable + %Recognized_Att_Keys @Get_from_Config @MM_Sections @Overridable $Filename ); @@ -21,12 +21,13 @@ use vars qw( use vars qw($Revision); use strict; -$VERSION = '6.30'; -($Revision = q$Revision: 1.8 $) =~ /Revision:\s+(\S+)/; +$VERSION = '6.42'; +($Revision) = q$Revision: 1.9 $ =~ /Revision:\s+(\S+)/; @ISA = qw(Exporter); @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); -@EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists); +@EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists + &WriteEmptyMakefile); # These will go away once the last of the Win32 & VMS specific code is # purged. @@ -67,40 +68,42 @@ sub WriteMakefile { # scalar. my %Att_Sigs; my %Special_Sigs = ( - C => 'array', - CONFIG => 'array', - CONFIGURE => 'code', - DIR => 'array', - DL_FUNCS => 'hash', - DL_VARS => 'array', - EXCLUDE_EXT => 'array', - EXE_FILES => 'array', - FUNCLIST => 'array', - H => 'array', - IMPORTS => 'hash', - INCLUDE_EXT => 'array', - LIBS => ['array',''], - MAN1PODS => 'hash', - MAN3PODS => 'hash', - PL_FILES => 'hash', - PM => 'hash', - PMLIBDIRS => 'array', - PREREQ_PM => 'hash', - SKIP => 'array', - TYPEMAPS => 'array', - XS => 'hash', + C => 'ARRAY', + CONFIG => 'ARRAY', + CONFIGURE => 'CODE', + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => ['ARRAY',''], + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', + VERSION => ['version',''], _KEEP_AFTER_FLUSH => '', - clean => 'hash', - depend => 'hash', - dist => 'hash', - dynamic_lib=> 'hash', - linkext => 'hash', - macro => 'hash', - postamble => 'hash', - realclean => 'hash', - test => 'hash', - tool_autosplit => 'hash', + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', ); @Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys; @@ -118,19 +121,28 @@ sub _verify_att { } my @sigs = ref $sig ? @$sig : $sig; - my $given = lc ref $val; - unless( grep $given eq $_, @sigs ) { - my $takes = join " or ", map { $_ ne '' ? "$_ reference" - : "string/number" - } @sigs; - my $has = $given ne '' ? "$given reference" - : "string/number"; + my $given = ref $val; + unless( grep { $given eq $_ || ($_ && eval{$val->isa($_)}) } @sigs ) { + my $takes = join " or ", map { _format_att($_) } @sigs; + + my $has = _format_att($given); warn "WARNING: $key takes a $takes not a $has.\n". " Please inform the author.\n"; } } } + +sub _format_att { + my $given = shift; + + return $given eq '' ? "string/number" + : uc $given eq $given ? "$given reference" + : "$given object" + ; +} + + sub prompt ($;$) { my($mess, $def) = @_; Carp::confess("prompt function called without an argument") @@ -208,13 +220,13 @@ sub full_setup { AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS - EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE + EXCLUDE_EXT EXE_FILES EXTRA_META FIRST_MAKEFILE FULLPERL FULLPERLRUN FULLPERLRUNINST FUNCLIST H IMPORTS INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR INSTALLDIRS - DESTDIR PREFIX INSTALLBASE + DESTDIR PREFIX INSTALL_BASE PERLPREFIX SITEPREFIX VENDORPREFIX INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH @@ -222,16 +234,16 @@ sub full_setup { INSTALLMAN1DIR INSTALLMAN3DIR INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR - INSTALLSCRIPT + INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT PERL_LIB PERL_ARCHLIB SITELIBEXP SITEARCHEXP - INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS - LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET + INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS LICENSE + LINKTYPE MAKE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC + PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ SIGN SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean @@ -281,7 +293,10 @@ sub full_setup { push @Overridable, qw[ libscan makeaperl needs_linking perm_rw perm_rwx - subdir_x test_via_harness test_via_script init_PERL + subdir_x test_via_harness test_via_script + + init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan + init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker ]; push @MM_Sections, qw[ @@ -300,9 +315,9 @@ sub full_setup { # we will use all these variables in the Makefile @Get_from_Config = qw( - ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc - lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so - exe_ext full_ar + ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld + lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib + sitelibexp sitearchexp so ); # 5.5.3 doesn't have any concept of vendor libs @@ -410,13 +425,18 @@ sub new { $self->{PREREQ_PM}->{$prereq} : 'unknown version' ; } } - if (%unsatisfied && $self->{PREREQ_FATAL}){ - my $failedprereqs = join ', ', map {"$_ $unsatisfied{$_}"} - keys %unsatisfied; - die qq{MakeMaker FATAL: prerequisites not found ($failedprereqs)\n - Please install these modules first and rerun 'perl Makefile.PL'.\n}; + + if (%unsatisfied && $self->{PREREQ_FATAL}){ + my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} + sort { $a cmp $b } keys %unsatisfied; + die <<"END"; +MakeMaker FATAL: prerequisites not found. +$failedprereqs + +Please install these modules first and rerun 'perl Makefile.PL'. +END } - + if (defined $self->{CONFIGURE}) { if (ref $self->{CONFIGURE} eq 'CODE') { %configure_att = %{&{$self->{CONFIGURE}}}; @@ -472,7 +492,7 @@ sub new { } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; - foreach my $opt (qw(POLLUTE PERL_CORE)) { + foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE)) { if (exists $self->{PARENT}->{$opt} and not exists $self->{$opt}) { @@ -487,10 +507,12 @@ sub new { parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV); } + $self->{NAME} ||= $self->guess_name; ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g; + $self->init_MAKE; $self->init_main; $self->init_VERSION; $self->init_dist; @@ -498,10 +520,13 @@ sub new { $self->init_INSTALL; $self->init_DEST; $self->init_dirscan; + $self->init_PM; + $self->init_MANPODS; $self->init_xs; $self->init_PERL; $self->init_DIRFILESEP; $self->init_linker; + $self->init_ABSTRACT; if (! $self->{PERL_SRC} ) { require VMS::Filespec if $Is_VMS; @@ -612,7 +637,9 @@ END my(%a) = %{$self->{$section} || {}}; push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; - push @{$self->{RESULT}}, $self->nicetext($self->$method( %a )); + push @{$self->{RESULT}}, $self->maketext_filter( + $self->$method( %a ) + ); } } @@ -622,32 +649,33 @@ END } sub WriteEmptyMakefile { - Carp::croak "WriteEmptyMakefile: Need even number of args" if @_ % 2; + Carp::croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; my %att = @_; my $self = MM->new(\%att); - if (-f $self->{MAKEFILE_OLD}) { - _unlink($self->{MAKEFILE_OLD}) or - warn "unlink $self->{MAKEFILE_OLD}: $!"; + + my $new = $self->{MAKEFILE}; + my $old = $self->{MAKEFILE_OLD}; + if (-f $old) { + _unlink($old) or warn "unlink $old: $!"; } - if ( -f $self->{MAKEFILE} ) { - _rename($self->{MAKEFILE}, $self->{MAKEFILE_OLD}) or - warn "rename $self->{MAKEFILE} => $self->{MAKEFILE_OLD}: $!" + if ( -f $new ) { + _rename($new, $old) or warn "rename $new => $old: $!" } - open MF, '>'.$self->{MAKEFILE} or die "open $self->{MAKEFILE} for write: $!"; + open MF, '>'.$new or die "open $new for write: $!"; print MF <<'EOP'; -all: +all : -clean: +clean : -install: +install : -makemakerdflt: +makemakerdflt : -test: +test : EOP - close MF or die "close $self->{MAKEFILE} for write: $!"; + close MF or die "close $new for write: $!"; } sub check_manifest { @@ -872,9 +900,11 @@ sub flush { my $self = shift; my($chunk); local *FH; - print STDOUT "Writing $self->{MAKEFILE} for $self->{NAME}\n"; - unlink($self->{MAKEFILE}, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ''); + my $finalname = $self->{MAKEFILE}; + print STDOUT "Writing $finalname for $self->{NAME}\n"; + + unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); open(FH,">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!"; for $chunk (@{$self->{RESULT}}) { @@ -882,7 +912,6 @@ sub flush { } close FH; - my($finalname) = $self->{MAKEFILE}; _rename("MakeMaker.tmp", $finalname) or warn "rename MakeMaker.tmp => $finalname: $!"; chmod 0644, $finalname unless $Is_VMS; @@ -1022,7 +1051,7 @@ The generated Makefile enables the user of the extension to invoke The Makefile to be produced may be altered by adding arguments of the form C<KEY=VALUE>. E.g. - perl Makefile.PL PREFIX=~ + perl Makefile.PL INSTALL_BASE=~ Other interesting targets in the generated Makefile are @@ -1084,7 +1113,7 @@ INSTALLDIRS according to the following table: INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN - INST_SCRIPT INSTALLSCRIPT INSTALLSCRIPT INSTALLSCRIPT + INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR @@ -1110,17 +1139,50 @@ C<UNINST> variable. make install UNINST=1 +=head2 INSTALL_BASE + +INSTALL_BASE can be passed into Makefile.PL to change where your +module will be installed. INSTALL_BASE is more like what everyone +else calls "prefix" than PREFIX is. + +To have everything installed in your home directory, do the following. + + # Unix users, INSTALL_BASE=~ works fine + perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir + +Like PREFIX, it sets several INSTALL* attributes at once. Unlike +PREFIX it is easy to predict where the module will end up. The +installation pattern looks like this: + + INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname} + INSTALLPRIVLIB INSTALL_BASE/lib/perl5 + INSTALLBIN INSTALL_BASE/bin + INSTALLSCRIPT INSTALL_BASE/bin + INSTALLMAN1DIR INSTALL_BASE/man/man1 + INSTALLMAN3DIR INSTALL_BASE/man/man3 + +INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as +of 0.28) install to the same location. If you want MakeMaker and +Module::Build to install to the same location simply set INSTALL_BASE +and C<--install_base> to the same location. + +INSTALL_BASE was added in 6.31. + + =head2 PREFIX and LIB attribute PREFIX and LIB can be used to set several INSTALL* attributes in one -go. The quickest way to install a module in a non-standard place might -be +go. Here's an example for installing into your home directory. - perl Makefile.PL PREFIX=~ + # Unix users, PREFIX=~ works fine + perl Makefile.PL PREFIX=/path/to/your/home/dir This will install all files in the module under your home directory, with man pages and libraries going into an appropriate place (usually -~/man and ~/lib). +~/man and ~/lib). How the exact location is determined is complicated +and depends on how your Perl was configured. INSTALL_BASE works more +like what other build systems call "prefix" than PREFIX and we +recommend you use that instead. Another way to specify many INSTALL directories with a single parameter is LIB. @@ -1545,7 +1607,7 @@ Defaults to $Config{installprivlib}. =item INSTALLSCRIPT Used by 'make install' which copies files from INST_SCRIPT to this -directory. +directory if INSTALLDIRS=perl. =item INSTALLSITEARCH @@ -1572,6 +1634,11 @@ $(SITEPREFIX)/man/man$(MAN*EXT). If set to 'none', no man pages will be installed. +=item INSTALLSITESCRIPT + +Used by 'make install' which copies files from INST_SCRIPT to this +directory if INSTALLDIRS is set to site (default). + =item INSTALLVENDORARCH Used by 'make install', which copies files from INST_ARCHLIB to this @@ -1596,6 +1663,11 @@ INSTALLDIRS=vendor. Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT). If set to 'none', no man pages will be installed. +=item INSTALLVENDORSCRIPT + +Used by 'make install' which copies files from INST_SCRIPT to this +directory if INSTALLDIRS is set to is set to vendor. + =item INST_ARCHLIB Same as INST_LIB for architecture dependent files. @@ -1679,12 +1751,35 @@ you specify a scalar as in MakeMaker will turn it into an array with one element. +=item LICENSE + +The licensing terms of your distribution. Generally its "perl" for the +same license as Perl itself. + +See L<Module::Build::Authoring> for the list of options. + +Defaults to "unknown". + =item LINKTYPE 'static' or 'dynamic' (default unless usedl=undef in config.sh). Should only be used to force static linking (also see linkext below). +=item MAKE + +Variant of make you intend to run the generated Makefile with. This +parameter lets Makefile.PL know what make quirks to account for when +generating the Makefile. + +MakeMaker also honors the MAKE environment variable. This parameter +takes precedent. + +Currently the only significant values are 'dmake' and 'nmake' for Windows +users. + +Defaults to $Config{make}. + =item MAKEAPERL Boolean which tells MakeMaker, that it should include the rules to @@ -1937,7 +2032,7 @@ done. For instance, you would need to say: {'PM_FILTER' => 'grep -v \\"^\\#\\"'} -to remove all the leading coments on the fly during the build. The +to remove all the leading comments on the fly during the build. The extra \\ are necessary, unfortunately, because this variable is interpolated within the context of a Perl program built on the command line, and double quotes are what is used with the -e switch to build that command line. The @@ -1984,16 +2079,23 @@ by the PREFIX. =item PREREQ_FATAL Bool. If this parameter is true, failing to have the required modules -(or the right versions thereof) will be fatal. perl Makefile.PL will die -with the proper message. +(or the right versions thereof) will be fatal. C<perl Makefile.PL> +will C<die> instead of simply informing the user of the missing dependencies. -Note: see L<Test::Harness> for a shortcut for stopping tests early if -you are missing dependencies. +It is I<extremely> rare to have to use C<PREREQ_FATAL>. Its use by module +authors is I<strongly discouraged> and should never be used lightly. +Module installation tools have ways of resolving umet dependencies but +to do that they need a F<Makefile>. Using C<PREREQ_FATAL> breaks this. +That's bad. -Do I<not> use this parameter for simple requirements, which could be resolved -at a later time, e.g. after an unsuccessful B<make test> of your module. +The only situation where it is appropriate is when you have +dependencies that are indispensible to actually I<write> a +F<Makefile>. For example, MakeMaker's F<Makefile.PL> needs L<File::Spec>. +If its not available it cannot write the F<Makefile>. -It is I<extremely> rare to have to use C<PREREQ_FATAL> at all! +Note: see L<Test::Harness> for a shortcut for stopping tests early +if you are missing dependencies and are afraid that users might +use your module with an incomplete environment. =item PREREQ_PM @@ -2090,10 +2192,10 @@ MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; *VERSION = \'1.01'; - $VERSION = sprintf "%d.%03d", q$Revision: 1.8 $ =~ /(\d+)/g; + ($VERSION) = q$Revision: 1.9 $ =~ /(\d+)/g; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; - our $VERSION = 1.2.3; # new for perl5.6.0 + our $VERSION = 1.2.3; # new for perl5.6.0 but these will fail: @@ -2101,6 +2203,17 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; +L<version> will be loaded, if available, so this will work. + + our $VERSION = qv(1.2.3); # version.pm will be loaded if available + +Its up to you to declare a dependency on C<version>. Also note that this +feature was introduced in MakeMaker 6.35. Earlier versions of MakeMaker +require this: + + # All on one line + use version; our $VERSION = qv(1.2.3); + (Putting C<my> or C<local> on the preceding line will work o.k.) The file named in VERSION_FROM is not added as a dependency to @@ -2161,7 +2274,7 @@ passed to the method as a hash. =item depend - {ANY_TARGET => ANY_DEPENDECY, ...} + {ANY_TARGET => ANY_DEPENDENCY, ...} (ANY_TARGET must not be given a double-colon rule by MakeMaker.) @@ -2271,7 +2384,7 @@ Some of the most common mistakes: =item C<< MAN3PODS => ' ' >> -This is commonly used to supress the creation of man pages. MAN3PODS +This is commonly used to suppress the creation of man pages. MAN3PODS takes a hash ref not a string, but the above worked by accident in old versions of MakeMaker. @@ -2336,7 +2449,7 @@ directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory exists, it will be removed first. Additionally, it will create a META.yml module meta-data file in the -distdir and add this to the distdir's MANFIEST. You can shut this +distdir and add this to the distdir's MANIFEST. You can shut this behavior off with the NO_META flag. =item make disttest @@ -2347,7 +2460,7 @@ a make test in that directory. =item make tardist First does a distdir. Then a command $(PREOP) which defaults to a null -command, followed by $(TOUNIX), which defaults to a null command under +command, followed by $(TO_UNIX), which defaults to a null command under UNIX, and will convert files in distribution directory to UNIX format otherwise. Next it runs C<tar> on that directory into a tarfile and deletes the directory. Finishes with a command $(POSTOP) which @@ -2432,7 +2545,8 @@ to create the Module, but this is a normal state of things, then you can create a F<Makefile> which does nothing, but succeeds on all the "usual" build targets. To do so, use - ExtUtils::MakeMaker::WriteEmptyMakefile(); + use ExtUtils::MakeMaker qw(WriteEmptyMakefile); + WriteEmptyMakefile(); instead of WriteMakefile(). @@ -2489,8 +2603,15 @@ Same as the PERL_CORE parameter. The parameter overrides this. =head1 SEE ALSO -ExtUtils::MM_Unix, ExtUtils::Manifest ExtUtils::Install, -ExtUtils::Embed +L<Module::Build> is a pure-Perl alternative to MakeMaker which does +not rely on make or any other external utility. It is easier to +extend to suit your needs. + +L<Module::Install> is a wrapper around MakeMaker which adds features +not normally available. + +L<ExtUtils::ModuleMaker> and L<Module::Starter> are both modules to +help you setup your distribution. =head1 AUTHORS diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker/FAQ.pod b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker/FAQ.pod index 8896c27c5b3..95846eb8208 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker/FAQ.pod +++ b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker/FAQ.pod @@ -1,7 +1,7 @@ package ExtUtils::MakeMaker::FAQ; use vars qw($VERSION); -$VERSION = '1.11'; +$VERSION = '1.12'; 1; __END__ @@ -19,6 +19,55 @@ FAQs, tricks and tips for C<ExtUtils::MakeMaker>. =over 4 +=item How do I install a module into my home directory? + +If you're not the Perl administrator you probably don't have +permission to install a module to its default location. Then you +should install it for your own use into your home directory like so: + + # Non-unix folks, replace ~ with /path/to/your/home/dir + perl Makefile.PL INSTALL_BASE=~ + +This will put modules into F<~/lib/perl5>, man pages into F<~/man> and +programs into F<~/bin>. + +To ensure your Perl programs can see these newly installed modules, +set your C<PERL5LIB> environment variable to F<~/lib/perl5> or tell +each of your programs to look in that directory with the following: + + use lib "$ENV{HOME}/lib/perl5"; + +or if $ENV{HOME} isn't set and you don't want to set it for some +reason, do it the long way. + + use lib "/path/to/your/home/dir/lib/perl5"; + + +=item How do I get MakeMaker and Module::Build to install to the same place? + +Module::Build, as of 0.28, supports two ways to install to the same +location as MakeMaker. + +1) Use INSTALL_BASE / C<--install_base> + +MakeMaker (as of 6.31) and Module::Build (as of 0.28) both can install +to the same locations using the "install_base" concept. See +L<ExtUtils::MakeMaker/INSTALL_BASE> for details. To get MM and MB to +install to the same location simply set INSTALL_BASE in MM and +C<--install_base> in MB to the same location. + + perl Makefile.PL INSTALL_BASE=/whatever + perl Build.PL --install_base /whatever + +2) Use PREFIX / C<--prefix> + +Module::Build 0.28 added support for C<--prefix> which works like +MakeMaker's PREFIX. + + perl Makefile.PL PREFIX=/whatever + perl Build.PL --prefix /whatever + + =item How do I keep from installing man pages? Recent versions of MakeMaker will only install man pages on Unix like @@ -39,17 +88,35 @@ Two ways. One is to build the module normally... perl Makefile.PL make + make test ...and then set the PERL5LIB environment variable to point at the blib/lib and blib/arch directories. The other is to install the module in a temporary location. - perl Makefile.PL PREFIX=~/tmp LIB=~/tmp/lib/perl + perl Makefile.PL INSTALL_BASE=~/tmp + make + make test + make install + +And then set PERL5LIB to F<~/tmp/lib/perl5>. This works well when you +have multiple modules to work with. It also ensures that the module +goes through its full installation process which may modify it. + +=item PREFIX vs INSTALL_BASE from Module::Build::Cookbook -And then set PERL5LIB to F<~/tmp/lib/perl>. This works well when you have -multiple modules to work with. It also ensures that the module goes -through its full installation process which may modify it. +The behavior of PREFIX is complicated and depends closely on how your +Perl is configured. The resulting installation locations will vary from +machine to machine and even different installations of Perl on the same machine. +Because of this, its difficult to document where prefix will place your modules. + +In contrast, INSTALL_BASE has predictable, easy to explain installation locations. +Now that Module::Build and MakeMaker both have INSTALL_BASE there is little reason +to use PREFIX other than to preserve your existing installation locations. If you +are starting a fresh Perl installation we encourage you to use INSTALL_BASE. If +you have an existing installation installed via PREFIX, consider moving it to an +installation structure matching INSTALL_BASE and using that instead. =back @@ -115,23 +182,35 @@ by hand is a pain and you often forget. Simplest way to do it automatically is to use your version control system's revision number (you are using version control, right?). -In CVS, RCS and SVN you use $Revision: 1.3 $ (see the documentation of your -version control system for details) writing it like so: +In CVS, RCS and SVN you use $Revision: 1.4 $ (see the documentation of your +version control system for details). Every time the file is checked +in the $Revision: 1.4 $ will be updated, updating your $VERSION. + +SVN uses a simple integer for $Revision: 1.4 $ so you can adapt it for your +$VERSION like so: - $VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)/g; + ($VERSION) = q$Revision: 1.4 $ =~ /(\d+)/; -Every time the file is checked in the $Revision: 1.3 $ will be updated, -updating your $VERSION. +In CVS and RCS version 1.9 is followed by 1.10. Since CPAN compares +version numbers numerically we use a sprintf() to convert 1.9 to 1.009 +and 1.10 to 1.010 which compare properly. -In CVS version 1.9 is followed by 1.10. Since CPAN compares version -numbers numerically we use a sprintf() to convert 1.9 to 1.009 and -1.10 to 1.010 which compare properly. + $VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/g; -If branches are involved (ie. $Revision: 1.3 $) its a little more +If branches are involved (ie. $Revision: 1.4 $) its a little more complicated. # must be all on one line or MakeMaker will get confused. - $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r }; + $VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r }; + +In SVN, $Revision: 1.4 $ should be the same for every file in the project so +they would all have the same $VERSION. CVS and RCS have a different +$Revision: 1.4 $ per file so each file will have a differnt $VERSION. +Distributed version control systems, such as SVK, may have a different +$Revision: 1.4 $ based on who checks out the file leading to a different $VERSION +on each machine! Finally, some distributed version control systems, such +as darcs, have no concept of revision number at all. + =item What's this F<META.yml> thing and how did it get in my F<MANIFEST>?! @@ -141,6 +220,54 @@ automatically generated as part of the 'distdir' target (and thus To shut off its generation, pass the C<NO_META> flag to C<WriteMakefile()>. + +=item How do I delete everything not in my F<MANIFEST>? + +Some folks are surpried that C<make distclean> does not delete +everything not listed in their MANIFEST (thus making a clean +distribution) but only tells them what they need to delete. This is +done because it is considered too dangerous. While developing your +module you might write a new file, not add it to the MANIFEST, then +run a C<distclean> and be sad because your new work was deleted. + +If you really want to do this, you can use +C<ExtUtils::Manifest::manifind()> to read the MANIFEST and File::Find +to delete the files. But you have to be careful. Here's a script to +do that. Use at your own risk. Have fun blowing holes in your foot. + + #!/usr/bin/perl -w + + use strict; + + use File::Spec; + use File::Find; + use ExtUtils::Manifest qw(maniread); + + my %manifest = map {( $_ => 1 )} + grep { File::Spec->canonpath($_) } + keys %{ maniread() }; + + if( !keys %manifest ) { + print "No files found in MANIFEST. Stopping.\n"; + exit; + } + + find({ + wanted => sub { + my $path = File::Spec->canonpath($_); + + return unless -f $path; + return if exists $manifest{ $path }; + + print "unlink $path\n"; + unlink $path; + }, + no_chdir => 1 + }, + "." + ); + + =back =head2 XS @@ -151,7 +278,7 @@ To shut off its generation, pass the C<NO_META> flag to C<WriteMakefile()>. XS code is very sensitive to the module version number and will complain if the version number in your Perl module doesn't match. If -you change your module's version # without reruning Makefile.PL the old +you change your module's version # without rerunning Makefile.PL the old version number will remain in the Makefile causing the XS code to be built with the wrong number. @@ -270,7 +397,7 @@ The following four files sum up all the details discussed so far. And of course a very basic test: - test.pl: + t/cool.t: -------- use Test; BEGIN { plan tests => 1 }; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm index 0c96f63ca9a..ee508c8fa98 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm @@ -13,7 +13,7 @@ use vars qw($VERSION @ISA @EXPORT_OK $Is_MacOS $Is_VMS $Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP); -$VERSION = '1.46'; +$VERSION = '1.51_01'; @ISA=('Exporter'); @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck @@ -93,7 +93,9 @@ sub mkmanifest { my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; $read = {} if $manimiss; local *M; - rename $MANIFEST, "$MANIFEST.bak" unless $manimiss; + my $bakbase = $MANIFEST; + $bakbase =~ s/\./_/g if $Is_VMS; # avoid double dots + rename $MANIFEST, "$bakbase.bak" unless $manimiss; open M, ">$MANIFEST" or die "Could not open $MANIFEST: $!"; my $skip = _maniskip(); my $found = manifind(); @@ -112,7 +114,6 @@ sub mkmanifest { warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; } my $text = $all{$file}; - ($file,$text) = split(/\s+/,$text,2) if $Is_VMS && $text; $file = _unmacify($file); my $tabs = (5 - (length($file)+1)/8); $tabs = 1 if $tabs < 1; @@ -308,7 +309,7 @@ sub maniread { my $read = {}; local *M; unless (open M, $mfile){ - warn "$mfile: $!"; + warn "Problem opening $mfile: $!"; return $read; } local $_; @@ -346,15 +347,19 @@ sub maniread { sub _maniskip { my @skip ; my $mfile = "$MANIFEST.SKIP"; - local(*M,$_); + _check_mskip_directives($mfile) if -f $mfile; + local(*M, $_); open M, $mfile or open M, $DEFAULT_MSKIP or return sub {0}; while (<M>){ chomp; + s/\r//; next if /^#/; next if /^\s*$/; push @skip, _macify($_); } close M; + return sub {0} unless (scalar @skip > 0); + my $opts = $Is_VMS ? '(?i)' : ''; # Make sure each entry is isolated in its own parentheses, in case @@ -364,6 +369,77 @@ sub _maniskip { return sub { $_[0] =~ qr{$opts$regex} }; } +# checks for the special directives +# #!include_default +# #!include /path/to/some/manifest.skip +# in a custom MANIFEST.SKIP for, for including +# the content of, respectively, the default MANIFEST.SKIP +# and an external manifest.skip file +sub _check_mskip_directives { + my $mfile = shift; + local (*M, $_); + my @lines = (); + my $flag = 0; + unless (open M, $mfile) { + warn "Problem opening $mfile: $!"; + return; + } + while (<M>) { + if (/^#!include_default\s*$/) { + if (my @default = _include_mskip_file()) { + push @lines, @default; + warn "Debug: Including default MANIFEST.SKIP\n" if $Debug; + $flag++; + } + next; + } + if (/^#!include\s+(.*)\s*$/) { + my $external_file = $1; + if (my @external = _include_mskip_file($external_file)) { + push @lines, @external; + warn "Debug: Including external $external_file\n" if $Debug; + $flag++; + } + next; + } + push @lines, $_; + } + close M; + return unless $flag; + my $bakbase = $mfile; + $bakbase =~ s/\./_/g if $Is_VMS; # avoid double dots + rename $mfile, "$bakbase.bak"; + warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug; + unless (open M, ">$mfile") { + warn "Problem opening $mfile: $!"; + return; + } + print M $_ for (@lines); + close M; + return; +} + +# returns an array containing the lines of an external +# manifest.skip file, if given, or $DEFAULT_MSKIP +sub _include_mskip_file { + my $mskip = shift || $DEFAULT_MSKIP; + unless (-f $mskip) { + warn qq{Included file "$mskip" not found - skipping}; + return; + } + local (*M, $_); + unless (open M, $mskip) { + warn "Problem opening $mskip: $!"; + return; + } + my @lines = (); + push @lines, "\n#!start included $mskip\n"; + push @lines, $_ while <M>; + close M; + push @lines, "#!end included $mskip\n\n"; + return @lines; +} + =item manicopy manicopy(\%src, $dest_dir); @@ -449,7 +525,7 @@ sub cp { copy($srcFile,$dstFile); utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; - _manicopy_chmod($dstFile); + _manicopy_chmod($srcFile, $dstFile); } @@ -458,7 +534,7 @@ sub ln { return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); link($srcFile, $dstFile); - unless( _manicopy_chmod($dstFile) ) { + unless( _manicopy_chmod($srcFile, $dstFile) ) { unlink $dstFile; return; } @@ -469,10 +545,10 @@ sub ln { # 2) Let everyone read it. # 3) If the owner can execute it, everyone can. sub _manicopy_chmod { - my($file) = shift; + my($srcFile, $dstFile) = @_; - my $perm = 0444 | (stat $file)[2] & 0700; - chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $file ); + my $perm = 0444 | (stat $srcFile)[2] & 0700; + chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile ); } # Files that are often modified in the distdir. Don't hard link them. @@ -632,6 +708,26 @@ If no MANIFEST.SKIP file is found, a default set of skips will be used, similar to the example above. If you want nothing skipped, simply make an empty MANIFEST.SKIP file. +In one's own MANIFEST.SKIP file, certain directives +can be used to include the contents of other MANIFEST.SKIP +files. At present two such directives are recognized. + +=over 4 + +=item #!include_default + +This inserts the contents of the default MANIFEST.SKIP file + +=item #!include /Path/to/another/manifest.skip + +This inserts the contents of the specified external file + +=back + +The included contents will be inserted into the MANIFEST.SKIP +file in between I<#!start included /path/to/manifest.skip> +and I<#!end included /path/to/manifest.skip> markers. +The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak. =head2 EXPORT_OK @@ -701,7 +797,9 @@ L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. Andreas Koenig C<andreas.koenig@anima.de> -Currently maintained by Michael G Schwern C<schwern@pobox.com> +Maintained by Michael G Schwern C<schwern@pobox.com> within the +ExtUtils-MakeMaker package and, as a separate CPAN package, by +Randy Kobes C<r.kobes@uwinnipeg.ca>. =cut diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm index ba452fe7ab0..b358709673f 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm @@ -1,11 +1,19 @@ package ExtUtils::Mkbootstrap; -$VERSION = 1.15; +# There's just too much Dynaloader incest here to turn on strict vars. +use strict 'refs'; + +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '6.42'; + +require Exporter; +@ISA = ('Exporter'); +@EXPORT = ('&Mkbootstrap'); use Config; -use Exporter; -@ISA=('Exporter'); -@EXPORT='&Mkbootstrap'; + +use vars qw($Verbose); + sub Mkbootstrap { my($baseext, @bsloadlibs)=@_; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm index 85922abcd8f..49fd6b2abc7 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm @@ -11,7 +11,7 @@ use Config; use vars qw(@ISA @EXPORT $VERSION); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = 1.19; +$VERSION = '6.42'; sub Mksymlists { my(%spec) = @_; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/t/Command.t b/gnu/usr.bin/perl/lib/ExtUtils/t/Command.t deleted file mode 100644 index 22eabe5f98c..00000000000 --- a/gnu/usr.bin/perl/lib/ExtUtils/t/Command.t +++ /dev/null @@ -1,288 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib/'); - } - else { - unshift @INC, 't/lib/'; - } -} -chdir 't'; - -BEGIN { - $Testfile = 'testfile.foo'; -} - -BEGIN { - 1 while unlink $Testfile, 'newfile'; - # forcibly remove ecmddir/temp2, but don't import mkpath - use File::Path (); - File::Path::rmtree( 'ecmddir' ); -} - -BEGIN { - use Test::More tests => 38; - use File::Spec; -} - -BEGIN { - # bad neighbor, but test_f() uses exit() - *CORE::GLOBAL::exit = ''; # quiet 'only once' warning. - *CORE::GLOBAL::exit = sub { return @_ }; - use_ok( 'ExtUtils::Command' ); -} - -{ - # concatenate this file with itself - # be extra careful the regex doesn't match itself - use TieOut; - my $out = tie *STDOUT, 'TieOut'; - my $self = $0; - unless (-f $self) { - my ($vol, $dirs, $file) = File::Spec->splitpath($self); - my @dirs = File::Spec->splitdir($dirs); - unshift(@dirs, File::Spec->updir); - $dirs = File::Spec->catdir(@dirs); - $self = File::Spec->catpath($vol, $dirs, $file); - } - @ARGV = ($self, $self); - - cat(); - is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2, - 'concatenation worked' ); - - # the truth value here is reversed -- Perl true is C false - @ARGV = ( $Testfile ); - ok( test_f(), 'testing non-existent file' ); - - @ARGV = ( $Testfile ); - cmp_ok( ! test_f(), '==', defined (-f $Testfile), 'testing non-existent file' ); - - # these are destructive, have to keep setting @ARGV - @ARGV = ( $Testfile ); - touch(); - - @ARGV = ( $Testfile ); - ok( test_f(), 'now creating that file' ); - is_deeply( \@ARGV, [$Testfile], 'test_f preserves @ARGV' ); - - @ARGV = ( $Testfile ); - ok( -e $ARGV[0], 'created!' ); - - my ($now) = time; - utime ($now, $now, $ARGV[0]); - sleep 2; - - # Just checking modify time stamp, access time stamp is set - # to the beginning of the day in Win95. - # There's a small chance of a 1 second flutter here. - my $stamp = (stat($ARGV[0]))[9]; - cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) || - diag "mtime == $stamp, should be $now"; - - @ARGV = qw(newfile); - touch(); - - my $new_stamp = (stat('newfile'))[9]; - cmp_ok( abs($new_stamp - $stamp), '>=', 2, 'newer file created' ); - - @ARGV = ('newfile', $Testfile); - eqtime(); - - $stamp = (stat($Testfile))[9]; - cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' ); - - # eqtime use to clear the contents of the file being equalized! - open(FILE, ">>$Testfile") || die $!; - print FILE "Foo"; - close FILE; - - @ARGV = ('newfile', $Testfile); - eqtime(); - ok( -s $Testfile, "eqtime doesn't clear the file being equalized" ); - - SKIP: { - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || - $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || - $^O eq 'MacOS' - ) { - skip( "different file permission semantics on $^O", 3); - } - - # change a file to execute-only - @ARGV = ( '0100', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - 0100, 'change a file to execute-only' ); - - # change a file to read-only - @ARGV = ( '0400', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' ); - - # change a file to write-only - @ARGV = ( '0200', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' ); - } - - # change a file to read-write - @ARGV = ( '0600', $Testfile ); - my @orig_argv = @ARGV; - ExtUtils::Command::chmod(); - is_deeply( \@ARGV, \@orig_argv, 'chmod preserves @ARGV' ); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' ); - - - SKIP: { - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || - $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || - $^O eq 'MacOS' - ) { - skip( "different file permission semantics on $^O", 4); - } - - @ARGV = ('testdir'); - mkpath; - ok( -e 'testdir' ); - - # change a dir to execute-only - @ARGV = ( '0100', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - 0100, 'change a dir to execute-only' ); - - # change a dir to read-only - @ARGV = ( '0400', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' ); - - # change a dir to write-only - @ARGV = ( '0200', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' ); - - @ARGV = ('testdir'); - rm_rf; - } - - - # mkpath - @ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) ); - ok( ! -e $ARGV[0], 'temp directory not there yet' ); - - mkpath(); - ok( -e $ARGV[0], 'temp directory created' ); - - # copy a file to a nested subdirectory - unshift @ARGV, $Testfile; - @orig_argv = @ARGV; - cp(); - is_deeply( \@ARGV, \@orig_argv, 'cp preserves @ARGV' ); - - ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' ); - - # cp should croak if destination isn't directory (not a great warning) - @ARGV = ( $Testfile ) x 3; - eval { cp() }; - - like( $@, qr/Too many arguments/, 'cp croaks on error' ); - - # move a file to a subdirectory - @ARGV = ( $Testfile, 'ecmddir' ); - @orig_argv = @ARGV; - ok( mv() ); - is_deeply( \@ARGV, \@orig_argv, 'mv preserves @ARGV' ); - - ok( ! -e $Testfile, 'moved file away' ); - ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' ); - - # mv should also croak with the same wacky warning - @ARGV = ( $Testfile ) x 3; - - eval { mv() }; - like( $@, qr/Too many arguments/, 'mv croaks on error' ); - - # Test expand_wildcards() - { - my $file = $Testfile; - @ARGV = (); - chdir 'ecmddir'; - - # % means 'match one character' on VMS. Everything else is ? - my $match_char = $^O eq 'VMS' ? '%' : '?'; - ($ARGV[0] = $file) =~ s/.\z/$match_char/; - - # this should find the file - ExtUtils::Command::expand_wildcards(); - - is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' ); - - # try it with the asterisk now - ($ARGV[0] = $file) =~ s/.{3}\z/\*/; - ExtUtils::Command::expand_wildcards(); - - is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' ); - - chdir File::Spec->updir; - } - - # remove some files - my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ), - File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) ); - rm_f(); - - ok( ! -e $_, "removed $_ successfully" ) for (@ARGV); - - # rm_f dir - @ARGV = my $dir = File::Spec->catfile( 'ecmddir' ); - rm_rf(); - ok( ! -e $dir, "removed $dir successfully" ); -} - -{ - { local @ARGV = 'd2utest'; mkpath; } - open(FILE, '>d2utest/foo'); - print FILE "stuff\015\012and thing\015\012"; - close FILE; - - open(FILE, '>d2utest/bar'); - binmode(FILE); - my $bin = "\c@\c@\c@\c@\c@\c@\cA\c@\c@\c@\015\012". - "\@\c@\cA\c@\c@\c@8__LIN\015\012"; - print FILE $bin; - close FILE; - - local @ARGV = 'd2utest'; - ExtUtils::Command::dos2unix(); - - open(FILE, 'd2utest/foo'); - is( join('', <FILE>), "stuff\012and thing\012", 'dos2unix' ); - close FILE; - - open(FILE, 'd2utest/bar'); - binmode(FILE); - ok( -B 'd2utest/bar' ); - is( join('', <FILE>), $bin, 'dos2unix preserves binaries'); - close FILE; -} - -END { - 1 while unlink $Testfile, 'newfile'; - File::Path::rmtree( 'ecmddir' ); - File::Path::rmtree( 'd2utest' ); -} diff --git a/gnu/usr.bin/perl/lib/ExtUtils/t/installbase.t b/gnu/usr.bin/perl/lib/ExtUtils/t/installbase.t deleted file mode 100755 index e22c3de5e41..00000000000 --- a/gnu/usr.bin/perl/lib/ExtUtils/t/installbase.t +++ /dev/null @@ -1,81 +0,0 @@ -#!/usr/bin/perl -w - -# Tests INSTALLBASE - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't' if -d 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use File::Path; -use Config; - -use Test::More tests => 21; -use MakeMaker::Test::Utils; -use MakeMaker::Test::Setup::BFD; - -my $Is_VMS = $^O eq 'VMS'; - -my $perl = which_perl(); - -chdir 't'; -perl_lib; - -ok( setup_recurs(), 'setup' ); -END { - ok( chdir File::Spec->updir ); - ok( teardown_recurs(), 'teardown' ); -} - -ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy") || diag("chdir failed; $!"); - -my @mpl_out = run(qq{$perl Makefile.PL "INSTALLBASE=../dummy-install"}); -END { rmtree '../dummy-install'; } - -cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) || - diag(@mpl_out); - -my $makefile = makefile_name(); -ok( grep(/^Writing $makefile for Big::Dummy/, - @mpl_out) == 1, - 'Makefile.PL output looks right'); - -my $make = make_run(); -run("$make"); # this is necessary due to a dmake bug. -my $install_out = run("$make install"); -is( $?, 0, ' make install exited normally' ) || diag $install_out; -like( $install_out, qr/^Installing /m ); -like( $install_out, qr/^Writing /m ); - -ok( -r '../dummy-install', ' install dir created' ); - -my @installed_files = - ('../dummy-install/lib/perl5/Big/Dummy.pm', - '../dummy-install/lib/perl5/Big/Liar.pm', - '../dummy-install/bin/program', - "../dummy-install/lib/perl5/$Config{archname}/perllocal.pod", - "../dummy-install/lib/perl5/$Config{archname}/auto/Big/Dummy/.packlist" - ); - -foreach my $file (@installed_files) { - ok( -e $file, " $file installed" ); - ok( -r $file, " $file readable" ); -} - - -# nmake outputs its damned logo -# Send STDERR off to oblivion. -open(SAVERR, ">&STDERR") or die $!; -open(STDERR, ">".File::Spec->devnull) or die $!; - -my $realclean_out = run("$make realclean"); -is( $?, 0, 'realclean' ) || diag($realclean_out); - -open(STDERR, ">&SAVERR") or die $!; -close SAVERR; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/t/parse_version.t b/gnu/usr.bin/perl/lib/ExtUtils/t/parse_version.t index 74621734334..5575e1a7258 100755 --- a/gnu/usr.bin/perl/lib/ExtUtils/t/parse_version.t +++ b/gnu/usr.bin/perl/lib/ExtUtils/t/parse_version.t @@ -18,7 +18,7 @@ my $Has_Version = eval 'require version; "version"->import; 1'; my %versions = (q[$VERSION = '1.00'] => '1.00', q[*VERSION = \'1.01'] => '1.01', - q[($VERSION) = q$Revision: 1.1.1.2 $ =~ /(\d+)/g;] => 32208, + q[($VERSION) = q$Revision: 1.2 $ =~ /(\d+)/g;] => 32208, q[$FOO::VERSION = '1.10';] => '1.10', q[*FOO::VERSION = \'1.11';] => '1.11', '$VERSION = 0.02' => 0.02, diff --git a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm index 043a6d409dd..972b1b9c53b 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm @@ -1,5 +1,9 @@ package ExtUtils::testlib; -$VERSION = 1.15; + +use strict; + +use vars qw($VERSION); +$VERSION = 6.42; use Cwd; use File::Spec; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/typemap b/gnu/usr.bin/perl/lib/ExtUtils/typemap index 2a53b62abf8..2c35437e34c 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/typemap +++ b/gnu/usr.bin/perl/lib/ExtUtils/typemap @@ -61,22 +61,30 @@ T_SVREF if (SvROK($arg)) $var = (SV*)SvRV($arg); else - Perl_croak(aTHX_ \"$var is not a reference\") + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_AVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) $var = (AV*)SvRV($arg); else - Perl_croak(aTHX_ \"$var is not an array reference\") + Perl_croak(aTHX_ \"%s: %s is not an array reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_HVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV) $var = (HV*)SvRV($arg); else - Perl_croak(aTHX_ \"$var is not a hash reference\") + Perl_croak(aTHX_ \"%s: %s is not a hash reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_CVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) $var = (CV*)SvRV($arg); else - Perl_croak(aTHX_ \"$var is not a code reference\") + Perl_croak(aTHX_ \"%s: %s is not a code reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_SYSRET $var NOT IMPLEMENTED T_UV @@ -119,28 +127,36 @@ T_PTRREF $var = INT2PTR($type,tmp); } else - Perl_croak(aTHX_ \"$var is not a reference\") + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_REF_IV_REF if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type *, tmp); } else - Perl_croak(aTHX_ \"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") T_REF_IV_PTR if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type, tmp); } else - Perl_croak(aTHX_ \"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else - Perl_croak(aTHX_ \"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); @@ -148,21 +164,27 @@ T_PTRDESC $var = ${type}_desc->ptr; } else - Perl_croak(aTHX_ \"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - Perl_croak(aTHX_ \"$var is not a reference\") + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else - Perl_croak(aTHX_ \"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") T_OPAQUE $var = *($type *)SvPV_nolen($arg) T_OPAQUEPTR diff --git a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp index 9be40e64ec6..e4e5b774d82 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp +++ b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp @@ -1,12 +1,54 @@ #!./miniperl +require 5.002; +use ExtUtils::ParseXS qw(process_file); +use Getopt::Long; + +my %args = (); + +my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; + +Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case); + +@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility +GetOptions(\%args, qw(hiertype! + prototypes! + versioncheck! + linenumbers! + optimize! + inout! + argtypes! + object_capi! + except! + v + typemap=s@ + output=s + s=s + csuffix=s + )) + or die $usage; + +if ($args{v}) { + print "xsubpp version $ExtUtils::ParseXS::VERSION\n"; + exit; +} + +@ARGV == 1 or die $usage; + +$args{filename} = shift @ARGV; + +process_file(%args); +exit( ExtUtils::ParseXS::errors() ? 1 : 0 ); + +__END__ + =head1 NAME xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-csuffix csuffix>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs +B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs =head1 DESCRIPTION @@ -23,6 +65,8 @@ typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap +It will also use a default typemap installed as C<ExtUtils::typemap>. + =head1 OPTIONS Note that the C<XSOPT> MakeMaker option may be used to add these options to @@ -30,19 +74,9 @@ any makefiles generated by MakeMaker. =over 5 -=item B<-C++> - -Adds ``extern "C"'' to the C code. - -=item B<-csuffix csuffix> - -Set the suffix used for the generated C or C++ code. Defaults to '.c' -(even with B<-C++>), but some platforms might want to have e.g. '.cpp'. -Don't forget the '.' from the front. - =item B<-hiertype> -Retains '::' in type names so that C++ hierachical types can be mapped. +Retains '::' in type names so that C++ hierarchical types can be mapped. =item B<-except> @@ -54,6 +88,11 @@ Indicates that a user-supplied typemap should take precedence over the default typemaps. This option may be used multiple times, with the last typemap having the highest precedence. +=item B<-output filename> + +Specifies the name of the output file to generate. If no file is +specified, output will be written to standard output. + =item B<-v> Prints the I<xsubpp> version number to standard output, then exits. @@ -88,6 +127,12 @@ Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. Disable recognition of ANSI-like descriptions of function signature. +=item B<-C++> + +Currently doesn't do anything at all. This flag has been a no-op for +many versions of perl, at least as far back as perl5.003_07. It's +allowed here for backwards compatibility. + =back =head1 ENVIRONMENT @@ -96,1813 +141,16 @@ No environment variables are used. =head1 AUTHOR -Larry Wall +Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module +by Ken Williams. =head1 MODIFICATION HISTORY -See the file F<changes.pod>. +See the file F<Changes>. =head1 SEE ALSO -perl(1), perlxs(1), perlxstut(1) +perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS =cut -require 5.002; -use Cwd; -use vars qw($cplusplus $hiertype); -use vars '%v'; - -use Config; - -sub Q ; - -# Global Constants - -$XSUBPP_version = "1.9508"; - -my ($Is_VMS, $SymSet); -if ($^O eq 'VMS') { - $Is_VMS = 1; - # Establish set of global symbols with max length 28, since xsubpp - # will later add the 'XS_' prefix. - require ExtUtils::XSSymSet; - $SymSet = new ExtUtils::XSSymSet 28; -} - -$FH = 'File0000' ; - -$usage = "Usage: xsubpp [-v] [-C++] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; - -$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; - -$except = ""; -$WantPrototypes = -1 ; -$WantVersionChk = 1 ; -$ProtoUsed = 0 ; -$WantLineNumbers = 1 ; -$WantOptimize = 1 ; -$Overload = 0; -$Fallback = 'PL_sv_undef'; - -my $process_inout = 1; -my $process_argtypes = 1; -my $csuffix = '.c'; - -SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { - $flag = shift @ARGV; - $flag =~ s/^-// ; - $spat = quotemeta shift, next SWITCH if $flag eq 's'; - $cplusplus = 1, next SWITCH if $flag eq 'C++'; - $csuffix = shift, next SWITCH if $flag eq 'csuffix'; - $hiertype = 1, next SWITCH if $flag eq 'hiertype'; - $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; - $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; - $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; - $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; - # XXX left this in for compat - next SWITCH if $flag eq 'object_capi'; - $except = " TRY", next SWITCH if $flag eq 'except'; - push(@tm,shift), next SWITCH if $flag eq 'typemap'; - $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; - $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; - $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; - $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; - $process_inout = 0, next SWITCH if $flag eq 'noinout'; - $process_inout = 1, next SWITCH if $flag eq 'inout'; - $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; - $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; - (print "xsubpp version $XSUBPP_version\n"), exit - if $flag eq 'v'; - die $usage; -} -if ($WantPrototypes == -1) - { $WantPrototypes = 0} -else - { $ProtoUsed = 1 } - - -@ARGV == 1 or die $usage; -($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# - or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# - or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# - or ($dir, $filename) = ('.', $ARGV[0]); -chdir($dir); -$pwd = cwd(); - -++ $IncludedFiles{$ARGV[0]} ; - -my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs -my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); - - -sub TrimWhitespace -{ - $_[0] =~ s/^\s+|\s+$//go ; -} - -sub TidyType -{ - local ($_) = @_ ; - - # rationalise any '*' by joining them into bunches and removing whitespace - s#\s*(\*+)\s*#$1#g; - s#(\*+)# $1 #g ; - - # change multiple whitespace into a single space - s/\s+/ /g ; - - # trim leading & trailing whitespace - TrimWhitespace($_) ; - - $_ ; -} - -$typemap = shift @ARGV; -foreach $typemap (@tm) { - die "Can't find $typemap in $pwd\n" unless -r $typemap; -} -unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap - ../../lib/ExtUtils/typemap ../../../typemap ../../typemap - ../typemap typemap); -foreach $typemap (@tm) { - next unless -f $typemap ; - # skip directories, binary files etc. - warn("Warning: ignoring non-text typemap file '$typemap'\n"), next - unless -T $typemap ; - open(TYPEMAP, $typemap) - or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; - $mode = 'Typemap'; - $junk = "" ; - $current = \$junk; - while (<TYPEMAP>) { - next if /^\s*#/; - my $line_no = $. + 1; - if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } - if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } - if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } - if ($mode eq 'Typemap') { - chomp; - my $line = $_ ; - TrimWhitespace($_) ; - # skip blank lines and comment lines - next if /^$/ or /^#/ ; - my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or - warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; - $type = TidyType($type) ; - $type_kind{$type} = $kind ; - # prototype defaults to '$' - $proto = "\$" unless $proto ; - warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") - unless ValidProtoString($proto) ; - $proto_letter{$type} = C_string($proto) ; - } - elsif (/^\s/) { - $$current .= $_; - } - elsif ($mode eq 'Input') { - s/\s+$//; - $input_expr{$_} = ''; - $current = \$input_expr{$_}; - } - else { - s/\s+$//; - $output_expr{$_} = ''; - $current = \$output_expr{$_}; - } - } - close(TYPEMAP); -} - -foreach $key (keys %input_expr) { - $input_expr{$key} =~ s/;*\s+\z//; -} - -$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced -$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast -$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) - -foreach $key (keys %output_expr) { - use re 'eval'; - - my ($t, $with_size, $arg, $sarg) = - ($output_expr{$key} =~ - m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn - \s* \( \s* $cast \$arg \s* , - \s* ( (??{ $bal }) ) # Set from - ( (??{ $size }) )? # Possible sizeof set-from - \) \s* ; \s* $ - ]x); - $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; -} - -$END = "!End!\n\n"; # "impossible" keyword (multiple newline) - -# Match an XS keyword -$BLOCK_re= '\s*(' . join('|', qw( - REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT - CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE - SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK - )) . "|$END)\\s*:"; - -# Input: ($_, @line) == unparsed input. -# Output: ($_, @line) == (rest of line, following lines). -# Return: the matched keyword if found, otherwise 0 -sub check_keyword { - $_ = shift(@line) while !/\S/ && @line; - s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; -} - -my ($C_group_rex, $C_arg); -# Group in C (no support for comments or literals) -$C_group_rex = qr/ [({\[] - (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* - [)}\]] /x ; -# Chunk in C without comma at toplevel (no comments): -$C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) - | (??{ $C_group_rex }) - | " (?: (?> [^\\"]+ ) - | \\. - )* " # String literal - | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal - )* /xs; - -if ($WantLineNumbers) { - { - package xsubpp::counter; - sub TIEHANDLE { - my ($class, $cfile) = @_; - my $buf = ""; - $SECTION_END_MARKER = "#line --- \"$cfile\""; - $line_no = 1; - bless \$buf; - } - - sub PRINT { - my $self = shift; - for (@_) { - $$self .= $_; - while ($$self =~ s/^([^\n]*\n)//) { - my $line = $1; - ++ $line_no; - $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; - print STDOUT $line; - } - } - } - - sub PRINTF { - my $self = shift; - my $fmt = shift; - $self->PRINT(sprintf($fmt, @_)); - } - - sub DESTROY { - # Not necessary if we're careful to end with a "\n" - my $self = shift; - print STDOUT $$self; - } - } - - my $cfile = $filename; - $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; - tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); - select PSEUDO_STDOUT; -} - -sub print_section { - # the "do" is required for right semantics - do { $_ = shift(@line) } while !/\S/ && @line; - - print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") - if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; - for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - print "$_\n"; - } - print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; -} - -sub merge_section { - my $in = ''; - - while (!/\S/ && @line) { - $_ = shift(@line); - } - - for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - $in .= "$_\n"; - } - chomp $in; - return $in; -} - -sub process_keyword($) -{ - my($pattern) = @_ ; - my $kwd ; - - &{"${kwd}_handler"}() - while $kwd = check_keyword($pattern) ; -} - -sub CASE_handler { - blurt ("Error: `CASE:' after unconditional `CASE:'") - if $condnum && $cond eq ''; - $cond = $_; - TrimWhitespace($cond); - print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); - $_ = '' ; -} - -sub INPUT_handler { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - last if /^\s*NOT_IMPLEMENTED_YET/; - next unless /\S/; # skip blank lines - - TrimWhitespace($_) ; - my $line = $_ ; - - # remove trailing semicolon if no initialisation - s/\s*;$//g unless /[=;+].*\S/ ; - - # Process the length(foo) declarations - if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { - print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; - $lengthof{$2} = $name; - # $islengthof{$name} = $1; - $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; - } - - # check for optional initialisation code - my $var_init = '' ; - $var_init = $1 if s/\s*([=;+].*)$//s ; - $var_init =~ s/"/\\"/g; - - s/\s+/ /g; - my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s - or blurt("Error: invalid argument declaration '$line'"), next; - - # Check for duplicate definitions - blurt ("Error: duplicate definition of argument '$var_name' ignored"), next - if $arg_list{$var_name}++ - or defined $argtype_seen{$var_name} and not $processing_arg_with_types; - - $thisdone |= $var_name eq "THIS"; - $retvaldone |= $var_name eq "RETVAL"; - $var_types{$var_name} = $var_type; - # XXXX This check is a safeguard against the unfinished conversion of - # generate_init(). When generate_init() is fixed, - # one can use 2-args map_type() unconditionally. - if ($var_type =~ / \( \s* \* \s* \) /x) { - # Function pointers are not yet supported with &output_init! - print "\t" . &map_type($var_type, $var_name); - $name_printed = 1; - } else { - print "\t" . &map_type($var_type); - $name_printed = 0; - } - $var_num = $args_match{$var_name}; - - $proto_arg[$var_num] = ProtoString($var_type) - if $var_num ; - $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; - if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ - or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ - and $var_init !~ /\S/) { - if ($name_printed) { - print ";\n"; - } else { - print "\t$var_name;\n"; - } - } elsif ($var_init =~ /\S/) { - &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); - } elsif ($var_num) { - # generate initialization code - &generate_init($var_type, $var_num, $var_name, $name_printed); - } else { - print ";\n"; - } - } -} - -sub OUTPUT_handler { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { - $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); - next; - } - my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; - blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next - if $outargs{$outarg} ++ ; - if (!$gotRETVAL and $outarg eq 'RETVAL') { - # deal with RETVAL last - $RETVAL_code = $outcode ; - $gotRETVAL = 1 ; - next ; - } - blurt ("Error: OUTPUT $outarg not an argument"), next - unless defined($args_match{$outarg}); - blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next - unless defined $var_types{$outarg} ; - $var_num = $args_match{$outarg}; - if ($outcode) { - print "\t$outcode\n"; - print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; - } else { - &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); - } - delete $in_out{$outarg} # No need to auto-OUTPUT - if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; - } -} - -sub C_ARGS_handler() { - my $in = merge_section(); - - TrimWhitespace($in); - $func_args = $in; -} - -sub INTERFACE_MACRO_handler() { - my $in = merge_section(); - - TrimWhitespace($in); - if ($in =~ /\s/) { # two - ($interface_macro, $interface_macro_set) = split ' ', $in; - } else { - $interface_macro = $in; - $interface_macro_set = 'UNKNOWN_CVT'; # catch later - } - $interface = 1; # local - $Interfaces = 1; # global -} - -sub INTERFACE_handler() { - my $in = merge_section(); - - TrimWhitespace($in); - - foreach (split /[\s,]+/, $in) { - $Interfaces{$_} = $_; - } - print Q<<"EOF"; -# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); -EOF - $interface = 1; # local - $Interfaces = 1; # global -} - -sub CLEANUP_handler() { print_section() } -sub PREINIT_handler() { print_section() } -sub POSTCALL_handler() { print_section() } -sub INIT_handler() { print_section() } - -sub GetAliases -{ - my ($line) = @_ ; - my ($orig) = $line ; - my ($alias) ; - my ($value) ; - - # Parse alias definitions - # format is - # alias = value alias = value ... - - while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { - $alias = $1 ; - $orig_alias = $alias ; - $value = $2 ; - - # check for optional package definition in the alias - $alias = $Packprefix . $alias if $alias !~ /::/ ; - - # check for duplicate alias name & duplicate value - Warn("Warning: Ignoring duplicate alias '$orig_alias'") - if defined $XsubAliases{$alias} ; - - Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") - if $XsubAliasValues{$value} ; - - $XsubAliases = 1; - $XsubAliases{$alias} = $value ; - $XsubAliasValues{$value} = $orig_alias ; - } - - blurt("Error: Cannot parse ALIAS definitions from '$orig'") - if $line ; -} - -sub ATTRS_handler () -{ - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - push @Attributes, $_; - } -} - -sub ALIAS_handler () -{ - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - GetAliases($_) if $_ ; - } -} - -sub OVERLOAD_handler() -{ - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { - $Overload = 1 unless $Overload; - my $overload = "$Package\::(".$1 ; - push(@InitFileCode, - " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); - } - } - -} - -sub FALLBACK_handler() -{ - # the rest of the current line should contain either TRUE, - # FALSE or UNDEF - - TrimWhitespace($_) ; - my %map = ( - TRUE => "PL_sv_yes", 1 => "PL_sv_yes", - FALSE => "PL_sv_no", 0 => "PL_sv_no", - UNDEF => "PL_sv_undef", - ) ; - - # check for valid FALLBACK value - death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ; - - $Fallback = $map{uc $_} ; -} - -sub REQUIRE_handler () -{ - # the rest of the current line should contain a version number - my ($Ver) = $_ ; - - TrimWhitespace($Ver) ; - - death ("Error: REQUIRE expects a version number") - unless $Ver ; - - # check that the version number is of the form n.n - death ("Error: REQUIRE: expected a number, got '$Ver'") - unless $Ver =~ /^\d+(\.\d*)?/ ; - - death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") - unless $XSUBPP_version >= $Ver ; -} - -sub VERSIONCHECK_handler () -{ - # the rest of the current line should contain either ENABLE or - # DISABLE - - TrimWhitespace($_) ; - - # check for ENABLE/DISABLE - death ("Error: VERSIONCHECK: ENABLE/DISABLE") - unless /^(ENABLE|DISABLE)/i ; - - $WantVersionChk = 1 if $1 eq 'ENABLE' ; - $WantVersionChk = 0 if $1 eq 'DISABLE' ; - -} - -sub PROTOTYPE_handler () -{ - my $specified ; - - death("Error: Only 1 PROTOTYPE definition allowed per xsub") - if $proto_in_this_xsub ++ ; - - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - $specified = 1 ; - TrimWhitespace($_) ; - if ($_ eq 'DISABLE') { - $ProtoThisXSUB = 0 - } - elsif ($_ eq 'ENABLE') { - $ProtoThisXSUB = 1 - } - else { - # remove any whitespace - s/\s+//g ; - death("Error: Invalid prototype '$_'") - unless ValidProtoString($_) ; - $ProtoThisXSUB = C_string($_) ; - } - } - - # If no prototype specified, then assume empty prototype "" - $ProtoThisXSUB = 2 unless $specified ; - - $ProtoUsed = 1 ; - -} - -sub SCOPE_handler () -{ - death("Error: Only 1 SCOPE declaration allowed per xsub") - if $scope_in_this_xsub ++ ; - - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - if ($_ =~ /^DISABLE/i) { - $ScopeThisXSUB = 0 - } - elsif ($_ =~ /^ENABLE/i) { - $ScopeThisXSUB = 1 - } - } - -} - -sub PROTOTYPES_handler () -{ - # the rest of the current line should contain either ENABLE or - # DISABLE - - TrimWhitespace($_) ; - - # check for ENABLE/DISABLE - death ("Error: PROTOTYPES: ENABLE/DISABLE") - unless /^(ENABLE|DISABLE)/i ; - - $WantPrototypes = 1 if $1 eq 'ENABLE' ; - $WantPrototypes = 0 if $1 eq 'DISABLE' ; - $ProtoUsed = 1 ; - -} - -sub INCLUDE_handler () -{ - # the rest of the current line should contain a valid filename - - TrimWhitespace($_) ; - - death("INCLUDE: filename missing") - unless $_ ; - - death("INCLUDE: output pipe is illegal") - if /^\s*\|/ ; - - # simple minded recursion detector - death("INCLUDE loop detected") - if $IncludedFiles{$_} ; - - ++ $IncludedFiles{$_} unless /\|\s*$/ ; - - # Save the current file context. - push(@XSStack, { - type => 'file', - LastLine => $lastline, - LastLineNo => $lastline_no, - Line => \@line, - LineNo => \@line_no, - Filename => $filename, - Handle => $FH, - }) ; - - ++ $FH ; - - # open the new file - open ($FH, "$_") or death("Cannot open '$_': $!") ; - - print Q<<"EOF" ; -# -#/* INCLUDE: Including '$_' from '$filename' */ -# -EOF - - $filename = $_ ; - - # Prime the pump by reading the first - # non-blank line - - # skip leading blank lines - while (<$FH>) { - last unless /^\s*$/ ; - } - - $lastline = $_ ; - $lastline_no = $. ; - -} - -sub PopFile() -{ - return 0 unless $XSStack[-1]{type} eq 'file' ; - - my $data = pop @XSStack ; - my $ThisFile = $filename ; - my $isPipe = ($filename =~ /\|\s*$/) ; - - -- $IncludedFiles{$filename} - unless $isPipe ; - - close $FH ; - - $FH = $data->{Handle} ; - $filename = $data->{Filename} ; - $lastline = $data->{LastLine} ; - $lastline_no = $data->{LastLineNo} ; - @line = @{ $data->{Line} } ; - @line_no = @{ $data->{LineNo} } ; - - if ($isPipe and $? ) { - -- $lastline_no ; - print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; - exit 1 ; - } - - print Q<<"EOF" ; -# -#/* INCLUDE: Returning to '$filename' from '$ThisFile' */ -# -EOF - - return 1 ; -} - -sub ValidProtoString ($) -{ - my($string) = @_ ; - - if ( $string =~ /^$proto_re+$/ ) { - return $string ; - } - - return 0 ; -} - -sub C_string ($) -{ - my($string) = @_ ; - - $string =~ s[\\][\\\\]g ; - $string ; -} - -sub ProtoString ($) -{ - my ($type) = @_ ; - - $proto_letter{$type} or "\$" ; -} - -sub check_cpp { - my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); - if (@cpp) { - my ($cpp, $cpplevel); - for $cpp (@cpp) { - if ($cpp =~ /^\#\s*if/) { - $cpplevel++; - } elsif (!$cpplevel) { - Warn("Warning: #else/elif/endif without #if in this function"); - print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" - if $XSStack[-1]{type} eq 'if'; - return; - } elsif ($cpp =~ /^\#\s*endif/) { - $cpplevel--; - } - } - Warn("Warning: #if without #endif in this function") if $cpplevel; - } -} - - -sub Q { - my($text) = @_; - $text =~ s/^#//gm; - $text =~ s/\[\[/{/g; - $text =~ s/\]\]/}/g; - $text; -} - -open($FH, $filename) or die "cannot open $filename: $!\n"; - -# Identify the version of xsubpp used -print <<EOM ; -/* - * This file was generated automatically by xsubpp version $XSUBPP_version from the - * contents of $filename. Do not edit this file, edit $filename instead. - * - * ANY CHANGES MADE HERE WILL BE LOST! - * - */ - -EOM - - -print("#line 1 \"$filename\"\n") - if $WantLineNumbers; - -firstmodule: -while (<$FH>) { - if (/^=/) { - my $podstartline = $.; - do { - if (/^=cut\s*$/) { - # We can't just write out a /* */ comment, as our embedded - # POD might itself be in a comment. We can't put a /**/ - # comment inside #if 0, as the C standard says that the source - # file is decomposed into preprocessing characters in the stage - # before preprocessing commands are executed. - # I don't want to leave the text as barewords, because the spec - # isn't clear whether macros are expanded before or after - # preprocessing commands are executed, and someone pathological - # may just have defined one of the 3 words as a macro that does - # something strange. Multiline strings are illegal in C, so - # the "" we write must be a string literal. And they aren't - # concatenated until 2 steps later, so we are safe. - print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); - printf("#line %d \"$filename\"\n", $. + 1) - if $WantLineNumbers; - next firstmodule - } - - } while (<$FH>); - # At this point $. is at end of file so die won't state the start - # of the problem, and as we haven't yet read any lines &death won't - # show the correct line in the message either. - die ("Error: Unterminated pod in $filename, line $podstartline\n") - unless $lastline; - } - last if ($Module, $Package, $Prefix) = - /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; - - print $_; -} -&Exit unless defined $_; - -print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; - -$lastline = $_; -$lastline_no = $.; - -# Read next xsub into @line from ($lastline, <$FH>). -sub fetch_para { - # parse paragraph - death ("Error: Unterminated `#if/#ifdef/#ifndef'") - if !defined $lastline && $XSStack[-1]{type} eq 'if'; - @line = (); - @line_no = () ; - return PopFile() if !defined $lastline; - - if ($lastline =~ - /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { - $Module = $1; - $Package = defined($2) ? $2 : ''; # keep -w happy - $Prefix = defined($3) ? $3 : ''; # keep -w happy - $Prefix = quotemeta $Prefix ; - ($Module_cname = $Module) =~ s/\W/_/g; - ($Packid = $Package) =~ tr/:/_/; - $Packprefix = $Package; - $Packprefix .= "::" if $Packprefix ne ""; - $lastline = ""; - } - - for(;;) { - # Skip embedded PODs - while ($lastline =~ /^=/) { - while ($lastline = <$FH>) { - last if ($lastline =~ /^=cut\s*$/); - } - death ("Error: Unterminated pod") unless $lastline; - $lastline = <$FH>; - chomp $lastline; - $lastline =~ s/^\s+$//; - } - if ($lastline !~ /^\s*#/ || - # CPP directives: - # ANSI: if ifdef ifndef elif else endif define undef - # line error pragma - # gcc: warning include_next - # obj-c: import - # others: ident (gcc notes that some cpps have this one) - $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { - last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; - push(@line, $lastline); - push(@line_no, $lastline_no) ; - } - - # Read next line and continuation lines - last unless defined($lastline = <$FH>); - $lastline_no = $.; - my $tmp_line; - $lastline .= $tmp_line - while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); - - chomp $lastline; - $lastline =~ s/^\s+$//; - } - pop(@line), pop(@line_no) while @line && $line[-1] eq ""; - 1; -} - -PARAGRAPH: -while (fetch_para()) { - # Print initial preprocessor statements and blank lines - while (@line && $line[0] !~ /^[^\#]/) { - my $line = shift(@line); - print $line, "\n"; - next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; - my $statement = $+; - if ($statement eq 'if') { - $XSS_work_idx = @XSStack; - push(@XSStack, {type => 'if'}); - } else { - death ("Error: `$statement' with no matching `if'") - if $XSStack[-1]{type} ne 'if'; - if ($XSStack[-1]{varname}) { - push(@InitFileCode, "#endif\n"); - push(@BootCode, "#endif"); - } - - my(@fns) = keys %{$XSStack[-1]{functions}}; - if ($statement ne 'endif') { - # Hide the functions defined in other #if branches, and reset. - @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; - @{$XSStack[-1]}{qw(varname functions)} = ('', {}); - } else { - my($tmp) = pop(@XSStack); - 0 while (--$XSS_work_idx - && $XSStack[$XSS_work_idx]{type} ne 'if'); - # Keep all new defined functions - push(@fns, keys %{$tmp->{other_functions}}); - @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; - } - } - } - - next PARAGRAPH unless @line; - - if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { - # We are inside an #if, but have not yet #defined its xsubpp variable. - print "#define $cpp_next_tmp 1\n\n"; - push(@InitFileCode, "#if $cpp_next_tmp\n"); - push(@BootCode, "#if $cpp_next_tmp"); - $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; - } - - death ("Code is not inside a function" - ." (maybe last function was ended by a blank line " - ." followed by a statement on column one?)") - if $line[0] =~ /^\s/; - - # initialize info arrays - undef(%args_match); - undef(%var_types); - undef(%defaults); - undef($class); - undef($externC); - undef($static); - undef($elipsis); - undef($wantRETVAL) ; - undef($RETVAL_no_return) ; - undef(%arg_list) ; - undef(@proto_arg) ; - undef(@fake_INPUT_pre) ; # For length(s) generated variables - undef(@fake_INPUT) ; - undef($processing_arg_with_types) ; - undef(%argtype_seen) ; - undef(@outlist) ; - undef(%in_out) ; - undef(%lengthof) ; - # undef(%islengthof) ; - undef($proto_in_this_xsub) ; - undef($scope_in_this_xsub) ; - undef($interface); - undef($prepush_done); - $interface_macro = 'XSINTERFACE_FUNC' ; - $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; - $ProtoThisXSUB = $WantPrototypes ; - $ScopeThisXSUB = 0; - $xsreturn = 0; - - $_ = shift(@line); - while ($kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) { - &{"${kwd}_handler"}() ; - next PARAGRAPH unless @line ; - $_ = shift(@line); - } - - if (check_keyword("BOOT")) { - &check_cpp; - push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") - if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; - push (@BootCode, @line, "") ; - next PARAGRAPH ; - } - - - # extract return type, function name and arguments - ($ret_type) = TidyType($_); - $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; - - # Allow one-line ANSI-like declaration - unshift @line, $2 - if $process_argtypes - and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; - - # a function definition needs at least 2 lines - blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH - unless @line ; - - $externC = 1 if $ret_type =~ s/^extern "C"\s+//; - $static = 1 if $ret_type =~ s/^static\s+//; - - $func_header = shift(@line); - blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH - unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; - - ($class, $func_name, $orig_args) = ($1, $2, $3) ; - $class = "$4 $class" if $4; - ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; - ($clean_func_name = $func_name) =~ s/^$Prefix//; - $Full_func_name = "${Packid}_$clean_func_name"; - if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } - - # Check for duplicate function definition - for $tmp (@XSStack) { - next unless defined $tmp->{functions}{$Full_func_name}; - Warn("Warning: duplicate function definition '$clean_func_name' detected"); - last; - } - $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); - $DoSetMagic = 1; - - $orig_args =~ s/\\\s*/ /g; # process line continuations - - my %only_C_inlist; # Not in the signature of Perl function - if ($process_argtypes and $orig_args =~ /\S/) { - my $args = "$orig_args ,"; - if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { - @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); - for ( @args ) { - s/^\s+//; - s/\s+$//; - my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; - my ($pre, $name) = ($arg =~ /(.*?) \s* - \b ( \w+ | length\( \s*\w+\s* \) ) - \s* $ /x); - next unless length $pre; - my $out_type; - my $inout_var; - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { - my $type = $1; - $out_type = $type if $type ne 'IN'; - $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; - $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; - } - my $islength; - if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { - $name = "XSauto_length_of_$1"; - $islength = 1; - die "Default value on length() argument: `$_'" - if length $default; - } - if (length $pre or $islength) { # Has a type - if ($islength) { - push @fake_INPUT_pre, $arg; - } else { - push @fake_INPUT, $arg; - } - # warn "pushing '$arg'\n"; - $argtype_seen{$name}++; - $_ = "$name$default"; # Assigns to @args - } - $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; - push @outlist, $name if $out_type =~ /OUTLIST$/; - $in_out{$name} = $out_type if $out_type; - } - } else { - @args = split(/\s*,\s*/, $orig_args); - Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); - } - } else { - @args = split(/\s*,\s*/, $orig_args); - for (@args) { - if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { - my $out_type = $1; - next if $out_type eq 'IN'; - $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; - push @outlist, $name if $out_type =~ /OUTLIST$/; - $in_out{$_} = $out_type; - } - } - } - if (defined($class)) { - my $arg0 = ((defined($static) or $func_name eq 'new') - ? "CLASS" : "THIS"); - unshift(@args, $arg0); - ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; - } - my $extra_args = 0; - @args_num = (); - $num_args = 0; - my $report_args = ''; - foreach $i (0 .. $#args) { - if ($args[$i] =~ s/\.\.\.//) { - $elipsis = 1; - if ($args[$i] eq '' && $i == $#args) { - $report_args .= ", ..."; - pop(@args); - last; - } - } - if ($only_C_inlist{$args[$i]}) { - push @args_num, undef; - } else { - push @args_num, ++$num_args; - $report_args .= ", $args[$i]"; - } - if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { - $extra_args++; - $args[$i] = $1; - $defaults{$args[$i]} = $2; - $defaults{$args[$i]} =~ s/"/\\"/g; - } - $proto_arg[$i+1] = "\$" ; - } - $min_args = $num_args - $extra_args; - $report_args =~ s/"/\\"/g; - $report_args =~ s/^,\s+//; - my @func_args = @args; - shift @func_args if defined($class); - - for (@func_args) { - s/^/&/ if $in_out{$_}; - } - $func_args = join(", ", @func_args); - @args_match{@args} = @args_num; - - $PPCODE = grep(/^\s*PPCODE\s*:/, @line); - $CODE = grep(/^\s*CODE\s*:/, @line); - # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) - # to set explicit return values. - $EXPLICIT_RETURN = ($CODE && - ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); - $ALIAS = grep(/^\s*ALIAS\s*:/, @line); - $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); - - $xsreturn = 1 if $EXPLICIT_RETURN; - - $externC = $externC ? qq[extern "C"] : ""; - - # print function header - print Q<<"EOF"; -#$externC -#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ -#XS(XS_${Full_func_name}) -#[[ -# dXSARGS; -EOF - print Q<<"EOF" if $ALIAS ; -# dXSI32; -EOF - print Q<<"EOF" if $INTERFACE ; -# dXSFUNCTION($ret_type); -EOF - if ($elipsis) { - $cond = ($min_args ? qq(items < $min_args) : 0); - } - elsif ($min_args == $num_args) { - $cond = qq(items != $min_args); - } - else { - $cond = qq(items < $min_args || items > $num_args); - } - - print Q<<"EOF" if $except; -# char errbuf[1024]; -# *errbuf = '\0'; -EOF - - if ($ALIAS) - { print Q<<"EOF" if $cond } -# if ($cond) -# Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); -EOF - else - { print Q<<"EOF" if $cond } -# if ($cond) -# Perl_croak(aTHX_ "Usage: $pname($report_args)"); -EOF - - #gcc -Wall: if an xsub has no arguments and PPCODE is used - #it is likely none of ST, XSRETURN or XSprePUSH macros are used - #hence `ax' (setup by dXSARGS) is unused - #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS - #but such a move could break third-party extensions - print Q<<"EOF" if $PPCODE and $num_args == 0; -# PERL_UNUSED_VAR(ax); /* -Wall */ -EOF - - print Q<<"EOF" if $PPCODE; -# SP -= items; -EOF - - # Now do a block of some sort. - - $condnum = 0; - $cond = ''; # last CASE: condidional - push(@line, "$END:"); - push(@line_no, $line_no[-1]); - $_ = ''; - &check_cpp; - while (@line) { - &CASE_handler if check_keyword("CASE"); - print Q<<"EOF"; -# $except [[ -EOF - - # do initialization of input variables - $thisdone = 0; - $retvaldone = 0; - $deferred = ""; - %arg_list = () ; - $gotRETVAL = 0; - - INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; - - print Q<<"EOF" if $ScopeThisXSUB; -# ENTER; -# [[ -EOF - - if (!$thisdone && defined($class)) { - if (defined($static) or $func_name eq 'new') { - print "\tchar *"; - $var_types{"CLASS"} = "char *"; - &generate_init("char *", 1, "CLASS"); - } - else { - print "\t$class *"; - $var_types{"THIS"} = "$class *"; - &generate_init("$class *", 1, "THIS"); - } - } - - # do code - if (/^\s*NOT_IMPLEMENTED_YET/) { - print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; - $_ = '' ; - } else { - if ($ret_type ne "void") { - print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" - if !$retvaldone; - $args_match{"RETVAL"} = 0; - $var_types{"RETVAL"} = $ret_type; - print "\tdXSTARG;\n" - if $WantOptimize and $targetable{$type_kind{$ret_type}}; - } - - if (@fake_INPUT or @fake_INPUT_pre) { - unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; - $_ = ""; - $processing_arg_with_types = 1; - INPUT_handler() ; - } - print $deferred; - - process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; - - if (check_keyword("PPCODE")) { - print_section(); - death ("PPCODE must be last thing") if @line; - print "\tLEAVE;\n" if $ScopeThisXSUB; - print "\tPUTBACK;\n\treturn;\n"; - } elsif (check_keyword("CODE")) { - print_section() ; - } elsif (defined($class) and $func_name eq "DESTROY") { - print "\n\t"; - print "delete THIS;\n"; - } else { - print "\n\t"; - if ($ret_type ne "void") { - print "RETVAL = "; - $wantRETVAL = 1; - } - if (defined($static)) { - if ($func_name eq 'new') { - $func_name = "$class"; - } else { - print "${class}::"; - } - } elsif (defined($class)) { - if ($func_name eq 'new') { - $func_name .= " $class"; - } else { - print "THIS->"; - } - } - $func_name =~ s/^($spat)// - if defined($spat); - $func_name = 'XSFUNCTION' if $interface; - print "$func_name($func_args);\n"; - } - } - - # do output variables - $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; - undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); - # $wantRETVAL set if 'RETVAL =' autogenerated - ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; - undef %outargs ; - process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); - - &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) - for grep $in_out{$_} =~ /OUT$/, keys %in_out; - - # all OUTPUT done, so now push the return value on the stack - if ($gotRETVAL && $RETVAL_code) { - print "\t$RETVAL_code\n"; - } elsif ($gotRETVAL || $wantRETVAL) { - my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; - my $var = 'RETVAL'; - my $type = $ret_type; - - # 0: type, 1: with_size, 2: how, 3: how_size - if ($t and not $t->[1] and $t->[0] eq 'p') { - # PUSHp corresponds to setpvn. Treate setpv directly - my $what = eval qq("$t->[2]"); - warn $@ if $@; - - print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; - $prepush_done = 1; - } - elsif ($t) { - my $what = eval qq("$t->[2]"); - warn $@ if $@; - - my $size = $t->[3]; - $size = '' unless defined $size; - $size = eval qq("$size"); - warn $@ if $@; - print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; - $prepush_done = 1; - } - else { - # RETVAL almost never needs SvSETMAGIC() - &generate_output($ret_type, 0, 'RETVAL', 0); - } - } - - $xsreturn = 1 if $ret_type ne "void"; - my $num = $xsreturn; - my $c = @outlist; - # (PP)CODE set different values of SP; reset to PPCODE's with 0 output - print "\tXSprePUSH;" if $c and not $prepush_done; - # Take into account stuff already put on stack - print "\t++SP;" if $c and not $prepush_done and $xsreturn; - # Now SP corresponds to ST($xsreturn), so one can combine PUSH and ST() - print "\tEXTEND(SP,$c);\n" if $c; - $xsreturn += $c; - generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; - - # do cleanup - process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; - - print Q<<"EOF" if $ScopeThisXSUB; -# ]] -EOF - print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; -# LEAVE; -EOF - - # print function trailer - print Q<<EOF; -# ]] -EOF - print Q<<EOF if $except; -# BEGHANDLERS -# CATCHALL -# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); -# ENDHANDLERS -EOF - if (check_keyword("CASE")) { - blurt ("Error: No `CASE:' at top of function") - unless $condnum; - $_ = "CASE: $_"; # Restore CASE: label - next; - } - last if $_ eq "$END:"; - death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); - } - - print Q<<EOF if $except; -# if (errbuf[0]) -# Perl_croak(aTHX_ errbuf); -EOF - - if ($xsreturn) { - print Q<<EOF unless $PPCODE; -# XSRETURN($xsreturn); -EOF - } else { - print Q<<EOF unless $PPCODE; -# XSRETURN_EMPTY; -EOF - } - - print Q<<EOF; -#]] -# -EOF - - my $newXS = "newXS" ; - my $proto = "" ; - - # Build the prototype string for the xsub - if ($ProtoThisXSUB) { - $newXS = "newXSproto"; - - if ($ProtoThisXSUB eq 2) { - # User has specified empty prototype - $proto = ', ""' ; - } - elsif ($ProtoThisXSUB ne 1) { - # User has specified a prototype - $proto = ', "' . $ProtoThisXSUB . '"'; - } - else { - my $s = ';'; - if ($min_args < $num_args) { - $s = ''; - $proto_arg[$min_args] .= ";" ; - } - push @proto_arg, "$s\@" - if $elipsis ; - - $proto = ', "' . join ("", @proto_arg) . '"'; - } - } - - if (%XsubAliases) { - $XsubAliases{$pname} = 0 - unless defined $XsubAliases{$pname} ; - while ( ($name, $value) = each %XsubAliases) { - push(@InitFileCode, Q<<"EOF"); -# cv = newXS(\"$name\", XS_$Full_func_name, file); -# XSANY.any_i32 = $value ; -EOF - push(@InitFileCode, Q<<"EOF") if $proto; -# sv_setpv((SV*)cv$proto) ; -EOF - } - } - elsif (@Attributes) { - push(@InitFileCode, Q<<"EOF"); -# cv = newXS(\"$pname\", XS_$Full_func_name, file); -# apply_attrs_string("$Package", cv, "@Attributes", 0); -EOF - } - elsif ($interface) { - while ( ($name, $value) = each %Interfaces) { - $name = "$Package\::$name" unless $name =~ /::/; - push(@InitFileCode, Q<<"EOF"); -# cv = newXS(\"$name\", XS_$Full_func_name, file); -# $interface_macro_set(cv,$value) ; -EOF - push(@InitFileCode, Q<<"EOF") if $proto; -# sv_setpv((SV*)cv$proto) ; -EOF - } - } - else { - push(@InitFileCode, - " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); - } -} - -if ($Overload) # make it findable with fetchmethod -{ - - print Q<<"EOF"; -#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */ -#XS(XS_${Packid}_nil) -#{ -# XSRETURN_EMPTY; -#} -# -EOF - unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK"); - /* Making a sub named "${Package}::()" allows the package */ - /* to be findable via fetchmethod(), and causes */ - /* overload::Overloaded("${Package}") to return true. */ - newXS("${Package}::()", XS_${Packid}_nil, file$proto); -MAKE_FETCHMETHOD_WORK -} - -# print initialization routine - -print Q<<"EOF"; -##ifdef __cplusplus -#extern "C" -##endif -EOF - -print Q<<"EOF"; -#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ -#XS(boot_$Module_cname) -EOF - -print Q<<"EOF"; -#[[ -# dXSARGS; -EOF - -#-Wall: if there is no $Full_func_name there are no xsubs in this .xs -#so `file' is unused -print Q<<"EOF" if $Full_func_name; -# char* file = __FILE__; -EOF - -print Q "#\n"; - -print Q<<"EOF" if $WantVersionChk ; -# XS_VERSION_BOOTCHECK ; -# -EOF - -print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; -# { -# CV * cv ; -# -EOF - -print Q<<"EOF" if ($Overload); -# /* register the overloading (type 'A') magic */ -# PL_amagic_generation++; -# /* The magic for overload gets a GV* via gv_fetchmeth as */ -# /* mentioned above, and looks in the SV* slot of it for */ -# /* the "fallback" status. */ -# sv_setsv( -# get_sv( "${Package}::()", TRUE ), -# $Fallback -# ); -EOF - -print @InitFileCode; - -print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; -# } -EOF - -if (@BootCode) -{ - print "\n /* Initialisation Section */\n\n" ; - @line = @BootCode; - print_section(); - print "\n /* End of Initialisation Section */\n\n" ; -} - -print Q<<"EOF";; -# XSRETURN_YES; -#]] -# -EOF - -warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") - unless $ProtoUsed ; -&Exit; - -sub output_init { - local($type, $num, $var, $init, $name_printed) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; - - if( $init =~ /^=/ ) { - if ($name_printed) { - eval qq/print " $init\\n"/; - } else { - eval qq/print "\\t$var $init\\n"/; - } - warn $@ if $@; - } else { - if( $init =~ s/^\+// && $num ) { - &generate_init($type, $num, $var, $name_printed); - } elsif ($name_printed) { - print ";\n"; - $init =~ s/^;//; - } else { - eval qq/print "\\t$var;\\n"/; - warn $@ if $@; - $init =~ s/^;//; - } - $deferred .= eval qq/"\\n\\t$init\\n"/; - warn $@ if $@; - } -} - -sub Warn -{ - # work out the line number - my $line_no = $line_no[@line_no - @line -1] ; - - print STDERR "@_ in $filename, line $line_no\n" ; -} - -sub blurt -{ - Warn @_ ; - $errors ++ -} - -sub death -{ - Warn @_ ; - exit 1 ; -} - -sub generate_init { - local($type, $num, $var) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; - local($argoff) = $num - 1; - local($ntype); - local($tk); - - $type = TidyType($type) ; - blurt("Error: '$type' not in typemap"), return - unless defined($type_kind{$type}); - - ($ntype = $type) =~ s/\s*\*/Ptr/g; - ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; - $tk = $type_kind{$type}; - $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; - if ($tk eq 'T_PV' and exists $lengthof{$var}) { - print "\t$var" unless $name_printed; - print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; - die "default value not supported with length(NAME) supplied" - if defined $defaults{$var}; - return; - } - $type =~ tr/:/_/ unless $hiertype; - blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return - unless defined $input_expr{$tk} ; - $expr = $input_expr{$tk}; - if ($expr =~ /DO_ARRAY_ELEM/) { - blurt("Error: '$subtype' not in typemap"), return - unless defined($type_kind{$subtype}); - blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return - unless defined $input_expr{$type_kind{$subtype}} ; - $subexpr = $input_expr{$type_kind{$subtype}}; - $subexpr =~ s/\$type/\$subtype/g; - $subexpr =~ s/ntype/subtype/g; - $subexpr =~ s/\$arg/ST(ix_$var)/g; - $subexpr =~ s/\n\t/\n\t\t/g; - $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; - $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; - $expr =~ s/DO_ARRAY_ELEM/$subexpr/; - } - if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments - $ScopeThisXSUB = 1; - } - if (defined($defaults{$var})) { - $expr =~ s/(\t+)/$1 /g; - $expr =~ s/ /\t/g; - if ($name_printed) { - print ";\n"; - } else { - eval qq/print "\\t$var;\\n"/; - warn $@ if $@; - } - if ($defaults{$var} eq 'NO_INIT') { - $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; - } else { - $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; - } - warn $@ if $@; - } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { - if ($name_printed) { - print ";\n"; - } else { - eval qq/print "\\t$var;\\n"/; - warn $@ if $@; - } - $deferred .= eval qq/"\\n$expr;\\n"/; - warn $@ if $@; - } else { - die "panic: do not know how to handle this branch for function pointers" - if $name_printed; - eval qq/print "$expr;\\n"/; - warn $@ if $@; - } -} - -sub generate_output { - local($type, $num, $var, $do_setmagic, $do_push) = @_; - local($arg) = "ST(" . ($num - ($num != 0)) . ")"; - local($argoff) = $num - 1; - local($ntype); - - $type = TidyType($type) ; - if ($type =~ /^array\(([^,]*),(.*)\)/) { - print "\t$arg = sv_newmortal();\n"; - print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; - print "\tSvSETMAGIC($arg);\n" if $do_setmagic; - } else { - blurt("Error: '$type' not in typemap"), return - unless defined($type_kind{$type}); - blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return - unless defined $output_expr{$type_kind{$type}} ; - ($ntype = $type) =~ s/\s*\*/Ptr/g; - $ntype =~ s/\(\)//g; - ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; - $expr = $output_expr{$type_kind{$type}}; - if ($expr =~ /DO_ARRAY_ELEM/) { - blurt("Error: '$subtype' not in typemap"), return - unless defined($type_kind{$subtype}); - blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return - unless defined $output_expr{$type_kind{$subtype}} ; - $subexpr = $output_expr{$type_kind{$subtype}}; - $subexpr =~ s/ntype/subtype/g; - $subexpr =~ s/\$arg/ST(ix_$var)/g; - $subexpr =~ s/\$var/${var}[ix_$var]/g; - $subexpr =~ s/\n\t/\n\t\t/g; - $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; - } - elsif ($var eq 'RETVAL') { - if ($expr =~ /^\t\$arg = new/) { - # We expect that $arg has refcnt 1, so we need to - # mortalize it. - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tsv_2mortal(ST($num));\n"; - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; - } - elsif ($expr =~ /^\s*\$arg\s*=/) { - # We expect that $arg has refcnt >=1, so we need - # to mortalize it! - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; - } - else { - # Just hope that the entry would safely write it - # over an already mortalized value. By - # coincidence, something like $arg = &sv_undef - # works too. - print "\tST(0) = sv_newmortal();\n"; - eval "print qq\a$expr\a"; - warn $@ if $@; - # new mortals don't have set magic - } - } - elsif ($do_push) { - print "\tPUSHs(sv_newmortal());\n"; - $arg = "ST($num)"; - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tSvSETMAGIC($arg);\n" if $do_setmagic; - } - elsif ($arg =~ /^ST\(\d+\)$/) { - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tSvSETMAGIC($arg);\n" if $do_setmagic; - } - } -} - -sub map_type { - my($type, $varname) = @_; - - # C++ has :: in types too so skip this - $type =~ tr/:/_/ unless $hiertype; - $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; - if ($varname) { - if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { - (substr $type, pos $type, 0) = " $varname "; - } else { - $type .= "\t$varname"; - } - } - $type; -} - - -sub Exit { -# If this is VMS, the exit status has meaning to the shell, so we -# use a predictable value (SS$_Normal or SS$_Abort) rather than an -# arbitrary number. -# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; - exit ($errors ? 1 : 0); -} |