diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/ExtUtils')
57 files changed, 26074 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder.pm new file mode 100644 index 00000000000..7854e88dc94 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder.pm @@ -0,0 +1,331 @@ +package ExtUtils::CBuilder; + +use File::Spec (); +use File::Path (); +use File::Basename (); + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +$VERSION = eval $VERSION; + +# Okay, this is the brute-force method of finding out what kind of +# platform we're on. I don't know of a systematic way. These values +# came from the latest (bleadperl) perlport.pod. + +my %OSTYPES = qw( + aix Unix + bsdos Unix + dgux Unix + dynixptx Unix + freebsd Unix + linux Unix + hpux Unix + irix Unix + darwin Unix + machten Unix + next Unix + openbsd Unix + netbsd Unix + dec_osf Unix + svr4 Unix + svr5 Unix + sco_sv Unix + unicos Unix + unicosmk Unix + solaris Unix + sunos Unix + cygwin Unix + os2 Unix + gnu Unix + gnukfreebsd Unix + haiku Unix + + dos Windows + MSWin32 Windows + + os390 EBCDIC + os400 EBCDIC + posix-bc EBCDIC + vmesa EBCDIC + + MacOS MacOS + VMS VMS + VOS VOS + riscos RiscOS + amigaos Amiga + mpeix MPEiX + ); + +# We only use this once - don't waste a symbol table entry on it. +# More importantly, don't make it an inheritable method. +my $load = sub { + my $mod = shift; + eval "use $mod"; + die $@ if $@; + @ISA = ($mod); +}; + +{ + my @package = split /::/, __PACKAGE__; + + if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) { + $load->(__PACKAGE__ . "::Platform::$^O"); + + } elsif (exists $OSTYPES{$^O} and + grep {-e File::Spec->catfile($_, @package, 'Platform', $OSTYPES{$^O}) . '.pm'} @INC) { + $load->(__PACKAGE__ . "::Platform::$OSTYPES{$^O}"); + + } else { + $load->(__PACKAGE__ . "::Base"); + } +} + +sub os_type { $OSTYPES{$^O} } + +1; +__END__ + +=head1 NAME + +ExtUtils::CBuilder - Compile and link C code for Perl modules + +=head1 SYNOPSIS + + use ExtUtils::CBuilder; + + my $b = ExtUtils::CBuilder->new(%options); + $obj_file = $b->compile(source => 'MyModule.c'); + $lib_file = $b->link(objects => $obj_file); + +=head1 DESCRIPTION + +This module can build the C portions of Perl modules by invoking the +appropriate compilers and linkers in a cross-platform manner. It was +motivated by the C<Module::Build> project, but may be useful for other +purposes as well. However, it is I<not> intended as a general +cross-platform interface to all your C building needs. That would +have been a much more ambitious goal! + +=head1 METHODS + +=over 4 + +=item new + +Returns a new C<ExtUtils::CBuilder> object. A C<config> parameter +lets you override C<Config.pm> settings for all operations performed +by the object, as in the following example: + + # Use a different compiler than Config.pm says + my $b = ExtUtils::CBuilder->new( config => + { ld => 'gcc' } ); + +A C<quiet> parameter tells C<CBuilder> to not print its C<system()> +commands before executing them: + + # Be quieter than normal + my $b = ExtUtils::CBuilder->new( quiet => 1 ); + +=item have_compiler + +Returns true if the current system has a working C compiler and +linker, false otherwise. To determine this, we actually compile and +link a sample C library. The sample will be compiled in the system +tempdir or, if that fails for some reason, in the current directory. + +=item have_cplusplus + +Just like have_compiler but for C++ instead of C. + +=item compile + +Compiles a C source file and produces an object file. The name of the +object file is returned. The source file is specified in a C<source> +parameter, which is required; the other parameters listed below are +optional. + +=over 4 + +=item C<object_file> + +Specifies the name of the output file to create. Otherwise the +C<object_file()> method will be consulted, passing it the name of the +C<source> file. + +=item C<include_dirs> + +Specifies any additional directories in which to search for header +files. May be given as a string indicating a single directory, or as +a list reference indicating multiple directories. + +=item C<extra_compiler_flags> + +Specifies any additional arguments to pass to the compiler. Should be +given as a list reference containing the arguments individually, or if +this is not possible, as a string containing all the arguments +together. + +=item C<C++> + +Specifies that the source file is a C++ source file and sets appropriate +compiler flags + +=back + +The operation of this method is also affected by the +C<archlibexp>, C<cccdlflags>, C<ccflags>, C<optimize>, and C<cc> +entries in C<Config.pm>. + +=item link + +Invokes the linker to produce a library file from object files. In +scalar context, the name of the library file is returned. In list +context, the library file and any temporary files created are +returned. A required C<objects> parameter contains the name of the +object files to process, either in a string (for one object file) or +list reference (for one or more files). The following parameters are +optional: + + +=over 4 + +=item lib_file + +Specifies the name of the output library file to create. Otherwise +the C<lib_file()> method will be consulted, passing it the name of +the first entry in C<objects>. + +=item module_name + +Specifies the name of the Perl module that will be created by linking. +On platforms that need to do prelinking (Win32, OS/2, etc.) this is a +required parameter. + +=item extra_linker_flags + +Any additional flags you wish to pass to the linker. + +=back + +On platforms where C<need_prelink()> returns true, C<prelink()> +will be called automatically. + +The operation of this method is also affected by the C<lddlflags>, +C<shrpenv>, and C<ld> entries in C<Config.pm>. + +=item link_executable + +Invokes the linker to produce an executable file from object files. In +scalar context, the name of the executable file is returned. In list +context, the executable file and any temporary files created are +returned. A required C<objects> parameter contains the name of the +object files to process, either in a string (for one object file) or +list reference (for one or more files). The optional parameters are +the same as C<link> with exception for + + +=over 4 + +=item exe_file + +Specifies the name of the output executable file to create. Otherwise +the C<exe_file()> method will be consulted, passing it the name of the +first entry in C<objects>. + +=back + +=item object_file + + my $object_file = $b->object_file($source_file); + +Converts the name of a C source file to the most natural name of an +output object file to create from it. For instance, on Unix the +source file F<foo.c> would result in the object file F<foo.o>. + +=item lib_file + + my $lib_file = $b->lib_file($object_file); + +Converts the name of an object file to the most natural name of a +output library file to create from it. For instance, on Mac OS X the +object file F<foo.o> would result in the library file F<foo.bundle>. + +=item exe_file + + my $exe_file = $b->exe_file($object_file); + +Converts the name of an object file to the most natural name of an +executable file to create from it. For instance, on Mac OS X the +object file F<foo.o> would result in the executable file F<foo>, and +on Windows it would result in F<foo.exe>. + + +=item prelink + +On certain platforms like Win32, OS/2, VMS, and AIX, it is necessary +to perform some actions before invoking the linker. The +C<ExtUtils::Mksymlists> module does this, writing files used by the +linker during the creation of shared libraries for dynamic extensions. +The names of any files written will be returned as a list. + +Several parameters correspond to C<ExtUtils::Mksymlists::Mksymlists()> +options, as follows: + + Mksymlists() prelink() type + -------------|-------------------|------------------- + NAME | dl_name | string (required) + DLBASE | dl_base | string + FILE | dl_file | string + DL_VARS | dl_vars | array reference + DL_FUNCS | dl_funcs | hash reference + FUNCLIST | dl_func_list | array reference + IMPORTS | dl_imports | hash reference + VERSION | dl_version | string + +Please see the documentation for C<ExtUtils::Mksymlists> for the +details of what these parameters do. + +=item need_prelink + +Returns true on platforms where C<prelink()> should be called +during linking, and false otherwise. + +=item extra_link_args_after_prelink + +Returns list of extra arguments to give to the link command; the arguments +are the same as for prelink(), with addition of array reference to the +results of prelink(); this reference is indexed by key C<prelink_res>. + +=back + +=head1 TO DO + +Currently this has only been tested on Unix and doesn't contain any of +the Windows-specific code from the C<Module::Build> project. I'll do +that next. + +=head1 HISTORY + +This module is an outgrowth of the C<Module::Build> project, to which +there have been many contributors. Notably, Randy W. Sims submitted +lots of code to support 3 compilers on Windows and helped with various +other platform-specific issues. Ilya Zakharevich has contributed +fixes for OS/2; John E. Malmberg and Peter Prymmer have done likewise +for VMS. + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 COPYRIGHT + +Copyright (c) 2003-2005 Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +perl(1), Module::Build(3) + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Base.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Base.pm new file mode 100644 index 00000000000..28036c61bdc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Base.pm @@ -0,0 +1,307 @@ +package ExtUtils::CBuilder::Base; + +use strict; +use File::Spec; +use File::Basename; +use Cwd (); +use Config; +use Text::ParseWords; +use IO::File; + +use vars qw($VERSION); +$VERSION = '0.27'; + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + + $self->{properties}{perl} = $class->find_perl_interpreter + or warn "Warning: Can't locate your perl binary"; + + while (my ($k,$v) = each %Config) { + $self->{config}{$k} = $v unless exists $self->{config}{$k}; + } + $self->{config}{cc} = $ENV{CC} if exists $ENV{CC}; + return $self; +} + +sub find_perl_interpreter { + my $perl; + File::Spec->file_name_is_absolute($perl = $^X) + or -f ($perl = $Config::Config{perlpath}) + or ($perl = $^X); + return $perl; +} + +sub add_to_cleanup { + my $self = shift; + foreach (@_) { + $self->{files_to_clean}{$_} = 1; + } +} + +sub cleanup { + my $self = shift; + foreach my $file (keys %{$self->{files_to_clean}}) { + unlink $file; + } +} + +sub object_file { + my ($self, $filename) = @_; + + # File name, minus the suffix + (my $file_base = $filename) =~ s/\.[^.]+$//; + return "$file_base$self->{config}{obj_ext}"; +} + +sub arg_include_dirs { + my $self = shift; + return map {"-I$_"} @_; +} + +sub arg_nolink { '-c' } + +sub arg_object_file { + my ($self, $file) = @_; + return ('-o', $file); +} + +sub arg_share_object_file { + my ($self, $file) = @_; + return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file); +} + +sub arg_exec_file { + my ($self, $file) = @_; + return ('-o', $file); +} + +sub arg_defines { + my ($self, %args) = @_; + return map "-D$_=$args{$_}", keys %args; +} + +sub compile { + my ($self, %args) = @_; + die "Missing 'source' argument to compile()" unless defined $args{source}; + + my $cf = $self->{config}; # For convenience + + $args{object_file} ||= $self->object_file($args{source}); + + my @include_dirs = $self->arg_include_dirs + (@{$args{include_dirs} || []}, + $self->perl_inc()); + + my @defines = $self->arg_defines( %{$args{defines} || {}} ); + + my @extra_compiler_flags = $self->split_like_shell($args{extra_compiler_flags}); + my @cccdlflags = $self->split_like_shell($cf->{cccdlflags}); + my @ccflags = $self->split_like_shell($cf->{ccflags}); + push @ccflags, qw/-x c++/ if $args{'C++'}; + my @optimize = $self->split_like_shell($cf->{optimize}); + my @flags = (@include_dirs, @defines, @cccdlflags, @extra_compiler_flags, + $self->arg_nolink, + @ccflags, @optimize, + $self->arg_object_file($args{object_file}), + ); + + my @cc = $self->split_like_shell($cf->{cc}); + + $self->do_system(@cc, @flags, $args{source}) + or die "error building $args{object_file} from '$args{source}'"; + + return $args{object_file}; +} + +sub have_compiler { + my ($self, $is_cplusplus) = @_; + return $self->{have_compiler} if defined $self->{have_compiler}; + + my $result; + my $attempts = 3; + # tmpdir has issues for some people so fall back to current dir + DIR: for my $dir ( File::Spec->tmpdir, '.' ) { + + # don't clobber existing files (rare, but possible) + my $rand = int(rand(2**31)); + my $tmpfile = File::Spec->catfile($dir, "compilet-$rand.c"); + $tmpfile .= "c" if $is_cplusplus; + if ( -e $tmpfile ) { + redo DIR if $attempts--; + next DIR; + } + + { + my $FH = IO::File->new("> $tmpfile") or die "Can't create $tmpfile: $!"; + if ( $is_cplusplus ) { + print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; + } + else { + print $FH "int boot_compilet() { return 1; }\n"; + } + } + + my ($obj_file, @lib_files); + eval { + local $^W = 0; + local $self->{quiet} = 1; + $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile); + @lib_files = $self->link(objects => $obj_file, module_name => 'compilet'); + }; + $result = $@ ? 0 : 1; + + foreach (grep defined, $tmpfile, $obj_file, @lib_files) { + 1 while unlink; + } + last DIR if $result; + } + + return $self->{have_compiler} = $result; +} + +sub have_cplusplus { + push @_, 1; + goto &have_compiler; +} + +sub lib_file { + my ($self, $dl_file) = @_; + $dl_file =~ s/\.[^.]+$//; + $dl_file =~ tr/"//d; + return "$dl_file.$self->{config}{dlext}"; +} + + +sub exe_file { + my ($self, $dl_file) = @_; + $dl_file =~ s/\.[^.]+$//; + $dl_file =~ tr/"//d; + return "$dl_file$self->{config}{_exe}"; +} + +sub need_prelink { 0 } + +sub extra_link_args_after_prelink { return } + +sub prelink { + my ($self, %args) = @_; + + ($args{dl_file} = $args{dl_name}) =~ s/.*::// unless $args{dl_file}; + + require ExtUtils::Mksymlists; + ExtUtils::Mksymlists::Mksymlists( # dl. abbrev for dynamic library + DL_VARS => $args{dl_vars} || [], + DL_FUNCS => $args{dl_funcs} || {}, + FUNCLIST => $args{dl_func_list} || [], + IMPORTS => $args{dl_imports} || {}, + NAME => $args{dl_name}, # Name of the Perl module + DLBASE => $args{dl_base}, # Basename of DLL file + FILE => $args{dl_file}, # Dir + Basename of symlist file + VERSION => (defined $args{dl_version} ? $args{dl_version} : '0.0'), + ); + + # Mksymlists will create one of these files + return grep -e, map "$args{dl_file}.$_", qw(ext def opt); +} + +sub link { + my ($self, %args) = @_; + return $self->_do_link('lib_file', lddl => 1, %args); +} + +sub link_executable { + my ($self, %args) = @_; + return $self->_do_link('exe_file', lddl => 0, %args); +} + +sub _do_link { + my ($self, $type, %args) = @_; + + my $cf = $self->{config}; # For convenience + + my $objects = delete $args{objects}; + $objects = [$objects] unless ref $objects; + my $out = $args{$type} || $self->$type($objects->[0]); + + my @temp_files; + @temp_files = + $self->prelink(%args, + dl_name => $args{module_name}) if $args{lddl} && $self->need_prelink; + + my @linker_flags = ($self->split_like_shell($args{extra_linker_flags}), + $self->extra_link_args_after_prelink(%args, dl_name => $args{module_name}, + prelink_res => \@temp_files)); + + my @output = $args{lddl} ? $self->arg_share_object_file($out) : $self->arg_exec_file($out); + my @shrp = $self->split_like_shell($cf->{shrpenv}); + my @ld = $self->split_like_shell($cf->{ld}); + + $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags) + or die "error building $out from @$objects"; + + return wantarray ? ($out, @temp_files) : $out; +} + + +sub do_system { + my ($self, @cmd) = @_; + print "@cmd\n" if !$self->{quiet}; + return !system(@cmd); +} + +sub split_like_shell { + my ($self, $string) = @_; + + return () unless defined($string); + return @$string if UNIVERSAL::isa($string, 'ARRAY'); + $string =~ s/^\s+|\s+$//g; + return () unless length($string); + + return Text::ParseWords::shellwords($string); +} + +# if building perl, perl's main source directory +sub perl_src { + # N.B. makemaker actually searches regardless of PERL_CORE, but + # only squawks at not finding it if PERL_CORE is set + + return unless $ENV{PERL_CORE}; + + my $Updir = File::Spec->updir; + my $dir = File::Spec->curdir; + + # Try up to 5 levels upwards + for (0..10) { + if ( + -f File::Spec->catfile($dir,"config_h.SH") + && + -f File::Spec->catfile($dir,"perl.h") + && + -f File::Spec->catfile($dir,"lib","Exporter.pm") + ) { + return Cwd::realpath( $dir ); + } + + $dir = File::Spec->catdir($dir, $Updir); + } + + warn "PERL_CORE is set but I can't find your perl source!\n"; + return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ??? +} + +# directory of perl's include files +sub perl_inc { + my $self = shift; + + $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE"); +} + +sub DESTROY { + my $self = shift; + local($., $@, $!, $^E, $?); + $self->cleanup(); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Unix.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Unix.pm new file mode 100644 index 00000000000..78ff244b5ba --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -0,0 +1,40 @@ +package ExtUtils::CBuilder::Platform::Unix; + +use strict; +use ExtUtils::CBuilder::Base; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Base); + +sub link_executable { + my $self = shift; + + # On some platforms (which ones??) $Config{cc} seems to be a better + # bet for linking executables than $Config{ld}. Cygwin is a notable + # exception. + local $self->{config}{ld} = + $self->{config}{cc} . " " . $self->{config}{ldflags}; + return $self->SUPER::link_executable(@_); +} + +sub link { + my $self = shift; + my $cf = $self->{config}; + + # Some platforms (notably Mac OS X 10.3, but some others too) expect + # the syntax "FOO=BAR /bin/command arg arg" to work in %Config + # (notably $Config{ld}). It usually works in system(SCALAR), but we + # use system(LIST). We fix it up here with 'env'. + + local $cf->{ld} = $cf->{ld}; + if (ref $cf->{ld}) { + unshift @{$cf->{ld}}, 'env' if $cf->{ld}[0] =~ /^\s*\w+=/; + } else { + $cf->{ld} =~ s/^(\s*\w+=)/env $1/; + } + + return $self->SUPER::link(@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/VMS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/VMS.pm new file mode 100644 index 00000000000..35a2eba550b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -0,0 +1,294 @@ +package ExtUtils::CBuilder::Platform::VMS; + +use strict; +use ExtUtils::CBuilder::Base; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Base); + +use File::Spec::Functions qw(catfile catdir); + +# We do prelink, but don't want the parent to redo it. + +sub need_prelink { 0 } + +sub arg_defines { + my ($self, %args) = @_; + + s/"/""/g foreach values %args; + + my @config_defines; + + # VMS can only have one define qualifier; add the one from config, if any. + if ($self->{config}{ccflags} =~ s{/ def[^=]+ =+ \(? ([^\/\)]*) } {}ix) { + push @config_defines, $1; + } + + return '' unless keys(%args) || @config_defines; + + return ('/define=(' + . join(',', + @config_defines, + map "\"$_" . ( length($args{$_}) ? "=$args{$_}" : '') . "\"", + keys %args) + . ')'); +} + +sub arg_include_dirs { + my ($self, @dirs) = @_; + + # VMS can only have one include list, add the one from config. + if ($self->{config}{ccflags} =~ s{/inc[^=]+(?:=)+(?:\()?([^\/\)]*)} {}i) { + unshift @dirs, $1; + } + return unless @dirs; + + return ('/include=(' . join(',', @dirs) . ')'); +} + +sub _do_link { + my ($self, $type, %args) = @_; + + my $objects = delete $args{objects}; + $objects = [$objects] unless ref $objects; + + if ($args{lddl}) { + + # prelink will call Mksymlists, which creates the extension-specific + # linker options file and populates it with the boot symbol. + + my @temp_files = $self->prelink(%args, dl_name => $args{module_name}); + + # We now add the rest of what we need to the linker options file. We + # should replicate the functionality of C<ExtUtils::MM_VMS::dlsyms>, + # but there is as yet no infrastructure for handling object libraries, + # so for now we depend on object files being listed individually on the + # command line, which should work for simple cases. We do bring in our + # own version of C<ExtUtils::Liblist::Kid::ext> so that any additional + # libraries (including PERLSHR) can be added to the options file. + + my @optlibs = $self->_liblist_ext( $args{'libs'} ); + + my $optfile = 'sys$disk:[]' . $temp_files[0]; + open my $opt_fh, '>>', $optfile + or die "_do_link: Unable to open $optfile: $!"; + for my $lib (@optlibs) {print $opt_fh "$lib\n" if length $lib } + close $opt_fh; + + $objects->[-1] .= ','; + push @$objects, $optfile . '/OPTIONS,'; + + # This one not needed for DEC C, but leave for completeness. + push @$objects, $self->perl_inc() . 'perlshr_attr.opt/OPTIONS'; + } + + return $self->SUPER::_do_link($type, %args, objects => $objects); +} + +sub arg_nolink { return; } + +sub arg_object_file { + my ($self, $file) = @_; + return "/obj=$file"; +} + +sub arg_exec_file { + my ($self, $file) = @_; + return ("/exe=$file"); +} + +sub arg_share_object_file { + my ($self, $file) = @_; + return ("$self->{config}{lddlflags}=$file"); +} + + +sub lib_file { + my ($self, $dl_file) = @_; + $dl_file =~ s/\.[^.]+$//; + $dl_file =~ tr/"//d; + $dl_file = $dl_file .= '.' . $self->{config}{dlext}; + + # Need to create with the same name as DynaLoader will load with. + if (defined &DynaLoader::mod2fname) { + my ($dev,$dir,$file) = File::Spec->splitpath($dl_file); + $file = DynaLoader::mod2fname([$file]); + $dl_file = File::Spec->catpath($dev,$dir,$file); + } + return $dl_file; +} + +# The following is reproduced almost verbatim from ExtUtils::Liblist::Kid::_vms_ext. +# We can't just call that because it's tied up with the MakeMaker object hierarchy. + +sub _liblist_ext { + my($self, $potential_libs,$verbose,$give_libs) = @_; + $verbose ||= 0; + + my(@crtls,$crtlstr); + @crtls = ( ($self->{'config'}{'ldflags'} =~ m-/Debug-i ? $self->{'config'}{'dbgprefix'} : '') + . 'PerlShr/Share' ); + push(@crtls, grep { not /\(/ } split /\s+/, $self->{'config'}{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $self->{'config'}{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to ensure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ($self->perl_src) { + my($lib,$locspec,$type); + foreach $lib (@crtls) { + if (($locspec,$type) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i) { + if (lc $type eq '/share') { $locspec .= $self->{'config'}{'exe_ext'}; } + elsif (lc $type eq '/library') { $locspec .= $self->{'config'}{'lib_ext'}; } + else { $locspec .= $self->{'config'}{'obj_ext'}; } + $locspec = catfile($self->perl_src, $locspec); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join(' ',@crtls) : ''; + + unless ($potential_libs) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); + } + + my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @{$self->{'config'}}{'so','lib_ext','obj_ext'}; + # List of common Unix library names and their VMS equivalents + # (VMS equivalent of '' indicates that the library is automatically + # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($self->{'config'}{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$self->{'config'}{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if (!File::Spec->file_name_is_absolute($dir)) { + $dir = catdir($cwd,$dir); + } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + warn "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + my($fullname, $name); + + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + $fullname = VMS::Filespec::rmsexpand($name); + if (defined $fullname and -f $fullname) { + # It's got its own suffix, so we'll have to figure out the type + if ($fullname =~ /(?:$so|exe)$/i) { $type = 'SHR'; } + elsif ($fullname =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; } + elsif ($fullname =~ /(?:$obj_ext|obj)$/i) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + } + else { + warn "Note (probably harmless): " + ."Unknown library type for $fullname; assuming shared\n"; + $type = 'SHR'; + } + } + elsif (-f ($fullname = VMS::Filespec::rmsexpand($name,$so)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'SHR'; + $name = $fullname unless $fullname =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'OLB'; + $name = $fullname unless $fullname =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.obj')))) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + $name = $fullname unless $fullname =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'SHR'; + } + } + if ($ctype) { + # This has to precede any other CRTLs, so just make it first + if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } + else { push @{$found{$ctype}}, $cand; } + warn "\tFound as $cand (really $fullname), type $ctype\n" + if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; + next LIB; + } + } + warn "Note (probably harmless): " + ."No library found for $lib\n"; + } + + push @fndlibs, @{$found{OBJ}} if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR}; + $lib = join(' ',@fndlibs); + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows.pm new file mode 100644 index 00000000000..f0b98dbaa30 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -0,0 +1,288 @@ +package ExtUtils::CBuilder::Platform::Windows; + +use strict; +use warnings; + +use File::Basename; +use File::Spec; + +use ExtUtils::CBuilder::Base; +use IO::File; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Base); + +=begin comment + +The compiler-specific packages implement functions for generating properly +formatted commandlines for the compiler being used. Each package +defines two primary functions 'format_linker_cmd()' & +'format_compiler_cmd()' that accepts a list of named arguments (a +hash) and returns a list of formatted options suitable for invoking the +compiler. By default, if the compiler supports scripting of its +operation then a script file is built containing the options while +those options are removed from the commandline, and a reference to the +script is pushed onto the commandline in their place. Scripting the +compiler in this way helps to avoid the problems associated with long +commandlines under some shells. + +=end comment + +=cut + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + my $cf = $self->{config}; + + # Inherit from an appropriate compiler driver class + my $driver = "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type; + eval "require $driver" or die "Could not load compiler driver: $@"; + unshift @ISA, $driver; + + return $self; +} + +sub _compiler_type { + my $self = shift; + my $cc = $self->{config}{cc}; + + return ( $cc =~ /cl(\.exe)?$/ ? 'MSVC' + : $cc =~ /bcc32(\.exe)?$/ ? 'BCC' + : 'GCC'); +} + +sub split_like_shell { + # Since Windows will pass the whole command string (not an argument + # array) to the target program and make the program parse it itself, + # we don't actually need to do any processing here. + (my $self, local $_) = @_; + + return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY'); + return unless defined() && length(); + return ($_); +} + +sub do_system { + # See above + my $self = shift; + my $cmd = join(" ", + grep length, + map {$a=$_;$a=~s/\t/ /g;$a=~s/^\s+|\s+$//;$a} + grep defined, @_); + return $self->SUPER::do_system($cmd); +} + +sub arg_defines { + my ($self, %args) = @_; + s/"/\\"/g foreach values %args; + return map qq{"-D$_=$args{$_}"}, keys %args; +} + +sub compile { + my ($self, %args) = @_; + my $cf = $self->{config}; + + die "Missing 'source' argument to compile()" unless defined $args{source}; + + my ($basename, $srcdir) = + ( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1]; + + $srcdir ||= File::Spec->curdir(); + + my @defines = $self->arg_defines( %{ $args{defines} || {} } ); + + my %spec = ( + srcdir => $srcdir, + builddir => $srcdir, + basename => $basename, + source => $args{source}, + output => File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext}, + cc => $cf->{cc}, + cflags => [ + $self->split_like_shell($cf->{ccflags}), + $self->split_like_shell($cf->{cccdlflags}), + $self->split_like_shell($args{extra_compiler_flags}), + ], + optimize => [ $self->split_like_shell($cf->{optimize}) ], + defines => \@defines, + includes => [ @{$args{include_dirs} || []} ], + perlinc => [ + $self->perl_inc(), + $self->split_like_shell($cf->{incpath}), + ], + use_scripts => 1, # XXX provide user option to change this??? + ); + + $self->normalize_filespecs( + \$spec{source}, + \$spec{output}, + $spec{includes}, + $spec{perlinc}, + ); + + my @cmds = $self->format_compiler_cmd(%spec); + while ( my $cmd = shift @cmds ) { + $self->do_system( @$cmd ) + or die "error building $cf->{dlext} file from '$args{source}'"; + } + + (my $out = $spec{output}) =~ tr/'"//d; + return $out; +} + +sub need_prelink { 1 } + +sub link { + my ($self, %args) = @_; + my $cf = $self->{config}; + + my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} ); + my $to = join '', (File::Spec->splitpath($objects[0]))[0,1]; + $to ||= File::Spec->curdir(); + + (my $file_base = $args{module_name}) =~ s/.*:://; + my $output = $args{lib_file} || + File::Spec->catfile($to, "$file_base.$cf->{dlext}"); + + # if running in perl source tree, look for libs there, not installed + my $lddlflags = $cf->{lddlflags}; + my $perl_src = $self->perl_src(); + $lddlflags =~ s/\Q$cf->{archlibexp}\E[\\\/]CORE/$perl_src/ if $perl_src; + + my %spec = ( + srcdir => $to, + builddir => $to, + startup => [ ], + objects => \@objects, + libs => [ ], + output => $output, + ld => $cf->{ld}, + libperl => $cf->{libperl}, + perllibs => [ $self->split_like_shell($cf->{perllibs}) ], + libpath => [ $self->split_like_shell($cf->{libpth}) ], + lddlflags => [ $self->split_like_shell($lddlflags) ], + other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} || '') ], + use_scripts => 1, # XXX provide user option to change this??? + ); + + unless ( $spec{basename} ) { + ($spec{basename} = $args{module_name}) =~ s/.*:://; + } + + $spec{srcdir} = File::Spec->canonpath( $spec{srcdir} ); + $spec{builddir} = File::Spec->canonpath( $spec{builddir} ); + + $spec{output} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.'.$cf->{dlext} ); + $spec{manifest} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.'.$cf->{dlext}.'.manifest'); + $spec{implib} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . $cf->{lib_ext} ); + $spec{explib} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.exp' ); + if ($cf->{cc} eq 'cl') { + $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.pdb' ); + } + elsif ($cf->{cc} eq 'bcc32') { + $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.tds' ); + } + $spec{def_file} ||= File::Spec->catfile( $spec{srcdir} , + $spec{basename} . '.def' ); + $spec{base_file} ||= File::Spec->catfile( $spec{srcdir} , + $spec{basename} . '.base' ); + + $self->add_to_cleanup( + grep defined, + @{[ @spec{qw(manifest implib explib dbg_file def_file base_file map_file)} ]} + ); + + foreach my $opt ( qw(output manifest implib explib dbg_file def_file map_file base_file) ) { + $self->normalize_filespecs( \$spec{$opt} ); + } + + foreach my $opt ( qw(libpath startup objects) ) { + $self->normalize_filespecs( $spec{$opt} ); + } + + (my $def_base = $spec{def_file}) =~ tr/'"//d; + $def_base =~ s/\.def$//; + $self->prelink( dl_name => $args{module_name}, + dl_file => $def_base, + dl_base => $spec{basename} ); + + my @cmds = $self->format_linker_cmd(%spec); + while ( my $cmd = shift @cmds ) { + $self->do_system( @$cmd ); + } + + $spec{output} =~ tr/'"//d; + return wantarray + ? grep defined, @spec{qw[output manifest implib explib dbg_file def_file map_file base_file]} + : $spec{output}; +} + +# canonize & quote paths +sub normalize_filespecs { + my ($self, @specs) = @_; + foreach my $spec ( grep defined, @specs ) { + if ( ref $spec eq 'ARRAY') { + $self->normalize_filespecs( map {\$_} grep defined, @$spec ) + } elsif ( ref $spec eq 'SCALAR' ) { + $$spec =~ tr/"//d if $$spec; + next unless $$spec; + $$spec = '"' . File::Spec->canonpath($$spec) . '"'; + } elsif ( ref $spec eq '' ) { + $spec = '"' . File::Spec->canonpath($spec) . '"'; + } else { + die "Don't know how to normalize " . (ref $spec || $spec) . "\n"; + } + } +} + +# directory of perl's include files +sub perl_inc { + my $self = shift; + + my $perl_src = $self->perl_src(); + + if ($perl_src) { + File::Spec->catdir($perl_src, "lib", "CORE"); + } else { + File::Spec->catdir($self->{config}{archlibexp},"CORE"); + } +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms + +=head1 DESCRIPTION + +This module implements the Windows-specific parts of ExtUtils::CBuilder. +Most of the Windows-specific stuff has to do with compiling and +linking C code. Currently we support the 3 compilers perl itself +supports: MSVC, BCC, and GCC. + +This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality +not implemented here will be implemented there. The interfaces are +defined by the L<ExtUtils::CBuilder> documentation. + +=head1 AUTHOR + +Ken Williams <ken@mathforum.org> + +Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>. + +=head1 SEE ALSO + +perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3) + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm new file mode 100644 index 00000000000..ee65c91a159 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -0,0 +1,130 @@ +package ExtUtils::CBuilder::Platform::Windows::BCC; + +use vars qw($VERSION); +$VERSION = '0.27'; + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + %spec = $self->write_compiler_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{cc}, '-c' , + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + "-o$spec{output}" , + $spec{source} , + ) ]; +} + +sub write_compiler_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.ccs' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + # XXX Borland "response files" seem to be unable to accept macro + # definitions containing quoted strings. Escaping strings with + # backslash doesn't work, and any level of quotes are stripped. The + # result is is a floating point number in the source file where a + # string is expected. So we leave the macros on the command line. + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(includes cflags optimize perlinc) } ) + ); + + push @{$spec{includes}}, '@"' . $script . '"'; + + return %spec; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-L$path"; + } + + push( @{$spec{startup}}, 'c0d32.obj' ) + unless ( $spec{starup} && @{$spec{startup}} ); + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{ld} , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{other_ldflags}} , + @{$spec{startup}} , + @{$spec{objects}} , ',', + $spec{output} , ',', + $spec{map_file} , ',', + $spec{libperl} , + @{$spec{perllibs}} , ',', + $spec{def_file} + ) ]; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + # To work around Borlands "unique" commandline syntax, + # two scripts are used: + + my $ld_script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + my $ld_libs = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lbs' ); + + $self->add_to_cleanup($ld_script, $ld_libs); + + print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet}; + + # Script 1: contains options & names of object files. + my $LD_SCRIPT = IO::File->new( ">$ld_script" ) + or die( "Could not create linker script '$ld_script': $!" ); + + print $LD_SCRIPT join( " +\n", + map { @{$_} } + grep defined, + delete( + @spec{ qw(lddlflags libpath other_ldflags startup objects) } ) + ); + + # Script 2: contains name of libs to link against. + my $LD_LIBS = IO::File->new( ">$ld_libs" ) + or die( "Could not create linker script '$ld_libs': $!" ); + + print $LD_LIBS join( " +\n", + (delete $spec{libperl} || ''), + @{delete $spec{perllibs} || []}, + ); + + push @{$spec{lddlflags}}, '@"' . $ld_script . '"'; + push @{$spec{perllibs}}, '@"' . $ld_libs . '"'; + + return %spec; +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm new file mode 100644 index 00000000000..132bf842bdb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -0,0 +1,151 @@ +package ExtUtils::CBuilder::Platform::Windows::GCC; + +use vars qw($VERSION); +$VERSION = '0.27'; + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + # split off any -arguments included in cc + my @cc = split / (?=-)/, $spec{cc}; + + return [ grep {defined && length} ( + @cc, '-c' , + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + '-o', $spec{output} , + $spec{source} , + ) ]; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + my $cf = $self->{config}; + + # The Config.pm variable 'libperl' is hardcoded to the full name + # of the perl import library (i.e. 'libperl56.a'). GCC will not + # find it unless the 'lib' prefix & the extension are stripped. + $spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/; + + unshift( @{$spec{other_ldflags}}, '-nostartfiles' ) + if ( $spec{startup} && @{$spec{startup}} ); + + # From ExtUtils::MM_Win32: + # + ## one thing for GCC/Mingw32: + ## we try to overcome non-relocateable-DLL problems by generating + ## a (hopefully unique) image-base from the dll's name + ## -- BKS, 10-19-1999 + File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/; + $spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) ); + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-L$path"; + } + + my @cmds; # Stores the series of commands needed to build the module. + + my $DLLTOOL = $cf->{dlltool} || 'dlltool'; + + push @cmds, [ + $DLLTOOL, '--def' , $spec{def_file}, + '--output-exp' , $spec{explib} + ]; + + # split off any -arguments included in ld + my @ld = split / (?=-)/, $spec{ld}; + + push @cmds, [ grep {defined && length} ( + @ld , + '-o', $spec{output} , + "-Wl,--base-file,$spec{base_file}" , + "-Wl,--image-base,$spec{image_base}" , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{startup}} , + @{$spec{objects}} , + @{$spec{other_ldflags}} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{explib} , + $spec{map_file} ? ('-Map', $spec{map_file}) : '' + ) ]; + + push @cmds, [ + $DLLTOOL, '--def' , $spec{def_file}, + '--output-exp' , $spec{explib}, + '--base-file' , $spec{base_file} + ]; + + push @cmds, [ grep {defined && length} ( + @ld , + '-o', $spec{output} , + "-Wl,--image-base,$spec{image_base}" , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{startup}} , + @{$spec{objects}} , + @{$spec{other_ldflags}} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{explib} , + $spec{map_file} ? ('-Map', $spec{map_file}) : '' + ) ]; + + return @cmds; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT ( 'SEARCH_DIR(' . $_ . ")\n" ) + for @{delete $spec{libpath} || []}; + + # gcc takes only one startup file, so the first object in startup is + # specified as the startup file and any others are shifted into the + # beginning of the list of objects. + if ( $spec{startup} && @{$spec{startup}} ) { + print $SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n"; + unshift @{$spec{objects}}, + @{delete $spec{startup} || []}; + } + + print $SCRIPT 'INPUT(' . join( ',', + @{delete $spec{objects} || []} + ) . ")\n"; + + print $SCRIPT 'INPUT(' . join( ' ', + (delete $spec{libperl} || ''), + @{delete $spec{perllibs} || []}, + ) . ")\n"; + + #it is important to keep the order 1.linker_script - 2.other_ldflags + unshift @{$spec{other_ldflags}}, '"' . $script . '"'; + + return %spec; +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm new file mode 100644 index 00000000000..7da1c9b4c12 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -0,0 +1,131 @@ +package ExtUtils::CBuilder::Platform::Windows::MSVC; + +use vars qw($VERSION); +$VERSION = '0.27'; + +sub arg_exec_file { + my ($self, $file) = @_; + return "/OUT:$file"; +} + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + %spec = $self->write_compiler_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{cc},'-nologo','-c', + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + "-Fo$spec{output}" , + $spec{source} , + ) ]; +} + +sub write_compiler_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.ccs' ); + + $self->add_to_cleanup($script); + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(includes cflags optimize defines perlinc) } ) + ); + + push @{$spec{includes}}, '@"' . $script . '"'; + + return %spec; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + my $cf = $self->{config}; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-libpath:$path"; + } + + my $output = $spec{output}; + + $spec{def_file} &&= '-def:' . $spec{def_file}; + $spec{output} &&= '-out:' . $spec{output}; + $spec{manifest} &&= '-manifest ' . $spec{manifest}; + $spec{implib} &&= '-implib:' . $spec{implib}; + $spec{map_file} &&= '-map:' . $spec{map_file}; + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + my @cmds; # Stores the series of commands needed to build the module. + + push @cmds, [ grep {defined && length} ( + $spec{ld} , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{other_ldflags}} , + @{$spec{startup}} , + @{$spec{objects}} , + $spec{map_file} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{def_file} , + $spec{implib} , + $spec{output} , + ) ]; + + # Embed the manifest file if it exists + push @cmds, [ + 'if', 'exist', $spec{manifest}, 'mt', '-nologo', $spec{manifest}, '-outputresource:' . "$output;2" + ]; + + return @cmds; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(lddlflags libpath other_ldflags + startup objects libperl perllibs + def_file implib map_file) } ) + ); + + push @{$spec{lddlflags}}, '@"' . $script . '"'; + + return %spec; +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/aix.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/aix.pm new file mode 100644 index 00000000000..656e0dc67ff --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -0,0 +1,31 @@ +package ExtUtils::CBuilder::Platform::aix; + +use strict; +use ExtUtils::CBuilder::Platform::Unix; +use File::Spec; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub need_prelink { 1 } + +sub link { + my ($self, %args) = @_; + my $cf = $self->{config}; + + (my $baseext = $args{module_name}) =~ s/.*:://; + my $perl_inc = $self->perl_inc(); + + # Massage some very naughty bits in %Config + local $cf->{lddlflags} = $cf->{lddlflags}; + for ($cf->{lddlflags}) { + s/\Q$(BASEEXT)\E/$baseext/; + s/\Q$(PERL_INC)\E/$perl_inc/; + } + + return $self->SUPER::link(%args); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/cygwin.pm new file mode 100644 index 00000000000..f8650978ec4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -0,0 +1,33 @@ +package ExtUtils::CBuilder::Platform::cygwin; + +use strict; +use File::Spec; +use ExtUtils::CBuilder::Platform::Unix; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +# TODO: If a specific exe_file name is requested, if the exe created +# doesn't have that name, we might want to rename it. Apparently asking +# for an exe of "foo" might result in "foo.exe". Alternatively, we should +# make sure the return value is correctly "foo.exe". +# C.f http://rt.cpan.org/Public/Bug/Display.html?id=41003 +sub link_executable { + my $self = shift; + return $self->SUPER::link_executable(@_); +} + +sub link { + my ($self, %args) = @_; + + my $lib = $self->{config}{useshrplib} ? 'libperl.dll.a' : 'libperl.a'; + $args{extra_linker_flags} = [ + File::Spec->catfile($self->perl_inc(), $lib), + $self->split_like_shell($args{extra_linker_flags}) + ]; + + return $self->SUPER::link(%args); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/darwin.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/darwin.pm new file mode 100644 index 00000000000..efc79347708 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -0,0 +1,22 @@ +package ExtUtils::CBuilder::Platform::darwin; + +use strict; +use ExtUtils::CBuilder::Platform::Unix; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub compile { + my $self = shift; + my $cf = $self->{config}; + + # -flat_namespace isn't a compile flag, it's a linker flag. But + # it's mistakenly in Config.pm as both. Make the correction here. + local $cf->{ccflags} = $cf->{ccflags}; + $cf->{ccflags} =~ s/-flat_namespace//; + $self->SUPER::compile(@_); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/dec_osf.pm new file mode 100644 index 00000000000..d07b71f6d65 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -0,0 +1,18 @@ +package ExtUtils::CBuilder::Platform::dec_osf; + +use strict; +use ExtUtils::CBuilder::Platform::Unix; +use File::Spec; + +use vars qw($VERSION @ISA); +@ISA = qw(ExtUtils::CBuilder::Platform::Unix); +$VERSION = '0.27'; + +sub link_executable { + my $self = shift; + # $Config{ld} is 'ld' but that won't work: use the cc instead. + local $self->{config}{ld} = $self->{config}{cc}; + return $self->SUPER::link_executable(@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/os2.pm b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/os2.pm new file mode 100644 index 00000000000..2815d587d7f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -0,0 +1,80 @@ +package ExtUtils::CBuilder::Platform::os2; + +use strict; +use ExtUtils::CBuilder::Platform::Unix; + +use vars qw($VERSION @ISA); +$VERSION = '0.27'; +@ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub need_prelink { 1 } + +sub prelink { + # Generate import libraries (XXXX currently near .DEF; should be near DLL!) + my $self = shift; + my %args = @_; + + my @res = $self->SUPER::prelink(%args); + die "Unexpected number of DEF files" unless @res == 1; + die "Can't find DEF file in the output" + unless $res[0] =~ m,^(.*)\.def$,si; + my $libname = "$1$self->{config}{lib_ext}"; # Put .LIB file near .DEF file + $self->do_system('emximp', '-o', $libname, $res[0]) or die "emxexp: res=$?"; + return (@res, $libname); +} + +sub _do_link { + my $self = shift; + my ($how, %args) = @_; + if ($how eq 'lib_file' + and (defined $args{module_name} and length $args{module_name})) { + + # DynaLoader::mod2fname() is a builtin func + my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]); + + # Now know the basename, find directory parts via lib_file, or objects + my $objs = ( (ref $args{objects}) ? $args{objects} : [$args{objects}] ); + my $near_obj = $self->lib_file(@$objs); + my $ref_file = ( defined $args{lib_file} ? $args{lib_file} : $near_obj ); + my $lib_dir = ($ref_file =~ m,(.*)[/\\],s ? "$1/" : '' ); + my $exp_dir = ($near_obj =~ m,(.*)[/\\],s ? "$1/" : '' ); + + $args{dl_file} = $1 if $near_obj =~ m,(.*)\.,s; # put ExportList near OBJ + $args{lib_file} = "$lib_dir$lib.$self->{config}{dlext}"; # DLL file + + # XXX _do_link does not have place to put libraries? + push @$objs, $self->perl_inc() . "/libperl$self->{config}{lib_ext}"; + $args{objects} = $objs; + } + # Some 'env' do exec(), thus return too early when run from ksh; + # To avoid 'env', remove (useless) shrpenv + local $self->{config}{shrpenv} = ''; + return $self->SUPER::_do_link($how, %args); +} + +sub extra_link_args_after_prelink { + # Add .DEF file to the link line + my ($self, %args) = @_; + + my @DEF = grep /\.def$/i, @{$args{prelink_res}}; + die "More than one .def files created by `prelink' stage" if @DEF > 1; + # XXXX No "$how" argument here, so how to test for dynamic link? + die "No .def file created by `prelink' stage" + unless @DEF or not @{$args{prelink_res}}; + + my @after_libs = ($OS2::is_aout ? () + : $self->perl_inc() . "/libperl_override$self->{config}{lib_ext}"); + # , "-L", "-lperl" + (@after_libs, @DEF); +} + +sub link_executable { + # ldflags is not expecting .exe extension given on command line; remove -Zexe + my $self = shift; + local $self->{config}{ldflags} = $self->{config}{ldflags}; + $self->{config}{ldflags} =~ s/(?<!\S)-Zexe(?!\S)//; + return $self->SUPER::link_executable(@_); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Command.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Command.pm new file mode 100644 index 00000000000..b5632ff06d6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Command.pm @@ -0,0 +1,369 @@ +package ExtUtils::Command; + +use 5.00503; +use strict; +use Carp; +use File::Copy; +use File::Compare; +use File::Basename; +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 test_d chmod + dos2unix); +$VERSION = '1.16'; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS_mode = $Is_VMS; +my $Is_VMS_noefs = $Is_VMS; +my $Is_Win32 = $^O eq 'MSWin32'; + +if( $Is_VMS ) { + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_mode = 0 if $vms_unix_rpt; + $Is_VMS_noefs = 0 if ($vms_efs); +} + + +=head1 NAME + +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 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. Call them like this: + + perl -MExtUtils::Command -e some_command some files to work on + +and I<NOT> like this: + + perl -MExtUtils::Command -e 'some_command qw(some files to work on)' + +For that use L<Shell::Command>. + +Filenames with * and ? will be glob expanded. + + +=head2 FUNCTIONS + +=over 4 + +=cut + +# VMS uses % instead of ? to mean "one character" +my $wild_regex = $Is_VMS ? '*%' : '*?'; +sub expand_wildcards +{ + @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); +} + + +=item cat + + cat file ... + +Concatenates all files mentioned on command line to STDOUT. + +=cut + +sub cat () +{ + expand_wildcards(); + print while (<>); +} + +=item eqtime + + eqtime source destination + +Sets modified time of destination to that of source. + +=cut + +sub eqtime +{ + my ($src,$dst) = @ARGV; + local @ARGV = ($dst); touch(); # in case $dst doesn't exist + utime((stat($src))[8,9],$dst); +} + +=item rm_rf + + rm_rf files or directories ... + +Removes files and directories - recursively (even if readonly) + +=cut + +sub rm_rf +{ + expand_wildcards(); + rmtree([grep -e $_,@ARGV],0,0); +} + +=item rm_f + + rm_f file ... + +Removes files (even if readonly) + +=cut + +sub rm_f { + expand_wildcards(); + + foreach my $file (@ARGV) { + next unless -f $file; + + next if _unlink($file); + + chmod(0777, $file); + + next if _unlink($file); + + carp "Cannot delete $file: $!"; + } +} + +sub _unlink { + my $files_unlinked = 0; + foreach my $file (@_) { + my $delete_count = 0; + $delete_count++ while unlink $file; + $files_unlinked++ if $delete_count; + } + return $files_unlinked; +} + + +=item touch + + touch file ... + +Makes files exist, with current timestamp + +=cut + +sub touch { + my $t = time; + expand_wildcards(); + foreach my $file (@ARGV) { + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + utime($t,$t,$file); + } +} + +=item mv + + mv source_file destination_file + mv source_file source_file destination_dir + +Moves source to destination. Multiple sources are allowed if +destination is an existing directory. + +Returns true if all moves succeeded, false otherwise. + +=cut + +sub mv { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + croak("Too many arguments") if (@src > 1 && ! -d $dst); + + my $nok = 0; + foreach my $src (@src) { + $nok ||= !move($src,$dst); + } + return !$nok; +} + +=item cp + + cp source_file destination_file + cp source_file source_file destination_dir + +Copies sources to the destination. Multiple sources are allowed if +destination is an existing directory. + +Returns true if all copies succeeded, false otherwise. + +=cut + +sub cp { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + croak("Too many arguments") if (@src > 1 && ! -d $dst); + + my $nok = 0; + foreach my $src (@src) { + $nok ||= !copy($src,$dst); + + # Win32 does not update the mod time of a copied file, just the + # created time which make does not look at. + utime(time, time, $dst) if $Is_Win32; + } + return $nok; +} + +=item chmod + + chmod mode files ... + +Sets UNIX like permissions 'mode' on all the files. e.g. 0666 + +=cut + +sub chmod { + local @ARGV = @ARGV; + my $mode = shift(@ARGV); + expand_wildcards(); + + if( $Is_VMS_mode && $Is_VMS_noefs) { + foreach my $idx (0..$#ARGV) { + my $path = $ARGV[$idx]; + next unless -d $path; + + # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do + # chmod 0777, [.foo]bar.dir + my @dirs = File::Spec->splitdir( $path ); + $dirs[-1] .= '.dir'; + $path = File::Spec->catfile(@dirs); + + $ARGV[$idx] = $path; + } + } + + chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; +} + +=item mkpath + + mkpath directory ... + +Creates directories, including any parent directories. + +=cut + +sub mkpath +{ + expand_wildcards(); + File::Path::mkpath([@ARGV],0,0777); +} + +=item test_f + + test_f file + +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] ? 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 + + dos2unix files or dirs ... + +Converts DOS and OS/2 linefeeds to Unix style recursively. + +=cut + +sub dos2unix { + require File::Find; + File::Find::find(sub { + return if -d; + return unless -w _; + return unless -r _; + return if -B _; + + local $\; + + my $orig = $_; + my $temp = '.dos2unix_tmp'; + open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; + open TEMP, ">$temp" or + do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; + while (my $line = <ORIG>) { + $line =~ s/\015\012/\012/g; + print TEMP $line; + } + close ORIG; + close TEMP; + rename $temp, $orig; + + }, @ARGV); +} + +=back + +=head1 SEE ALSO + +Shell::Command which is these same functions but take arguments normally. + + +=head1 AUTHOR + +Nick Ing-Simmons C<ni-s@cpan.org> + +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/Master/tlpkg/tlperl/lib/ExtUtils/Command/MM.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Command/MM.pm new file mode 100644 index 00000000000..f9b474de16f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Command/MM.pm @@ -0,0 +1,275 @@ +package ExtUtils::Command::MM; + +require 5.006; + +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_harness pod2man perllocal_install uninstall + warn_if_old_packlist); +our $VERSION = '6.56'; + +my $Is_VMS = $^O eq 'VMS'; + + +=head1 NAME + +ExtUtils::Command::MM - Commands for the MM's to use in Makefiles + +=head1 SYNOPSIS + + perl "-MExtUtils::Command::MM" -e "function" "--" arguments... + + +=head1 DESCRIPTION + +B<FOR INTERNAL USE ONLY!> The interface is not stable. + +ExtUtils::Command::MM encapsulates code which would otherwise have to +be done with large "one" liners. + +Any $(FOO) used in the examples are make variables, not Perl. + +=over 4 + +=item B<test_harness> + + test_harness($verbose, @test_libs); + +Runs the tests on @ARGV via Test::Harness passing through the $verbose +flag. Any @test_libs will be unshifted onto the test's @INC. + +@test_libs are run in alphabetical order. + +=cut + +sub test_harness { + require Test::Harness; + require File::Spec; + + $Test::Harness::verbose = shift; + + # Because Windows doesn't do this for us and listing all the *.t files + # out on the command line can blow over its exec limit. + require ExtUtils::Command; + my @argv = ExtUtils::Command::expand_wildcards(@ARGV); + + local @INC = @INC; + unshift @INC, map { File::Spec->rel2abs($_) } @_; + Test::Harness::runtests(sort { lc $a cmp lc $b } @argv); +} + + + +=item B<pod2man> + + pod2man( '--option=value', + $podfile1 => $manpage1, + $podfile2 => $manpage2, + ... + ); + + # or args on @ARGV + +pod2man() is a function performing most of the duties of the pod2man +program. Its arguments are exactly the same as pod2man as of 5.8.0 +with the addition of: + + --perm_rw octal permission to set the resulting manpage to + +And the removal of: + + --verbose/-v + --help/-h + +If no arguments are given to pod2man it will read from @ARGV. + +If Pod::Man is unavailable, this function will warn and return undef. + +=cut + +sub pod2man { + local @ARGV = @_ ? @_ : @ARGV; + + { + local $@; + if( !eval { require Pod::Man } ) { + warn "Pod::Man is not available: $@". + "Man pages will not be generated during this install.\n"; + return undef; + } + } + require Getopt::Long; + + # We will cheat and just use Getopt::Long. We fool it by putting + # our arguments into @ARGV. Should be safe. + my %options = (); + Getopt::Long::config ('bundling_override'); + Getopt::Long::GetOptions (\%options, + 'section|s=s', 'release|r=s', 'center|c=s', + 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', + 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', + 'name|n=s', 'perm_rw=i' + ); + + # If there's no files, don't bother going further. + return 0 unless @ARGV; + + # Official sets --center, but don't override things explicitly set. + if ($options{official} && !defined $options{center}) { + $options{center} = q[Perl Programmer's Reference Guide]; + } + + # This isn't a valid Pod::Man option and is only accepted for backwards + # compatibility. + delete $options{lax}; + + do {{ # so 'next' works + my ($pod, $man) = splice(@ARGV, 0, 2); + + next if ((-e $man) && + (-M $man < -M $pod) && + (-M $man < -M "Makefile")); + + print "Manifying $man\n"; + + my $parser = Pod::Man->new(%options); + $parser->parse_from_file($pod, $man) + or do { warn("Could not install $man\n"); next }; + + if (exists $options{perm_rw}) { + chmod(oct($options{perm_rw}), $man) + or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; + } + }} while @ARGV; + + return 1; +} + + +=item B<warn_if_old_packlist> + + perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile> + +Displays a warning that an old packlist file was found. Reads the +filename from @ARGV. + +=cut + +sub warn_if_old_packlist { + my $packlist = $ARGV[0]; + + return unless -f $packlist; + print <<"PACKLIST_WARNING"; +WARNING: I have found an old package in + $packlist. +Please make sure the two installations are not conflicting +PACKLIST_WARNING + +} + + +=item B<perllocal_install> + + perl "-MExtUtils::Command::MM" -e perllocal_install + <type> <module name> <key> <value> ... + + # VMS only, key|value pairs come on STDIN + perl "-MExtUtils::Command::MM" -e perllocal_install + <type> <module name> < <key>|<value> ... + +Prints a fragment of POD suitable for appending to perllocal.pod. +Arguments are read from @ARGV. + +'type' is the type of what you're installing. Usually 'Module'. + +'module name' is simply the name of your module. (Foo::Bar) + +Key/value pairs are extra information about the module. Fields include: + + installed into which directory your module was out into + LINKTYPE dynamic or static linking + VERSION module version number + EXE_FILES any executables installed in a space seperated + list + +=cut + +sub perllocal_install { + my($type, $name) = splice(@ARGV, 0, 2); + + # VMS feeds args as a piped file on STDIN since it usually can't + # fit all the args on a single command line. + my @mod_info = $Is_VMS ? split /\|/, <STDIN> + : @ARGV; + + my $pod; + $pod = sprintf <<POD, scalar localtime; + =head2 %s: C<$type> L<$name|$name> + + =over 4 + +POD + + do { + my($key, $val) = splice(@mod_info, 0, 2); + + $pod .= <<POD + =item * + + C<$key: $val> + +POD + + } while(@mod_info); + + $pod .= "=back\n\n"; + $pod =~ s/^ //mg; + print $pod; + + return 1; +} + +=item B<uninstall> + + perl "-MExtUtils::Command::MM" -e uninstall <packlist> + +A wrapper around ExtUtils::Install::uninstall(). Warns that +uninstallation is deprecated and doesn't actually perform the +uninstallation. + +=cut + +sub uninstall { + my($packlist) = shift @ARGV; + + require ExtUtils::Install; + + print <<'WARNING'; + +Uninstall is unsafe and deprecated, the uninstallation was not performed. +We will show what would have been done. + +WARNING + + ExtUtils::Install::uninstall($packlist, 1, 1); + + print <<'WARNING'; + +Uninstall is unsafe and deprecated, the uninstallation was not performed. +Please check the list above carefully, there may be errors. +Remove the appropriate files manually. +Sorry for the inconvenience. + +WARNING + +} + +=back + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant.pm new file mode 100644 index 00000000000..0a20b89b792 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant.pm @@ -0,0 +1,565 @@ +package ExtUtils::Constant; +use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); +$VERSION = 0.22; + +=head1 NAME + +ExtUtils::Constant - generate XS code to import C header constants + +=head1 SYNOPSIS + + use ExtUtils::Constant qw (WriteConstants); + WriteConstants( + NAME => 'Foo', + NAMES => [qw(FOO BAR BAZ)], + ); + # Generates wrapper code to make the values of the constants FOO BAR BAZ + # available to perl + +=head1 DESCRIPTION + +ExtUtils::Constant facilitates generating C and XS wrapper code to allow +perl modules to AUTOLOAD constants defined in C library header files. +It is principally used by the C<h2xs> utility, on which this code is based. +It doesn't contain the routines to scan header files to extract these +constants. + +=head1 USAGE + +Generally one only needs to call the C<WriteConstants> function, and then + + #include "const-c.inc" + +in the C section of C<Foo.xs> + + INCLUDE: const-xs.inc + +in the XS section of C<Foo.xs>. + +For greater flexibility use C<constant_types()>, C<C_constant> and +C<XS_constant>, with which C<WriteConstants> is implemented. + +Currently this module understands the following types. h2xs may only know +a subset. The sizes of the numeric types are chosen by the C<Configure> +script at compile time. + +=over 4 + +=item IV + +signed integer, at least 32 bits. + +=item UV + +unsigned integer, the same size as I<IV> + +=item NV + +floating point type, probably C<double>, possibly C<long double> + +=item PV + +NUL terminated string, length will be determined with C<strlen> + +=item PVN + +A fixed length thing, given as a [pointer, length] pair. If you know the +length of a string at compile time you may use this instead of I<PV> + +=item SV + +A B<mortal> SV. + +=item YES + +Truth. (C<PL_sv_yes>) The value is not needed (and ignored). + +=item NO + +Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). + +=item UNDEF + +C<undef>. The value of the macro is not needed. + +=back + +=head1 FUNCTIONS + +=over 4 + +=cut + +if ($] >= 5.006) { + eval "use warnings; 1" or die $@; +} +use strict; +use Carp qw(croak cluck); + +use Exporter; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet); + +@ISA = 'Exporter'; + +%EXPORT_TAGS = ( 'all' => [ qw( + XS_constant constant_types return_clause memEQ_clause C_stringify + C_constant autoload WriteConstants WriteMakefileSnippet +) ] ); + +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +=item constant_types + +A function returning a single scalar with C<#define> definitions for the +constants used internally between the generated C and XS functions. + +=cut + +sub constant_types { + ExtUtils::Constant::XS->header(); +} + +sub memEQ_clause { + cluck "ExtUtils::Constant::memEQ_clause is deprecated"; + ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1], + indent=>$_[2]}); +} + +sub return_clause ($$) { + cluck "ExtUtils::Constant::return_clause is deprecated"; + my $indent = shift; + ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_); +} + +sub switch_clause { + cluck "ExtUtils::Constant::switch_clause is deprecated"; + my $indent = shift; + my $comment = shift; + ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment}, + @_); +} + +sub C_constant { + my ($package, $subname, $default_type, $what, $indent, $breakout, @items) + = @_; + ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname, + default_type => $default_type, + types => $what, indent => $indent, + breakout => $breakout}, @items); +} + +=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME + +A function to generate the XS code to implement the perl subroutine +I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. +This XS code is a wrapper around a C subroutine usually generated by +C<C_constant>, and usually named C<constant>. + +I<TYPES> should be given either as a comma separated list of types that the +C subroutine C<constant> will generate or as a reference to a hash. It should +be the same list of types as C<C_constant> was given. +[Otherwise C<XS_constant> and C<C_constant> may have different ideas about +the number of parameters passed to the C function C<constant>] + +You can call the perl visible subroutine something other than C<constant> if +you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to +the name of the perl visible subroutine, unless you give the parameter +I<C_SUBNAME>. + +=cut + +sub XS_constant { + my $package = shift; + my $what = shift; + my $XS_subname = shift; + my $C_subname = shift; + $XS_subname ||= 'constant'; + $C_subname ||= $XS_subname; + + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what)}; + } + my $params = ExtUtils::Constant::XS->params ($what); + my $type; + + my $xs = <<"EOT"; +void +$XS_subname(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; +EOT + + if ($params->{IV}) { + $xs .= " IV iv;\n"; + } else { + $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; + } + if ($params->{NV}) { + $xs .= " NV nv;\n"; + } else { + $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; + } + if ($params->{PV}) { + $xs .= " const char *pv;\n"; + } else { + $xs .= + " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; + } + + $xs .= << 'EOT'; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); +EOT + if ($params->{''}) { + $xs .= << 'EOT'; + INPUT: + int utf8 = SvUTF8(sv); +EOT + } + $xs .= << 'EOT'; + PPCODE: +EOT + + if ($params->{IV} xor $params->{NV}) { + $xs .= << "EOT"; + /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ +EOT + } + $xs .= " type = $C_subname(aTHX_ s, len"; + $xs .= ', utf8' if $params->{''}; + $xs .= ', &iv' if $params->{IV}; + $xs .= ', &nv' if $params->{NV}; + $xs .= ', &pv' if $params->{PV}; + $xs .= ', &sv' if $params->{SV}; + $xs .= ");\n"; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + $xs .= << "EOT"; + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = + sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined $package_sprintf_safe macro %s, used", + s)); + PUSHs(sv); + break; +EOT + + foreach $type (sort keys %XS_Constant) { + # '' marks utf8 flag needed. + next if $type eq ''; + $xs .= "\t/* Uncomment this if you need to return ${type}s\n" + unless $what->{$type}; + $xs .= " case PERL_constant_IS$type:\n"; + if (length $XS_Constant{$type}) { + $xs .= << "EOT"; + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + $XS_Constant{$type}; +EOT + } else { + # Do nothing. return (), which will be correctly interpreted as + # (undef, undef) + } + $xs .= " break;\n"; + unless ($what->{$type}) { + chop $xs; # Yes, another need for chop not chomp. + $xs .= " */\n"; + } + } + $xs .= << "EOT"; + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing $package_sprintf_safe macro %s, used", + type, s)); + PUSHs(sv); + } +EOT + + return $xs; +} + + +=item autoload PACKAGE, VERSION, AUTOLOADER + +A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> +I<VERSION> is the perl version the code should be backwards compatible with. +It defaults to the version of perl running the subroutine. If I<AUTOLOADER> +is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all +names that the constant() routine doesn't recognise. + +=cut + +# ' # Grr. syntax highlighters that don't grok pod. + +sub autoload { + my ($module, $compat_version, $autoloader) = @_; + $compat_version ||= $]; + croak "Can't maintain compatibility back as far as version $compat_version" + if $compat_version < 5; + my $func = "sub AUTOLOAD {\n" + . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" + . " # XS function."; + $func .= " If a constant is not found then control is passed\n" + . " # to the AUTOLOAD in AutoLoader." if $autoloader; + + + $func .= "\n\n" + . " my \$constname;\n"; + $func .= + " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); + + $func .= <<"EOT"; + (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&${module}::constant not defined" if \$constname eq 'constant'; + my (\$error, \$val) = constant(\$constname); +EOT + + if ($autoloader) { + $func .= <<'EOT'; + if ($error) { + if ($error =~ /is not a valid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + croak $error; + } + } +EOT + } else { + $func .= + " if (\$error) { croak \$error; }\n"; + } + + $func .= <<'END'; + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 +#XXX if ($] >= 5.00561) { +#XXX *$AUTOLOAD = sub () { $val }; +#XXX } +#XXX else { + *$AUTOLOAD = sub { $val }; +#XXX } + } + goto &$AUTOLOAD; +} + +END + + return $func; +} + + +=item WriteMakefileSnippet + +WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] + +A function to generate perl code for Makefile.PL that will regenerate +the constant subroutines. Parameters are named as passed to C<WriteConstants>, +with the addition of C<INDENT> to specify the number of leading spaces +(default 2). + +Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and +C<XS_FILE> are recognised. + +=cut + +sub WriteMakefileSnippet { + my %args = @_; + my $indent = $args{INDENT} || 2; + + my $result = <<"EOT"; +ExtUtils::Constant::WriteConstants( + NAME => '$args{NAME}', + NAMES => \\\@names, + DEFAULT_TYPE => '$args{DEFAULT_TYPE}', +EOT + foreach (qw (C_FILE XS_FILE)) { + next unless exists $args{$_}; + $result .= sprintf " %-12s => '%s',\n", + $_, $args{$_}; + } + $result .= <<'EOT'; + ); +EOT + + $result =~ s/^/' 'x$indent/gem; + return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, + indent=>$indent,}, + @{$args{NAMES}}) + . $result; +} + +=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] + +Writes a file of C code and a file of XS code which you should C<#include> +and C<INCLUDE> in the C and XS sections respectively of your module's XS +code. You probably want to do this in your C<Makefile.PL>, so that you can +easily edit the list of constants without touching the rest of your module. +The attributes supported are + +=over 4 + +=item NAME + +Name of the module. This must be specified + +=item DEFAULT_TYPE + +The default type for the constants. If not specified C<IV> is assumed. + +=item BREAKOUT_AT + +The names of the constants are grouped by length. Generate child subroutines +for each group with this number or more names in. + +=item NAMES + +An array of constants' names, either scalars containing names, or hashrefs +as detailed in L<"C_constant">. + +=item PROXYSUBS + +If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>. + +=item C_FH + +A filehandle to write the C code to. If not given, then I<C_FILE> is opened +for writing. + +=item C_FILE + +The name of the file to write containing the C code. The default is +C<const-c.inc>. The C<-> in the name ensures that the file can't be +mistaken for anything related to a legitimate perl package name, and +not naming the file C<.c> avoids having to override Makefile.PL's +C<.xs> to C<.c> rules. + +=item XS_FH + +A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened +for writing. + +=item XS_FILE + +The name of the file to write containing the XS code. The default is +C<const-xs.inc>. + +=item XS_SUBNAME + +The perl visible name of the XS subroutine generated which will return the +constants. The default is C<constant>. + +=item C_SUBNAME + +The name of the C subroutine generated which will return the constants. +The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name +length appended, so constants with 10 character names would be in +C<constant_10> with the default I<XS_SUBNAME>. + +=back + +=cut + +sub WriteConstants { + my %ARGS = + ( # defaults + C_FILE => 'const-c.inc', + XS_FILE => 'const-xs.inc', + XS_SUBNAME => 'constant', + DEFAULT_TYPE => 'IV', + @_); + + $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0' + + croak "Module name not specified" unless length $ARGS{NAME}; + + my $c_fh = $ARGS{C_FH}; + if (!$c_fh) { + if ($] <= 5.008) { + # We need these little games, rather than doing things + # unconditionally, because we're used in core Makefile.PLs before + # IO is available (needed by filehandle), but also we want to work on + # older perls where undefined scalars do not automatically turn into + # anonymous file handles. + require FileHandle; + $c_fh = FileHandle->new(); + } + open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; + } + + my $xs_fh = $ARGS{XS_FH}; + if (!$xs_fh) { + if ($] <= 5.008) { + require FileHandle; + $xs_fh = FileHandle->new(); + } + open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; + } + + # As this subroutine is intended to make code that isn't edited, there's no + # need for the user to specify any types that aren't found in the list of + # names. + + if ($ARGS{PROXYSUBS}) { + require ExtUtils::Constant::ProxySubs; + $ARGS{C_FH} = $c_fh; + $ARGS{XS_FH} = $xs_fh; + ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS); + } else { + my $types = {}; + + print $c_fh constant_types(); # macro defs + print $c_fh "\n"; + + # indent is still undef. Until anyone implements indent style rules with + # it. + foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, + subname => $ARGS{C_SUBNAME}, + default_type => + $ARGS{DEFAULT_TYPE}, + types => $types, + breakout => + $ARGS{BREAKOUT_AT}}, + @{$ARGS{NAMES}})) { + print $c_fh $_, "\n"; # C constant subs + } + print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, + $ARGS{C_SUBNAME}); + } + + close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH}; + close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH}; +} + +1; +__END__ + +=back + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm new file mode 100644 index 00000000000..b5b79af1ea7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm @@ -0,0 +1,1006 @@ +package ExtUtils::Constant::Base; + +use strict; +use vars qw($VERSION); +use Carp; +use Text::Wrap; +use ExtUtils::Constant::Utils qw(C_stringify perl_stringify); +$VERSION = '0.04'; + +use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); + + +=head1 NAME + +ExtUtils::Constant::Base - base class for ExtUtils::Constant objects + +=head1 SYNOPSIS + + require ExtUtils::Constant::Base; + @ISA = 'ExtUtils::Constant::Base'; + +=head1 DESCRIPTION + +ExtUtils::Constant::Base provides a base implementation of methods to +generate C code to give fast constant value lookup by named string. Currently +it's mostly used ExtUtils::Constant::XS, which generates the lookup code +for the constant() subroutine found in many XS modules. + +=head1 USAGE + +ExtUtils::Constant::Base exports no subroutines. The following methods are +available + +=over 4 + +=cut + +sub valid_type { + # Default to assuming that you don't need different types of return data. + 1; +} +sub default_type { + ''; +} + +=item header + +A method returning a scalar containing definitions needed, typically for a +C header file. + +=cut + +sub header { + '' +} + +# This might actually be a return statement. Note that you are responsible +# for any space you might need before your value, as it lets to perform +# "tricks" such as "return KEY_" and have strings appended. +sub assignment_clause_for_type; +# In which case this might be an empty string +sub return_statement_for_type {undef}; +sub return_statement_for_notdef; +sub return_statement_for_notfound; + +# "#if 1" is true to a C pre-processor +sub macro_from_name { + 1; +} + +sub macro_from_item { + 1; +} + +sub macro_to_ifdef { + my ($self, $macro) = @_; + if (ref $macro) { + return $macro->[0]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return $macro ? "#ifdef $macro\n" : "#if 0\n"; + } + return ""; +} + +sub macro_to_endif { + my ($self, $macro) = @_; + + if (ref $macro) { + return $macro->[1]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return "#endif\n"; + } + return ""; +} + +sub name_param { + 'name'; +} + +# This is possibly buggy, in that it's not mandatory (below, in the main +# C_constant parameters, but is expected to exist here, if it's needed) +# Buggy because if you're definitely pure 8 bit only, and will never be +# presented with your constants in utf8, the default form of C_constant can't +# be told not to do the utf8 version. + +sub is_utf8_param { + 'utf8'; +} + +sub memEQ { + "!memcmp"; +} + +=item memEQ_clause args_hashref + +A method to return a suitable C C<if> statement to check whether I<name> +is equal to the C variable C<name>. If I<checked_at> is defined, then it +is used to avoid C<memEQ> for short names, or to generate a comment to +highlight the position of the character in the C<switch> statement. + +If i<checked_at> is a reference to a scalar, then instead it gives +the characters pre-checked at the beginning, (and the number of chars by +which the C variable name has been advanced. These need to be chopped from +the front of I<name>). + +=cut + +sub memEQ_clause { +# if (memEQ(name, "thingy", 6)) { + # Which could actually be a character comparison or even "" + my ($self, $args) = @_; + my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $front_chop; + if (ref $checked_at) { + # regexp won't work on 5.6.1 without use utf8; in turn that won't work + # on 5.005_03. + substr ($name, 0, length $$checked_at,) = ''; + $front_chop = C_stringify ($$checked_at); + undef $checked_at; + } + my $len = length $name; + + if ($len < 2) { + return $indent . "{\n" + if (defined $checked_at and $checked_at == 0) or $len == 0; + # We didn't switch, drop through to the code for the 2 character string + $checked_at = 1; + } + + my $name_param = $self->name_param; + + if ($len < 3 and defined $checked_at) { + my $check; + if ($checked_at == 1) { + $check = 0; + } elsif ($checked_at == 0) { + $check = 1; + } + if (defined $check) { + my $char = C_stringify (substr $name, $check, 1); + # Placate 5.005 with a break in the string. I can't see a good way of + # getting it to not take [ as introducing an array lookup, even with + # ${name_param}[$check] + return $indent . "if ($name_param" . "[$check] == '$char') {\n"; + } + } + if (($len == 2 and !defined $checked_at) + or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 1, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n"; + } + if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 2, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n"; + } + + my $pointer = '^'; + my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; + if ($have_checked_last) { + # Checked at the last character, so no need to memEQ it. + $pointer = C_stringify (chop $name); + $len--; + } + + $name = C_stringify ($name); + my $memEQ = $self->memEQ(); + my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n"; + # Put a little ^ under the letter we checked at + # Screws up for non printable and non-7 bit stuff, but that's too hard to + # get right. + if (defined $checked_at) { + $body .= $indent . "/* " . (' ' x length $memEQ) + . (' ' x length $name_param) + . (' ' x $checked_at) . $pointer + . (' ' x ($len - $checked_at + length $len)) . " */\n"; + } elsif (defined $front_chop) { + $body .= $indent . "/* $front_chop" + . (' ' x ($len + 1 + length $len)) . " */\n"; + } + return $body; +} + +=item dump_names arg_hashref, ITEM... + +An internal function to generate the embedded perl code that will regenerate +the constant subroutines. I<default_type>, I<types> and I<ITEM>s are the +same as for C_constant. I<indent> is treated as number of spaces to indent +by. If C<declare_types> is true a C<$types> is always declared in the perl +code generated, if defined and false never declared, and if undefined C<$types> +is only declared if the values in I<types> as passed in cannot be inferred from +I<default_types> and the I<ITEM>s. + +=cut + +sub dump_names { + my ($self, $args, @items) = @_; + my ($default_type, $what, $indent, $declare_types) + = @{$args}{qw(default_type what indent declare_types)}; + $indent = ' ' x ($indent || 0); + + my $result; + my (@simple, @complex, %used_types); + foreach (@items) { + my $type; + if (ref $_) { + $type = $_->{type} || $default_type; + if ($_->{utf8}) { + # For simplicity always skip the bytes case, and reconstitute this entry + # from its utf8 twin. + next if $_->{utf8} eq 'no'; + # Copy the hashref, as we don't want to mess with the caller's hashref. + $_ = {%$_}; + unless (is_perl56) { + utf8::decode ($_->{name}); + } else { + $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; + } + delete $_->{utf8}; + } + } else { + $_ = {name=>$_}; + $type = $default_type; + } + $used_types{$type}++; + if ($type eq $default_type + # grr 5.6.1 + and length $_->{name} + and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) + and !defined ($_->{macro}) and !defined ($_->{value}) + and !defined ($_->{default}) and !defined ($_->{pre}) + and !defined ($_->{post}) and !defined ($_->{def_pre}) + and !defined ($_->{def_post}) and !defined ($_->{weight})) { + # It's the default type, and the name consists only of A-Za-z0-9_ + push @simple, $_->{name}; + } else { + push @complex, $_; + } + } + + if (!defined $declare_types) { + # Do they pass in any types we weren't already using? + foreach (keys %$what) { + next if $used_types{$_}; + $declare_types++; # Found one in $what that wasn't used. + last; # And one is enough to terminate this loop + } + } + if ($declare_types) { + $result = $indent . 'my $types = {map {($_, 1)} qw(' + . join (" ", sort keys %$what) . ")};\n"; + } + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + $result .= wrap ($indent . "my \@names = (qw(", + $indent . " ", join (" ", sort @simple) . ")"); + if (@complex) { + foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { + my $name = perl_stringify $item->{name}; + my $line = ",\n$indent {name=>\"$name\""; + $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; + foreach my $thing (qw (macro value default pre post def_pre def_post)) { + my $value = $item->{$thing}; + if (defined $value) { + if (ref $value) { + $line .= ", $thing=>[\"" + . join ('", "', map {perl_stringify $_} @$value) . '"]'; + } else { + $line .= ", $thing=>\"" . perl_stringify($value) . "\""; + } + } + } + $line .= "}"; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + $line =~ s!\*\/!\*" . "/!gs; + # gcc -Wall doesn't like finding /* inside a comment + $line =~ s!\/\*!/" . "\*!gs; + $result .= $line; + } + } + $result .= ");\n"; + + $result; +} + +=item assign arg_hashref, VALUE... + +A method to return a suitable assignment clause. If I<type> is aggregate +(eg I<PVN> expects both pointer and length) then there should be multiple +I<VALUE>s for the components. I<pre> and I<post> if defined give snippets +of C code to proceed and follow the assignment. I<pre> will be at the start +of a block, so variables may be defined in it. + +=cut +# Hmm. value undef to to NOTDEF? value () to do NOTFOUND? + +sub assign { + my $self = shift; + my $args = shift; + my ($indent, $type, $pre, $post, $item) + = @{$args}{qw(indent type pre post item)}; + $post ||= ''; + my $clause; + my $close; + if ($pre) { + chomp $pre; + $close = "$indent}\n"; + $clause = $indent . "{\n"; + $indent .= " "; + $clause .= "$indent$pre"; + $clause .= ";" unless $pre =~ /;$/; + $clause .= "\n"; + } + confess "undef \$type" unless defined $type; + confess "Can't generate code for type $type" + unless $self->valid_type($type); + + $clause .= join '', map {"$indent$_\n"} + $self->assignment_clause_for_type({type=>$type,item=>$item}, @_); + chomp $post; + if (length $post) { + $clause .= "$post"; + $clause .= ";" unless $post =~ /;$/; + $clause .= "\n"; + } + my $return = $self->return_statement_for_type($type); + $clause .= "$indent$return\n" if defined $return; + $clause .= $close if $close; + return $clause; +} + +=item return_clause arg_hashref, ITEM + +A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref +(as passed to C<C_constant> and C<match_clause>. I<indent> is the number +of spaces to indent, defaulting to 6. + +=cut + +sub return_clause { + +##ifdef thingy +# *iv_return = thingy; +# return PERL_constant_ISIV; +##else +# return PERL_constant_NOTDEF; +##endif + my ($self, $args, $item) = @_; + my $indent = $args->{indent}; + + my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type) + = @$item{qw (name value default pre post def_pre def_post type)}; + $value = $name unless defined $value; + my $macro = $self->macro_from_item($item); + $indent = ' ' x ($indent || 6); + unless (defined $type) { + # use Data::Dumper; print STDERR Dumper ($item); + confess "undef \$type"; + } + + ##ifdef thingy + my $clause = $self->macro_to_ifdef($macro); + + # *iv_return = thingy; + # return PERL_constant_ISIV; + $clause + .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post, + item=>$item}, ref $value ? @$value : $value); + + if (defined $macro && $macro ne "" && $macro ne "1") { + ##else + $clause .= "#else\n"; + + # return PERL_constant_NOTDEF; + if (!defined $default) { + my $notdef = $self->return_statement_for_notdef(); + $clause .= "$indent$notdef\n" if defined $notdef; + } else { + my @default = ref $default ? @$default : $default; + $type = shift @default; + $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, + post=>$post, item=>$item}, @default); + } + } + ##endif + $clause .= $self->macro_to_endif($macro); + + return $clause; +} + +sub match_clause { + # $offset defined if we have checked an offset. + my ($self, $args, $item) = @_; + my ($offset, $indent) = @{$args}{qw(checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $body = ''; + my ($no, $yes, $either, $name, $inner_indent); + if (ref $item eq 'ARRAY') { + ($yes, $no) = @$item; + $either = $yes || $no; + confess "$item is $either expecting hashref in [0] || [1]" + unless ref $either eq 'HASH'; + $name = $either->{name}; + } else { + confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" + if $item->{utf8}; + $name = $item->{name}; + $inner_indent = $indent; + } + + $body .= $self->memEQ_clause ({name => $name, checked_at => $offset, + indent => length $indent}); + # If we've been presented with an arrayref for $item, then the user string + # contains in the range 128-255, and we need to check whether it was utf8 + # (or not). + # In the worst case we have two named constants, where one's name happens + # encoded in UTF8 happens to be the same byte sequence as the second's + # encoded in (say) ISO-8859-1. + # In this case, $yes and $no both have item hashrefs. + if ($yes) { + $body .= $indent . " if (" . $self->is_utf8_param . ") {\n"; + } elsif ($no) { + $body .= $indent . " if (!" . $self->is_utf8_param . ") {\n"; + } + if ($either) { + $body .= $self->return_clause ({indent=>4 + length $indent}, $either); + if ($yes and $no) { + $body .= $indent . " } else {\n"; + $body .= $self->return_clause ({indent=>4 + length $indent}, $no); + } + $body .= $indent . " }\n"; + } else { + $body .= $self->return_clause ({indent=>2 + length $indent}, $item); + } + $body .= $indent . "}\n"; +} + + +=item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM... + +An internal method to generate a suitable C<switch> clause, called by +C<C_constant> I<ITEM>s are in the hash ref format as given in the description +of C<C_constant>, and must all have the names of the same length, given by +I<NAMELEN>. I<ITEMHASH> is a reference to a hash, keyed by name, values being +the hashrefs in the I<ITEM> list. (No parameters are modified, and there can +be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without +causing problems - the hash is passed in to save generating it afresh for +each call). + +=cut + +sub switch_clause { + my ($self, $args, $namelen, $items, @items) = @_; + my ($indent, $comment) = @{$args}{qw(indent comment)}; + $indent = ' ' x ($indent || 2); + + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + + my @names = sort map {$_->{name}} @items; + my $leader = $indent . '/* '; + my $follower = ' ' x length $leader; + my $body = $indent . "/* Names all of length $namelen. */\n"; + if (defined $comment) { + $body = wrap ($leader, $follower, $comment) . "\n"; + $leader = $follower; + } + my @safe_names = @names; + foreach (@safe_names) { + confess sprintf "Name '$_' is length %d, not $namelen", length + unless length == $namelen; + # Argh. 5.6.1 + # next unless tr/A-Za-z0-9_//c; + next if tr/A-Za-z0-9_// == length; + $_ = '"' . perl_stringify ($_) . '"'; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + s!\*\/!\*"."/!gs; + # gcc -Wall doesn't like finding /* inside a comment + s!\/\*!/"."\*!gs; + } + $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; + # Figure out what to switch on. + # (RMS, Spread of jump table, Position, Hashref) + my @best = (1e38, ~0); + # Prefer the last character over the others. (As it lets us shorten the + # memEQ clause at no cost). + foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { + my ($min, $max) = (~0, 0); + my %spread; + if (is_perl56) { + # Need proper Unicode preserving hash keys for bytes in range 128-255 + # here too, for some reason. grr 5.6.1 yet again. + tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; + } + foreach (@names) { + my $char = substr $_, $i, 1; + my $ord = ord $char; + confess "char $ord is out of range" if $ord > 255; + $max = $ord if $ord > $max; + $min = $ord if $ord < $min; + push @{$spread{$char}}, $_; + # warn "$_ $char"; + } + # I'm going to pick the character to split on that minimises the root + # mean square of the number of names in each case. Normally this should + # be the one with the most keys, but it may pick a 7 where the 8 has + # one long linear search. I'm not sure if RMS or just sum of squares is + # actually better. + # $max and $min are for the tie-breaker if the root mean squares match. + # Assuming that the compiler may be building a jump table for the + # switch() then try to minimise the size of that jump table. + # Finally use < not <= so that if it still ties the earliest part of + # the string wins. Because if that passes but the memEQ fails, it may + # only need the start of the string to bin the choice. + # I think. But I'm micro-optimising. :-) + # OK. Trump that. Now favour the last character of the string, before the + # rest. + my $ss; + $ss += @$_ * @$_ foreach values %spread; + my $rms = sqrt ($ss / keys %spread); + if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { + @best = ($rms, $max - $min, $i, \%spread); + } + } + confess "Internal error. Failed to pick a switch point for @names" + unless defined $best[2]; + # use Data::Dumper; print Dumper (@best); + my ($offset, $best) = @best[2,3]; + $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; + + my $do_front_chop = $offset == 0 && $namelen > 2; + if ($do_front_chop) { + $body .= $indent . "switch (*" . $self->name_param() . "++) {\n"; + } else { + $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n"; + } + foreach my $char (sort keys %$best) { + confess sprintf "'$char' is %d bytes long, not 1", length $char + if length ($char) != 1; + confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; + $body .= $indent . "case '" . C_stringify ($char) . "':\n"; + foreach my $thisone (sort { + # Deal with the case of an item actually being an array ref to 1 or 2 + # hashrefs. Don't assign to $a or $b, as they're aliases to the orignal + my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a; + my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b; + # Sort by weight first + ($r->{weight} || 0) <=> ($l->{weight} || 0) + # Sort equal weights by name + or $l->{name} cmp $r->{name}} + # If this looks evil, maybe it is. $items is a + # hashref, and we're doing a hash slice on it + @{$items}{@{$best->{$char}}}) { + # warn "You are here"; + if ($do_front_chop) { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => \$char}, $thisone); + } else { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => $offset}, $thisone); + } + } + $body .= $indent . " break;\n"; + } + $body .= $indent . "}\n"; + return $body; +} + +sub C_constant_return_type { + "static int"; +} + +sub C_constant_prefix_param { + ''; +} + +sub C_constant_prefix_param_defintion { + ''; +} + +sub name_param_definition { + "const char *" . $_[0]->name_param; +} + +sub namelen_param { + 'len'; +} + +sub namelen_param_definition { + 'size_t ' . $_[0]->namelen_param; +} + +sub C_constant_other_params { + ''; +} + +sub C_constant_other_params_defintion { + ''; +} + +=item params WHAT + +An "internal" method, subject to change, currently called to allow an +overriding class to cache information that will then be passed into all +the C<*param*> calls. (Yes, having to read the source to make sense of this is +considered a known bug). I<WHAT> is be a hashref of types the constant +function will return. In ExtUtils::Constant::XS this method is used to +returns a hashref keyed IV NV PV SV to show which combination of pointers will +be needed in the C argument list generated by +C_constant_other_params_definition and C_constant_other_params + +=cut + +sub params { + ''; +} + + +=item dogfood arg_hashref, ITEM... + +An internal function to generate the embedded perl code that will regenerate +the constant subroutines. Parameters are the same as for C_constant. + +Currently the base class does nothing and returns an empty string. + +=cut + +sub dogfood { + '' +} + +=item normalise_items args, default_type, seen_types, seen_items, ITEM... + +Convert the items to a normalised form. For 8 bit and Unicode values converts +the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded. + +=cut + +sub normalise_items +{ + my $self = shift; + my $args = shift; + my $default_type = shift; + my $what = shift; + my $items = shift; + my @new_items; + foreach my $orig (@_) { + my ($name, $item); + if (ref $orig) { + # Make a copy which is a normalised version of the ref passed in. + $name = $orig->{name}; + my ($type, $macro, $value) = @$orig{qw (type macro value)}; + $type ||= $default_type; + $what->{$type} = 1; + $item = {name=>$name, type=>$type}; + + undef $macro if defined $macro and $macro eq $name; + $item->{macro} = $macro if defined $macro; + undef $value if defined $value and $value eq $name; + $item->{value} = $value if defined $value; + foreach my $key (qw(default pre post def_pre def_post weight + not_constant)) { + my $value = $orig->{$key}; + $item->{$key} = $value if defined $value; + # warn "$key $value"; + } + } else { + $name = $orig; + $item = {name=>$name, type=>$default_type}; + $what->{$default_type} = 1; + } + warn +(ref ($self) || $self) + . "doesn't know how to handle values of type $_ used in macro $name" + unless $self->valid_type ($item->{type}); + # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c + # doesn't work. Upgrade to 5.8 + # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { + if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50 + || $args->{disable_utf8_duplication}) { + # No characters outside 7 bit ASCII. + if (exists $items->{$name}) { + die "Multiple definitions for macro $name"; + } + $items->{$name} = $item; + } else { + # No characters outside 8 bit. This is hardest. + if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { + confess "Unexpected ASCII definition for macro $name"; + } + # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; + # if ($name !~ tr/\0-\377//c) { + if ($name =~ tr/\0-\377// == length $name) { +# if ($] < 5.007) { +# $name = pack "C*", unpack "U*", $name; +# } + $item->{utf8} = 'no'; + $items->{$name}[1] = $item; + push @new_items, $item; + # Copy item, to create the utf8 variant. + $item = {%$item}; + } + # Encode the name as utf8 bytes. + unless (is_perl56) { + utf8::encode($name); + } else { +# warn "Was >$name< " . length ${name}; + $name = pack 'C*', unpack 'C*', $name . pack 'U*'; +# warn "Now '${name}' " . length ${name}; + } + if ($items->{$name}[0]) { + die "Multiple definitions for macro $name"; + } + $item->{utf8} = 'yes'; + $item->{name} = $name; + $items->{$name}[0] = $item; + # We have need for the utf8 flag. + $what->{''} = 1; + } + push @new_items, $item; + } + @new_items; +} + +=item C_constant arg_hashref, ITEM... + +A function that returns a B<list> of C subroutine definitions that return +the value and type of constants when passed the name by the XS wrapper. +I<ITEM...> gives a list of constant names. Each can either be a string, +which is taken as a C macro name, or a reference to a hash with the following +keys + +=over 8 + +=item name + +The name of the constant, as seen by the perl code. + +=item type + +The type of the constant (I<IV>, I<NV> etc) + +=item value + +A C expression for the value of the constant, or a list of C expressions if +the type is aggregate. This defaults to the I<name> if not given. + +=item macro + +The C pre-processor macro to use in the C<#ifdef>. This defaults to the +I<name>, and is mainly used if I<value> is an C<enum>. If a reference an +array is passed then the first element is used in place of the C<#ifdef> +line, and the second element in place of the C<#endif>. This allows +pre-processor constructions such as + + #if defined (foo) + #if !defined (bar) + ... + #endif + #endif + +to be used to determine if a constant is to be defined. + +A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> +test is omitted. + +=item default + +Default value to use (instead of C<croak>ing with "your vendor has not +defined...") to return if the macro isn't defined. Specify a reference to +an array with type followed by value(s). + +=item pre + +C code to use before the assignment of the value of the constant. This allows +you to use temporary variables to extract a value from part of a C<struct> +and return this as I<value>. This C code is places at the start of a block, +so you can declare variables in it. + +=item post + +C code to place between the assignment of value (to a temporary) and the +return from the function. This allows you to clear up anything in I<pre>. +Rarely needed. + +=item def_pre + +=item def_post + +Equivalents of I<pre> and I<post> for the default value. + +=item utf8 + +Generated internally. Is zero or undefined if name is 7 bit ASCII, +"no" if the name is 8 bit (and so should only match if SvUTF8() is false), +"yes" if the name is utf8 encoded. + +The internals automatically clone any name with characters 128-255 but none +256+ (ie one that could be either in bytes or utf8) into a second entry +which is utf8 encoded. + +=item weight + +Optional sorting weight for names, to determine the order of +linear testing when multiple names fall in the same case of a switch clause. +Higher comes earlier, undefined defaults to zero. + +=back + +In the argument hashref, I<package> is the name of the package, and is only +used in comments inside the generated C code. I<subname> defaults to +C<constant> if undefined. + +I<default_type> is the type returned by C<ITEM>s that don't specify their +type. It defaults to the value of C<default_type()>. I<types> should be given +either as a comma separated list of types that the C subroutine I<subname> +will generate or as a reference to a hash. I<default_type> will be added to +the list if not present, as will any types given in the list of I<ITEM>s. The +resultant list should be the same list of types that C<XS_constant> is +given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of +parameters to the constant function. I<indent> is currently unused and +ignored. In future it may be used to pass in information used to change the C +indentation style used.] The best way to maintain consistency is to pass in a +hash reference and let this function update it. + +I<breakout> governs when child functions of I<subname> are generated. If there +are I<breakout> or more I<ITEM>s with the same length of name, then the code +to switch between them is placed into a function named I<subname>_I<len>, for +example C<constant_5> for names 5 characters long. The default I<breakout> is +3. A single C<ITEM> is always inlined. + +=cut + +# The parameter now BREAKOUT was previously documented as: +# +# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of +# this length, and that the constant name passed in by perl is checked and +# also of this length. It is used during recursion, and should be C<undef> +# unless the caller has checked all the lengths during code generation, and +# the generated subroutine is only to be called with a name of this length. +# +# As you can see it now performs this function during recursion by being a +# scalar reference. + +sub C_constant { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type types indent breakout)}; + $package ||= 'Foo'; + $subname ||= 'constant'; + # I'm not using this. But a hashref could be used for full formatting without + # breaking this API + # $indent ||= 0; + + my ($namelen, $items); + if (ref $breakout) { + # We are called recursively. We trust @items to be normalised, $what to + # be a hashref, and pinch %$items from our parent to save recalculation. + ($namelen, $items) = @$breakout; + } else { + $items = {}; + if (is_perl56) { + # Need proper Unicode preserving hash keys. + require ExtUtils::Constant::Aaargh56Hash; + tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; + } + $breakout ||= 3; + $default_type ||= $self->default_type(); + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what || '')}; + # Figure out what types we're dealing with, and assign all unknowns to the + # default type + } + @items = $self->normalise_items ({}, $default_type, $what, $items, @items); + # use Data::Dumper; print Dumper @items; + } + my $params = $self->params ($what); + + # Probably "static int" + my ($body, @subs); + $body = $self->C_constant_return_type($params) . "\n$subname (" + # Eg "pTHX_ " + . $self->C_constant_prefix_param_defintion($params) + # Probably "const char *name" + . $self->name_param_definition($params); + # Something like ", STRLEN len" + $body .= ", " . $self->namelen_param_definition($params) + unless defined $namelen; + $body .= $self->C_constant_other_params_defintion($params); + $body .= ") {\n"; + + if (defined $namelen) { + # We are a child subroutine. Print the simple description + my $comment = 'When generated this function returned values for the list' + . ' of names given here. However, subsequent manual editing may have' + . ' added or removed some.'; + $body .= $self->switch_clause ({indent=>2, comment=>$comment}, + $namelen, $items, @items); + } else { + # We are the top level. + $body .= " /* Initially switch on the length of the name. */\n"; + $body .= $self->dogfood ({package => $package, subname => $subname, + default_type => $default_type, what => $what, + indent => $indent, breakout => $breakout}, + @items); + $body .= ' switch ('.$self->namelen_param().") {\n"; + # Need to group names of the same length + my @by_length; + foreach (@items) { + push @{$by_length[length $_->{name}]}, $_; + } + foreach my $i (0 .. $#by_length) { + next unless $by_length[$i]; # None of this length + $body .= " case $i:\n"; + if (@{$by_length[$i]} == 1) { + my $only_thing = $by_length[$i]->[0]; + if ($only_thing->{utf8}) { + if ($only_thing->{utf8} eq 'yes') { + # With utf8 on flag item is passed in element 0 + $body .= $self->match_clause (undef, [$only_thing]); + } else { + # With utf8 off flag item is passed in element 1 + $body .= $self->match_clause (undef, [undef, $only_thing]); + } + } else { + $body .= $self->match_clause (undef, $only_thing); + } + } elsif (@{$by_length[$i]} < $breakout) { + $body .= $self->switch_clause ({indent=>4}, + $i, $items, @{$by_length[$i]}); + } else { + # Only use the minimal set of parameters actually needed by the types + # of the names of this length. + my $what = {}; + foreach (@{$by_length[$i]}) { + $what->{$_->{type}} = 1; + $what->{''} = 1 if $_->{utf8}; + } + $params = $self->params ($what); + push @subs, $self->C_constant ({package=>$package, + subname=>"${subname}_$i", + default_type => $default_type, + types => $what, indent => $indent, + breakout => [$i, $items]}, + @{$by_length[$i]}); + $body .= " return ${subname}_$i (" + # Eg "aTHX_ " + . $self->C_constant_prefix_param($params) + # Probably "name" + . $self->name_param($params); + $body .= $self->C_constant_other_params($params); + $body .= ");\n"; + } + $body .= " break;\n"; + } + $body .= " }\n"; + } + my $notfound = $self->return_statement_for_notfound(); + $body .= " $notfound\n" if $notfound; + $body .= "}\n"; + return (@subs, $body); +} + +1; +__END__ + +=back + +=head1 BUGS + +Not everything is documented yet. + +Probably others. + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm new file mode 100644 index 00000000000..c3fe8ed3c56 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm @@ -0,0 +1,549 @@ +package ExtUtils::Constant::ProxySubs; + +use strict; +use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv + %type_to_C_value %type_is_a_problem %type_num_args + %type_temporary); +use Carp; +require ExtUtils::Constant::XS; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_TypeSet); + +$VERSION = '0.06'; +@ISA = 'ExtUtils::Constant::XS'; + +%type_to_struct = + ( + IV => '{const char *name; I32 namelen; IV value;}', + NV => '{const char *name; I32 namelen; NV value;}', + UV => '{const char *name; I32 namelen; UV value;}', + PV => '{const char *name; I32 namelen; const char *value;}', + PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}', + YES => '{const char *name; I32 namelen;}', + NO => '{const char *name; I32 namelen;}', + UNDEF => '{const char *name; I32 namelen;}', + '' => '{const char *name; I32 namelen;} ', + ); + +%type_from_struct = + ( + IV => sub { $_[0] . '->value' }, + NV => sub { $_[0] . '->value' }, + UV => sub { $_[0] . '->value' }, + PV => sub { $_[0] . '->value' }, + PVN => sub { $_[0] . '->value', $_[0] . '->len' }, + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +%type_to_sv = + ( + IV => sub { "newSViv($_[0])" }, + NV => sub { "newSVnv($_[0])" }, + UV => sub { "newSVuv($_[0])" }, + PV => sub { "newSVpv($_[0], 0)" }, + PVN => sub { "newSVpvn($_[0], $_[1])" }, + YES => sub { '&PL_sv_yes' }, + NO => sub { '&PL_sv_no' }, + UNDEF => sub { '&PL_sv_undef' }, + '' => sub { '&PL_sv_yes' }, + SV => sub {"SvREFCNT_inc($_[0])"}, + ); + +%type_to_C_value = + ( + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +sub type_to_C_value { + my ($self, $type) = @_; + return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; +} + +# TODO - figure out if there is a clean way for the type_to_sv code to +# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add +# SvREFCNT_inc +%type_is_a_problem = + ( + # The documentation says *mortal SV*, but we now need a non-mortal copy. + SV => 1, + ); + +%type_temporary = + ( + SV => ['SV *'], + PV => ['const char *'], + PVN => ['const char *', 'STRLEN'], + ); +$type_temporary{$_} = [$_] foreach qw(IV UV NV); + +while (my ($type, $value) = each %XS_TypeSet) { + $type_num_args{$type} + = defined $value ? ref $value ? scalar @$value : 1 : 0; +} +$type_num_args{''} = 0; + +sub partition_names { + my ($self, $default_type, @items) = @_; + my (%found, @notfound, @trouble); + + while (my $item = shift @items) { + my $default = delete $item->{default}; + if ($default) { + # If we find a default value, convert it into a regular item and + # append it to the queue of items to process + my $default_item = {%$item}; + $default_item->{invert_macro} = 1; + $default_item->{pre} = delete $item->{def_pre}; + $default_item->{post} = delete $item->{def_post}; + $default_item->{type} = shift @$default; + $default_item->{value} = $default; + push @items, $default_item; + } else { + # It can be "not found" unless it's the default (invert the macro) + # or the "macro" is an empty string (ie no macro) + push @notfound, $item unless $item->{invert_macro} + or !$self->macro_to_ifdef($self->macro_from_item($item)); + } + + if ($item->{pre} or $item->{post} or $item->{not_constant} + or $type_is_a_problem{$item->{type}}) { + push @trouble, $item; + } else { + push @{$found{$item->{type}}}, $item; + } + } + # use Data::Dumper; print Dumper \%found; + (\%found, \@notfound, \@trouble); +} + +sub boottime_iterator { + my ($self, $type, $iterator, $hash, $subname) = @_; + my $extractor = $type_from_struct{$type}; + die "Can't find extractor code for type $type" + unless defined $extractor; + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + my $athx = $self->C_constant_prefix_param(); + + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + while ($iterator->name) { + $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + ++$iterator; + } +EOBOOT +} + +sub name_len_value_macro { + my ($self, $item) = @_; + my $name = $item->{name}; + my $value = $item->{value}; + $value = $item->{name} unless defined $value; + + my $namelen = length $name; + if ($name =~ tr/\0-\377// != $namelen) { + # the hash API signals UTF-8 by passing the length negated. + utf8::encode($name); + $namelen = -length $name; + } + $name = C_stringify($name); + + my $macro = $self->macro_from_item($item); + ($name, $namelen, $value, $macro); +} + +sub WriteConstants { + my $self = shift; + my $ARGS = {@_}; + + my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) + = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)}; + + my $options = $ARGS->{PROXYSUBS}; + $options = {} unless ref $options; + my $explosives = $options->{croak_on_read}; + + $xs_subname ||= 'constant'; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + # All the types we see + my $what = {}; + # A hash to lookup items with. + my $items = {}; + + my @items = $self->normalise_items ({disable_utf8_duplication => 1}, + $default_type, $what, $items, + @{$ARGS->{NAMES}}); + + # Partition the values by type. Also include any defaults in here + # Everything that doesn't have a default needs alternative code for + # "I'm missing" + # And everything that has pre or post code ends up in a private block + my ($found, $notfound, $trouble) + = $self->partition_names($default_type, @items); + + my $pthx = $self->C_constant_prefix_param_defintion(); + my $athx = $self->C_constant_prefix_param(); + my $symbol_table = C_stringify($package) . '::'; + + my $can_do_pcs = $] >= 5.009; + my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; + + print $c_fh $self->header(), <<"EOADD"; +static void +${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { +EOADD + if (!$can_do_pcs) { + print $c_fh <<'EO_NOPCS'; + if (namelen == namelen) { +EO_NOPCS + } else { + print $c_fh <<"EO_PCS"; + SV **sv = hv_fetch(hash, name, namelen, TRUE); + if (!sv) { + Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::", + name); + } + if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { + /* Someone has been here before us - have to make a real sub. */ +EO_PCS + } + # This piece of code is common to both + print $c_fh <<"EOADD"; + newCONSTSUB(hash, ${cast_CONSTSUB}name, value); +EOADD + if ($can_do_pcs) { + print $c_fh <<'EO_PCS'; + } else { + SvUPGRADE(*sv, SVt_RV); + SvRV_set(*sv, value); + SvROK_on(*sv); + SvREADONLY_on(value); + } +EO_PCS + } else { + print $c_fh <<'EO_NOPCS'; + } +EO_NOPCS + } + print $c_fh <<'EOADD'; +} + +EOADD + + print $c_fh $explosives ? <<"EXPLODE" : "\n"; + +static int +Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_UNUSED_ARG(mg); + Perl_croak(aTHX_ + "Your vendor has not defined $package_sprintf_safe macro %"SVf + " used", sv); + NORETURN_FUNCTION_END; +} + +static MGVTBL not_defined_vtbl = { + Im_sorry_Dave, /* get - I'm afraid I can't do that */ + Im_sorry_Dave, /* set */ + 0, /* len */ + 0, /* clear */ + 0, /* free */ + 0, /* copy */ + 0, /* dup */ +}; + +EXPLODE + +{ + my $key = $symbol_table; + # Just seems tidier (and slightly more space efficient) not to have keys + # such as Fcntl:: + $key =~ s/::$//; + my $key_len = length $key; + + print $c_fh <<"MISSING"; + +#ifndef SYMBIAN + +/* Store a hash of all symbols missing from the package. To avoid trampling on + the package namespace (uninvited) put each package's hash in our namespace. + To avoid creating lots of typeblogs and symbol tables for sub-packages, put + each package's hash into one hash in our namespace. */ + +static HV * +get_missing_hash(pTHX) { + HV *const parent + = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); + /* We could make a hash of hashes directly, but this would confuse anything + at Perl space that looks at us, and as we're visible in Perl space, + best to play nice. */ + SV *const *const ref + = hv_fetch(parent, "$key", $key_len, TRUE); + HV *new_hv; + + if (!ref) + return NULL; + + if (SvROK(*ref)) + return (HV*) SvRV(*ref); + + new_hv = newHV(); + SvUPGRADE(*ref, SVt_RV); + SvRV_set(*ref, (SV *)new_hv); + SvROK_on(*ref); + return new_hv; +} + +#endif + +MISSING + +} + + print $xs_fh <<"EOBOOT"; +BOOT: + { +#ifdef dTHX + dTHX; +#endif + HV *symbol_table = get_hv("$symbol_table", GV_ADD); +#ifndef SYMBIAN + HV *${c_subname}_missing; +#endif +EOBOOT + + my %iterator; + + $found->{''} + = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; + + foreach my $type (sort keys %$found) { + my $struct = $type_to_struct{$type}; + my $type_to_value = $self->type_to_C_value($type); + my $number_of_args = $type_num_args{$type}; + die "Can't find structure definition for type $type" + unless defined $struct; + + my $struct_type = $type ? lc($type) . '_s' : 'notfound_s'; + print $c_fh "struct $struct_type $struct;\n"; + + my $array_name = 'values_for_' . ($type ? lc $type : 'notfound'); + print $xs_fh <<"EOBOOT"; + + static const struct $struct_type $array_name\[] = + { +EOBOOT + + + foreach my $item (@{$found->{$type}}) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + + my $ifdef = $self->macro_to_ifdef($macro); + if (!$ifdef && $item->{invert_macro}) { + carp("Attempting to supply a default for '$name' which has no conditional macro"); + next; + } + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + print $xs_fh " { ", join (', ', "\"$name\"", $namelen, + &$type_to_value($value)), " },\n", + $self->macro_to_endif($macro); + } + + + # Terminate the list with a NULL + print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; + + $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound'); + + print $xs_fh <<"EOBOOT"; + const struct $struct_type *$iterator{$type} = $array_name; +EOBOOT + } + + delete $found->{''}; + + print $xs_fh <<"EOBOOT"; +#ifndef SYMBIAN + ${c_subname}_missing = get_missing_hash(aTHX); +#endif +EOBOOT + + my $add_symbol_subname = $c_subname . '_add_symbol'; + foreach my $type (sort keys %$found) { + print $xs_fh $self->boottime_iterator($type, $iterator{$type}, + 'symbol_table', + $add_symbol_subname); + } + + print $xs_fh <<"EOBOOT"; + while (value_for_notfound->name) { +EOBOOT + + print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; + SV *tripwire = newSV(0); + + sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); + SvPV_set(tripwire, (char *)value_for_notfound->name); + if(value_for_notfound->namelen >= 0) { + SvCUR_set(tripwire, value_for_notfound->namelen); + } else { + SvCUR_set(tripwire, -value_for_notfound->namelen); + SvUTF8_on(tripwire); + } + SvPOKp_on(tripwire); + SvREADONLY_on(tripwire); + assert(SvLEN(tripwire) == 0); + + $add_symbol_subname($athx symbol_table, value_for_notfound->name, + value_for_notfound->namelen, tripwire); +EXPLODE + + /* Need to add prototypes, else parsing will vary by platform. */ + SV **sv = hv_fetch(symbol_table, value_for_notfound->name, + value_for_notfound->namelen, TRUE); + if (!sv) { + Perl_croak($athx + "Couldn't add key '%s' to %%$package_sprintf_safe\::", + value_for_notfound->name); + } + if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) { + /* Nothing was here before, so mark a prototype of "" */ + sv_setpvn(*sv, "", 0); + } else if (SvPOK(*sv) && SvCUR(*sv) == 0) { + /* There is already a prototype of "" - do nothing */ + } else { + /* Someone has been here before us - have to make a real + typeglob. */ + /* It turns out to be incredibly hard to deal with all the + corner cases of sub foo (); and reporting errors correctly, + so lets cheat a bit. Start with a constant subroutine */ + CV *cv = newCONSTSUB(symbol_table, + ${cast_CONSTSUB}value_for_notfound->name, + &PL_sv_yes); + /* and then turn it into a non constant declaration only. */ + SvREFCNT_dec(CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + CvXSUB(cv) = NULL; + CvXSUBANY(cv).any_ptr = NULL; + } +#ifndef SYMBIAN + if (!hv_store(${c_subname}_missing, value_for_notfound->name, + value_for_notfound->namelen, &PL_sv_yes, 0)) + Perl_croak($athx "Couldn't add key '%s' to missing_hash", + value_for_notfound->name); +#endif +DONT + + print $xs_fh <<"EOBOOT"; + + ++value_for_notfound; + } +EOBOOT + + foreach my $item (@$trouble) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + my $ifdef = $self->macro_to_ifdef($macro); + my $type = $item->{type}; + my $type_to_value = $self->type_to_C_value($type); + + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + print $xs_fh " {\n"; + # We need to use a temporary value because some really troublesome + # items use C pre processor directives in their values, and in turn + # these don't fit nicely in the macro-ised generator functions + my $counter = 0; + printf $xs_fh " %s temp%d;\n", $_, $counter++ + foreach @{$type_temporary{$type}}; + + print $xs_fh " $item->{pre}\n" if $item->{pre}; + + # And because the code in pre might be both declarations and + # statements, we can't declare and assign to the temporaries in one. + $counter = 0; + printf $xs_fh " temp%d = %s;\n", $counter++, $_ + foreach &$type_to_value($value); + + my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; + printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); + ${c_subname}_add_symbol($athx symbol_table, "%s", + $namelen, %s); +EOBOOT + print $xs_fh " $item->{post}\n" if $item->{post}; + print $xs_fh " }\n"; + + print $xs_fh $self->macro_to_endif($macro); + } + + print $xs_fh <<EOBOOT; + /* As we've been creating subroutines, we better invalidate any cached + methods */ + ++PL_sub_generation; + } +EOBOOT + + print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; + +void +$xs_subname(sv) + INPUT: + SV * sv; + PPCODE: + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + PUSHs(sv_2mortal(sv)); +EXPLODE + +void +$xs_subname(sv) + PREINIT: + STRLEN len; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: +#ifdef SYMBIAN + sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv); +#else + HV *${c_subname}_missing = get_missing_hash(aTHX); + if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) { + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + } else { + sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", + sv); + } +#endif + PUSHs(sv_2mortal(sv)); +DONT + +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm new file mode 100644 index 00000000000..016507c72a6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm @@ -0,0 +1,131 @@ +package ExtUtils::Constant::Utils; + +use strict; +use vars qw($VERSION @EXPORT_OK @ISA $is_perl56); +use Carp; + +@ISA = 'Exporter'; +@EXPORT_OK = qw(C_stringify perl_stringify); +$VERSION = '0.02'; + +$is_perl56 = ($] < 5.007 && $] > 5.005_50); + +=head1 NAME + +ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant + +=head1 SYNOPSIS + + use ExtUtils::Constant::Utils qw (C_stringify); + $C_code = C_stringify $stuff; + +=head1 DESCRIPTION + +ExtUtils::Constant::Utils packages up utility subroutines used by +ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its +functions are explicitly exportable. + +=head1 USAGE + +=over 4 + +=item C_stringify NAME + +A function which returns a 7 bit ASCII correctly \ escaped version of the +string passed suitable for C's "" or ''. It will die if passed Unicode +characters. + +=cut + +# Hopefully make a happy C identifier. +sub C_stringify { + local $_ = shift; + return unless defined $_; + # grr 5.6.1 + confess "Wide character in '$_' intended as a C identifier" + if tr/\0-\377// != length; + # grr 5.6.1 moreso because its regexps will break on data that happens to + # be utf8, which includes my 8 bit test cases. + $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/([[:^print:]])/sprintf "\\%03o", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; + } + unless ($] < 5.006) { + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + +=item perl_stringify NAME + +A function which returns a 7 bit ASCII correctly \ escaped version of the +string passed suitable for a perl "" string. + +=cut + +# Hopefully make a happy perl identifier. +sub perl_stringify { + local $_ = shift; + return unless defined $_; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + unless ($] < 5.006) { + if ($] > 5.007) { + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; + } + } else { + # Grr 5.6.1. And I don't think I can use utf8; to force the regexp + # because 5.005_03 will fail. + # This is grim, but I also can't split on // + my $copy; + foreach my $index (0 .. length ($_) - 1) { + my $char = substr ($_, $index, 1); + $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; + } + $_ = $copy; + } + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + # Turns out "\x{}" notation only arrived with 5.6 + s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + +1; +__END__ + +=back + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/XS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/XS.pm new file mode 100644 index 00000000000..14eb8097146 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/XS.pm @@ -0,0 +1,259 @@ +package ExtUtils::Constant::XS; + +use strict; +use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56); +use Carp; +use ExtUtils::Constant::Utils 'perl_stringify'; +require ExtUtils::Constant::Base; + + +@ISA = qw(ExtUtils::Constant::Base Exporter); +@EXPORT_OK = qw(%XS_Constant %XS_TypeSet); + +$VERSION = '0.03'; + +$is_perl56 = ($] < 5.007 && $] > 5.005_50); + +=head1 NAME + +ExtUtils::Constant::XS - generate C code for XS modules' constants. + +=head1 SYNOPSIS + + require ExtUtils::Constant::XS; + +=head1 DESCRIPTION + +ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C +code for XS modules' constants. + +=head1 BUGS + +Nothing is documented. + +Probably others. + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others + +=cut + +# '' is used as a flag to indicate non-ascii macro names, and hence the need +# to pass in the utf8 on/off flag. +%XS_Constant = ( + '' => '', + IV => 'PUSHi(iv)', + UV => 'PUSHu((UV)iv)', + NV => 'PUSHn(nv)', + PV => 'PUSHp(pv, strlen(pv))', + PVN => 'PUSHp(pv, iv)', + SV => 'PUSHs(sv)', + YES => 'PUSHs(&PL_sv_yes)', + NO => 'PUSHs(&PL_sv_no)', + UNDEF => '', # implicit undef +); + +%XS_TypeSet = ( + IV => '*iv_return = ', + UV => '*iv_return = (IV)', + NV => '*nv_return = ', + PV => '*pv_return = ', + PVN => ['*pv_return = ', '*iv_return = (IV)'], + SV => '*sv_return = ', + YES => undef, + NO => undef, + UNDEF => undef, +); + +sub header { + my $start = 1; + my @lines; + push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; + push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; + foreach (sort keys %XS_Constant) { + next if $_ eq ''; + push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; + } + push @lines, << 'EOT'; + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif +EOT + + return join '', @lines; +} + +sub valid_type { + my ($self, $type) = @_; + return exists $XS_TypeSet{$type}; +} + +# This might actually be a return statement +sub assignment_clause_for_type { + my $self = shift; + my $args = shift; + my $type = $args->{type}; + my $typeset = $XS_TypeSet{$type}; + if (ref $typeset) { + die "Type $type is aggregate, but only single value given" + if @_ == 1; + return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset; + } elsif (defined $typeset) { + confess "Aggregate value given for type $type" + if @_ > 1; + return "$typeset$_[0];"; + } + return (); +} + +sub return_statement_for_type { + my ($self, $type) = @_; + # In the future may pass in an options hash + $type = $type->{type} if ref $type; + "return PERL_constant_IS$type;"; +} + +sub return_statement_for_notdef { + # my ($self) = @_; + "return PERL_constant_NOTDEF;"; +} + +sub return_statement_for_notfound { + # my ($self) = @_; + "return PERL_constant_NOTFOUND;"; +} + +sub default_type { + 'IV'; +} + +sub macro_from_name { + my ($self, $item) = @_; + my $macro = $item->{name}; + $macro = $item->{value} unless defined $macro; + $macro; +} + +sub macro_from_item { + my ($self, $item) = @_; + my $macro = $item->{macro}; + $macro = $self->macro_from_name($item) unless defined $macro; + $macro; +} + +# Keep to the traditional perl source macro +sub memEQ { + "memEQ"; +} + +sub params { + my ($self, $what) = @_; + foreach (sort keys %$what) { + warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; + } + my $params = {}; + $params->{''} = 1 if $what->{''}; + $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; + $params->{NV} = 1 if $what->{NV}; + $params->{PV} = 1 if $what->{PV} || $what->{PVN}; + $params->{SV} = 1 if $what->{SV}; + return $params; +} + + +sub C_constant_prefix_param { + "aTHX_ "; +} + +sub C_constant_prefix_param_defintion { + "pTHX_ "; +} + +sub namelen_param_definition { + 'STRLEN ' . $_[0] -> namelen_param; +} + +sub C_constant_other_params_defintion { + my ($self, $params) = @_; + my $body = ''; + $body .= ", int utf8" if $params->{''}; + $body .= ", IV *iv_return" if $params->{IV}; + $body .= ", NV *nv_return" if $params->{NV}; + $body .= ", const char **pv_return" if $params->{PV}; + $body .= ", SV **sv_return" if $params->{SV}; + $body; +} + +sub C_constant_other_params { + my ($self, $params) = @_; + my $body = ''; + $body .= ", utf8" if $params->{''}; + $body .= ", iv_return" if $params->{IV}; + $body .= ", nv_return" if $params->{NV}; + $body .= ", pv_return" if $params->{PV}; + $body .= ", sv_return" if $params->{SV}; + $body; +} + +sub dogfood { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type what indent breakout)}; + my $result = <<"EOT"; + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!$^X -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +EOT + $result .= $self->dump_names ({default_type=>$default_type, what=>$what, + indent=>0, declare_types=>1}, + @items); + $result .= <<'EOT'; + +print constant_types(), "\n"; # macro defs +EOT + $package = perl_stringify($package); + $result .= + "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; + # The form of the indent parameter isn't defined. (Yet) + if (defined $indent) { + require Data::Dumper; + $Data::Dumper::Terse=1; + $Data::Dumper::Terse=1; # Not used once. :-) + chomp ($indent = Data::Dumper::Dumper ($indent)); + $result .= $indent; + } else { + $result .= 'undef'; + } + $result .= ", $breakout" . ', @names) ) { + print $_, "\n"; # C constant subs +} +print "\n#### XS Section:\n"; +print XS_constant ("' . $package . '", $types); +__END__ + */ + +'; + + $result; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Embed.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Embed.pm new file mode 100644 index 00000000000..24ae9092f52 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Embed.pm @@ -0,0 +1,511 @@ +# $Id: Embed.pm,v 1.1.1.1 2002/01/16 19:27:19 schwern Exp $ +require 5.002; + +package ExtUtils::Embed; +require Exporter; +require FileHandle; +use Config; +use Getopt::Std; +use File::Spec; + +#Only when we need them +#require ExtUtils::MakeMaker; +#require ExtUtils::Liblist; + +use vars qw(@ISA @EXPORT $VERSION + @Extensions $Verbose $lib_ext + $opt_o $opt_s + ); +use strict; + +# This is not a dual-life module, so no need for development version numbers +$VERSION = '1.28'; + +@ISA = qw(Exporter); +@EXPORT = qw(&xsinit &ldopts + &ccopts &ccflags &ccdlflags &perl_inc + &xsi_header &xsi_protos &xsi_body); + +#let's have Miniperl borrow from us instead +#require ExtUtils::Miniperl; +#*canon = \&ExtUtils::Miniperl::canon; + +$Verbose = 0; +$lib_ext = $Config{lib_ext} || '.a'; + +sub is_cmd { $0 eq '-e' } + +sub my_return { + my $val = shift; + if(is_cmd) { + print $val; + } + else { + return $val; + } +} + +sub xsinit { + my($file, $std, $mods) = @_; + my($fh,@mods,%seen); + $file ||= "perlxsi.c"; + my $xsinit_proto = "pTHX"; + + if (@_) { + @mods = @$mods if $mods; + } + else { + getopts('o:s:'); + $file = $opt_o if defined $opt_o; + $std = $opt_s if defined $opt_s; + @mods = @ARGV; + } + $std = 1 unless scalar @mods; + + if ($file eq "STDOUT") { + $fh = \*STDOUT; + } + else { + $fh = new FileHandle "> $file"; + } + + push(@mods, static_ext()) if defined $std; + @mods = grep(!$seen{$_}++, @mods); + + print $fh &xsi_header(); + print $fh "EXTERN_C void xs_init ($xsinit_proto);\n\n"; + print $fh &xsi_protos(@mods); + + print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n"; + print $fh &xsi_body(@mods); + print $fh "}\n"; + +} + +sub xsi_header { + return <<EOF; +#include <EXTERN.h> +#include <perl.h> + +EOF +} + +sub xsi_protos { + my(@exts) = @_; + my(@retval,%seen); + my $boot_proto = "pTHX_ CV* cv"; + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + my($ccode) = "EXTERN_C void boot_${cname} ($boot_proto);\n"; + next if $seen{$ccode}++; + push(@retval, $ccode); + } + return join '', @retval; +} + +sub xsi_body { + my(@exts) = @_; + my($pname,@retval,%seen); + my($dl) = canon('/','DynaLoader'); + push(@retval, "\tchar *file = __FILE__;\n"); + push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002; + push(@retval, "\n"); + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname, $ccode); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + if ($pname eq $dl){ + # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! + # boot_DynaLoader is called directly in DynaLoader.pm + $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n"; + push(@retval, $ccode) unless $seen{$ccode}++; + } else { + $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n"; + push(@retval, $ccode) unless $seen{$ccode}++; + } + } + return join '', @retval; +} + +sub static_ext { + unless (scalar @Extensions) { + my $static_ext = $Config{static_ext}; + $static_ext =~ s/^\s+//; + @Extensions = sort split /\s+/, $static_ext; + unshift @Extensions, qw(DynaLoader); + } + @Extensions; +} + +sub _escape { + my $arg = shift; + $$arg =~ s/([\(\)])/\\$1/g; +} + +sub _ldflags { + my $ldflags = $Config{ldflags}; + _escape(\$ldflags); + return $ldflags; +} + +sub _ccflags { + my $ccflags = $Config{ccflags}; + _escape(\$ccflags); + return $ccflags; +} + +sub _ccdlflags { + my $ccdlflags = $Config{ccdlflags}; + _escape(\$ccdlflags); + return $ccdlflags; +} + +sub ldopts { + require ExtUtils::MakeMaker; + require ExtUtils::Liblist; + my($std,$mods,$link_args,$path) = @_; + my(@mods,@link_args,@argv); + my($dllib,$config_libs,@potential_libs,@path); + local($") = ' ' unless $" eq ' '; + if (scalar @_) { + @link_args = @$link_args if $link_args; + @mods = @$mods if $mods; + } + else { + @argv = @ARGV; + #hmm + while($_ = shift @argv) { + /^-std$/ && do { $std = 1; next; }; + /^--$/ && do { @link_args = @argv; last; }; + /^-I(.*)/ && do { $path = $1 || shift @argv; next; }; + push(@mods, $_); + } + } + $std = 1 unless scalar @link_args; + my $sep = $Config{path_sep} || ':'; + @path = $path ? split(/\Q$sep/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; + # makemaker includes std libs on windows by default + if ($^O ne 'MSWin32' and defined($std)) { + push(@potential_libs, $Config{perllibs}); + } + + push(@mods, static_ext()) if $std; + + my($mod,@ns,$root,$sub,$extra,$archive,@archives); + print STDERR "Searching (@path) for archives\n" if $Verbose; + foreach $mod (@mods) { + @ns = split(/::|\/|\\/, $mod); + $sub = $ns[-1]; + $root = File::Spec->catdir(@ns); + + print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose; + foreach (@path) { + next unless -e ($archive = File::Spec->catdir($_,"auto",$root,"$sub$lib_ext")); + push @archives, $archive; + if(-e ($extra = File::Spec->catdir($_,"auto",$root,"extralibs.ld"))) { + local(*FH); + if(open(FH, $extra)) { + my($libs) = <FH>; chomp $libs; + push @potential_libs, split /\s+/, $libs; + } + else { + warn "Couldn't open '$extra'"; + } + } + last; + } + } + #print STDERR "\@potential_libs = @potential_libs\n"; + + my $libperl; + if ($^O eq 'MSWin32') { + $libperl = $Config{libperl}; + } + 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"; + } + + my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $lpath = qq["$lpath"] if $^O eq 'MSWin32'; + my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) = + MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs); + + my $ld_or_bs = $bsloadlibs || $ldloadlibs; + print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose; + my $ccdlflags = _ccdlflags(); + my $ldflags = _ldflags(); + my $linkage = "$ccdlflags $ldflags @archives $ld_or_bs"; + print STDERR "ldopts: '$linkage'\n" if $Verbose; + + return $linkage if scalar @_; + my_return("$linkage\n"); +} + +sub ccflags { + my $ccflags = _ccflags(); + my_return(" $ccflags "); +} + +sub ccdlflags { + my $ccdlflags = _ccdlflags(); + my_return(" $ccdlflags "); +} + +sub perl_inc { + my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $dir = qq["$dir"] if $^O eq 'MSWin32'; + my_return(" -I$dir "); +} + +sub ccopts { + ccflags . perl_inc; +} + +sub canon { + my($as, @ext) = @_; + foreach(@ext) { + # might be X::Y or lib/auto/X/Y/Y.a + next if s!::!/!g; + s:^(lib|ext)/(auto/)?::; + s:/\w+\.\w+$::; + } + map(s:/:$as:, @ext) if ($as ne '/'); + @ext; +} + +__END__ + +=head1 NAME + +ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications + +=head1 SYNOPSIS + + + perl -MExtUtils::Embed -e xsinit + perl -MExtUtils::Embed -e ccopts + perl -MExtUtils::Embed -e ldopts + +=head1 DESCRIPTION + +ExtUtils::Embed provides utility functions for embedding a Perl interpreter +and extensions in your C/C++ applications. +Typically, an application B<Makefile> will invoke ExtUtils::Embed +functions while building your application. + +=head1 @EXPORT + +ExtUtils::Embed exports the following functions: + +xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(), +ccdlflags(), xsi_header(), xsi_protos(), xsi_body() + +=head1 FUNCTIONS + +=over 4 + +=item xsinit() + +Generate C/C++ code for the XS initializer function. + +When invoked as C<`perl -MExtUtils::Embed -e xsinit --`> +the following options are recognized: + +B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>) + +B<-o STDOUT> will print to STDOUT. + +B<-std> (Write code for extensions that are linked with the current Perl.) + +Any additional arguments are expected to be names of modules +to generate code for. + +When invoked with parameters the following are accepted and optional: + +C<xsinit($filename,$std,[@modules])> + +Where, + +B<$filename> is equivalent to the B<-o> option. + +B<$std> is boolean, equivalent to the B<-std> option. + +B<[@modules]> is an array ref, same as additional arguments mentioned above. + +=item Examples + + + perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket + + +This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function +to the C B<boot_Socket> function and writes it to a file named F<xsinit.c>. + +Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly. + + perl -MExtUtils::Embed -e xsinit + + +This will generate code for linking with B<DynaLoader> and +each static extension found in B<$Config{static_ext}>. +The code is written to the default file name B<perlxsi.c>. + + + perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle + + +Here, code is written for all the currently linked extensions along with code +for B<DBI> and B<DBD::Oracle>. + +If you have a working B<DynaLoader> then there is rarely any need to statically link in any +other extensions. + +=item ldopts() + +Output arguments for linking the Perl library and extensions to your +application. + +When invoked as C<`perl -MExtUtils::Embed -e ldopts --`> +the following options are recognized: + +B<-std> + +Output arguments for linking the Perl library and any extensions linked +with the current Perl. + +B<-I> E<lt>path1:path2E<gt> + +Search path for ModuleName.a archives. +Default path is B<@INC>. +Library archives are expected to be found as +B</some/path/auto/ModuleName/ModuleName.a> +For example, when looking for B<Socket.a> relative to a search path, +we should find B<auto/Socket/Socket.a> + +When looking for B<DBD::Oracle> relative to a search path, +we should find B<auto/DBD/Oracle/Oracle.a> + +Keep in mind that you can always supply B</my/own/path/ModuleName.a> +as an additional linker argument. + +B<--> E<lt>list of linker argsE<gt> + +Additional linker arguments to be considered. + +Any additional arguments found before the B<--> token +are expected to be names of modules to generate code for. + +When invoked with parameters the following are accepted and optional: + +C<ldopts($std,[@modules],[@link_args],$path)> + +Where: + +B<$std> is boolean, equivalent to the B<-std> option. + +B<[@modules]> is equivalent to additional arguments found before the B<--> token. + +B<[@link_args]> is equivalent to arguments found after the B<--> token. + +B<$path> is equivalent to the B<-I> option. + +In addition, when ldopts is called with parameters, it will return the argument string +rather than print it to STDOUT. + +=item Examples + + + perl -MExtUtils::Embed -e ldopts + + +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 +specified by the B<-I> option. +In addition, when ModuleName.a is found, additional linker arguments +are picked up from the B<extralibs.ld> file in the same directory. + + + perl -MExtUtils::Embed -e ldopts -- -std Socket + + +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 -- -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. + + +=item perl_inc() + +For including perl header files this function simply prints: + + -I$Config{archlibexp}/CORE + +So, rather than having to say: + + perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"' + +Just say: + + perl -MExtUtils::Embed -e perl_inc + +=item ccflags(), ccdlflags() + +These functions simply print $Config{ccflags} and $Config{ccdlflags} + +=item ccopts() + +This function combines perl_inc(), ccflags() and ccdlflags() into one. + +=item xsi_header() + +This function simply returns a string defining the same B<EXTERN_C> macro as +B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>. + +=item xsi_protos(@modules) + +This function returns a string of B<boot_$ModuleName> prototypes for each @modules. + +=item xsi_body(@modules) + +This function returns a string of calls to B<newXS()> that glue the module B<bootstrap> +function to B<boot_ModuleName> for each @modules. + +B<xsinit()> uses the xsi_* functions to generate most of its code. + +=back + +=head1 EXAMPLES + +For examples on how to use B<ExtUtils::Embed> for building C/C++ applications +with embedded perl, see L<perlembed>. + +=head1 SEE ALSO + +L<perlembed> + +=head1 AUTHOR + +Doug MacEachern E<lt>F<dougm@osf.org>E<gt> + +Based on ideas from Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and +B<minimod.pl> by Andreas Koenig E<lt>F<k@anna.in-berlin.de>E<gt> and Tim Bunce. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Install.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Install.pm new file mode 100644 index 00000000000..da583650fdf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Install.pm @@ -0,0 +1,1365 @@ +package ExtUtils::Install; +use strict; + +use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config); + +use AutoSplit; +use Carp (); +use Config qw(%Config); +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; + + +@ISA = ('Exporter'); +@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); + +=pod + +=head1 NAME + +ExtUtils::Install - install files from here to there + +=head1 SYNOPSIS + + use ExtUtils::Install; + + install({ 'blib/lib' => 'some/install/dir' } ); + + uninstall($packlist); + + pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); + +=head1 VERSION + +1.55 + +=cut + +$VERSION = '1.55'; # <---- dont forget to update the POD section just above this line! +$VERSION = eval $VERSION; + +=pod + +=head1 DESCRIPTION + +Handles the installing and uninstalling of perl modules, scripts, man +pages, etc... + +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 + +=over + +=item _chmod($$;$) + +Wrapper to chmod() for debugging and error trapping. + +=item _warnonce(@) + +Warns about something only once. + +=item _choke(@) + +Dies with a special message. + +=back + +=end _private + +=cut + +my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS_noefs = $Is_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); + + if( $Is_VMS ) { + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_noefs = 0 if ($vms_efs); + } + + + +# *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) { + printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1; + } else { + my $err="$!"; + _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n", + $mode, $item, $err + if -e $item; + } +} + +=begin _private + +=over + +=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. + +=back + +=end _private + +=cut + + + +sub _unlink_or_rename { #XXX OS-SPECIFIC + my ( $file, $tryhard, $installing )= @_; + + _chmod( 0666, $file ); + my $unlink_count = 0; + while (unlink $file) { $unlink_count++; } + return $file if $unlink_count > 0; + 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."); + } + +} + + +=pod + +=head2 Functions + +=begin _private + +=over + +=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 +} + +=pod + +=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; + unless (defined $has_posix) { + $has_posix= (!$Is_cygwin && !$Is_Win32 + && eval 'local $^W; require POSIX; 1') || 0; + } + if ($has_posix) { + return POSIX::access($dir, POSIX::W_OK()); + } else { + return -w $dir; + } + } +} + +=pod + +=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($dir,1); + my @dirs = File::Spec->splitdir($dirs); + unshift @dirs, File::Spec->curdir + unless File::Spec->file_name_is_absolute($dir); + + my $path=''; + my @make; + while (@dirs) { + if ($Is_VMS_noefs) { + # There is a bug in catdir that is fixed when the EFS character + # set is enabled, which requires this VMS specific code. + $dir = File::Spec->catdir($vol,@dirs); + } + else { + $dir = File::Spec->catdir(@dirs); + $dir = File::Spec->catpath($vol,$dir,'') + if defined $vol and length $vol; + } + 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; +} + +=pod + +=item _mkpath($dir,$show,$mode,$verbose,$dry_run) + +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 $dry_run 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 $dry_run is not true dies if the directory can not be created or is not +writable. + +=cut + +sub _mkpath { + my ($dir,$show,$mode,$verbose,$dry_run)=@_; + if ( $verbose && $verbose > 1 && ! -d $dir) { + $show= 1; + printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; + } + if (!$dry_run) { + 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 ($dry_run) { + _warnonce @msg; + } else { + _choke @msg; + } + } elsif ($show and $dry_run) { + print "$_\n" for @make; + } + +} + +=pod + +=item _copy($from,$to,$verbose,$dry_run) + +Wrapper around File::Copy::copy to handle errors. + +If $verbose is true and >1 then additional dignostics will be emitted. + +If $dry_run is true then the copy will not actually occur. + +Dies if the copy fails. + +=cut + + +sub _copy { + my ( $from, $to, $verbose, $dry_run)=@_; + if ($verbose && $verbose>1) { + printf "copy(%s,%s)\n", $from, $to; + } + if (!$dry_run) { + File::Copy::copy($from,$to) + or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" ); + } +} + +=pod + +=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; +} + +=pod + +=end _private + +=item B<install> + + # deprecated forms + install(\%from_to); + install(\%from_to, $verbose, $dry_run, $uninstall_shadows, + $skip, $always_copy, \%result); + + # recommended form as of 1.47 + install([ + from_to => \%from_to, + verbose => 1, + dry_run => 0, + uninstall_shadows => 1, + skip => undef, + always_copy => 1, + result => \%install_results, + ]); + + +Copies each directory tree of %from_to to its corresponding value +preserving timestamps and permissions. + +There are two keys with a special meaning in the hash: "read" and +"write". These contain packlist files. After the copying is done, +install() will write the list of target files to $from_to{write}. If +$from_to{read} is given the contents of this file will be merged into +the written file. The read and the written file may be identical, but +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". $verbose values going +up to 5 show increasingly more diagnostics output. + +If $dry_run is true it will only print what it was going to do +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. + +B<Changes As of Version 1.47> + +As of version 1.47 the following additions were made to the install interface. +Note that the new argument style and use of the %result hash is recommended. + +The $always_copy parameter which when true causes files to be updated +regardles as to whether they have changed, if it is defined but false then +copies are made only if the files have changed, if it is undefined then the +value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default. + +The %result hash will be populated with the various keys/subhashes reflecting +the install. Currently these keys and their structure are: + + install => { $target => $source }, + install_fail => { $target => $source }, + install_unchanged => { $target => $source }, + + install_filtered => { $source => $pattern }, + + uninstall => { $uninstalled => $source }, + uninstall_fail => { $uninstalled => $source }, + +where C<$source> is the filespec of the file being installed. C<$target> is where +it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC> +or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that +caused a source file to be skipped. In future more keys will be added, such as to +show created directories, however this requires changes in other modules and must +therefore wait. + +These keys will be populated before any exceptions are thrown should there be an +error. + +Note that all updates of the %result are additive, the hash will not be +cleared before use, thus allowing status results of many installs to be easily +aggregated. + +B<NEW ARGUMENT STYLE> + +If there is only one argument and it is a reference to an array then +the array is assumed to contain a list of key-value pairs specifying +the options. In this case the option "from_to" is mandatory. This style +means that you dont have to supply a cryptic list of arguments and can +use a self documenting argument list that is easier to understand. + +This is now the recommended interface to install(). + +B<RETURN> + +If all actions were successful install will return a hashref of the results +as described above for the $result parameter. If any action is a failure +then install will die, therefore it is recommended to pass in the $result +parameter instead of using the return value. If the result parameter is +provided then the returned hashref will be the passed in hashref. + +=cut + +sub install { #XXX OS-SPECIFIC + my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_; + if (@_==1 and eval { 1+@$from_to }) { + my %opts = @$from_to; + $from_to = $opts{from_to} + or Carp::confess("from_to is a mandatory parameter"); + $verbose = $opts{verbose}; + $dry_run = $opts{dry_run}; + $uninstall_shadows = $opts{uninstall_shadows}; + $skip = $opts{skip}; + $always_copy = $opts{always_copy}; + $result = $opts{result}; + } + + $result ||= {}; + $verbose ||= 0; + $dry_run ||= 0; + + $skip= _get_install_skip($skip,$verbose); + $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY} + || $ENV{EU_ALWAYS_COPY} + || 0 + unless defined $always_copy; + + my(%from_to) = %$from_to; + my(%pack, $dir, %warned); + my($packlist) = ExtUtils::Packlist->new(); + + local(*DIR); + for (qw/read write/) { + $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. + + #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 $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}); + print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; + } + + 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); + my $sourcedir = File::Spec->catdir($source, $File::Find::dir); + my $sourcefile = File::Spec->catfile($sourcedir, $origfile); + + for my $pat (@$skip) { + if ( $sourcefile=~/$pat/ ) { + print "Skipping $targetfile (filtered)\n" + if $verbose>1; + $result->{install_filtered}{$sourcefile} = $pat; + 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; + # XXX: I wonder how useful this logic is actually -- demerphq + if ( $always_copy or !-f $targetfile or -s $targetfile != $size) { + $diff++; + } else { + # we might not need to copy this file + $diff = compare($sourcefile, $targetfile); + } + $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, $dry_run ); + } + foreach my $found (@found_files) { + my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, + $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found; + + my $realtarget= $targetfile; + if ($diff) { + eval { + if (-f $targetfile) { + print "_unlink_or_rename($targetfile)\n" if $verbose>1; + $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) + unless $dry_run; + } elsif ( ! -d $targetdir ) { + _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); + } + print "Installing $targetfile\n"; + + _copy( $sourcefile, $targetfile, $verbose, $dry_run, ); + + + #XXX OS-SPECIFIC + print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; + utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1; + + + $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + $mode = $mode | 0222 + if $realtarget ne $targetfile; + _chmod( $mode, $targetfile, $verbose ); + $result->{install}{$targetfile} = $sourcefile; + 1 + } or do { + $result->{install_fail}{$targetfile} = $sourcefile; + die $@; + }; + } else { + $result->{install_unchanged}{$targetfile} = $sourcefile; + print "Skipping $targetfile (unchanged)\n" if $verbose; + } + + if ( $uninstall_shadows ) { + inc_uninstall($sourcefile,$ffd, $verbose, + $dry_run, + $realtarget ne $targetfile ? $realtarget : "", + $result); + } + + # Record the full pathname. + $packlist->{$targetfile}++; + } + + if ($pack{'write'}) { + $dir = install_rooted_dir(dirname($pack{'write'})); + _mkpath( $dir, 0, 0755, $verbose, $dry_run ); + print "Writing $pack{'write'}\n" if $verbose; + $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; + } + + _do_cleanup($verbose); + return $result; +} + +=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]); + } else { + $_[0]; + } +} + + +sub install_rooted_dir { + if (defined $INSTALL_ROOT) { + File::Spec->catdir($INSTALL_ROOT, $_[0]); + } else { + $_[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 { + my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC + _unlink_or_rename( $file, $tryhard, not("installing") ); +} + +=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; + } + }, $dir); + return $files; +} + +=pod + +=item B<install_default> I<DISCOURAGED> + + install_default(); + install_default($fullext); + +Calls install() with arguments to copy a module from blib/ to the +default site installation location. + +$fullext is the name of the module converted to a directory +(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it +will attempt to read it from @ARGV. + +This is primarily useful for install scripts. + +B<NOTE> This function is not really useful because of the hard-coded +install location with no way to control site vs core vs vendor +directories and the strange way in which the module name is given. +Consider its use discouraged. + +=cut + +sub install_default { + @_ < 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"); + my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch"); + my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin'); + my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script'); + my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1'); + my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3'); + + my @INST_HTML; + if($Config{installhtmldir}) { + my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html'); + @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir}); + } + + 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}, + @INST_HTML, + },1,0,0); +} + + +=item B<uninstall> + + uninstall($packlist_file); + uninstall($packlist_file, $verbose, $dont_execute); + +Removes the files listed in a $packlist_file. + +If $verbose is true, will print out each file removed. Default is +false. + +If $dont_execute is true it will only print what it was going to do +without actually doing it. Default is false. + +=cut + +sub uninstall { + my($fil,$verbose,$dry_run) = @_; + $verbose ||= 0; + $dry_run ||= 0; + + 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($_,'tryhard') unless $dry_run; + } + print "unlink $fil\n" if $verbose; + forceunlink($fil, 'tryhard') unless $dry_run; + _do_cleanup($verbose); +} + +=begin _undocumented + +=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results) + +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. + +We now only die when failing to remove a file that has precedence over +our own, when our install has precedence we only warn. + +$results is assumed to contain a hashref which will have the keys +'uninstall' and 'uninstall_fail' populated with keys for the files +removed and values of the source files they would shadow. + +=end _undocumented + +=cut + +sub inc_uninstall { + my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_; + my($dir); + $ignore||=""; + my $file = (File::Spec->splitpath($filepath))[2]; + my %seen_dir = (); + + my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} + ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; + + my @dirs=( @PERL_ENV_LIB, + @INC, + @Config{qw(archlibexp + privlibexp + sitearchexp + sitelibexp)}); + + #warn join "\n","---",@dirs,"---"; + my $seen_ours; + foreach $dir ( @dirs ) { + my $canonpath = $Is_VMS ? $dir : 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; + + if (!$diff or $targetfile eq $ignore) { + $seen_ours = 1; + next; + } + if ($dry_run) { + $results->{uninstall}{$targetfile} = $filepath; + 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" if $verbose; + eval { + die "Fake die for testing" + if $ExtUtils::Install::Testing and + ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile); + forceunlink($targetfile,'tryhard'); + $results->{uninstall}{$targetfile} = $filepath; + 1; + } or do { + $results->{fail_uninstall}{$targetfile} = $filepath; + if ($seen_ours) { + warn "Failed to remove probably harmless shadow file '$targetfile'\n"; + } else { + die "$@\n"; + } + }; + } + } +} + +=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); + open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; + open(SRC, $src) || die "Cannot open $src: $!"; + my $buf; + my $sz = 1024; + while (my $len = sysread(SRC, $buf, $sz)) { + syswrite(CMD, $buf, $len); + } + close SRC; + close CMD or die "Filter command '$cmd' failed for $src"; +} + +=pod + +=item B<pm_to_blib> + + pm_to_blib(\%from_to, $autosplit_dir); + pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd); + +Copies each key of %from_to to its corresponding value efficiently. +Filenames with the extension .pm are autosplit into the $autosplit_dir. +Any destination directories are created. + +$filter_cmd is an optional shell command to run each .pm file through +prior to splitting and copying. Input is the contents of the module, +output the new module contents. + +You can have an environment variable PERL_INSTALL_ROOT set which will +be prepended as a directory to each installed file (and directory). + +=cut + +sub pm_to_blib { + my($fromto,$autodir,$pm_filter) = @_; + + _mkpath($autodir,0,0755); + while(my($from, $to) = each %$fromto) { + 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 + + 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){ + # 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); + } +} + + +=begin _private + +=item _autosplit + +From 1.0307 back, AutoSplit will sometimes leave an open filehandle to +the file being split. This causes problems on systems with mandatory +locking (ie. Windows). So we wrap it and close the filehandle. + +=end _private + +=cut + +sub _autosplit { #XXX OS-SPECIFIC + my $retval = autosplit(@_); + close *AutoSplit::IN if defined *AutoSplit::IN{IO}; + + return $retval; +} + + +package ExtUtils::Install::Warn; + +sub new { bless {}, shift } + +sub add { + my($self,$file,$targetfile) = @_; + push @{$self->{$file}}, $targetfile; +} + +sub DESTROY { + unless(defined $INSTALL_ROOT) { + my $self = shift; + my($file,$i,$plural); + foreach $file (sort keys %$self) { + $plural = @{$self->{$file}} > 1 ? "s" : ""; + print "## Differing version$plural of $file found. You might like to\n"; + for (0..$#{$self->{$file}}) { + print "rm ", $self->{$file}[$_], "\n"; + $i++; + } + } + $plural = $i>1 ? "all those files" : "this file"; + my $inst = (_invokant() eq 'ExtUtils::MakeMaker') + ? ( $Config::Config{make} || 'make' ).' install' + . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' ) + : './Build install uninst=1'; + print "## Running '$inst' will unlink $plural for you.\n"; + } +} + +=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; +} + +=pod + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item B<PERL_INSTALL_ROOT> + +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. + +=item B<EU_INSTALL_ALWAYS_COPY> + +If this environment variable is true then normal install processes will +always overwrite older identical files during the install process. + +Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY +is not defined until at least the 1.50 release. Please ensure you use the +correct EU_INSTALL_ALWAYS_COPY. + +=back + +=head1 AUTHOR + +Original author lost in the mists of time. Probably the same as Makemaker. + +Production release currently maintained by demerphq C<yves at cpan.org>, +extensive changes by Michael G. Schwern. + +Send bug reports via http://rt.cpan.org/. Please send your +generated Makefile along with your report. + +=head1 LICENSE + +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> + + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Installed.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Installed.pm new file mode 100644 index 00000000000..9cb1fc10d75 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Installed.pm @@ -0,0 +1,462 @@ +package ExtUtils::Installed; + +use 5.00503; +use strict; +#use warnings; # XXX requires 5.6 +use Carp qw(); +use ExtUtils::Packlist; +use ExtUtils::MakeMaker; +use Config; +use File::Find; +use File::Basename; +use File::Spec; + +my $Is_VMS = $^O eq 'VMS'; +my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); + +require VMS::Filespec if $Is_VMS; + +use vars qw($VERSION); +$VERSION = '1.999_001'; +$VERSION = eval $VERSION; + +sub _is_prefix { + my ($self, $path, $prefix) = @_; + return unless defined $prefix && defined $path; + + if( $Is_VMS ) { + $prefix = VMS::Filespec::unixify($prefix); + $path = VMS::Filespec::unixify($path); + } + + # Unix path normalization. + $prefix = File::Spec->canonpath($prefix); + + return 1 if substr($path, 0, length($prefix)) eq $prefix; + + if ($DOSISH) { + $path =~ s|\\|/|g; + $prefix =~ s|\\|/|g; + return 1 if $path =~ m{^\Q$prefix\E}i; + } + return(0); +} + +sub _is_doc { + my ($self, $path) = @_; + + my $man1dir = $self->{':private:'}{Config}{man1direxp}; + my $man3dir = $self->{':private:'}{Config}{man3direxp}; + return(($man1dir && $self->_is_prefix($path, $man1dir)) + || + ($man3dir && $self->_is_prefix($path, $man3dir)) + ? 1 : 0) +} + +sub _is_type { + my ($self, $path, $type) = @_; + return 1 if $type eq "all"; + + return($self->_is_doc($path)) if $type eq "doc"; + my $conf= $self->{':private:'}{Config}; + if ($type eq "prog") { + return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp}) + && !($self->_is_doc($path)) ? 1 : 0); + } + return(0); +} + +sub _is_under { + my ($self, $path, @under) = @_; + $under[0] = "" if (! @under); + foreach my $dir (@under) { + return(1) if ($self->_is_prefix($path, $dir)); + } + + return(0); +} + +sub _fix_dirs { + my ($self, @dirs)= @_; + # File::Find does not know how to deal with VMS filepaths. + if( $Is_VMS ) { + $_ = VMS::Filespec::unixify($_) + for @dirs; + } + + if ($DOSISH) { + s|\\|/|g for @dirs; + } + return wantarray ? @dirs : $dirs[0]; +} + +sub _make_entry { + my ($self, $module, $packlist_file, $modfile)= @_; + + my $data= { + module => $module, + packlist => scalar(ExtUtils::Packlist->new($packlist_file)), + packlist_file => $packlist_file, + }; + + if (!$modfile) { + $data->{version} = $self->{':private:'}{Config}{version}; + } else { + $data->{modfile} = $modfile; + # Find the top-level module file in @INC + $data->{version} = ''; + foreach my $dir (@{$self->{':private:'}{INC}}) { + my $p = File::Spec->catfile($dir, $modfile); + if (-r $p) { + $module = _module_name($p, $module) if $Is_VMS; + + $data->{version} = MM->parse_version($p); + $data->{version_from} = $p; + $data->{packlist_valid} = exists $data->{packlist}{$p}; + last; + } + } + } + $self->{$module}= $data; +} + +our $INSTALLED; +sub new { + my ($class) = shift(@_); + $class = ref($class) || $class; + + my %args = @_; + + return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default}); + + my $self = bless {}, $class; + + $INSTALLED= $self if $args{default_set} || $args{default}; + + + if ($args{config_override}) { + eval { + $self->{':private:'}{Config} = { %{$args{config_override}} }; + } or Carp::croak( + "The 'config_override' parameter must be a hash reference." + ); + } + else { + $self->{':private:'}{Config} = \%Config; + } + + for my $tuple ([inc_override => INC => [ @INC ] ], + [ extra_libs => EXTRA => [] ]) + { + my ($arg,$key,$val)=@$tuple; + if ( $args{$arg} ) { + eval { + $self->{':private:'}{$key} = [ @{$args{$arg}} ]; + } or Carp::croak( + "The '$arg' parameter must be an array reference." + ); + } + elsif ($val) { + $self->{':private:'}{$key} = $val; + } + } + { + my %dupe; + @{$self->{':private:'}{LIBDIRS}} = grep { -e $_ && !$dupe{$_}++ } + @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}}; + } + + my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}}); + + # Read the core packlist + my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp}); + $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist')); + + my $root; + # Read the module packlists + my $sub = sub { + # Only process module .packlists + return if $_ ne ".packlist" || $File::Find::dir eq $archlib; + + # Hack of the leading bits of the paths & convert to a module name + my $module = $File::Find::name; + my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s + or do { + # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n", + # join ("\n",@dirs); + return; + }; + + my $modfile = "$module.pm"; + $module =~ s!/!::!g; + + return if $self->{$module}; #shadowing? + $self->_make_entry($module,$File::Find::name,$modfile); + }; + while (@dirs) { + $root= shift @dirs; + next if !-d $root; + find($sub,$root); + } + + return $self; +} + +# VMS's non-case preserving file-system means the package name can't +# be reconstructed from the filename. +sub _module_name { + my($file, $orig_module) = @_; + + my $module = ''; + if (open PACKFH, $file) { + while (<PACKFH>) { + if (/package\s+(\S+)\s*;/) { + my $pack = $1; + # Make a sanity check, that lower case $module + # is identical to lowercase $pack before + # accepting it + if (lc($pack) eq lc($orig_module)) { + $module = $pack; + last; + } + } + } + close PACKFH; + } + + print STDERR "Couldn't figure out the package name for $file\n" + unless $module; + + return $module; +} + +sub modules { + my ($self) = @_; + $self= $self->new(default=>1) if !ref $self; + + # Bug/feature of sort in scalar context requires this. + return wantarray + ? sort grep { not /^:private:$/ } keys %$self + : grep { not /^:private:$/ } keys %$self; +} + +sub files { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + + # Validate arguments + Carp::croak("$module is not installed") if (! exists($self->{$module})); + $type = "all" if (! defined($type)); + Carp::croak('type must be "all", "prog" or "doc"') + if ($type ne "all" && $type ne "prog" && $type ne "doc"); + + my (@files); + foreach my $file (keys(%{$self->{$module}{packlist}})) { + push(@files, $file) + if ($self->_is_type($file, $type) && + $self->_is_under($file, @under)); + } + return(@files); +} + +sub directories { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + my (%dirs); + foreach my $file ($self->files($module, $type, @under)) { + $dirs{dirname($file)}++; + } + return sort keys %dirs; +} + +sub directory_tree { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + my (%dirs); + foreach my $dir ($self->directories($module, $type, @under)) { + $dirs{$dir}++; + my ($last) = (""); + while ($last ne $dir) { + $last = $dir; + $dir = dirname($dir); + last if !$self->_is_under($dir, @under); + $dirs{$dir}++; + } + } + return(sort(keys(%dirs))); +} + +sub validate { + my ($self, $module, $remove) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{packlist}->validate($remove)); +} + +sub packlist { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{packlist}); +} + +sub version { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{version}); +} + +sub debug_dump { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + local $self->{":private:"}{Config}; + require Data::Dumper; + print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump(); +} + + +1; + +__END__ + +=head1 NAME + +ExtUtils::Installed - Inventory management of installed modules + +=head1 SYNOPSIS + + use ExtUtils::Installed; + my ($inst) = ExtUtils::Installed->new(); + my (@modules) = $inst->modules(); + my (@missing) = $inst->validate("DBI"); + my $all_files = $inst->files("DBI"); + my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local"); + my $all_dirs = $inst->directories("DBI"); + my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog"); + my $packlist = $inst->packlist("DBI"); + +=head1 DESCRIPTION + +ExtUtils::Installed provides a standard way to find out what core and module +files have been installed. It uses the information stored in .packlist files +created during installation to provide this information. In addition it +provides facilities to classify the installed files and to extract directory +information from the .packlist files. + +=head1 USAGE + +The new() function searches for all the installed .packlists on the system, and +stores their contents. The .packlists can be queried with the functions +described below. Where it searches by default is determined by the settings found +in C<%Config::Config>, and what the value is of the PERL5LIB environment variable. + +=head1 METHODS + +Unless specified otherwise all method can be called as class methods, or as object +methods. If called as class methods then the "default" object will be used, and if +necessary created using the current processes %Config and @INC. See the +'default' option to new() for details. + + +=over 4 + +=item new() + +This takes optional named parameters. Without parameters, this +searches for all the installed .packlists on the system using +information from C<%Config::Config> and the default module search +paths C<@INC>. The packlists are read using the +L<ExtUtils::Packlist> module. + +If the named parameter C<config_override> is specified, +it should be a reference to a hash which contains all information +usually found in C<%Config::Config>. For example, you can obtain +the configuration information for a separate perl installation and +pass that in. + + my $yoda_cfg = get_fake_config('yoda'); + my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg); + +Similarly, the parameter C<inc_override> may be a reference to an +array which is used in place of the default module search paths +from C<@INC>. + + use Config; + my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB}); + my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs); + +B<Note>: You probably do not want to use these options alone, almost always +you will want to set both together. + +The parameter c<extra_libs> can be used to specify B<additional> paths to +search for installed modules. For instance + + my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]); + +This should only be necessary if C</my/lib/path> is not in PERL5LIB. + +Finally there is the 'default', and the related 'default_get' and 'default_set' +options. These options control the "default" object which is provided by the +class interface to the methods. Setting C<default_get> to true tells the constructor +to return the default object if it is defined. Setting C<default_set> to true tells +the constructor to make the default object the constructed object. Setting the +C<default> option is like setting both to true. This is used primarily internally +and probably isn't interesting to any real user. + +=item modules() + +This returns a list of the names of all the installed modules. The perl 'core' +is given the special name 'Perl'. + +=item files() + +This takes one mandatory parameter, the name of a module. It returns a list of +all the filenames from the package. To obtain a list of core perl files, use +the module name 'Perl'. Additional parameters are allowed. The first is one +of the strings "prog", "doc" or "all", to select either just program files, +just manual files or all files. The remaining parameters are a list of +directories. The filenames returned will be restricted to those under the +specified directories. + +=item directories() + +This takes one mandatory parameter, the name of a module. It returns a list of +all the directories from the package. Additional parameters are allowed. The +first is one of the strings "prog", "doc" or "all", to select either just +program directories, just manual directories or all directories. The remaining +parameters are a list of directories. The directories returned will be +restricted to those under the specified directories. This method returns only +the leaf directories that contain files from the specified module. + +=item directory_tree() + +This is identical in operation to directories(), except that it includes all the +intermediate directories back up to the specified directories. + +=item validate() + +This takes one mandatory parameter, the name of a module. It checks that all +the files listed in the modules .packlist actually exist, and returns a list of +any missing files. If an optional second argument which evaluates to true is +given any missing files will be removed from the .packlist + +=item packlist() + +This returns the ExtUtils::Packlist object for the specified module. + +=item version() + +This returns the version number for the specified module. + +=back + +=head1 EXAMPLE + +See the example in L<ExtUtils::Packlist>. + +=head1 AUTHOR + +Alan Burlison <Alan.Burlison@uk.sun.com> + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Liblist.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Liblist.pm new file mode 100644 index 00000000000..ea4dac4ae7c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Liblist.pm @@ -0,0 +1,286 @@ +package ExtUtils::Liblist; + +use strict; + +our $VERSION = '6.56'; + +use File::Spec; +require ExtUtils::Liblist::Kid; +our @ISA = qw(ExtUtils::Liblist::Kid File::Spec); + +# Backwards compatibility with old interface. +sub ext { + goto &ExtUtils::Liblist::Kid::ext; +} + +sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir DIR, $_[0]; + my @out = grep /$rex/, readdir DIR; + closedir DIR; + return @out; +} + +__END__ + +=head1 NAME + +ExtUtils::Liblist - determine libraries to use and how to use them + +=head1 SYNOPSIS + + require ExtUtils::Liblist; + + $MM->ext($potential_libs, $verbose, $need_names); + + # Usually you can get away with: + ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names) + +=head1 DESCRIPTION + +This utility takes a list of libraries in the form C<-llib1 -llib2 +-llib3> and returns lines suitable for inclusion in an extension +Makefile. Extra library paths may be included with the form +C<-L/another/path> this will affect the searches for all subsequent +libraries. + +It returns an array of four or five scalar values: EXTRALIBS, +BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to +the array of the filenames of actual libraries. Some of these don't +mean anything unless on Unix. See the details about those platform +specifics below. The list of the filenames is returned only if +$need_names argument is true. + +Dependent libraries can be linked in one of three ways: + +=over 2 + +=item * For static extensions + +by the ld command when the perl binary is linked with the extension +library. See EXTRALIBS below. + +=item * For dynamic extensions at build/link time + +by the ld command when the shared object is built/linked. See +LDLOADLIBS below. + +=item * For dynamic extensions at load time + +by the DynaLoader when the shared object is loaded. See BSLOADLIBS +below. + +=back + +=head2 EXTRALIBS + +List of libraries that need to be linked with when linking a perl +binary which includes this extension. Only those libraries that +actually exist are included. These are written to a file and used +when linking perl. + +=head2 LDLOADLIBS and LD_RUN_PATH + +List of those libraries which can or must be linked into the shared +library when created using ld. These may be static or dynamic +libraries. LD_RUN_PATH is a colon separated list of the directories +in LDLOADLIBS. It is passed as an environment variable to the process +that links the shared library. + +=head2 BSLOADLIBS + +List of those libraries that are needed but can be linked in +dynamically at run time on this platform. SunOS/Solaris does not need +this because ld records the information (from LDLOADLIBS) into the +object file. This list is used to create a .bs (bootstrap) file. + +=head1 PORTABILITY + +This module deals with a lot of system dependencies and has quite a +few architecture specific C<if>s in the code. + +=head2 VMS implementation + +The version of ext() which is executed under VMS differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is +present, a token is considered a directory to search if it is in fact +a directory, and a library to search for otherwise. Authors who wish +their extensions to be portable to Unix or OS/2 should use the Unix +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Wherever possible, shareable images are preferred to object libraries, +and object libraries to plain object files. In accordance with VMS +naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; +it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions +used in some ported software. + +=item * + +For each library that is found, an appropriate directive for a linker options +file is generated. The return values are space-separated strings of +these directives, rather than elements used on the linker command line. + +=item * + +LDLOADLIBS contains both the libraries found based on C<$potential_libs> and +the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those +libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH +are always empty. + +=back + +In addition, an attempt is made to recognize several common Unix library +names, and filter them out or convert them to their VMS equivalents, as +appropriate. + +In general, the VMS version of ext() should properly handle input from +extensions originally designed for a Unix or VMS environment. If you +encounter problems, or discover cases where the search could be improved, +please let us know. + +=head2 Win32 implementation + +The version of ext() which is executed under Win32 differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +If C<$potential_libs> is empty, the return value will be empty. +Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) +will be appended to the list of C<$potential_libs>. The libraries +will be searched for in the directories specified in C<$potential_libs>, +C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +For each library that is found, a space-separated list of fully qualified +library pathnames is generated. + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefixes used by Unix linkers. + +An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look +for the libraries that follow. + +An entry of the form C<-lfoo> specifies the library C<foo>, which may be +spelled differently depending on what kind of compiler you are using. If +you are using GCC, it gets translated to C<libfoo.a>, but for other win32 +compilers, it becomes C<foo.lib>. If no files are found by those translated +names, one more attempt is made to find them using either C<foo.a> or +C<libfoo.lib>, depending on whether GCC or some other win32 compiler is +being used, respectively. + +If neither the C<-L> or C<-l> prefix is present in an entry, the entry is +considered a directory to search if it is in fact a directory, and a +library to search for otherwise. The C<$Config{lib_ext}> suffix will +be appended to any entries that are not directories and don't already have +the suffix. + +Note that the C<-L> and C<-l> prefixes are B<not required>, but authors +who wish their extensions to be portable to Unix or OS/2 should use the +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Entries cannot be plain object files, as many Win32 compilers will +not handle object files in the place of libraries. + +=item * + +Entries in C<$potential_libs> beginning with a colon and followed by +alphanumeric characters are treated as flags. Unknown flags will be ignored. + +An entry that matches C</:nodefault/i> disables the appending of default +libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + +An entry that matches C</:nosearch/i> disables all searching for +the libraries specified after it. Translation of C<-Lfoo> and +C<-lfoo> still happens as appropriate (depending on compiler being used, +as reflected by C<$Config{cc}>), but the entries are not verified to be +valid files or directories. + +An entry that matches C</:search/i> reenables searching for +the libraries specified after it. You can put it at the end to +enable searching for default libraries specified by C<$Config{perllibs}>. + +=item * + +The libraries specified may be a mixture of static libraries and +import libraries (to link with DLLs). Since both kinds are used +pretty transparently on the Win32 platform, we do not attempt to +distinguish between them. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS +and LD_RUN_PATH are always empty (this may change in future). + +=item * + +You must make sure that any paths and path components are properly +surrounded with double-quotes if they contain spaces. For example, +C<$potential_libs> could be (literally): + + "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" + +Note how the first and last entries are protected by quotes in order +to protect the spaces. + +=item * + +Since this module is most often used only indirectly from extension +C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add +a library to the build process for an extension: + + LIBS => ['-lgl'] + +When using GCC, that entry specifies that MakeMaker should first look +for C<libgl.a> (followed by C<gl.a>) in all the locations specified by +C<$Config{libpth}>. + +When using a compiler other than GCC, the above entry will search for +C<gl.lib> (followed by C<libgl.lib>). + +If the library happens to be in a location not in C<$Config{libpth}>, +you need: + + LIBS => ['-Lc:\gllibs -lgl'] + +Here is a less often used example: + + LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] + +This specifies a search for library C<gl> as before. If that search +fails to find the library, it looks at the next item in the list. The +C<:nosearch> flag will prevent searching for the libraries that follow, +so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, +since GCC can use that value as is with its linker. + +When using the Visual C compiler, the second item is returned as +C<-libpath:d:\mesalibs mesa.lib user32.lib>. + +When using the Borland compiler, the second item is returned as +C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of +moving the C<-Ld:\mesalibs> to the correct place in the linker +command line. + +=back + + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Liblist/Kid.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Liblist/Kid.pm new file mode 100644 index 00000000000..b807e97cc86 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Liblist/Kid.pm @@ -0,0 +1,546 @@ +package ExtUtils::Liblist::Kid; + +# XXX Splitting this out into its own .pm is a temporary solution. + +# This kid package is to be used by MakeMaker. It will not work if +# $self is not a Makemaker. + +use 5.006; +# Broken out of MakeMaker from version 4.11 + +use strict; +our $VERSION = 6.56; + +use Config; +use Cwd 'cwd'; +use File::Basename; +use File::Spec; + +sub ext { + if ($^O eq 'VMS') { return &_vms_ext; } + elsif($^O eq 'MSWin32') { return &_win32_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { + my($self,$potential_libs, $verbose, $give_libs) = @_; + $verbose ||= 0; + + if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{so}; + my($libs) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs}; + my $Config_libext = $Config{lib_ext} || ".a"; + + + # compute $extralibs, $bsloadlibs and $ldloadlibs from + # $potential_libs + # this is a rewrite of Andy Dougherty's extliblist in perl + + my(@searchpath); # from "-L/path" entries in $potential_libs + my(@libpath) = split " ", $Config{'libpth'}; + my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); + my(@libs, %libs_seen); + my($fullname, @fullname); + my($pwd) = cwd(); # from Cwd.pm + my($found) = 0; + + foreach my $thislib (split ' ', $potential_libs) { + + # Handle possible linker path arguments. + if ($thislib =~ s/^(-[LR]|-Wl,-R)//){ # save path flag type + my($ptype) = $1; + unless (-d $thislib){ + warn "$ptype$thislib ignored, directory does not exist\n" + if $verbose; + next; + } + my($rtype) = $ptype; + if (($ptype eq '-R') or ($ptype eq '-Wl,-R')) { + if ($Config{'lddlflags'} =~ /-Wl,-R/) { + $rtype = '-Wl,-R'; + } elsif ($Config{'lddlflags'} =~ /-R/) { + $rtype = '-R'; + } + } + unless (File::Spec->file_name_is_absolute($thislib)) { + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + $thislib = $self->catdir($pwd,$thislib); + } + push(@searchpath, $thislib); + push(@extralibs, "$ptype$thislib"); + push(@ldloadlibs, "$rtype$thislib"); + next; + } + + # Handle possible library arguments. + unless ($thislib =~ s/^-l//){ + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; + next; + } + + my($found_lib)=0; + foreach my $thispth (@searchpath, @libpath) { + + # Try to find the full name of the library. We need this to + # determine whether it's a dynamically-loadable library or not. + # This tends to be subject to various os-specific quirks. + # For gcc-2.6.2 on linux (March 1995), DLD can not load + # .sa libraries, with the exception of libm.sa, so we + # deliberately skip them. + if (@fullname = + $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){ + # Take care that libfoo.so.10 wins against libfoo.so.9. + # Compare two libraries to find the most recent version + # number. E.g. if you have libfoo.so.9.0.7 and + # libfoo.so.10.1, first convert all digits into two + # decimal places. Then we'll add ".00" to the shorter + # strings so that we're comparing strings of equal length + # Thus we'll compare libfoo.so.09.07.00 with + # libfoo.so.10.01.00. Some libraries might have letters + # in the version. We don't know what they mean, but will + # try to skip them gracefully -- we'll set any letter to + # '0'. Finally, sort in reverse so we can take the + # first element. + + #TODO: iterate through the directory instead of sorting + + $fullname = "$thispth/" . + (sort { my($ma) = $a; + my($mb) = $b; + $ma =~ tr/A-Za-z/0/s; + $ma =~ s/\b(\d)\b/0$1/g; + $mb =~ tr/A-Za-z/0/s; + $mb =~ s/\b(\d)\b/0$1/g; + while (length($ma) < length($mb)) { $ma .= ".00"; } + while (length($mb) < length($ma)) { $mb .= ".00"; } + # Comparison deliberately backwards + $mb cmp $ma;} @fullname)[0]; + } elsif (-f ($fullname="$thispth/lib$thislib.$so") + && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){ + } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext") + && ($Config{'archname'} !~ /RM\d\d\d-svr4/) + && ($thislib .= "_s") ){ # we must explicitly use _s version + } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){ + } elsif (-f ($fullname="$thispth/$thislib$Config_libext")){ + } elsif (-f ($fullname="$thispth/lib$thislib.dll$Config_libext")){ + } elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){ + } elsif ($^O eq 'dgux' + && -l ($fullname="$thispth/lib$thislib$Config_libext") + && readlink($fullname) =~ /^elink:/s) { + # Some of DG's libraries look like misconnected symbolic + # links, but development tools can follow them. (They + # look like this: + # + # libm.a -> elink:${SDE_PATH:-/usr}/sde/\ + # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a + # + # , the compilation tools expand the environment variables.) + } else { + warn "$thislib not found in $thispth\n" if $verbose; + next; + } + warn "'-l$thislib' found at $fullname\n" if $verbose; + push @libs, $fullname unless $libs_seen{$fullname}++; + $found++; + $found_lib++; + + # Now update library lists + + # what do we know about this library... + my $is_dyna = ($fullname !~ /\Q$Config_libext\E\z/); + my $in_perl = ($libs =~ /\B-l\Q${thislib}\E\b/s); + + # include the path to the lib once in the dynamic linker path + # but only if it is a dynamic lib and not in Perl itself + my($fullnamedir) = dirname($fullname); + push @ld_run_path, $fullnamedir + if $is_dyna && !$in_perl && + !$ld_run_path_seen{$fullnamedir}++; + + # Do not add it into the list if it is already linked in + # with the main perl executable. + # We have to special-case the NeXT, because math and ndbm + # are both in libsys_s + unless ($in_perl || + ($Config{'osname'} eq 'next' && + ($thislib eq 'm' || $thislib eq 'ndbm')) ){ + push(@extralibs, "-l$thislib"); + } + + # We might be able to load this archive file dynamically + if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0') + || ($Config{'dlsrc'} =~ /dl_dld/) ) + { + # We push -l$thislib instead of $fullname because + # it avoids hardwiring a fixed path into the .bs file. + # Mkbootstrap will automatically add dl_findfile() to + # the .bs file if it sees a name in the -l format. + # USE THIS, when dl_findfile() is fixed: + # push(@bsloadlibs, "-l$thislib"); + # OLD USE WAS while checking results against old_extliblist + push(@bsloadlibs, "$fullname"); + } else { + if ($is_dyna){ + # For SunOS4, do not add in this shared library if + # it is already linked in the main perl executable + push(@ldloadlibs, "-l$thislib") + unless ($in_perl and $^O eq 'sunos'); + } else { + push(@ldloadlibs, "-l$thislib"); + } + } + last; # found one here so don't bother looking further + } + warn "Note (probably harmless): " + ."No library found for -l$thislib\n" + unless $found_lib>0; + } + + unless( $found ) { + return ('','','','', ($give_libs ? \@libs : ())); + } + else { + return ("@extralibs", "@bsloadlibs", "@ldloadlibs", + join(":",@ld_run_path), ($give_libs ? \@libs : ())); + } +} + +sub _win32_ext { + + require Text::ParseWords; + + my($self, $potential_libs, $verbose, $give_libs) = @_; + $verbose ||= 0; + + # If user did not supply a list, we punt. + # (caller should probably use the list in $Config{libs}) + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; + + my $cc = $Config{cc}; + my $VC = $cc =~ /^cl/i; + my $BC = $cc =~ /^bcc/i; + my $GC = $cc =~ /^gcc/i; + my $so = $Config{'so'}; + my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + my(@libs, %libs_seen); + + if ($libs and $potential_libs !~ /:nodefault/i) { + # If Config.pm defines a set of default libs, we always + # tack them on to the user-supplied list, unless the user + # specified :nodefault + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $libs; + } + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + # normalize to forward slashes + $libpth =~ s,\\,/,g; + $potential_libs =~ s,\\,/,g; + + # compute $extralibs from $potential_libs + + my @searchpath; # from "-L/path" in $potential_libs + my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth); + my @extralibs; + my $pwd = cwd(); # from Cwd.pm + my $lib = ''; + my $found = 0; + my $search = 1; + my($fullname); + + # add "$Config{installarchlib}/CORE" to default search path + push @libpath, "$Config{installarchlib}/CORE"; + + if ($VC and exists $ENV{LIB} and $ENV{LIB}) { + push @libpath, split /;/, $ENV{LIB}; + } + + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ + + my $thislib = $_; + + # see if entry is a flag + if (/^:\w+$/) { + $search = 0 if lc eq ':nosearch'; + $search = 1 if lc eq ':search'; + warn "Ignoring unknown flag '$thislib'\n" + if $verbose and !/^:(no)?(search|default)$/i; + next; + } + + # if searching is disabled, do compiler-specific translations + unless ($search) { + s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; + push(@extralibs, $_); + $found++; + next; + } + + # handle possible linker path arguments + if (s/^-L// and not -d) { + warn "$thislib ignored, directory does not exist\n" + if $verbose; + next; + } + elsif (-d) { + unless (File::Spec->file_name_is_absolute($_)) { + warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; + $_ = $self->catdir($pwd,$_); + } + push(@searchpath, $_); + next; + } + + # handle possible library arguments + if (s/^-l// and $GC and !/^lib/i) { + $_ = "lib$_"; + } + $_ .= $libext if !/\Q$libext\E$/i; + + my $secondpass = 0; + LOOKAGAIN: + + # look for the file itself + if (-f) { + warn "'$thislib' found as '$_'\n" if $verbose; + $found++; + push(@extralibs, $_); + next; + } + + my $found_lib = 0; + foreach my $thispth (@searchpath, @libpath){ + unless (-f ($fullname="$thispth\\$_")) { + warn "'$thislib' not found as '$fullname'\n" if $verbose; + next; + } + warn "'$thislib' found as '$fullname'\n" if $verbose; + $found++; + $found_lib++; + push(@extralibs, $fullname); + push @libs, $fullname unless $libs_seen{$fullname}++; + last; + } + + # do another pass with (or without) leading 'lib' if they used -l + if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) { + if ($GC) { + goto LOOKAGAIN if s/^lib//i; + } + elsif (!/^lib/i) { + $_ = "lib$_"; + goto LOOKAGAIN; + } + } + + # give up + warn "Note (probably harmless): " + ."No library found for $thislib\n" + unless $found_lib>0; + + } + + return ('','','','', ($give_libs ? \@libs : ())) unless $found; + + # make sure paths with spaces are properly quoted + @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; + @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs; + $lib = join(' ',@extralibs); + + # normalize back to backward slashes (to help braindead tools) + # XXX this may break equally braindead GNU tools that don't understand + # backslashes, either. Seems like one can't win here. Cursed be CP/M. + $lib =~ s,/,\\,g; + + warn "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib; +} + + +sub _vms_ext { + my($self, $potential_libs, $verbose, $give_libs) = @_; + $verbose ||= 0; + + my(@crtls,$crtlstr); + @crtls = ( ($Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to insure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ($self->{PERL_SRC}) { + my($locspec,$type); + foreach my $lib (@crtls) { + if (($locspec,$type) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i) { + if (lc $type eq '/share') { $locspec .= $Config{'exe_ext'}; } + elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; } + else { $locspec .= $Config{'obj_ext'}; } + $locspec = $self->catfile($self->{PERL_SRC},$locspec); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join(' ',@crtls) : ''; + + unless ($potential_libs) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); + } + + my(%found,@fndlibs,$ldlib); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; + # List of common Unix library names and their VMS equivalents + # (VMS equivalent of '' indicates that the library is automatically + # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + my(@dirs, @libs); + foreach my $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$Config{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach my $dir (@dirs) { + unless (-d $dir) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if (File::Spec->file_name_is_absolute($dir)) { + $dir = $self->fixpath($dir,1); + } + else { + $dir = $self->catdir($cwd,$dir); + } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach my $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + warn "Looking for $lib\n" if $verbose; + foreach my $variant (@variants) { + my($fullname, $name); + + foreach my $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + $fullname = VMS::Filespec::rmsexpand($name); + if (defined $fullname and -f $fullname) { + # It's got its own suffix, so we'll have to figure out the type + if ($fullname =~ /(?:$so|exe)$/i) { $type = 'SHR'; } + elsif ($fullname =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; } + elsif ($fullname =~ /(?:$obj_ext|obj)$/i) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + } + else { + warn "Note (probably harmless): " + ."Unknown library type for $fullname; assuming shared\n"; + $type = 'SHR'; + } + } + elsif (-f ($fullname = VMS::Filespec::rmsexpand($name,$so)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'SHR'; + $name = $fullname unless $fullname =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'OLB'; + $name = $fullname unless $fullname =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.obj')))) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + $name = $fullname unless $fullname =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'SHR'; + } + } + if ($ctype) { + # This has to precede any other CRTLs, so just make it first + if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } + else { push @{$found{$ctype}}, $cand; } + warn "\tFound as $cand (really $fullname), type $ctype\n" + if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; + next LIB; + } + } + warn "Note (probably harmless): " + ."No library found for $lib\n"; + } + + push @fndlibs, @{$found{OBJ}} if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR}; + my $lib = join(' ',@fndlibs); + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MANIFEST.SKIP b/Master/tlpkg/tlperl/lib/ExtUtils/MANIFEST.SKIP new file mode 100644 index 00000000000..e50a7b390f7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MANIFEST.SKIP @@ -0,0 +1,51 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +\bSCCS\b +,v$ +\B\.svn\b +\B\.git\b +\B\.gitignore\b +\b_darcs\b +\B\.cvsignore$ + +# Avoid VMS specific MakeMaker generated files +\bDescrip.MMS$ +\bDESCRIP.MMS$ +\bdescrip.mms$ + +# Avoid Makemaker generated and utility files. +\bMANIFEST\.bak +\bMakefile$ +\bblib/ +\bMakeMaker-\d +\bpm_to_blib\.ts$ +\bpm_to_blib$ +\bblibdirs\.ts$ # 6.18 through 6.25 generated this + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build/ +\bBuild.bat$ +\bBuild.COM$ +\bBUILD.COM$ +\bbuild.com$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ +\b\.# +\.bak$ +\.tmp$ +\.# +\.rej$ + +# Avoid OS-specific files/dirs +# Mac OSX metadata +\B\.DS_Store +# Mac OSX SMB mount metadata files +\B\._ + +# Avoid Devel::Cover files. +\bcover_db\b diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM.pm new file mode 100644 index 00000000000..eac5f483494 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM.pm @@ -0,0 +1,90 @@ +package ExtUtils::MM; + +use strict; +use ExtUtils::MakeMaker::Config; + +our $VERSION = '6.56'; + +require ExtUtils::Liblist; +require ExtUtils::MakeMaker; +our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker); + +=head1 NAME + +ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass + +=head1 SYNOPSIS + + require ExtUtils::MM; + my $mm = MM->new(...); + +=head1 DESCRIPTION + +B<FOR INTERNAL USE ONLY> + +ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically +chooses the appropriate OS specific subclass for you +(ie. ExtUils::MM_Unix, etc...). + +It also provides a convenient alias via the MM class (I didn't want +MakeMaker modules outside of ExtUtils/). + +This class might turn out to be a temporary solution, but MM won't go +away. + +=cut + +{ + # Convenient alias. + package MM; + our @ISA = qw(ExtUtils::MM); + sub DESTROY {} +} + +sub _is_win95 { + # miniperl might not have the Win32 functions available and we need + # to run in miniperl. + my $have_win32 = eval { require Win32 }; + return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95() + : ! defined $ENV{SYSTEMROOT}; +} + +my %Is = (); +$Is{VMS} = $^O eq 'VMS'; +$Is{OS2} = $^O eq 'os2'; +$Is{MacOS} = $^O eq 'MacOS'; +if( $^O eq 'MSWin32' ) { + _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1; +} +$Is{UWIN} = $^O =~ /^uwin(-nt)?$/; +$Is{Cygwin} = $^O eq 'cygwin'; +$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional +$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku'); +$Is{DOS} = $^O eq 'dos'; +if( $Is{NW5} ) { + $^O = 'NetWare'; + delete $Is{Win32}; +} +$Is{VOS} = $^O eq 'vos'; +$Is{QNX} = $^O eq 'qnx'; +$Is{AIX} = $^O eq 'aix'; +$Is{Darwin} = $^O eq 'darwin'; + +$Is{Unix} = !grep { $_ } values %Is; + +map { delete $Is{$_} unless $Is{$_} } keys %Is; +_assert( keys %Is == 1 ); +my($OS) = keys %Is; + + +my $class = "ExtUtils::MM_$OS"; +eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic +die $@ if $@; +unshift @ISA, $class; + + +sub _assert { + my $sanity = shift; + die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity; + return; +} diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_AIX.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_AIX.pm new file mode 100644 index 00000000000..5179be4bc2a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_AIX.pm @@ -0,0 +1,79 @@ +package ExtUtils::MM_AIX; + +use strict; +our $VERSION = '6.56'; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + +use ExtUtils::MakeMaker qw(neatvalue); + + +=head1 NAME + +ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix + +=head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Unix which contains functionality for +AIX. + +Unless otherwise stated it works just like ExtUtils::MM_Unix + +=head2 Overridden methods + +=head3 dlsyms + +Define DL_FUNCS and DL_VARS and write the *.exp files. + +=cut + +sub dlsyms { + my($self,%attribs) = @_; + + return '' unless $self->needs_linking(); + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; + my(@m); + + push(@m," +dynamic :: $self->{BASEEXT}.exp + +") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so... + + push(@m," +static :: $self->{BASEEXT}.exp + +") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them + + push(@m," +$self->{BASEEXT}.exp: Makefile.PL +",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\ + Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ', + neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist), + ', "DL_VARS" => ', neatvalue($vars), ');\' +'); + + join('',@m); +} + + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Any.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Any.pm new file mode 100644 index 00000000000..4905aebc642 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Any.pm @@ -0,0 +1,2334 @@ +package ExtUtils::MM_Any; + +use strict; +our $VERSION = '6.56'; + +use Carp; +use File::Spec; +use File::Basename; +BEGIN { our @ISA = qw(File::Spec); } + +# We need $Verbose +use ExtUtils::MakeMaker qw($Verbose); + +use ExtUtils::MakeMaker::Config; + + +# So we don't have to keep calling the methods over and over again, +# we have these globals to cache the values. Faster and shrtr. +my $Curdir = __PACKAGE__->curdir; +my $Rootdir = __PACKAGE__->rootdir; +my $Updir = __PACKAGE__->updir; + + +=head1 NAME + +ExtUtils::MM_Any - Platform-agnostic MM methods + +=head1 SYNOPSIS + + FOR INTERNAL USE ONLY! + + package ExtUtils::MM_SomeOS; + + # Temporarily, you have to subclass both. Put MM_Any first. + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix); + +=head1 DESCRIPTION + +B<FOR INTERNAL USE ONLY!> + +ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of +modules. It contains methods which are either inherently +cross-platform or are written in a cross-platform manner. + +Subclass off of ExtUtils::MM_Any I<and> ExtUtils::MM_Unix. This is a +temporary solution. + +B<THIS MAY BE TEMPORARY!> + + +=head1 METHODS + +Any methods marked I<Abstract> must be implemented by subclasses. + + +=head2 Cross-platform helper methods + +These are methods which help writing cross-platform code. + + + +=head3 os_flavor I<Abstract> + + my @os_flavor = $mm->os_flavor; + +@os_flavor is the style of operating system this is, usually +corresponding to the MM_*.pm file we're using. + +The first element of @os_flavor is the major family (ie. Unix, +Windows, VMS, OS/2, etc...) and the rest are sub families. + +Some examples: + + Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x') + Windows ('Win32') + Win98 ('Win32', 'Win9x') + Linux ('Unix', 'Linux') + MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X') + OS/2 ('OS/2') + +This is used to write code for styles of operating system. +See os_flavor_is() for use. + + +=head3 os_flavor_is + + my $is_this_flavor = $mm->os_flavor_is($this_flavor); + my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors); + +Checks to see if the current operating system is one of the given flavors. + +This is useful for code like: + + if( $mm->os_flavor_is('Unix') ) { + $out = `foo 2>&1`; + } + else { + $out = `foo`; + } + +=cut + +sub os_flavor_is { + my $self = shift; + my %flavors = map { ($_ => 1) } $self->os_flavor; + return (grep { $flavors{$_} } @_) ? 1 : 0; +} + + +=head3 can_load_xs + + my $can_load_xs = $self->can_load_xs; + +Returns true if we have the ability to load XS. + +This is important because miniperl, used to build XS modules in the +core, can not load XS. + +=cut + +sub can_load_xs { + return defined &DynaLoader::boot_DynaLoader ? 1 : 0; +} + + +=head3 split_command + + my @cmds = $MM->split_command($cmd, @args); + +Most OS have a maximum command length they can execute at once. Large +modules can easily generate commands well past that limit. Its +necessary to split long commands up into a series of shorter commands. + +C<split_command> will return a series of @cmds each processing part of +the args. Collectively they will process all the arguments. Each +individual line in @cmds will not be longer than the +$self->max_exec_len being careful to take into account macro expansion. + +$cmd should include any switches and repeated initial arguments. + +If no @args are given, no @cmds will be returned. + +Pairs of arguments will always be preserved in a single command, this +is a heuristic for things like pm_to_blib and pod2man which work on +pairs of arguments. This makes things like this safe: + + $self->split_command($cmd, %pod2man); + + +=cut + +sub split_command { + my($self, $cmd, @args) = @_; + + my @cmds = (); + return(@cmds) unless @args; + + # If the command was given as a here-doc, there's probably a trailing + # newline. + chomp $cmd; + + # set aside 30% for macro expansion. + my $len_left = int($self->max_exec_len * 0.70); + $len_left -= length $self->_expand_macros($cmd); + + do { + my $arg_str = ''; + my @next_args; + while( @next_args = splice(@args, 0, 2) ) { + # Two at a time to preserve pairs. + my $next_arg_str = "\t ". join ' ', @next_args, "\n"; + + if( !length $arg_str ) { + $arg_str .= $next_arg_str + } + elsif( length($arg_str) + length($next_arg_str) > $len_left ) { + unshift @args, @next_args; + last; + } + else { + $arg_str .= $next_arg_str; + } + } + chop $arg_str; + + push @cmds, $self->escape_newlines("$cmd \n$arg_str"); + } while @args; + + return @cmds; +} + + +sub _expand_macros { + my($self, $cmd) = @_; + + $cmd =~ s{\$\((\w+)\)}{ + defined $self->{$1} ? $self->{$1} : "\$($1)" + }e; + return $cmd; +} + + +=head3 echo + + my @commands = $MM->echo($text); + my @commands = $MM->echo($text, $file); + my @commands = $MM->echo($text, $file, $appending); + +Generates a set of @commands which print the $text to a $file. + +If $file is not given, output goes to STDOUT. + +If $appending is true the $file will be appended to rather than +overwritten. + +=cut + +sub echo { + my($self, $text, $file, $appending) = @_; + $appending ||= 0; + + my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_) } + split /\n/, $text; + if( $file ) { + my $redirect = $appending ? '>>' : '>'; + $cmds[0] .= " $redirect $file"; + $_ .= " >> $file" foreach @cmds[1..$#cmds]; + } + + return @cmds; +} + + +=head3 wraplist + + my $args = $mm->wraplist(@list); + +Takes an array of items and turns them into a well-formatted list of +arguments. In most cases this is simply something like: + + FOO \ + BAR \ + BAZ + +=cut + +sub wraplist { + my $self = shift; + return join " \\\n\t", @_; +} + + +=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); + +This will generate a make fragment which runs the @cmds in the given +$dir. The rough equivalent to this, except cross platform. + + cd $subdir && $cmd + +Currently $dir can only go down one level. "foo" is fine. "foo/bar" is +not. "../foo" is right out. + +The resulting $subdir_cmd has no leading tab nor trailing newline. This +makes it easier to embed in a make string. For example. + + my $make = sprintf <<'CODE', $subdir_cmd; + foo : + $(ECHO) what + %s + $(ECHO) mouche + CODE + + +=head3 oneliner I<Abstract> + + my $oneliner = $MM->oneliner($perl_code); + my $oneliner = $MM->oneliner($perl_code, \@switches); + +This will generate a perl one-liner safe for the particular platform +you're on based on the given $perl_code and @switches (a -e is +assumed) suitable for using in a make target. It will use the proper +shell quoting and escapes. + +$(PERLRUN) will be used as perl. + +Any newlines in $perl_code will be escaped. Leading and trailing +newlines will be stripped. Makes this idiom much easier: + + my $code = $MM->oneliner(<<'CODE', [...switches...]); +some code here +another line here +CODE + +Usage might be something like: + + # an echo emulation + $oneliner = $MM->oneliner('print "Foo\n"'); + $make = '$oneliner > somefile'; + +All dollar signs must be doubled in the $perl_code if you expect them +to be interpreted normally, otherwise it will be considered a make +macro. Also remember to quote make macros else it might be used as a +bareword. For example: + + # Assign the value of the $(VERSION_FROM) make macro to $vf. + $oneliner = $MM->oneliner('$$vf = "$(VERSION_FROM)"'); + +Its currently very simple and may be expanded sometime in the figure +to include more flexible code and switches. + + +=head3 quote_literal I<Abstract> + + my $safe_text = $MM->quote_literal($text); + +This will quote $text so it is interpreted literally in the shell. + +For example, on Unix this would escape any single-quotes in $text and +put single-quotes around the whole thing. + + +=head3 escape_newlines I<Abstract> + + my $escaped_text = $MM->escape_newlines($text); + +Shell escapes newlines in $text. + + +=head3 max_exec_len I<Abstract> + + my $max_exec_len = $MM->max_exec_len; + +Calculates the maximum command size the OS can exec. Effectively, +this is the max size of a shell command line. + +=for _private +$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 + +These are methods which produce make targets. + + +=head3 all_target + +Generate the default target 'all'. + +=cut + +sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; +all :: pure_all + $(NOECHO) $(NOOP) +MAKE_EXT + +} + + +=head3 blibdirs_target + + my $make_frag = $mm->blibdirs_target; + +Creates the blibdirs target which creates all the directories we use +in blib/. + +The blibdirs.ts target is deprecated. Depend on blibdirs instead. + + +=cut + +sub blibdirs_target { + my $self = shift; + + my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib + autodir archautodir + bin script + man1dir man3dir + ); + + my @exists = map { $_.'$(DFSEP).exists' } @dirs; + + my $make = sprintf <<'MAKE', join(' ', @exists); +blibdirs : %s + $(NOECHO) $(NOOP) + +# Backwards compat with 6.18 through 6.25 +blibdirs.ts : blibdirs + $(NOECHO) $(NOOP) + +MAKE + + $make .= $self->dir_target(@dirs); + + return $make; +} + + +=head3 clean (o) + +Defines the clean target. + +=cut + +sub clean { +# --- Cleanup and Distribution Sections --- + + my($self, %attribs) = @_; + my @m; + push(@m, ' +# Delete temporary files but do not touch installed files. We don\'t delete +# the Makefile here so a later make realclean still has a makefile to use. + +clean :: clean_subdirs +'); + + my @files = values %{$self->{XS}}; # .c files from *.xs files + my @dirs = qw(blib); + + # Normally these are all under blib but they might have been + # redefined. + # XXX normally this would be a good idea, but the Perl core sets + # INST_LIB = ../../lib rather than actually installing the files. + # So a "make clean" in an ext/ directory would blow away lib. + # Until the core is adjusted let's leave this out. +# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB) +# $(INST_BIN) $(INST_SCRIPT) +# $(INST_MAN1DIR) $(INST_MAN3DIR) +# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR) +# $(INST_STATIC) $(INST_DYNAMIC) $(INST_BOOT) +# ); + + + if( $attribs{FILES} ) { + # Use @dirs because we don't know what's in here. + push @dirs, ref $attribs{FILES} ? + @{$attribs{FILES}} : + split /\s+/, $attribs{FILES} ; + } + + push(@files, qw[$(MAKE_APERL_FILE) + perlmain.c tmon.out mon.out so_locations + blibdirs.ts pm_to_blib pm_to_blib.ts + *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT) + $(BOOTSTRAP) $(BASEEXT).bso + $(BASEEXT).def lib$(BASEEXT).def + $(BASEEXT).exp $(BASEEXT).x + ]); + + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld')); + + # core files + push(@files, qw[core core.*perl.*.? *perl.core]); + push(@files, map { "core." . "[0-9]"x$_ } (1..5)); + + # OS specific things to clean up. Use @dirs since we don't know + # what might be in here. + push @dirs, $self->extra_clean_files; + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; } + + push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files); + push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs); + + # Leave Makefile.old around for realclean + push @m, <<'MAKE'; + - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) +MAKE + + push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; + + join("", @m); +} + + +=head3 clean_subdirs_target + + my $make_frag = $MM->clean_subdirs_target; + +Returns the clean_subdirs target. This is used by the clean target to +call clean on any subdirectories which contain Makefiles. + +=cut + +sub clean_subdirs_target { + my($self) = shift; + + # No subdirectories, no cleaning. + return <<'NOOP_FRAG' unless @{$self->{DIR}}; +clean_subdirs : + $(NOECHO) $(NOOP) +NOOP_FRAG + + + my $clean = "clean_subdirs :\n"; + + for my $dir (@{$self->{DIR}}) { + my $subclean = $self->oneliner(sprintf <<'CODE', $dir); +chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)'; +CODE + + $clean .= "\t$subclean\n"; + } + + return $clean; +} + + +=head3 dir_target + + my $make_frag = $mm->dir_target(@directories); + +Generates targets to create the specified directories and set its +permission to PERM_DIR. + +Because depending on a directory to just ensure it exists doesn't work +too well (the modified time changes too often) dir_target() creates a +.exists file in the created directory. It is this you should depend on. +For portability purposes you should use the $(DIRFILESEP) macro rather +than a '/' to seperate the directory from the file. + + yourdirectory$(DIRFILESEP).exists + +=cut + +sub dir_target { + my($self, @dirs) = @_; + + my $make = ''; + foreach my $dir (@dirs) { + $make .= sprintf <<'MAKE', ($dir) x 7; +%s$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) %s + $(NOECHO) $(CHMOD) $(PERM_DIR) %s + $(NOECHO) $(TOUCH) %s$(DFSEP).exists + +MAKE + + } + + return $make; +} + + +=head3 distdir + +Defines the scratch directory target that will hold the distribution +before tar-ing (or shar-ing). + +=cut + +# For backwards compatibility. +*dist_dir = *distdir; + +sub distdir { + my($self) = shift; + + my $meta_target = $self->{NO_META} ? '' : 'distmeta'; + my $sign_target = !$self->{SIGN} ? '' : 'distsignature'; + + return sprintf <<'MAKE_FRAG', $meta_target, $sign_target; +create_distdir : + $(RM_RF) $(DISTVNAME) + $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" + +distdir : create_distdir %s %s + $(NOECHO) $(NOOP) + +MAKE_FRAG + +} + + +=head3 dist_test + +Defines a target that produces the distribution in the +scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that +subdirectory. + +=cut + +sub dist_test { + my($self) = shift; + + my $mpl_args = join " ", map qq["$_"], @ARGV; + + my $test = $self->cd('$(DISTVNAME)', + '$(ABSPERLRUN) Makefile.PL '.$mpl_args, + '$(MAKE) $(PASTHRU)', + '$(MAKE) test $(PASTHRU)' + ); + + return sprintf <<'MAKE_FRAG', $test; +disttest : distdir + %s + +MAKE_FRAG + + +} + + +=head3 dynamic (o) + +Defines the dynamic target. + +=cut + +sub dynamic { +# --- Dynamic Loading Sections --- + + my($self) = shift; + ' +dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT) + $(NOECHO) $(NOOP) +'; +} + + +=head3 makemakerdflt_target + + my $make_frag = $mm->makemakerdflt_target + +Returns a make fragment with the makemakerdeflt_target specified. +This target is the first target in the Makefile, is the default target +and simply points off to 'all' just in case any make variant gets +confused or something gets snuck in before the real 'all' target. + +=cut + +sub makemakerdflt_target { + return <<'MAKE_FRAG'; +makemakerdflt : all + $(NOECHO) $(NOOP) +MAKE_FRAG + +} + + +=head3 manifypods_target + + my $manifypods_target = $self->manifypods_target; + +Generates the manifypods target. This target generates man pages from +all POD files in MAN1PODS and MAN3PODS. + +=cut + +sub manifypods_target { + my($self) = shift; + + my $man1pods = ''; + my $man3pods = ''; + my $dependencies = ''; + + # populate manXpods & dependencies: + foreach my $name (keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}) { + $dependencies .= " \\\n\t$name"; + } + + my $manify = <<END; +manifypods : pure_all $dependencies +END + + my @man_cmds; + foreach my $section (qw(1 3)) { + my $pods = $self->{"MAN${section}PODS"}; + push @man_cmds, $self->split_command(<<CMD, %$pods); + \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW) +CMD + } + + $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds; + $manify .= join '', map { "$_\n" } @man_cmds; + + return $manify; +} + + +=head3 metafile_target + + my $target = $mm->metafile_target; + +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. + +=cut + +sub metafile_target { + my $self = shift; + + return <<'MAKE_FRAG' if $self->{NO_META}; +metafile : + $(NOECHO) $(NOOP) +MAKE_FRAG + + my @metadata = $self->metafile_data( + $self->{META_ADD} || {}, + $self->{META_MERGE} || {}, + ); + my $meta = $self->metafile_file(@metadata); + my @write_meta = $self->echo($meta, 'META_new.yml'); + + return sprintf <<'MAKE_FRAG', join("\n\t", @write_meta); +metafile : create_distdir + $(NOECHO) $(ECHO) Generating META.yml + %s + -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml +MAKE_FRAG + +} + + +=begin private + +=head3 _sort_pairs + + my @pairs = _sort_pairs($sort_sub, \%hash); + +Sorts the pairs of a hash based on keys ordered according +to C<$sort_sub>. + +=end private + +=cut + +sub _sort_pairs { + my $sort = shift; + my $pairs = shift; + return map { $_ => $pairs->{$_} } + sort $sort + keys %$pairs; +} + + +# Taken from Module::Build::Base +sub _hash_merge { + my ($self, $h, $k, $v) = @_; + if (ref $h->{$k} eq 'ARRAY') { + push @{$h->{$k}}, ref $v ? @$v : $v; + } elsif (ref $h->{$k} eq 'HASH') { + $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v; + } else { + $h->{$k} = $v; + } +} + + +=head3 metafile_data + + my @metadata_pairs = $mm->metafile_data(\%meta_add, \%meta_merge); + +Returns the data which MakeMaker turns into the META.yml file. + +Values of %meta_add will overwrite any existing metadata in those +keys. %meta_merge will be merged with them. + +=cut + +sub metafile_data { + my $self = shift; + my($meta_add, $meta_merge) = @_; + + # The order in which standard meta keys should be written. + my @meta_order = qw( + name + version + abstract + author + license + distribution_type + + configure_requires + build_requires + requires + + resources + + provides + no_index + + generated_by + meta-spec + ); + + # Check the original args so we can tell between the user setting it + # to an empty hash and it just being initialized. + my $configure_requires; + if( $self->{ARGS}{CONFIGURE_REQUIRES} ) { + $configure_requires = $self->{CONFIGURE_REQUIRES}; + } else { + $configure_requires = { + 'ExtUtils::MakeMaker' => 0, + }; + } + my $build_requires; + if( $self->{ARGS}{BUILD_REQUIRES} ) { + $build_requires = $self->{BUILD_REQUIRES}; + } else { + $build_requires = { + 'ExtUtils::MakeMaker' => 0, + }; + } + + my %meta = ( + name => $self->{DISTNAME}, + version => $self->{VERSION}, + abstract => $self->{ABSTRACT}, + license => $self->{LICENSE} || 'unknown', + distribution_type => $self->{PM} ? 'module' : 'script', + + configure_requires => $configure_requires, + + build_requires => $build_requires, + + no_index => { + directory => [qw(t inc)] + }, + + generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", + 'meta-spec' => { + url => 'http://module-build.sourceforge.net/META-spec-v1.4.html', + version => 1.4 + }, + ); + + # The author key is required and it takes a list. + $meta{author} = defined $self->{AUTHOR} ? [$self->{AUTHOR}] : []; + + $meta{requires} = $self->{PREREQ_PM} if defined $self->{PREREQ_PM}; + $meta{requires}{perl} = $self->{MIN_PERL_VERSION} if $self->{MIN_PERL_VERSION}; + + while( my($key, $val) = each %$meta_add ) { + $meta{$key} = $val; + } + + while( my($key, $val) = each %$meta_merge ) { + $self->_hash_merge(\%meta, $key, $val); + } + + my @meta_pairs; + + # Put the standard keys first in the proper order. + for my $key (@meta_order) { + next unless exists $meta{$key}; + + push @meta_pairs, $key, delete $meta{$key}; + } + + # Then tack everything else onto the end, alpha sorted. + for my $key (sort {lc $a cmp lc $b} keys %meta) { + push @meta_pairs, $key, $meta{$key}; + } + + return @meta_pairs +} + +=begin private + +=head3 _dump_hash + + $yaml = _dump_hash(\%options, %hash); + +Implements a fake YAML dumper for a hash given +as a list of pairs. No quoting/escaping is done. Keys +are supposed to be strings. Values are undef, strings, +hash refs or array refs of strings. + +Supported options are: + + delta => STR - indentation delta + use_header => BOOL - whether to include a YAML header + indent => STR - a string of spaces + default: '' + + max_key_length => INT - maximum key length used to align + keys and values of the same hash + default: 20 + key_sort => CODE - a sort sub + It may be undef, which means no sorting by keys + default: sub { lc $a cmp lc $b } + + customs => HASH - special options for certain keys + (whose values are hashes themselves) + may contain: max_key_length, key_sort, customs + +=end private + +=cut + +sub _dump_hash { + croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH'; + my $options = shift; + my %hash = @_; + + # Use a list to preserve order. + my @pairs; + + my $k_sort + = exists $options->{key_sort} ? $options->{key_sort} + : sub { lc $a cmp lc $b }; + if ($k_sort) { + croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE'; + @pairs = _sort_pairs($k_sort, \%hash); + } else { # list of pairs, no sorting + @pairs = @_; + } + + my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : ''; + my $indent = $options->{indent} || ''; + my $k_length = min( + ($options->{max_key_length} || 20), + max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash) + ); + my $customs = $options->{customs} || {}; + + # printf format for key + my $k_format = "%-${k_length}s"; + + while( @pairs ) { + my($key, $val) = splice @pairs, 0, 2; + $val = '~' unless defined $val; + if(ref $val eq 'HASH') { + if ( keys %$val ) { + my %k_options = ( # options for recursive call + delta => $options->{delta}, + use_header => 0, + indent => $indent . $options->{delta}, + ); + if (exists $customs->{$key}) { + my %k_custom = %{$customs->{$key}}; + foreach my $k qw(key_sort max_key_length customs) { + $k_options{$k} = $k_custom{$k} if exists $k_custom{$k}; + } + } + $yaml .= $indent . "$key:\n" + . _dump_hash(\%k_options, %$val); + } + else { + $yaml .= $indent . "$key: {}\n"; + } + } + elsif (ref $val eq 'ARRAY') { + if( @$val ) { + $yaml .= $indent . "$key:\n"; + + for (@$val) { + croak "only nested arrays of non-refs are supported" if ref $_; + $yaml .= $indent . $options->{delta} . "- $_\n"; + } + } + else { + $yaml .= $indent . "$key: []\n"; + } + } + elsif( ref $val and !blessed($val) ) { + croak "only nested hashes, arrays and objects are supported"; + } + else { # if it's an object, just stringify it + $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val; + } + }; + + return $yaml; + +} + +sub blessed { + return eval { $_[0]->isa("UNIVERSAL"); }; +} + +sub max { + return (sort { $b <=> $a } @_)[0]; +} + +sub min { + return (sort { $a <=> $b } @_)[0]; +} + +=head3 metafile_file + + my $meta_yml = $mm->metafile_file(@metadata_pairs); + +Turns the @metadata_pairs into YAML. + +This method does not implement a complete YAML dumper, being limited +to dump a hash with values which are strings, undef's or nested hashes +and arrays of strings. No quoting/escaping is done. + +=cut + +sub metafile_file { + my $self = shift; + + my %dump_options = ( + use_header => 1, + delta => ' ' x 4, + key_sort => undef, + ); + return _dump_hash(\%dump_options, @_); + +} + + +=head3 distmeta_target + + my $make_frag = $mm->distmeta_target; + +Generates the distmeta target to add META.yml to the MANIFEST in the +distdir. + +=cut + +sub distmeta_target { + my $self = shift; + + my $add_meta = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']); +eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) } + or print "Could not add META.yml to MANIFEST: $${'@'}\n" +CODE + + my $add_meta_to_distdir = $self->cd('$(DISTVNAME)', $add_meta); + + return sprintf <<'MAKE', $add_meta_to_distdir; +distmeta : create_distdir metafile + $(NOECHO) %s + +MAKE + +} + + +=head3 realclean (o) + +Defines the realclean target. + +=cut + +sub realclean { + my($self, %attribs) = @_; + + my @dirs = qw($(DISTVNAME)); + my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD)); + + # Special exception for the perl core where INST_* is not in blib. + # This cleans up the files built from the ext/ directory (all XS). + if( $self->{PERL_CORE} ) { + push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR)); + push @files, values %{$self->{PM}}; + } + + if( $self->has_link_code ){ + push @files, qw($(OBJECT)); + } + + if( $attribs{FILES} ) { + if( ref $attribs{FILES} ) { + push @dirs, @{ $attribs{FILES} }; + } + else { + push @dirs, split /\s+/, $attribs{FILES}; + } + } + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; } + + my $rm_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_F)', @files); + my $rmf_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_RF)', @dirs); + + my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd; +# Delete temporary files (via clean) and also delete dist files +realclean purge :: clean realclean_subdirs + %s + %s +MAKE + + $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP}; + + return $m; +} + + +=head3 realclean_subdirs_target + + my $make_frag = $MM->realclean_subdirs_target; + +Returns the realclean_subdirs target. This is used by the realclean +target to call realclean on any subdirectories which contain Makefiles. + +=cut + +sub realclean_subdirs_target { + my $self = shift; + + return <<'NOOP_FRAG' unless @{$self->{DIR}}; +realclean_subdirs : + $(NOECHO) $(NOOP) +NOOP_FRAG + + my $rclean = "realclean_subdirs :\n"; + + foreach my $dir (@{$self->{DIR}}) { + foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) { + my $subrclean .= $self->oneliner(sprintf <<'CODE', $dir, ($makefile) x 2); +chdir '%s'; system '$(MAKE) $(USEMAKEFILE) %s realclean' if -f '%s'; +CODE + + $rclean .= sprintf <<'RCLEAN', $subrclean; + - %s +RCLEAN + + } + } + + return $rclean; +} + + +=head3 signature_target + + my $target = $mm->signature_target; + +Generate the signature target. + +Writes the file SIGNATURE with "cpansign -s". + +=cut + +sub signature_target { + my $self = shift; + + return <<'MAKE_FRAG'; +signature : + cpansign -s +MAKE_FRAG + +} + + +=head3 distsignature_target + + my $make_frag = $mm->distsignature_target; + +Generates the distsignature target to add SIGNATURE to the MANIFEST in the +distdir. + +=cut + +sub distsignature_target { + my $self = shift; + + my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']); +eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } + or print "Could not add SIGNATURE to MANIFEST: $${'@'}\n" +CODE + + my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s'); + + # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not + # exist + my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE'); + my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign ); + + return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist +distsignature : create_distdir + $(NOECHO) %s + $(NOECHO) %s + %s + +MAKE + +} + + +=head3 special_targets + + my $make_frag = $mm->special_targets + +Returns a make fragment containing any targets which have special +meaning to make. For example, .SUFFIXES and .PHONY. + +=cut + +sub special_targets { + my $make_frag = <<'MAKE_FRAG'; +.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) + +.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir + +MAKE_FRAG + + $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT}; +.NO_CONFIG_REC: Makefile + +MAKE_FRAG + + return $make_frag; +} + + + + +=head2 Init methods + +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; + +Called by init_main. Sets up all INST_* variables except those related +to XS code. Those are handled in init_xs. + +=cut + +sub init_INST { + my($self) = shift; + + $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch"); + $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin'); + + # INST_LIB typically pre-set if building an extension after + # perl has been built and installed. Setting INST_LIB allows + # you to build directly into, say $Config{privlibexp}. + unless ($self->{INST_LIB}){ + if ($self->{PERL_CORE}) { + if (defined $Cross::platform) { + $self->{INST_LIB} = $self->{INST_ARCHLIB} = + $self->catdir($self->{PERL_LIB},"..","xlib", + $Cross::platform); + } + else { + $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; + } + } else { + $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib"); + } + } + + my @parentdir = split(/::/, $self->{PARENT_NAME}); + $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir); + $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir); + $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto', + '$(FULLEXT)'); + $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto', + '$(FULLEXT)'); + + $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script'); + + $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1'); + $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3'); + + return 1; +} + + +=head3 init_INSTALL + + $mm->init_INSTALL; + +Called by init_main. Sets up all INSTALL_* variables (except +INSTALLDIRS) and *PREFIX. + +=cut + +sub init_INSTALL { + my($self) = shift; + + 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}{INSTALL_BASE} ) { + $self->init_INSTALL_from_INSTALL_BASE; + } + else { + $self->init_INSTALL_from_PREFIX; + } +} + + +=head3 init_INSTALL_from_PREFIX + + $mm->init_INSTALL_from_PREFIX; + +=cut + +sub init_INSTALL_from_PREFIX { + my $self = shift; + + $self->init_lib2arch; + + # There are often no Config.pm defaults for these new man variables so + # we fall back to the old behavior which is to use installman*dir + foreach my $num (1, 3) { + my $k = 'installsiteman'.$num.'dir'; + + $self->{uc $k} ||= uc "\$(installman${num}dir)" + unless $Config{$k}; + } + + foreach my $num (1, 3) { + my $k = 'installvendorman'.$num.'dir'; + + unless( $Config{$k} ) { + $self->{uc $k} ||= $Config{usevendorprefix} + ? uc "\$(installman${num}dir)" + : ''; + } + } + + $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} || + $Config{prefixexp} || $Config{prefix} || ''; + my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : ''; + my $sprefix = $Config{siteprefixexp} || ''; + + # 5.005_03 doesn't have a siteprefix. + $sprefix = $iprefix unless $sprefix; + + + $self->{PREFIX} ||= ''; + + if( $self->{PREFIX} ) { + @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} = + ('$(PREFIX)') x 3; + } + else { + $self->{PERLPREFIX} ||= $iprefix; + $self->{SITEPREFIX} ||= $sprefix; + $self->{VENDORPREFIX} ||= $vprefix; + + # Lots of MM extension authors like to use $(PREFIX) so we + # put something sensible in there no matter what. + $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)'; + } + + my $arch = $Config{archname}; + my $version = $Config{version}; + + # default style + my $libstyle = $Config{installstyle} || 'lib/perl5'; + my $manstyle = ''; + + if( $self->{LIBSTYLE} ) { + $libstyle = $self->{LIBSTYLE}; + $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : ''; + } + + # Some systems, like VOS, set installman*dir to '' if they can't + # read man pages. + for my $num (1, 3) { + $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none' + unless $Config{'installman'.$num.'dir'}; + } + + my %bin_layouts = + ( + bin => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorbin => { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitebin => { s => $sprefix, + t => 'site', + d => 'bin' }, + script => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorscript=> { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitescript => { s => $sprefix, + t => 'site', + d => 'bin' }, + ); + + my %man_layouts = + ( + man1dir => { s => $iprefix, + t => 'perl', + d => 'man/man1', + style => $manstyle, }, + siteman1dir => { s => $sprefix, + t => 'site', + d => 'man/man1', + style => $manstyle, }, + vendorman1dir => { s => $vprefix, + t => 'vendor', + d => 'man/man1', + style => $manstyle, }, + + man3dir => { s => $iprefix, + t => 'perl', + d => 'man/man3', + style => $manstyle, }, + siteman3dir => { s => $sprefix, + t => 'site', + d => 'man/man3', + style => $manstyle, }, + vendorman3dir => { s => $vprefix, + t => 'vendor', + d => 'man/man3', + style => $manstyle, }, + ); + + my %lib_layouts = + ( + privlib => { s => $iprefix, + t => 'perl', + d => '', + style => $libstyle, }, + vendorlib => { s => $vprefix, + t => 'vendor', + d => '', + style => $libstyle, }, + sitelib => { s => $sprefix, + t => 'site', + d => 'site_perl', + style => $libstyle, }, + + archlib => { s => $iprefix, + t => 'perl', + d => "$version/$arch", + style => $libstyle }, + vendorarch => { s => $vprefix, + t => 'vendor', + d => "$version/$arch", + style => $libstyle }, + sitearch => { s => $sprefix, + t => 'site', + d => "site_perl/$version/$arch", + style => $libstyle }, + ); + + + # Special case for LIB. + if( $self->{LIB} ) { + foreach my $var (keys %lib_layouts) { + my $Installvar = uc "install$var"; + + if( $var =~ /arch/ ) { + $self->{$Installvar} ||= + $self->catdir($self->{LIB}, $Config{archname}); + } + else { + $self->{$Installvar} ||= $self->{LIB}; + } + } + } + + my %type2prefix = ( perl => 'PERLPREFIX', + site => 'SITEPREFIX', + vendor => 'VENDORPREFIX' + ); + + my %layouts = (%bin_layouts, %man_layouts, %lib_layouts); + while( my($var, $layout) = each(%layouts) ) { + my($s, $t, $d, $style) = @{$layout}{qw(s t d style)}; + my $r = '$('.$type2prefix{$t}.')'; + + print STDERR "Prefixing $var\n" if $Verbose >= 2; + + my $installvar = "install$var"; + my $Installvar = uc $installvar; + next if $self->{$Installvar}; + + $d = "$style/$d" if $style; + $self->prefixify($installvar, $s, $r, $d); + + print STDERR " $Installvar == $self->{$Installvar}\n" + if $Verbose >= 2; + } + + # Generate these if they weren't figured out. + $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH}; + $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB}; + + return 1; +} + + +=head3 init_from_INSTALL_BASE + + $mm->init_from_INSTALL_BASE + +=cut + +my %map = ( + lib => [qw(lib perl5)], + arch => [('lib', 'perl5', $Config{archname})], + bin => [qw(bin)], + man1dir => [qw(man man1)], + man3dir => [qw(man man3)] + ); +$map{script} = $map{bin}; + +sub init_INSTALL_from_INSTALL_BASE { + my $self = shift; + + @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} = + '$(INSTALL_BASE)'; + + my %install; + foreach my $thing (keys %map) { + foreach my $dir (('', 'SITE', 'VENDOR')) { + my $uc_thing = uc $thing; + my $key = "INSTALL".$dir.$uc_thing; + + $install{$key} ||= + $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); + } + } + + # Adjust for variable quirks. + $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH}; + $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB}; + + foreach my $key (keys %install) { + $self->{$key} ||= $install{$key}; + } + + return 1; +} + + +=head3 init_VERSION I<Abstract> + + $mm->init_VERSION + +Initialize macros representing versions of MakeMaker and other tools + +MAKEMAKER: path to the MakeMaker module. + +MM_VERSION: ExtUtils::MakeMaker Version + +MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards + compat) + +VERSION: version of your module + +VERSION_MACRO: which macro represents the version (usually 'VERSION') + +VERSION_SYM: like version but safe for use as an RCS revision number + +DEFINE_VERSION: -D line to set the module version when compiling + +XS_VERSION: version in your .xs file. Defaults to $(VERSION) + +XS_VERSION_MACRO: which macro represents the XS version. + +XS_DEFINE_VERSION: -D line to set the xs version when compiling. + +Called by init_main. + +=cut + +sub init_VERSION { + my($self) = shift; + + $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename; + $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION; + $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision; + $self->{VERSION_FROM} ||= ''; + + if ($self->{VERSION_FROM}){ + $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}); + if( $self->{VERSION} eq 'undef' ) { + carp("WARNING: Setting VERSION via file ". + "'$self->{VERSION_FROM}' failed\n"); + } + } + + # strip blanks + if (defined $self->{VERSION}) { + $self->{VERSION} =~ s/^\s+//; + $self->{VERSION} =~ s/\s+$//; + } + else { + $self->{VERSION} = ''; + } + + + $self->{VERSION_MACRO} = 'VERSION'; + ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g; + $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"'; + + + # Graham Barr and Paul Marquess had some ideas how to ensure + # version compatibility between the *.pm file and the + # corresponding *.xs file. The bottomline was, that we need an + # XS_VERSION macro that defaults to VERSION: + $self->{XS_VERSION} ||= $self->{VERSION}; + + $self->{XS_VERSION_MACRO} = 'XS_VERSION'; + $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"'; + +} + + +=head3 init_others + + $MM->init_others(); + +Initializes the macro definitions used by tools_other() and places them +in the $MM object. + +If there is no description, its the same as the parameter to +WriteMakefile() documented in ExtUtils::MakeMaker. + +Defines at least these macros. + + Macro Description + + NOOP Do nothing + NOECHO Tell make not to display the command itself + + MAKEFILE + FIRST_MAKEFILE + MAKEFILE_OLD + MAKE_APERL_FILE File used by MAKE_APERL + + SHELL Program used to run shell commands + + ECHO Print text adding a newline on the end + RM_F Remove a file + RM_RF Remove a directory + TOUCH Update a file's timestamp + TEST_F Test for a file's existence + CP Copy a file + MV Move a file + CHMOD Change permissions on a file + FALSE Exit with non-zero + TRUE Exit with zero + + UMASK_NULL Nullify umask + DEV_NULL Suppress all command output + +=cut + +sub init_others { + my $self = shift; + + $self->{ECHO} ||= $self->oneliner('print qq{@ARGV}', ['-l']); + $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}'); + + $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]); + $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]); + $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]); + $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]); + $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]); + $self->{FALSE} ||= $self->oneliner('exit 1'); + $self->{TRUE} ||= $self->oneliner('exit 0'); + + $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]); + + $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]); + $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]); + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); +install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); +CODE + $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]); + $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]); + $self->{WARN_IF_OLD_PACKLIST} ||= + $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]); + $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]); + $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]); + + $self->{UNINST} ||= 0; + $self->{VERBINST} ||= 0; + + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile'; + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; + $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old'; + $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl'; + + # Not everybody uses -f to indicate "use this Makefile instead" + $self->{USEMAKEFILE} ||= '-f'; + + # Some makes require a wrapper around macros passed in on the command + # line. + $self->{MACROSTART} ||= ''; + $self->{MACROEND} ||= ''; + + $self->{SHELL} ||= $Config{sh}; + + # UMASK_NULL is not used by MakeMaker but some CPAN modules + # make use of it. + $self->{UMASK_NULL} ||= "umask 0"; + + # Not the greatest default, but its something. + $self->{DEV_NULL} ||= "> /dev/null 2>&1"; + + $self->{NOOP} ||= '$(TRUE)'; + $self->{NOECHO} = '@' unless defined $self->{NOECHO}; + + $self->{LD_RUN_PATH} = ""; + + $self->{LIBS} = $self->_fix_libs($self->{LIBS}); + + # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS} + foreach my $libs ( @{$self->{LIBS}} ){ + $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace + my(@libs) = $self->extliblist($libs); + if ($libs[0] or $libs[1] or $libs[2]){ + # LD_RUN_PATH now computed by ExtUtils::Liblist + ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, + $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; + last; + } + } + + if ( $self->{OBJECT} ) { + $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; + } else { + # init_dirscan should have found out, if we have C files + $self->{OBJECT} = ""; + $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; + } + $self->{OBJECT} =~ s/\n+/ \\\n\t/g; + + $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; + $self->{PERLMAINCC} ||= '$(CC)'; + $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; + + # Sanity check: don't define LINKTYPE = dynamic if we're skipping + # the 'dynamic' section of MM. We don't have this problem with + # 'static', since we either must use it (%Config says we can't + # use dynamic loading) or the caller asked for it explicitly. + if (!$self->{LINKTYPE}) { + $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'} + ? 'static' + : ($Config{usedl} ? 'dynamic' : 'static'); + } + + return 1; +} + + +# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or +# undefined. In any case we turn it into an anon array +sub _fix_libs { + my($self, $libs) = @_; + + return !defined $libs ? [''] : + !ref $libs ? [$libs] : + !defined $libs->[0] ? [''] : + $libs ; +} + + +=head3 tools_other + + my $make_frag = $MM->tools_other; + +Returns a make fragment containing definitions for the macros init_others() +initializes. + +=cut + +sub tools_other { + my($self) = shift; + my @m; + + # We set PM_FILTER as late as possible so it can see all the earlier + # on macro-order sensitive makes such as nmake. + for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH + UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP + FALSE TRUE + ECHO ECHO_N + UNINST VERBINST + MOD_INSTALL DOC_INSTALL UNINSTALL + WARN_IF_OLD_PACKLIST + MACROSTART MACROEND + USEMAKEFILE + PM_FILTER + FIXIN + } ) + { + next unless defined $self->{$tool}; + push @m, "$tool = $self->{$tool}\n"; + } + + return join "", @m; +} + + +=head3 init_DIRFILESEP I<Abstract> + + $MM->init_DIRFILESEP; + my $dirfilesep = $MM->{DIRFILESEP}; + +Initializes the DIRFILESEP macro which is the seperator between the +directory and filename in a filepath. ie. / on Unix, \ on Win32 and +nothing on VMS. + +For example: + + # instead of $(INST_ARCHAUTODIR)/extralibs.ld + $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld + +Something of a hack but it prevents a lot of code duplication between +MM_* variants. + +Do not use this as a seperator between directories. Some operating +systems use different seperators between subdirectories as between +directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS). + +=head3 init_linker I<Abstract> + + $mm->init_linker; + +Initialize macros which have to do with linking. + +PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic +extensions. + +PERL_ARCHIVE_AFTER: path to a library which should be put on the +linker command line I<after> the external libraries to be linked to +dynamic extensions. This may be needed if the linker is one-pass, and +Perl includes some overrides for C RTL functions, such as malloc(). + +EXPORT_LIST: name of a file that is passed to linker to define symbols +to be exported. + +Some OSes do not need these in which case leave it blank. + + +=head3 init_platform + + $mm->init_platform + +Initialize any macros which are for platform specific use only. + +A typical one is the version number of your OS specific mocule. +(ie. MM_Unix_VERSION or MM_VMS_VERSION). + +=cut + +sub init_platform { + return ''; +} + + +=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 + +A grab bag of methods to generate specific macros and commands. + + + +=head3 manifypods + +Defines targets and routines to translate the pods into manpages and +put them into the INST_* directories. + +=cut + +sub manifypods { + my $self = shift; + + my $POD2MAN_macro = $self->POD2MAN_macro(); + my $manifypods_target = $self->manifypods_target(); + + return <<END_OF_TARGET; + +$POD2MAN_macro + +$manifypods_target + +END_OF_TARGET + +} + + +=head3 POD2MAN_macro + + my $pod2man_macro = $self->POD2MAN_macro + +Returns a definition for the POD2MAN macro. This is a program +which emulates the pod2man utility. You can add more switches to the +command by simply appending them on the macro. + +Typical usage: + + $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ... + +=cut + +sub POD2MAN_macro { + my $self = shift; + +# Need the trailing '--' so perl stops gobbling arguments and - happens +# to be an alternative end of line seperator on VMS so we quote it + return <<'END_OF_DEF'; +POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" +POD2MAN = $(POD2MAN_EXE) +END_OF_DEF +} + + +=head3 test_via_harness + + my $command = $mm->test_via_harness($perl, $tests); + +Returns a $command line which runs the given set of $tests with +Test::Harness and the given $perl. + +Used on the t/*.t files. + +=cut + +sub test_via_harness { + my($self, $perl, $tests) = @_; + + return qq{\t$perl "-MExtUtils::Command::MM" }. + qq{"-e" "test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; +} + +=head3 test_via_script + + my $command = $mm->test_via_script($perl, $script); + +Returns a $command line which just runs a single test without +Test::Harness. No checks are done on the results, they're just +printed. + +Used for test.pl, since they don't always follow Test::Harness +formatting. + +=cut + +sub test_via_script { + my($self, $perl, $script) = @_; + return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n}; +} + + +=head3 tool_autosplit + +Defines a simple perl call that runs autosplit. May be deprecated by +pm_to_blib soon. + +=cut + +sub tool_autosplit { + my($self, %attribs) = @_; + + my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};' + : ''; + + my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen); +use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) +PERL_CODE + + return sprintf <<'MAKE_FRAG', $asplit; +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = %s + +MAKE_FRAG + +} + + +=head3 arch_check + + my $arch_ok = $mm->arch_check( + $INC{"Config.pm"}, + File::Spec->catfile($Config{archlibexp}, "Config.pm") + ); + +A sanity check that what Perl thinks the architecture is and what +Config thinks the architecture is are the same. If they're not it +will return false and show a diagnostic message. + +When building Perl it will always return true, as nothing is installed +yet. + +The interface is a bit odd because this is the result of a +quick refactoring. Don't rely on it. + +=cut + +sub arch_check { + my $self = shift; + my($pconfig, $cconfig) = @_; + + return 1 if $self->{PERL_SRC}; + + my($pvol, $pthinks) = $self->splitpath($pconfig); + my($cvol, $cthinks) = $self->splitpath($cconfig); + + $pthinks = $self->canonpath($pthinks); + $cthinks = $self->canonpath($cthinks); + + my $ret = 1; + if ($pthinks ne $cthinks) { + print "Have $pthinks\n"; + print "Want $cthinks\n"; + + $ret = 0; + + my $arch = (grep length, $self->splitdir($pthinks))[-1]; + + print STDOUT <<END unless $self->{UNINSTALLED_PERL}; +Your perl and your Config.pm seem to have different ideas about the +architecture they are running on. +Perl thinks: [$arch] +Config says: [$Config{archname}] +This may or may not cause problems. Please check your installation of perl +if you have problems building this extension. +END + } + + return $ret; +} + + + +=head2 File::Spec wrappers + +ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here +override File::Spec. + + + +=head3 catfile + +File::Spec <= 0.83 has a bug where the file part of catfile is not +canonicalized. This override fixes that bug. + +=cut + +sub catfile { + my $self = shift; + return $self->canonpath($self->SUPER::catfile(@_)); +} + + + +=head2 Misc + +Methods I can't really figure out where they should go yet. + + +=head3 find_tests + + my $test = $mm->find_tests; + +Returns a string suitable for feeding to the shell to return all +tests in t/*.t. + +=cut + +sub find_tests { + my($self) = shift; + return -d 't' ? 't/*.t' : ''; +} + + +=head3 extra_clean_files + + my @files_to_clean = $MM->extra_clean_files; + +Returns a list of OS specific files to be removed in the clean target in +addition to the usual set. + +=cut + +# An empty method here tickled a perl 5.8.1 bug and would return its object. +sub extra_clean_files { + return; +} + + +=head3 installvars + + my @installvars = $mm->installvars; + +A list of all the INSTALL* variables without the INSTALL prefix. Useful +for iteration or building related variable sets. + +=cut + +sub installvars { + return qw(PRIVLIB SITELIB VENDORLIB + ARCHLIB SITEARCH VENDORARCH + BIN SITEBIN VENDORBIN + SCRIPT SITESCRIPT VENDORSCRIPT + MAN1DIR SITEMAN1DIR VENDORMAN1DIR + MAN3DIR SITEMAN3DIR VENDORMAN3DIR + ); +} + + +=head3 libscan + + my $wanted = $self->libscan($path); + +Takes a path to a file or dir and returns an empty string if we don't +want to include this file in the library. Otherwise it returns the +the $path unchanged. + +Mainly used to exclude version control administrative directories from +installation. + +=cut + +sub libscan { + my($self,$path) = @_; + my($dirs,$file) = ($self->splitpath($path))[1,2]; + return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/, + $self->splitdir($dirs), $file; + + return $path; +} + + +=head3 platform_constants + + my $make_frag = $mm->platform_constants + +Returns a make fragment defining all the macros initialized in +init_platform() rather than put them in constants(). + +=cut + +sub platform_constants { + return ''; +} + +=begin private + +=head3 _PREREQ_PRINT + + $self->_PREREQ_PRINT; + +Implements PREREQ_PRINT. + +Refactored out of MakeMaker->new(). + +=end private + +=cut + +sub _PREREQ_PRINT { + my $self = shift; + + require Data::Dumper; + my @what = ('PREREQ_PM'); + push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION}; + push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES}; + print Data::Dumper->Dump([@{$self}{@what}], \@what); + exit 0; +} + + +=begin private + +=head3 _PRINT_PREREQ + + $mm->_PRINT_PREREQ; + +Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT +added by Redhat to, I think, support generating RPMs from Perl modules. + +Should not include BUILD_REQUIRES as RPMs do not incluide them. + +Refactored out of MakeMaker->new(). + +=end private + +=cut + +sub _PRINT_PREREQ { + my $self = shift; + + my $prereqs= $self->{PREREQ_PM}; + my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs; + + if ( $self->{MIN_PERL_VERSION} ) { + push @prereq, ['perl' => $self->{MIN_PERL_VERSION}]; + } + + print join(" ", map { "perl($_->[0])>=$_->[1] " } + sort { $a->[0] cmp $b->[0] } @prereq), "\n"; + exit 0; +} + + +=begin private + +=head3 _all_prereqs + + my $prereqs = $self->_all_prereqs; + +Returns a hash ref of both PREREQ_PM and BUILD_REQUIRES. + +=end private + +=cut + +sub _all_prereqs { + my $self = shift; + + return { %{$self->{PREREQ_PM}}, %{$self->{BUILD_REQUIRES}} }; +} + + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> and the denizens of +makemaker@perl.org with code from ExtUtils::MM_Unix and +ExtUtils::MM_Win32. + + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_BeOS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_BeOS.pm new file mode 100644 index 00000000000..0b7c8db9225 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_BeOS.pm @@ -0,0 +1,61 @@ +package ExtUtils::MM_BeOS; + +use strict; + +=head1 NAME + +ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=cut + +use ExtUtils::MakeMaker::Config; +use File::Spec; +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; + +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); +our $VERSION = '6.56'; + + +=item os_flavor + +BeOS is BeOS. + +=cut + +sub os_flavor { + return('BeOS'); +} + +=item init_linker + +libperl.a equivalent to be linked to dynamic extensions. + +=cut + +sub init_linker { + my($self) = shift; + + $self->{PERL_ARCHIVE} ||= + File::Spec->catdir('$(PERL_INC)',$Config{libperl}); + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + +=back + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Cygwin.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Cygwin.pm new file mode 100644 index 00000000000..394fbc68a75 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Cygwin.pm @@ -0,0 +1,123 @@ +package ExtUtils::MM_Cygwin; + +use strict; + +use ExtUtils::MakeMaker::Config; +use File::Spec; + +require ExtUtils::MM_Unix; +require ExtUtils::MM_Win32; +our @ISA = qw( ExtUtils::MM_Unix ); + +our $VERSION = '6.56'; + + +=head1 NAME + +ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided there. + +=over 4 + +=item os_flavor + +We're Unix and Cygwin. + +=cut + +sub os_flavor { + return('Unix', 'Cygwin'); +} + +=item cflags + +if configured for dynamic loading, triggers #define EXT in EXTERN.h + +=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} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true'); + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; + +} + + +=item replace_manpage_separator + +replaces strings '::' with '.' in MAN*POD man page names + +=cut + +sub replace_manpage_separator { + my($self, $man) = @_; + $man =~ s{/+}{.}g; + return $man; +} + +=item init_linker + +points to libperl.a + +=cut + +sub init_linker { + my $self = shift; + + if ($Config{useshrplib} eq 'true') { + my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}"; + if( $] >= 5.006002 ) { + $libperl =~ s/a$/dll.a/; + } + $self->{PERL_ARCHIVE} = $libperl; + } else { + $self->{PERL_ARCHIVE} = + '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a"); + } + + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + +=item maybe_command + +If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32> +to determine if it may be a command. Otherwise we use the tests +from C<ExtUtils::MM_Unix>. + +=cut + +sub maybe_command { + my ($self, $file) = @_; + + if ($file =~ m{^/cygdrive/}i) { + return ExtUtils::MM_Win32->maybe_command($file); + } + + return $self->SUPER::maybe_command($file); +} + +=back + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_DOS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_DOS.pm new file mode 100644 index 00000000000..fc0a7947235 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_DOS.pm @@ -0,0 +1,65 @@ +package ExtUtils::MM_DOS; + +use strict; + +our $VERSION = 6.56; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + + +=head1 NAME + +ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix + +=head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Unix which contains functionality +for DOS. + +Unless otherwise stated, it works just like ExtUtils::MM_Unix + +=head2 Overridden methods + +=over 4 + +=item os_flavor + +=cut + +sub os_flavor { + return('DOS'); +} + +=item B<replace_manpage_separator> + +Generates Foo__Bar.3 style man page names + +=cut + +sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,__,g; + return $man; +} + +=back + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix + +=head1 SEE ALSO + +L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker> + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Darwin.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Darwin.pm new file mode 100644 index 00000000000..1cb87c78815 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Darwin.pm @@ -0,0 +1,47 @@ +package ExtUtils::MM_Darwin; + +use strict; + +BEGIN { + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Unix ); +} + +our $VERSION = '6.56'; + + +=head1 NAME + +ExtUtils::MM_Darwin - special behaviors for OS X + +=head1 SYNOPSIS + + For internal MakeMaker use only + +=head1 DESCRIPTION + +See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documention on the +methods overridden here. + +=head2 Overriden Methods + +=head3 init_dist + +Turn off Apple tar's tendency to copy resource forks as "._foo" files. + +=cut + +sub init_dist { + my $self = shift; + + # Thank you, Apple, for breaking tar and then breaking the work around. + # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants + # COPYFILE_DISABLE. I'm not going to push my luck and instead just + # set both. + $self->{TAR} ||= + 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar'; + + $self->SUPER::init_dist(@_); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_MacOS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_MacOS.pm new file mode 100644 index 00000000000..cfc82051e1b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_MacOS.pm @@ -0,0 +1,40 @@ +package ExtUtils::MM_MacOS; + +use strict; + +our $VERSION = 6.56; + +sub new { + die <<'UNSUPPORTED'; +MacOS Classic (MacPerl) is no longer supported by MakeMaker. +Please use Module::Build instead. +UNSUPPORTED +} + +=head1 NAME + +ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic + +=head1 SYNOPSIS + + # MM_MacOS no longer contains any code. This is just a stub. + +=head1 DESCRIPTION + +Once upon a time, MakeMaker could produce an approximation of a correct +Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this +fell out of sync with the rest of MakeMaker and hadn't worked in years. +Since there's little chance of it being repaired, MacOS Classic is fading +away, and the code was icky to begin with, the code has been deleted to +make maintenance easier. + +Those interested in writing modules for MacPerl should use Module::Build +which works better than MakeMaker ever did. + +Anyone interested in resurrecting this file should pull the old version +from the MakeMaker CVS repository and contact makemaker@perl.org, but we +really encourage you to work on Module::Build instead. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_NW5.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_NW5.pm new file mode 100644 index 00000000000..0c8f6c0affb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_NW5.pm @@ -0,0 +1,269 @@ +package ExtUtils::MM_NW5; + +=head1 NAME + +ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over + +=cut + +use strict; +use ExtUtils::MakeMaker::Config; +use File::Basename; + +our $VERSION = '6.56'; + +require ExtUtils::MM_Win32; +our @ISA = qw(ExtUtils::MM_Win32); + +use ExtUtils::MakeMaker qw( &neatvalue ); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +my $BORLAND = $Config{'cc'} =~ /^bcc/i; +my $GCC = $Config{'cc'} =~ /^gcc/i; + + +=item os_flavor + +We're Netware in addition to being Windows. + +=cut + +sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Netware'); +} + +=item init_platform + +Add Netware macros. + +LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL, +NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION + + +=item platform_constants + +Add Netware macros initialized above to the Makefile. + +=cut + +sub init_platform { + my($self) = shift; + + # To get Win32's setup. + $self->SUPER::init_platform; + + # incpath is copied to makefile var INCLUDE in constants sub, here just + # make it empty + my $libpth = $Config{'libpth'}; + $libpth =~ s( )(;); + $self->{'LIBPTH'} = $libpth; + + $self->{'BASE_IMPORT'} = $Config{'base_import'}; + + # Additional import file specified from Makefile.pl + if($self->{'base_import'}) { + $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'}; + } + + $self->{'NLM_VERSION'} = $Config{'nlm_version'}; + $self->{'MPKTOOL'} = $Config{'mpktool'}; + $self->{'TOOLPATH'} = $Config{'toolpath'}; + + (my $boot = $self->{'NAME'}) =~ s/:/_/g; + $self->{'BOOT_SYMBOL'}=$boot; + + # If the final binary name is greater than 8 chars, + # truncate it here. + if(length($self->{'BASEEXT'}) > 8) { + $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); + } + + # Get the include path and replace the spaces with ; + # Copy this to makefile as INCLUDE = d:\...;d:\; + ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; + + # Set the path to CodeWarrior binaries which might not have been set in + # any other place + $self->{PATH} = '$(PATH);$(TOOLPATH)'; + + $self->{MM_NW5_VERSION} = $VERSION; +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + # Setup Win32's constants. + $make_frag .= $self->SUPER::platform_constants; + + foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL + TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH + MM_NW5_VERSION + )) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +=item const_cccmd + +=cut + +sub const_cccmd { + my($self,$libperl)=@_; + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + return $self->{CONST_CCCMD} = <<'MAKE_FRAG'; +CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \ + $(PERLTYPE) $(MPOLLUTE) -o $@ \ + -DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\" +MAKE_FRAG + +} + + +=item static_lib + +=cut + +sub static_lib { + my($self) = @_; + + return '' unless $self->has_link_code; + + my $m = <<'END'; +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(RM_RF) $@ +END + + # If this extension has it's own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + $m .= <<'END' if $self->{MYEXTLIB}; + $self->{CP} $(MYEXTLIB) $@ +END + + my $ar_arg; + if( $BORLAND ) { + $ar_arg = '$@ $(OBJECT:^"+")'; + } + elsif( $GCC ) { + $ar_arg = '-ru $@ $(OBJECT)'; + } + else { + $ar_arg = '-type library -o $@ $(OBJECT)'; + } + + $m .= sprintf <<'END', $ar_arg; + $(AR) %s + $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld + $(CHMOD) 755 $@ +END + + $m .= <<'END' if $self->{PERL_SRC}; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs + + +END + return $m; +} + +=item dynamic_lib + +Defines how to produce the *.so (or equivalent) files. + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($ldfrom) = '$(LDFROM)'; + + (my $boot = $self->{NAME}) =~ s/:/_/g; + + my $m = <<'MAKE_FRAG'; +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +OTHERLDFLAGS = '.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' + +# Create xdc data for an MT safe NLM in case of mpk build +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def + $(NOECHO) $(ECHO) $(BASE_IMPORT) >> $(BASEEXT).def + $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def +MAKE_FRAG + + + if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { + $m .= <<'MAKE_FRAG'; + $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc + $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> $(BASEEXT).def +MAKE_FRAG + } + + # Reconstruct the X.Y.Z version. + my $version = join '.', map { sprintf "%d", $_ } + $] =~ /(\d)\.(\d{3})(\d{2})/; + $m .= sprintf ' $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION)', $version; + + # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc + if($self->{NLM_SHORT_NAME}) { + # In case of nlms with names exceeding 8 chars, build nlm in the + # current dir, rename and move to auto\lib. + $m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)} + } else { + $m .= q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)} + } + + # Add additional lib files if any (SDBM_File) + $m .= q{ $(MYEXTLIB) } if $self->{MYEXTLIB}; + + $m .= q{ $(PERL_INC)\Main.lib -commandfile $(BASEEXT).def}."\n"; + + if($self->{NLM_SHORT_NAME}) { + $m .= <<'MAKE_FRAG'; + if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) + move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR) +MAKE_FRAG + } + + $m .= <<'MAKE_FRAG'; + + $(CHMOD) 755 $@ +MAKE_FRAG + + return $m; +} + + +1; +__END__ + +=back + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_OS2.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_OS2.pm new file mode 100644 index 00000000000..680502baf24 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_OS2.pm @@ -0,0 +1,152 @@ +package ExtUtils::MM_OS2; + +use strict; + +use ExtUtils::MakeMaker qw(neatvalue); +use File::Spec; + +our $VERSION = '6.56'; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix); + +=pod + +=head1 NAME + +ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=head1 METHODS + +=over 4 + +=item init_dist + +Define TO_UNIX to convert OS2 linefeeds to Unix style. + +=cut + +sub init_dist { + my($self) = @_; + + $self->{TO_UNIX} ||= <<'MAKE_TEXT'; +$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip +MAKE_TEXT + + $self->SUPER::init_dist; +} + +sub dlsyms { + my($self,%attribs) = @_; + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; + my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; + my(@m); + (my $boot = $self->{NAME}) =~ s/:/_/g; + + if (not $self->{SKIPHASH}{'dynamic'}) { + push(@m," +$self->{BASEEXT}.def: Makefile.PL +", + ' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\ + Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ', + '"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ', + '"INSTALLDIRS" => "$(INSTALLDIRS)", ', + '"DL_FUNCS" => ',neatvalue($funcs), + ', "FUNCLIST" => ',neatvalue($funclist), + ', "IMPORTS" => ',neatvalue($imports), + ', "DL_VARS" => ', neatvalue($vars), ');\' +'); + } + if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp"; + while (my($name, $exp) = each %{$self->{IMPORTS}}) { + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print $imp "$name $lib $id ?\n"; + } + close $imp or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + # May be running under miniperl, so have no glob... + eval "unlink <tmp_imp/*>; 1" or system "rm tmp_imp/*"; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } + join('',@m); +} + +sub static_lib { + my($self) = @_; + my $old = $self->ExtUtils::MM_Unix::static_lib(); + return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; + + my @chunks = split /\n{2,}/, $old; + shift @chunks unless length $chunks[0]; # Empty lines at the start + $chunks[0] .= <<'EOC'; + + $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@ +EOC + return join "\n\n". '', @chunks; +} + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + +sub maybe_command { + my($self,$file) = @_; + $file =~ s,[/\\]+,/,g; + return $file if -x $file && ! -d _; + return "$file.exe" if -x "$file.exe" && ! -d _; + return "$file.cmd" if -x "$file.cmd" && ! -d _; + return; +} + +=item init_linker + +=cut + +sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)"; + + $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout + ? '' + : '$(PERL_INC)/libperl_override$(LIB_EXT)'; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; +} + +=item os_flavor + +OS/2 is OS/2 + +=cut + +sub os_flavor { + return('OS/2'); +} + +=back + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_QNX.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_QNX.pm new file mode 100644 index 00000000000..f78d5e8a9ee --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_QNX.pm @@ -0,0 +1,57 @@ +package ExtUtils::MM_QNX; + +use strict; +our $VERSION = '6.56'; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + +=head1 NAME + +ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix + +=head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Unix which contains functionality for +QNX. + +Unless otherwise stated it works just like ExtUtils::MM_Unix + +=head2 Overridden methods + +=head3 extra_clean_files + +Add .err files corresponding to each .c file. + +=cut + +sub extra_clean_files { + my $self = shift; + + my @errfiles = @{$self->{C}}; + for ( @errfiles ) { + s/.c$/.err/; + } + + return( @errfiles, 'perlmain.err' ); +} + + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_UWIN.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_UWIN.pm new file mode 100644 index 00000000000..5adc46ea8d2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_UWIN.pm @@ -0,0 +1,64 @@ +package ExtUtils::MM_UWIN; + +use strict; +our $VERSION = 6.56; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + +=head1 NAME + +ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix + +=head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Unix which contains functionality for +the AT&T U/WIN UNIX on Windows environment. + +Unless otherwise stated it works just like ExtUtils::MM_Unix + +=head2 Overridden methods + +=over 4 + +=item os_flavor + +In addition to being Unix, we're U/WIN. + +=cut + +sub os_flavor { + return('Unix', 'U/WIN'); +} + + +=item B<replace_manpage_separator> + +=cut + +sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,.,g; + return $man; +} + +=back + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix + +=head1 SEE ALSO + +L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker> + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Unix.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Unix.pm new file mode 100644 index 00000000000..239d6df826c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Unix.pm @@ -0,0 +1,3634 @@ +package ExtUtils::MM_Unix; + +require 5.006; + +use strict; + +use Carp; +use ExtUtils::MakeMaker::Config; +use File::Basename qw(basename dirname); +use DirHandle; + +our %Config_Override; + +use ExtUtils::MakeMaker qw($Verbose neatvalue); + +# If we make $VERSION an our variable parse_version() breaks +use vars qw($VERSION); +$VERSION = '6.56'; + +require ExtUtils::MM_Any; +our @ISA = qw(ExtUtils::MM_Any); + +my %Is; +BEGIN { + $Is{OS2} = $^O eq 'os2'; + $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare'; + $Is{Dos} = $^O eq 'dos'; + $Is{VMS} = $^O eq 'VMS'; + $Is{OSF} = $^O eq 'dec_osf'; + $Is{IRIX} = $^O eq 'irix'; + $Is{NetBSD} = $^O eq 'netbsd'; + $Is{Interix} = $^O eq 'interix'; + $Is{SunOS4} = $^O eq 'sunos'; + $Is{Solaris} = $^O eq 'solaris'; + $Is{SunOS} = $Is{SunOS4} || $Is{Solaris}; + $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or + grep( $^O eq $_, qw(bsdos interix dragonfly) ) + ); +} + +BEGIN { + if( $Is{VMS} ) { + # For things like vmsify() + require VMS::Filespec; + VMS::Filespec->import; + } +} + + +=head1 NAME + +ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker + +=head1 SYNOPSIS + +C<require ExtUtils::MM_Unix;> + +=head1 DESCRIPTION + +The methods provided by this package are designed to be used in +conjunction with ExtUtils::MakeMaker. When MakeMaker writes a +Makefile, it creates one or more objects that inherit their methods +from a package C<MM>. MM itself doesn't provide any methods, but it +ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating +specific packages take the responsibility for all the methods provided +by MM_Unix. We are trying to reduce the number of the necessary +overrides by defining rather primitive operations within +ExtUtils::MM_Unix. + +If you are going to write a platform specific MM package, please try +to limit the necessary overrides to primitive methods, and if it is not +possible to do so, let's work out how to achieve that gain. + +If you are overriding any of these methods in your Makefile.PL (in the +MY class), please report that to the makemaker mailing list. We are +trying to minimize the necessary method overrides and switch to data +driven Makefile.PLs wherever possible. In the long run less methods +will be overridable via the MY class. + +=head1 METHODS + +The following description of methods is still under +development. Please refer to the code for not suitably documented +sections and complain loudly to the makemaker@perl.org mailing list. +Better yet, provide a patch. + +Not all of the methods below are overridable in a +Makefile.PL. Overridable methods are marked as (o). All methods are +overridable by a platform specific MM_*.pm file. + +Cross-platform methods are being moved into MM_Any. If you can't find +something that used to be in here, look in MM_Any. + +=cut + +# So we don't have to keep calling the methods over and over again, +# we have these globals to cache the values. Faster and shrtr. +my $Curdir = __PACKAGE__->curdir; +my $Rootdir = __PACKAGE__->rootdir; +my $Updir = __PACKAGE__->updir; + + +=head2 Methods + +=over 4 + +=item os_flavor + +Simply says that we're Unix. + +=cut + +sub os_flavor { + return('Unix'); +} + + +=item c_o (o) + +Defines the suffix rules to compile different flavors of C files to +object files. + +=cut + +sub c_o { +# --- Translation Sections --- + + 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, qq{ +.c.i: + $cpp_cmd $flags \$*.c > \$*.i +}; + } + + push @m, qq{ +.c.s: + $command -S $flags \$*.c + +.c\$(OBJ_EXT): + $command $flags \$*.c + +.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 $flags \$*.C +} if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific + + return join "", @m; +} + +=item cflags (o) + +Does very much the same as the cflags script in the perl +distribution. It doesn't return the whole compiler command line, but +initializes all of its parts. The const_cccmd method then actually +returns the definition of the CCCMD macro which uses these parts. + +=cut + +#' + +sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my($prog, $uc, $perltype, %cflags); + $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; + $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; + + @cflags{qw(cc ccflags optimize shellflags)} + = @Config{qw(cc ccflags optimize shellflags)}; + my($optdebug) = ""; + + $cflags{shellflags} ||= ''; + + my(%map) = ( + D => '-DDEBUGGING', + E => '-DEMBED', + DE => '-DDEBUGGING -DEMBED', + M => '-DEMBED -DMULTIPLICITY', + DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', + ); + + if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ + $uc = uc($1); + } else { + $uc = ""; # avoid warning + } + $perltype = $map{$uc} ? $map{$uc} : ""; + + if ($uc =~ /^D/) { + $optdebug = "-g"; + } + + + my($name); + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + if ($prog = $Config{$name}) { + # Expand hints for this extension via the shell + print STDOUT "Processing $name hint:\n" if $Verbose; + my(@o)=`cc=\"$cflags{cc}\" + ccflags=\"$cflags{ccflags}\" + optimize=\"$cflags{optimize}\" + perltype=\"$cflags{perltype}\" + optdebug=\"$cflags{optdebug}\" + eval '$prog' + echo cc=\$cc + echo ccflags=\$ccflags + echo optimize=\$optimize + echo perltype=\$perltype + echo optdebug=\$optdebug + `; + foreach my $line (@o){ + chomp $line; + if ($line =~ /(.*?)=\s*(.*)\s*$/){ + $cflags{$1} = $2; + print STDOUT " $1 = $2\n" if $Verbose; + } else { + print STDOUT "Unrecognised result from hint: '$line'\n"; + } + } + } + + if ($optdebug) { + $cflags{optimize} = $optdebug; + } + + for (qw(ccflags optimize perltype)) { + $cflags{$_} ||= ''; + $cflags{$_} =~ s/^\s+//; + $cflags{$_} =~ s/\s+/ /g; + $cflags{$_} =~ s/\s+$//; + $self->{uc $_} ||= $cflags{$_}; + } + + if ($self->{POLLUTE}) { + $self->{CCFLAGS} .= ' -DPERL_POLLUTE '; + } + + my $pollute = ''; + if ($Config{usemymalloc} and not $Config{bincompat5005} + and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/ + and $self->{PERL_MALLOC_OK}) { + $pollute = '$(PERL_MALLOC_DEF)'; + } + + $self->{CCFLAGS} = quote_paren($self->{CCFLAGS}); + $self->{OPTIMIZE} = quote_paren($self->{OPTIMIZE}); + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +MPOLLUTE = $pollute +}; + +} + + +=item const_cccmd (o) + +Returns the full compiler call for C programs and stores the +definition in CONST_CCCMD. + +=cut + +sub const_cccmd { + my($self,$libperl)=@_; + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + return $self->{CONST_CCCMD} = + q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\ + $(CCFLAGS) $(OPTIMIZE) \\ + $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ + $(XS_DEFINE_VERSION)}; +} + +=item const_config (o) + +Defines a couple of constants in the Makefile that are imported from +%Config. + +=cut + +sub const_config { +# --- Constants Sections --- + + my($self) = shift; + my @m = <<"END"; + +# These definitions are from config.sh (via $INC{'Config.pm'}). +# They may have been overridden via Makefile.PL or on the command line. +END + + my(%once_only); + foreach my $key (@{$self->{CONFIG}}){ + # SITE*EXP macros are defined in &constants; avoid duplicates here + next if $once_only{$key}; + $self->{uc $key} = quote_paren($self->{uc $key}); + push @m, uc($key) , ' = ' , $self->{uc $key}, "\n"; + $once_only{$key} = 1; + } + join('', @m); +} + +=item const_loadlibs (o) + +Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See +L<ExtUtils::Liblist> for details. + +=cut + +sub const_loadlibs { + my($self) = shift; + return "" unless $self->needs_linking; + my @m; + push @m, qq{ +# $self->{NAME} might depend on some other libraries: +# See ExtUtils::Liblist for details +# +}; + for my $tmp (qw/ + EXTRALIBS LDLOADLIBS BSLOADLIBS + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + # don't set LD_RUN_PATH if empty + for my $tmp (qw/ + LD_RUN_PATH + /) { + next unless $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + return join "", @m; +} + +=item constants (o) + + my $make_frag = $mm->constants; + +Prints out macros for lots of constants. + +=cut + +sub constants { + my($self) = @_; + my @m = (); + + $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use + + for my $macro (qw( + + AR_STATIC_ARGS DIRFILESEP DFSEP + NAME NAME_SYM + VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION + XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB + INST_MAN1DIR INST_MAN3DIR + MAN1EXT MAN3EXT + INSTALLDIRS INSTALL_BASE DESTDIR PREFIX + PERLPREFIX SITEPREFIX VENDORPREFIX + ), + (map { ("INSTALL".$_, + "DESTINSTALL".$_) + } $self->installvars), + qw( + PERL_LIB + PERL_ARCHLIB + LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE + PERLMAINCC PERL_SRC PERL_INC + PERL FULLPERL ABSPERL + PERLRUN FULLPERLRUN ABSPERLRUN + PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST + PERL_CORE + PERM_DIR PERM_RW PERM_RWX + + ) ) + { + next unless defined $self->{$macro}; + + # pathnames can have sharp signs in them; escape them so + # make doesn't think it is a comment-start character. + $self->{$macro} =~ s/#/\\#/g; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, qq{ +MAKEMAKER = $self->{MAKEMAKER} +MM_VERSION = $self->{MM_VERSION} +MM_REVISION = $self->{MM_REVISION} +}; + + push @m, q{ +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +}; + + for my $macro (qw/ + MAKE + FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE BOOTDEP + / ) + { + next unless defined $self->{$macro}; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, " +# Handy lists of source code files: +XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})." +C_FILES = ".$self->wraplist(@{$self->{C}})." +O_FILES = ".$self->wraplist(@{$self->{O_FILES}})." +H_FILES = ".$self->wraplist(@{$self->{H}})." +MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})." +MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})." +"; + + + push @m, q{ +# Where is the Config information that we are using/depend on +CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h +}; + + + push @m, qq{ +# Where to build things +INST_LIBDIR = $self->{INST_LIBDIR} +INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR} + +INST_AUTODIR = $self->{INST_AUTODIR} +INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} + +INST_STATIC = $self->{INST_STATIC} +INST_DYNAMIC = $self->{INST_DYNAMIC} +INST_BOOT = $self->{INST_BOOT} +}; + + + push @m, qq{ +# Extra linker info +EXPORT_LIST = $self->{EXPORT_LIST} +PERL_ARCHIVE = $self->{PERL_ARCHIVE} +PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER} +}; + + push @m, " + +TO_INST_PM = ".$self->wraplist(sort keys %{$self->{PM}})." + +PM_TO_BLIB = ".$self->wraplist(%{$self->{PM}})." +"; + + join('',@m); +} + + +=item depend (o) + +Same as macro for the depend attribute. + +=cut + +sub depend { + my($self,%attribs) = @_; + my(@m,$key,$val); + while (($key,$val) = each %attribs){ + last unless defined $key; + push @m, "$key : $val\n"; + } + join "", @m; +} + + +=item init_DEST + + $mm->init_DEST + +Defines the DESTDIR and DEST* variables paralleling the INSTALL*. + +=cut + +sub init_DEST { + my $self = shift; + + # Initialize DESTDIR + $self->{DESTDIR} ||= ''; + + # Make DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')'; + } +} + + +=item init_dist + + $mm->init_dist; + +Defines a lot of macros for distribution support. + + macro description default + + TAR tar command to use tar + TARFLAGS flags to pass to TAR cvf + + ZIP zip command to use zip + ZIPFLAGS flags to pass to ZIP -r + + COMPRESS compression command to gzip --best + use for tarfiles + SUFFIX suffix to put on .gz + compressed files + + SHAR shar command to use shar + + PREOP extra commands to run before + making the archive + POSTOP extra commands to run after + making the archive + + TO_UNIX a command to convert linefeeds + to Unix style in your archive + + CI command to checkin your ci -u + sources to version control + RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q + just after CI is run + + DIST_CP $how argument to manicopy() best + when the distdir is created + + DIST_DEFAULT default target to use to tardist + create a distribution + + DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION) + (minus suffixes) + +=cut + +sub init_dist { + my $self = shift; + + $self->{TAR} ||= 'tar'; + $self->{TARFLAGS} ||= 'cvf'; + $self->{ZIP} ||= 'zip'; + $self->{ZIPFLAGS} ||= '-r'; + $self->{COMPRESS} ||= 'gzip --best'; + $self->{SUFFIX} ||= '.gz'; + $self->{SHAR} ||= 'shar'; + $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST + $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir + $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)'; + + $self->{CI} ||= 'ci -u'; + $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q'; + $self->{DIST_CP} ||= 'best'; + $self->{DIST_DEFAULT} ||= 'tardist'; + + ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME}; + $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION}; + +} + +=item dist (o) + + my $dist_macros = $mm->dist(%overrides); + +Generates a make fragment defining all the macros initialized in +init_dist. + +%overrides can be used to override any of the above. + +=cut + +sub dist { + my($self, %attribs) = @_; + + my $make = ''; + foreach my $key (qw( + TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR + PREOP POSTOP TO_UNIX + CI RCS_LABEL DIST_CP DIST_DEFAULT + DISTNAME DISTVNAME + )) + { + my $value = $attribs{$key} || $self->{$key}; + $make .= "$key = $value\n"; + } + + return $make; +} + +=item dist_basics (o) + +Defines the targets distclean, distcheck, skipcheck, manifest, veryclean. + +=cut + +sub dist_basics { + my($self) = shift; + + return <<'MAKE_FRAG'; +distclean :: realclean distcheck + $(NOECHO) $(NOOP) + +distcheck : + $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck + +skipcheck : + $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck + +manifest : + $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest + +veryclean : realclean + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old + +MAKE_FRAG + +} + +=item dist_ci (o) + +Defines a check in target for RCS. + +=cut + +sub dist_ci { + my($self) = shift; + return q{ +ci : + $(PERLRUN) "-MExtUtils::Manifest=maniread" \\ + -e "@all = keys %{ maniread() };" \\ + -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \\ + -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});" +}; +} + +=item dist_core (o) + + my $dist_make_fragment = $MM->dist_core; + +Puts the targets necessary for 'make dist' together into one make +fragment. + +=cut + +sub dist_core { + my($self) = shift; + + my $make_frag = ''; + foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile + shdist)) + { + my $method = $target.'_target'; + $make_frag .= "\n"; + $make_frag .= $self->$method(); + } + + return $make_frag; +} + + +=item B<dist_target> + + my $make_frag = $MM->dist_target; + +Returns the 'dist' target to make an archive for distribution. This +target simply checks to make sure the Makefile is up-to-date and +depends on $(DIST_DEFAULT). + +=cut + +sub dist_target { + my($self) = shift; + + my $date_check = $self->oneliner(<<'CODE', ['-l']); +print 'Warning: Makefile possibly out of date with $(VERSION_FROM)' + if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)'; +CODE + + return sprintf <<'MAKE_FRAG', $date_check; +dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) + $(NOECHO) %s +MAKE_FRAG +} + +=item B<tardist_target> + + my $make_frag = $MM->tardist_target; + +Returns the 'tardist' target which is simply so 'make tardist' works. +The real work is done by the dynamically named tardistfile_target() +method, tardist should have that as a dependency. + +=cut + +sub tardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) +MAKE_FRAG +} + +=item B<zipdist_target> + + my $make_frag = $MM->zipdist_target; + +Returns the 'zipdist' target which is simply so 'make zipdist' works. +The real work is done by the dynamically named zipdistfile_target() +method, zipdist should have that as a dependency. + +=cut + +sub zipdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +zipdist : $(DISTVNAME).zip + $(NOECHO) $(NOOP) +MAKE_FRAG +} + +=item B<tarfile_target> + + my $make_frag = $MM->tarfile_target; + +The name of this target is the name of the tarball generated by +tardist. This target does the actual work of turning the distdir into +a tarball. + +=cut + +sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) +MAKE_FRAG +} + +=item zipfile_target + + my $make_frag = $MM->zipfile_target; + +The name of this target is the name of the zip file generated by +zipdist. This target does the actual work of turning the distdir into +a zip file. + +=cut + +sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + +=item uutardist_target + + my $make_frag = $MM->uutardist_target; + +Converts the tarfile into a uuencoded file + +=cut + +sub uutardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu +MAKE_FRAG +} + + +=item shdist_target + + my $make_frag = $MM->shdist_target; + +Converts the distdir into a shell archive. + +=cut + +sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + + +=item dlsyms (o) + +Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files. + +Normally just returns an empty string. + +=cut + +sub dlsyms { + return ''; +} + + +=item dynamic_bs (o) + +Defines targets for bootstrap files. + +=cut + +sub dynamic_bs { + my($self, %attribs) = @_; + return ' +BOOTSTRAP = +' unless $self->has_link_code(); + + my $target = $Is{VMS} ? '$(MMS$TARGET)' : '$@'; + + return sprintf <<'MAKE_FRAG', ($target) x 5; +BOOTSTRAP = $(BASEEXT).bs + +# As Mkbootstrap might not write a file (if none is required) +# we use touch to prevent make continually trying to remake it. +# The DynaLoader only reads a non-empty file. +$(BOOTSTRAP) : $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" + $(NOECHO) $(PERLRUN) \ + "-MExtUtils::Mkbootstrap" \ + -e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');" + $(NOECHO) $(TOUCH) %s + $(CHMOD) $(PERM_RW) %s + +$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(NOECHO) $(RM_RF) %s + - $(CP) $(BOOTSTRAP) %s + $(CHMOD) $(PERM_RW) %s +MAKE_FRAG +} + +=item dynamic_lib (o) + +Defines how to produce the *.so (or equivalent) files. + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":"; + my($ldfrom) = '$(LDFROM)'; + $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':'); + my(@m); + my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too? + my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : ''; + push(@m,' +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +ARMAYBE = '.$armaybe.' +OTHERLDFLAGS = '.$ld_opt.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' +INST_DYNAMIC_FIX = '.$ld_fix.' + +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) +'); + if ($armaybe ne ':'){ + $ldfrom = 'tmp$(LIB_EXT)'; + push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n"); + push(@m,' $(RANLIB) '."$ldfrom\n"); + } + $ldfrom = "-all $ldfrom -none" if $Is{OSF}; + + # The IRIX linker doesn't use LD_RUN_PATH + my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ? + qq{-rpath "$self->{LD_RUN_PATH}"} : ''; + + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m,' $(RM_F) $@ +'); + + my $libs = '$(LDLOADLIBS)'; + + 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 + # or -R to add paths to the run-time library search path. + if ($Config{'lddlflags'} =~ /-Wl,-R/) { + $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl'; + } elsif ($Config{'lddlflags'} =~ /-R/) { + $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl'; + } + } + + my $ld_run_path_shell = ""; + if ($self->{LD_RUN_PATH} ne "") { + $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" '; + } + + push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $libs; + %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) \ + $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST) \ + $(INST_DYNAMIC_FIX) +MAKE + + push @m, <<'MAKE'; + $(CHMOD) $(PERM_RWX) $@ +MAKE + + return join('',@m); +} + +=item exescan + +Deprecated method. Use libscan instead. + +=cut + +sub exescan { + my($self,$path) = @_; + $path; +} + +=item extliblist + +Called by init_others, and calls ext ExtUtils::Liblist. See +L<ExtUtils::Liblist> for details. + +=cut + +sub extliblist { + my($self,$libs) = @_; + require ExtUtils::Liblist; + $self->ext($libs, $Verbose); +} + +=item find_perl + +Finds the executables PERL and FULLPERL + +=cut + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + + if ($trace >= 2){ + print "Looking for perl $ver by these names: +@$names +in these dirs: +@$dirs +"; + } + + my $stderr_duped = 0; + local *STDERR_COPY; + + unless ($Is{BSD}) { + # >& and lexical filehandles together give 5.6.2 indigestion + if( open(STDERR_COPY, '>&STDERR') ) { ## no critic + $stderr_duped = 1; + } + else { + warn <<WARNING; +find_perl() can't dup STDERR: $! +You might see some garbage while we search for Perl +WARNING + } + } + + foreach my $name (@$names){ + foreach my $dir (@$dirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + my ($abs, $val); + if ($self->file_name_is_absolute($name)) { # /foo/bar + $abs = $name; + } elsif ($self->canonpath($name) eq + $self->canonpath(basename($name))) { # foo + $abs = $self->catfile($dir, $name); + } else { # foo/bar + $abs = $self->catfile($Curdir, $name); + } + print "Checking $abs\n" if ($trace >= 2); + next unless $self->maybe_command($abs); + print "Executing $abs\n" if ($trace >= 2); + + my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"}; + $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 ) + # we cannot use the fancier more portable way in here + # but instead need to use the traditional 2>&1 construct. + if ($Is{BSD}) { + $val = `$version_check 2>&1`; + } else { + close STDERR if $stderr_duped; + $val = `$version_check`; + + # 5.6.2's 3-arg open doesn't work with >& + open STDERR, ">&STDERR_COPY" ## no critic + if $stderr_duped; + } + + if ($val =~ /^VER_OK/m) { + print "Using PERL=$abs\n" if $trace; + return $abs; + } elsif ($trace >= 2) { + print "Result: '$val' ".($? >> 8)."\n"; + } + } + } + print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + +=item fixin + + $mm->fixin(@files); + +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 ) = @_; + + my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; + for my $file (@files) { + my $file_new = "$file.new"; + my $file_bak = "$file.bak"; + + open( my $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 =~ m{^perl(?:\z|[^a-z])} ) { + if ( $Config{startperl} =~ m,^\#!.*/perl, ) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } + else { + $interpreter = $Config{perlpath}; + } + } + else { + my (@absdirs) + = reverse grep { $self->file_name_is_absolute($_) } $self->path; + $interpreter = ''; + + foreach my $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; + } + + open( my $fixout, ">", "$file_new" ) or do { + 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 { + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; + } +} + + +sub _rename { + my($old, $new) = @_; + + foreach my $file ($old, $new) { + if( $Is{VMS} and basename($file) !~ /\./ ) { + # rename() in 5.8.0 on VMS will not rename a file if it + # does not contain a dot yet it returns success. + $file = "$file."; + } + } + + return rename($old, $new); +} + + +=item force (o) + +Writes an empty FORCE: target. + +=cut + +sub force { + my($self) = shift; + '# Phony target to force checking subdirectories. +FORCE : + $(NOECHO) $(NOOP) +'; +} + +=item guess_name + +Guess the name of this package by examining the working directory's +name. MakeMaker calls this only if the developer has not supplied a +NAME attribute. + +=cut + +# '; + +sub guess_name { + my($self) = @_; + use Cwd 'cwd'; + my $name = basename(cwd()); + $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we + # strip minus or underline + # followed by a float or some such + print "Warning: Guessing NAME [$name] from current directory name.\n"; + $name; +} + +=item has_link_code + +Returns true if C, XS, MYEXTLIB or similar objects exist within this +object that need a compiler. Does not descend into subdirectories as +needs_linking() does. + +=cut + +sub has_link_code { + my($self) = shift; + return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; + if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ + $self->{HAS_LINK_CODE} = 1; + return 1; + } + return $self->{HAS_LINK_CODE} = 0; +} + + +=item init_dirscan + +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. + +=cut + +sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) + my($self) = @_; + my(%dir, %xs, %c, %h, %pl_files, %pm); + + my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t); + + # ignore the distdir + $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1 + : $ignore{$self->{DISTVNAME}} = 1; + + @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS}; + + foreach my $name ($self->lsdir($Curdir)){ + next if $name =~ /\#/; + next if $name eq $Curdir or $name eq $Updir or $ignore{$name}; + next unless $self->libscan($name); + if (-d $name){ + next if -l $name; # We do not support symlinks at all + next if $self->{NORECURS}; + $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); + } elsif ($name =~ /\.xs\z/){ + my($c); ($c = $name) =~ s/\.xs\z/.c/; + $xs{$name} = $c; + $c{$c} = 1; + } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc + $c{$name} = 1 + unless $name =~ m/perlmain\.c/; # See MAP_TARGET + } elsif ($name =~ /\.h\z/i){ + $h{$name} = 1; + } elsif ($name =~ /\.PL\z/) { + ($pl_files{$name} = $name) =~ s/\.PL\z// ; + } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) { + # case-insensitive filesystem, one dot per name, so foo.h.PL + # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos + local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; + } + else { + $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); + } + } elsif ($name =~ /\.(p[ml]|pod)\z/){ + $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); + } + } + + $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) = @_; + + my($ispod)=0; + if (open( my $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. + + # The attribute PMLIBDIRS holds an array reference which lists + # subdirectories which we should search for library files to + # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We + # recursively search through the named directories (skipping any + # which don't exist or contain Makefile.PL files). + + # For each *.pm or *.pl file found $self->libscan() is called with + # the default installation path in $_[1]. The return value of + # libscan defines the actual installation location. The default + # libscan function simply returns the path. The file is skipped + # if libscan returns false. + + # The default installation location passed to libscan in $_[1] is: + # + # ./*.pm => $(INST_LIBDIR)/*.pm + # ./xyz/... => $(INST_LIBDIR)/xyz/... + # ./lib/... => $(INST_LIB)/... + # + # In this way the 'lib' directory is seen as the root of the actual + # perl library whereas the others are relative to INST_LIBDIR + # (which includes PARENT_NAME). This is a subtle distinction but one + # that's important for nested modules. + + unless( $self->{PMLIBDIRS} ) { + if( $Is{VMS} ) { + # Avoid logical name vs directory collisions + $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"]; + } + else { + $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}]; + } + } + + #only existing directories that aren't in $dir are allowed + + # Avoid $_ wherever possible: + # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; + my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; + @{$self->{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); + require File::Find; + File::Find::find(sub { + if (-d $_){ + unless ($self->libscan($_)){ + $File::Find::prune = 1; + } + return; + } + return if /\#/; + return if /~$/; # emacs temp files + return if /,v$/; # RCS files + return if m{\.swp$}; # vim swap files + + my $path = $File::Find::name; + my $prefix = $self->{INST_LIBDIR}; + my $striplibpath; + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + $prefix = $self->{INST_LIB} + 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; + $self->{PM}{$path} = $inst; + }, @{$self->{PMLIBDIRS}}); + } +} + + +=item init_DIRFILESEP + +Using / for Unix. Called by init_main. + +=cut + +sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = '/'; +} + + +=item init_main + +Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE, +EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*, +INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME, +OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB, +PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION, +VERSION_SYM, XS_VERSION. + +=cut + +sub init_main { + my($self) = @_; + + # --- Initialize Module Name and Paths + + # NAME = Foo::Bar::Oracle + # FULLEXT = Foo/Bar/Oracle + # BASEEXT = Oracle + # PARENT_NAME = Foo::Bar +### Only UNIX: +### ($self->{FULLEXT} = +### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket + $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME}); + + + # Copied from DynaLoader: + + my(@modparts) = split(/::/,$self->{NAME}); + my($modfname) = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + if (defined &DynaLoader::mod2fname) { + $modfname = &DynaLoader::mod2fname(\@modparts); + } + + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ; + $self->{PARENT_NAME} ||= ''; + + if (defined &DynaLoader::mod2fname) { + # As of 5.001m, dl_os2 appends '_' + $self->{DLBASE} = $modfname; + } else { + $self->{DLBASE} = '$(BASEEXT)'; + } + + + # --- Initialize PERL_LIB, PERL_SRC + + # *Real* information: where did we get these two from? ... + my $inc_config_dir = dirname($INC{'Config.pm'}); + my $inc_carp_dir = dirname($INC{'Carp.pm'}); + + unless ($self->{PERL_SRC}){ + 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","strict.pm") + ) { + $self->{PERL_SRC}=$dir ; + last; + } + } + } + + warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if + $self->{PERL_CORE} and !$self->{PERL_SRC}; + + if ($self->{PERL_SRC}){ + $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); + + if (defined $Cross::platform) { + $self->{PERL_ARCHLIB} = + $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform); + $self->{PERL_INC} = + $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform, + $Is{Win32}?("CORE"):()); + } + else { + $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; + $self->{PERL_INC} = ($Is{Win32}) ? + $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; + } + + # catch a situation that has occurred a few times in the past: + unless ( + -s $self->catfile($self->{PERL_SRC},'cflags') + or + $Is{VMS} + && + -s $self->catfile($self->{PERL_SRC},'vmsish.h') + or + $Is{Win32} + ){ + warn qq{ +You cannot build extensions below the perl source tree after executing +a 'make clean' in the perl source tree. + +To rebuild extensions distributed with the perl source you should +simply Configure (to include those extensions) and then build perl as +normal. After installing perl the source tree can be deleted. It is +not needed for building extensions by running 'perl Makefile.PL' +usually without extra arguments. + +It is recommended that you unpack and build additional extensions away +from the perl source tree. +}; + } + } else { + # we should also consider $ENV{PERL5LIB} here + my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC}; + $self->{PERL_LIB} ||= $Config{privlibexp}; + $self->{PERL_ARCHLIB} ||= $Config{archlibexp}; + $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now + my $perl_h; + + if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) + and not $old){ + # Maybe somebody tries to build an extension with an + # uninstalled Perl outside of Perl build tree + my $lib; + for my $dir (@INC) { + $lib = $dir, last if -e $self->catfile($dir, "Config.pm"); + } + 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->catfile($inc, "perl.h")) { + $self->{PERL_LIB} = $lib; + $self->{PERL_ARCHLIB} = $lib; + $self->{PERL_INC} = $inc; + $self->{UNINSTALLED_PERL} = 1; + print STDOUT <<EOP; +... Detected uninstalled Perl. Trying to continue. +EOP + } + } + } + } + + # We get SITELIBEXP and SITEARCHEXP directly via + # Get_from_Config. When we are running standard modules, these + # won't matter, we will set INSTALLDIRS to "perl". Otherwise we + # set it to "site". I prefer that INSTALLDIRS be set from outside + # MakeMaker. + $self->{INSTALLDIRS} ||= "site"; + + $self->{MAN1EXT} ||= $Config{man1ext}; + $self->{MAN3EXT} ||= $Config{man3ext}; + + # Get some stuff out of %Config if we haven't yet done so + print STDOUT "CONFIG must be an array ref\n" + if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY'); + $self->{CONFIG} = [] unless (ref $self->{CONFIG}); + push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config); + push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags}; + my(%once_only); + foreach my $m (@{$self->{CONFIG}}){ + next if $once_only{$m}; + print STDOUT "CONFIG key '$m' does not exist in Config.pm\n" + unless exists $Config{$m}; + $self->{uc $m} ||= $Config{$m}; + $once_only{$m} = 1; + } + +# This is too dangerous: +# if ($^O eq "next") { +# $self->{AR} = "libtool"; +# $self->{AR_STATIC_ARGS} = "-o"; +# } +# But I leave it as a placeholder + + $self->{AR_STATIC_ARGS} ||= "cr"; + + # These should never be needed + $self->{OBJ_EXT} ||= '.o'; + $self->{LIB_EXT} ||= '.a'; + + $self->{MAP_TARGET} ||= "perl"; + + $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}"; + + # make a simple check if we find strict + warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory + (strict.pm not found)" + unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") || + $self->{NAME} eq "ExtUtils::MakeMaker"; +} + +=item init_others + +Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, LD, +OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, SHELL, NOOP, +FIRST_MAKEFILE, MAKEFILE_OLD, NOECHO, RM_F, RM_RF, TEST_F, +TOUCH, CP, MV, CHMOD, UMASK_NULL, ECHO, ECHO_N + +=cut + +sub init_others { # --- Initialize Other Attributes + my($self) = shift; + + $self->{ECHO} ||= 'echo'; + $self->{ECHO_N} ||= 'echo -n'; + $self->{RM_F} ||= "rm -f"; + $self->{RM_RF} ||= "rm -rf"; + $self->{TOUCH} ||= "touch"; + $self->{TEST_F} ||= "test -f"; + $self->{CP} ||= "cp"; + $self->{MV} ||= "mv"; + $self->{CHMOD} ||= "chmod"; + $self->{FALSE} ||= 'false'; + $self->{TRUE} ||= 'true'; + + $self->{LD} ||= 'ld'; + + $self->SUPER::init_others(@_); + + # After SUPER::init_others so $Config{shell} has a + # chance to get set. + $self->{SHELL} ||= '/bin/sh'; + + return 1; +} + + +=item init_linker + +Unix has no need of special linker flags. + +=cut + +sub init_linker { + my($self) = shift; + $self->{PERL_ARCHIVE} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + + +=begin _protected + +=item init_lib2arch + + $mm->init_lib2arch + +=end _protected + +=cut + +sub init_lib2arch { + my($self) = shift; + + # The user who requests an installation directory explicitly + # should not have to tell us an architecture installation directory + # as well. We look if a directory exists that is named after the + # architecture. If not we take it as a sign that it should be the + # same as the requested installation directory. Otherwise we take + # the found one. + for my $libpair ({l=>"privlib", a=>"archlib"}, + {l=>"sitelib", a=>"sitearch"}, + {l=>"vendorlib", a=>"vendorarch"}, + ) + { + my $lib = "install$libpair->{l}"; + my $Lib = uc $lib; + my $Arch = uc "install$libpair->{a}"; + if( $self->{$Lib} && ! $self->{$Arch} ){ + my($ilib) = $Config{$lib}; + + $self->prefixify($Arch,$ilib,$self->{$Lib}); + + unless (-d $self->{$Arch}) { + print STDOUT "Directory $self->{$Arch} not found\n" + if $Verbose; + $self->{$Arch} = $self->{$Lib}; + } + print STDOUT "Defaulting $Arch to $self->{$Arch}\n" if $Verbose; + } + } +} + + +=item init_PERL + + $mm->init_PERL; + +Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the +*PERLRUN* permutations. + + PERL is allowed to be miniperl + FULLPERL must be a complete perl + + ABSPERL is PERL converted to an absolute path + + *PERLRUN contains everything necessary to run perl, find it's + libraries, etc... + + *PERLRUNINST is *PERLRUN + everything necessary to find the + modules being built. + +=cut + +sub init_PERL { + my($self) = shift; + + my @defpath = (); + foreach my $component ($self->{PERL_SRC}, $self->path(), + $Config{binexp}) + { + push @defpath, $component if defined $component; + } + + # Build up a set of file names (not command names). + my $thisperl = $self->canonpath($^X); + $thisperl .= $Config{exe_ext} unless + # VMS might have a file version # at the end + $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i + : $thisperl =~ m/$Config{exe_ext}$/i; + + # We need a relative path to perl when in the core. + $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE}; + + my @perls = ($thisperl); + push @perls, map { "$_$Config{exe_ext}" } + ('perl', 'perl5', "perl$Config{version}"); + + # miniperl has priority over all but the cannonical perl when in the + # core. Otherwise its a last resort. + my $miniperl = "miniperl$Config{exe_ext}"; + if( $self->{PERL_CORE} ) { + splice @perls, 1, 0, $miniperl; + } + else { + push @perls, $miniperl; + } + + $self->{PERL} ||= + $self->find_perl(5.0, \@perls, \@defpath, $Verbose ); + # don't check if perl is executable, maybe they have decided to + # supply switches with perl + + # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe. + my $perl_name = 'perl'; + $perl_name = 'ndbgperl' if $Is{VMS} && + defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define'; + + # XXX This logic is flawed. If "miniperl" is anywhere in the path + # it will get confused. It should be fixed to work only on the filename. + # Define 'FULLPERL' to be a non-miniperl (used in test: target) + ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/$perl_name/i + unless $self->{FULLPERL}; + + # Little hack to get around VMS's find_perl putting "MCR" in front + # sometimes. + $self->{ABSPERL} = $self->{PERL}; + my $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//; + if( $self->file_name_is_absolute($self->{ABSPERL}) ) { + $self->{ABSPERL} = '$(PERL)'; + } + else { + $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL}); + + # Quote the perl command if it contains whitespace + $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL}) + if $self->{ABSPERL} =~ /\s/; + + $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr; + } + + # Are we building the core? + $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE}; + $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE}; + + # How do we run perl? + foreach my $perl (qw(PERL FULLPERL ABSPERL)) { + my $run = $perl.'RUN'; + + $self->{$run} = "\$($perl)"; + + # Make sure perl can find itself before it's installed. + $self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} + if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}; + + $self->{$perl.'RUNINST'} = + sprintf q{$(%sRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"}, $perl; + } + + return 1; +} + + +=item init_platform + +=item platform_constants + +Add MM_Unix_VERSION. + +=cut + +sub init_platform { + my($self) = shift; + + $self->{MM_Unix_VERSION} = $VERSION; + $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '. + '-Dfree=Perl_mfree -Drealloc=Perl_realloc '. + '-Dcalloc=Perl_calloc'; + +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +=item init_PERM + + $mm->init_PERM + +Called by init_main. Initializes PERL_* + +=cut + +sub init_PERM { + my($self) = shift; + + $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR}; + $self->{PERM_RW} = 644 unless defined $self->{PERM_RW}; + $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX}; + + return 1; +} + + +=item init_xs + + $mm->init_xs + +Sets up macros having to do with XS code. Currently just INST_STATIC, +INST_DYNAMIC and INST_BOOT. + +=cut + +sub init_xs { + my $self = shift; + + if ($self->has_link_code()) { + $self->{INST_STATIC} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)'); + $self->{INST_DYNAMIC} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)'); + $self->{INST_BOOT} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs'); + } else { + $self->{INST_STATIC} = ''; + $self->{INST_DYNAMIC} = ''; + $self->{INST_BOOT} = ''; + } +} + +=item install (o) + +Defines the install target. + +=cut + +sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q{ +install :: pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +install_vendor :: pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +doc__install : doc_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +pure_perl_install :: all + $(NOECHO) $(MOD_INSTALL) \ + read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ + write }.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ + $(INST_LIB) $(DESTINSTALLPRIVLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \ + $(INST_BIN) $(DESTINSTALLBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{ + + +pure_site_install :: all + $(NOECHO) $(MOD_INSTALL) \ + read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \ + write }.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \ + $(INST_LIB) $(DESTINSTALLSITELIB) \ + $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \ + $(INST_BIN) $(DESTINSTALLSITEBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ + +pure_vendor_install :: all + $(NOECHO) $(MOD_INSTALL) \ + read }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \ + write }.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{ \ + $(INST_LIB) $(DESTINSTALLVENDORLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \ + $(INST_BIN) $(DESTINSTALLVENDORBIN) \ + $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) + +doc_perl_install :: all + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLPRIVLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{ + +doc_site_install :: all + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLSITELIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{ + +doc_vendor_install :: all + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLVENDORLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{ + +}; + + push @m, q{ +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ + +uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ +}; + + join("",@m); +} + +=item installbin (o) + +Defines targets to make and to install EXE_FILES. + +=cut + +sub installbin { + my($self) = shift; + + return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; + my @exefiles = @{$self->{EXE_FILES}}; + return "" unless @exefiles; + + @exefiles = map vmsify($_), @exefiles if $Is{VMS}; + + my %fromto; + for my $from (@exefiles) { + my($path)= $self->catfile('$(INST_SCRIPT)', basename($from)); + + local($_) = $path; # for backwards compatibility + my $to = $self->libscan($path); + print "libscan($from) => '$to'\n" if ($Verbose >=2); + + $to = vmsify($to) if $Is{VMS}; + $fromto{$from} = $to; + } + my @to = values %fromto; + + my @m; + push(@m, qq{ +EXE_FILES = @exefiles + +pure_all :: @to + \$(NOECHO) \$(NOOP) + +realclean :: +}); + + # realclean can get rather large. + push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to); + push @m, "\n"; + + + # A target for each exe file. + while (my($from,$to) = each %fromto) { + last unless defined $from; + + push @m, sprintf <<'MAKE', $to, $from, $to, $from, $to, $to, $to; +%s : %s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists + $(NOECHO) $(RM_F) %s + $(CP) %s %s + $(FIXIN) %s + -$(NOECHO) $(CHMOD) $(PERM_RWX) %s + +MAKE + + } + + join "", @m; +} + + +=item linkext (o) + +Defines the linkext target which in turn defines the LINKTYPE. + +=cut + +sub linkext { + my($self, %attribs) = @_; + # LINKTYPE => static or dynamic or '' + my($linktype) = defined $attribs{LINKTYPE} ? + $attribs{LINKTYPE} : '$(LINKTYPE)'; + " +linkext :: $linktype + \$(NOECHO) \$(NOOP) +"; +} + +=item lsdir + +Takes as arguments a directory name and a regular expression. Returns +all entries in the directory that match the regular expression. + +=cut + +sub lsdir { + my($self) = shift; + my($dir, $regex) = @_; + my(@ls); + my $dh = new DirHandle; + $dh->open($dir || ".") or return (); + @ls = $dh->read; + $dh->close; + @ls = grep(/$regex/, @ls) if $regex; + @ls; +} + +=item macro (o) + +Simple subroutine to insert the macros defined by the macro attribute +into the Makefile. + +=cut + +sub macro { + my($self,%attribs) = @_; + my(@m,$key,$val); + while (($key,$val) = each %attribs){ + last unless defined $key; + push @m, "$key = $val\n"; + } + join "", @m; +} + +=item makeaperl (o) + +Called by staticmake. Defines how to write the Makefile to produce a +static new perl. + +By default the Makefile produced includes all the static extensions in +the perl library. (Purified versions of library files, e.g., +DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + +=cut + +sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + my(@m); + push @m, " +# --- MakeMaker makeaperl section --- +MAP_TARGET = $target +FULLPERL = $self->{FULLPERL} +"; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ +$(MAP_TARGET) :: static $(MAKE_APERL_FILE) + $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ + +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib + $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR=}, $dir, q{ \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=}; + + foreach (@ARGV){ + if( /\s/ ){ + s/=(.*)/='$1'/; + } + push @m, " \\\n\t\t$_"; + } +# push @m, map( " \\\n\t\t$_", @ARGV ); + push @m, "\n"; + + return join '', @m; + } + + + + my($cccmd, $linkcmd, $lperl); + + + $cccmd = $self->const_cccmd($libperl); + $cccmd =~ s/^CCCMD\s*=\s*//; + $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /; + $cccmd .= " $Config{cccdlflags}" + if ($Config{useshrplib} eq 'true'); + $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; + + # The front matter of the linkcommand... + $linkcmd = join ' ', "\$(CC)", + grep($_, @Config{qw(ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; + + # Which *.a files could we make use of... + my %static; + require File::Find; + File::Find::find(sub { + return unless m/\Q$self->{LIB_EXT}\E$/; + + # Skip perl's libraries. + return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/; + + # Skip purified versions of libraries + # (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + # don't include the installed version of this extension. I + # leave this line here, although it is not necessary anymore: + # I patched minimod.PL instead, so that Miniperl.pm won't + # enclude duplicates + + # Once the patch to minimod.PL is in the distribution, I can + # drop it + return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:; + use Cwd 'cwd'; + $static{cwd() . "/" . $_}++; + }, grep( -d $_, @{$searchdirs || []}) ); + + # We trust that what has been handed in as argument, will be buildable + $static = [] unless $static; + @static{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + for (sort keys %static) { + next unless /\Q$self->{LIB_EXT}\E\z/; + $_ = dirname($_) . "/extralibs.ld"; + push @$extra, $_; + } + + s/^(.*)/"-I$1"/ for @{$perlinc || []}; + + $target ||= "perl"; + $tmp ||= "."; + +# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we +# regenerate the Makefiles, MAP_STATIC and the dependencies for +# extralibs.all are computed correctly + push @m, " +MAP_LINKCMD = $linkcmd +MAP_PERLINC = @{$perlinc || []} +MAP_STATIC = ", +join(" \\\n\t", reverse sort keys %static), " + +MAP_PRELIBS = $Config{perllibs} $Config{cryptlib} +"; + + if (defined $libperl) { + ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/; + } + unless ($libperl && -f $lperl) { # Ilya's code... + my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; + $libperl ||= "libperl$self->{LIB_EXT}"; + $libperl = "$dir/$libperl"; + $lperl ||= "libperl$self->{LIB_EXT}"; + $lperl = "$dir/$lperl"; + + if (! -f $libperl and ! -f $lperl) { + # We did not find a static libperl. Maybe there is a shared one? + if ($Is{SunOS}) { + $lperl = $libperl = "$dir/$Config{libperl}"; + # SUNOS ld does not take the full path to a shared library + $libperl = '' if $Is{SunOS4}; + } + } + + print STDOUT "Warning: $libperl not found + If you're going to build a static perl binary, make sure perl is installed + otherwise ignore this warning\n" + unless (-f $lperl || defined($self->{PERL_SRC})); + } + + # SUNOS ld does not take the full path to a shared library + my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl'; + + push @m, " +MAP_LIBPERL = $libperl +LLIBPERL = $llibperl +"; + + push @m, ' +$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).' + $(NOECHO) $(RM_F) $@ + $(NOECHO) $(TOUCH) $@ +'; + + foreach my $catfile (@$extra){ + push @m, "\tcat $catfile >> \$\@\n"; + } + +push @m, " +\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) \$(LLIBPERL) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(NOECHO) \$(ECHO) 'To install the new \"\$(MAP_TARGET)\" binary, call' + \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' + \$(NOECHO) \$(ECHO) 'To remove the intermediate files say' + \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename map_clean' + +$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c +"; + push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n"; + + push @m, qq{ +$tmp/perlmain.c: $makefilename}, q{ + $(NOECHO) $(ECHO) Writing $@ + $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \\ + -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ + +}; + push @m, "\t", q{$(NOECHO) $(PERL) $(INSTALLSCRIPT)/fixpmain +} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); + + + push @m, q{ +doc_inst_perl : + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Perl binary" "$(MAP_TARGET)" \ + MAP_STATIC "$(MAP_STATIC)" \ + MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ + MAP_LIBPERL "$(MAP_LIBPERL)" \ + >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{ + +}; + + push @m, q{ +inst_perl : pure_inst_perl doc_inst_perl + +pure_inst_perl : $(MAP_TARGET) + }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{ + +clean :: map_clean + +map_clean : + }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all +}; + + join '', @m; +} + +=item makefile (o) + +Defines how to rewrite the Makefile. + +=cut + +sub makefile { + my($self) = shift; + my $m; + # We do not know what target was originally specified so we + # must force a manual rerun to be sure. But as it should only + # happen very rarely it is not a significant problem. + $m = ' +$(OBJECT) : $(FIRST_MAKEFILE) + +' if $self->{OBJECT}; + + my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?'; + my $mpl_args = join " ", map qq["$_"], @ARGV; + + $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $mpl_args; +# We take a very conservative approach here, but it's worth it. +# We move Makefile to Makefile.old here to avoid gnu make looping. +$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) + $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s" + $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." + -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) + -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) + - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) + $(PERLRUN) Makefile.PL %s + $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" + $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" + $(FALSE) + +MAKE_FRAG + + return $m; +} + + +=item maybe_command + +Returns true, if the argument is likely to be a command. + +=cut + +sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d $file; + return; +} + + +=item needs_linking (o) + +Does this module need linking? Looks into subdirectory objects (see +also has_link_code()) + +=cut + +sub needs_linking { + my($self) = shift; + + my $caller = (caller(0))[3]; + confess("needs_linking called too early") if + $caller =~ /^ExtUtils::MakeMaker::/; + return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING}; + if ($self->has_link_code or $self->{MAKEAPERL}){ + $self->{NEEDS_LINKING} = 1; + return 1; + } + foreach my $child (keys %{$self->{CHILDREN}}) { + if ($self->{CHILDREN}->{$child}->needs_linking) { + $self->{NEEDS_LINKING} = 1; + return 1; + } + } + return $self->{NEEDS_LINKING} = 0; +} + + +=item parse_abstract + +parse a file and return what you think is the ABSTRACT + +=cut + +sub parse_abstract { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + my $package = $self->{DISTNAME}; + $package =~ s/-/::/g; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if !$inpod; + chop; + next unless /^($package\s-\s)(.*)/; + $result = $2; + last; + } + close $fh; + + return $result; +} + +=item parse_version + + 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 C<our $VERSION> or plain $VERSION +are okay, but C<my $VERSION> is not. + +C<<package Foo VERSION>> is also checked for. The first version +declaration found is used, but this may change as it differs from how +Perl does it. + +parse_version() will try to C<use version> before checking for +C<$VERSION> so the following will work. + + $VERSION = qv(1.2.3); + +=cut + +sub parse_version { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + local $_; + open(my $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 if /^\s*(if|unless)/; + if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ; }x ) { + local $^W = 0; + $result = $1; + } + elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* =}x ) { + 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); ## no critic + warn "Could not eval '$eval' in $parsefile: $@" if $@; + } + else { + next; + } + last if defined $result; + } + close $fh; + + $result = "undef" unless defined $result; + return $result; +} + + +=item pasthru (o) + +Defines the string that is passed to recursive make calls in +subdirectories. + +=cut + +sub pasthru { + my($self) = shift; + my(@m); + + my(@pasthru); + my($sep) = $Is{VMS} ? ',' : ''; + $sep .= "\\\n\t"; + + foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE + PREFIX INSTALL_BASE) + ) + { + next unless defined $self->{$key}; + push @pasthru, "$key=\"\$($key)\""; + } + + foreach my $key (qw(DEFINE INC)) { + next unless defined $self->{$key}; + push @pasthru, "PASTHRU_$key=\"\$(PASTHRU_$key)\""; + } + + push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; + join "", @m; +} + +=item perl_script + +Takes one argument, a file name, and returns the file name, if the +argument is likely to be a perl script. On MM_Unix this is true for +any ordinary, readable file. + +=cut + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return; +} + +=item perldepend (o) + +Defines the dependency from all *.h files that come with the perl +distribution. + +=cut + +sub perldepend { + my($self) = shift; + my(@m); + + my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm'); + + push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC}; +# Check for unpropogated config.sh changes. Should never happen. +# We do NOT just update config.h because that is not sufficient. +# An out of date config.h is not fatal but complains loudly! +$(PERL_INC)/config.h: $(PERL_SRC)/config.sh + -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE) + +$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh + $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" + %s +MAKE_FRAG + + return join "", @m unless $self->needs_linking; + + push @m, q{ +PERL_HDRS = \ + $(PERL_INC)/EXTERN.h \ + $(PERL_INC)/INTERN.h \ + $(PERL_INC)/XSUB.h \ + $(PERL_INC)/av.h \ + $(PERL_INC)/cc_runtime.h \ + $(PERL_INC)/config.h \ + $(PERL_INC)/cop.h \ + $(PERL_INC)/cv.h \ + $(PERL_INC)/dosish.h \ + $(PERL_INC)/embed.h \ + $(PERL_INC)/embedvar.h \ + $(PERL_INC)/fakethr.h \ + $(PERL_INC)/form.h \ + $(PERL_INC)/gv.h \ + $(PERL_INC)/handy.h \ + $(PERL_INC)/hv.h \ + $(PERL_INC)/intrpvar.h \ + $(PERL_INC)/iperlsys.h \ + $(PERL_INC)/keywords.h \ + $(PERL_INC)/mg.h \ + $(PERL_INC)/nostdio.h \ + $(PERL_INC)/op.h \ + $(PERL_INC)/opcode.h \ + $(PERL_INC)/patchlevel.h \ + $(PERL_INC)/perl.h \ + $(PERL_INC)/perlio.h \ + $(PERL_INC)/perlsdio.h \ + $(PERL_INC)/perlsfio.h \ + $(PERL_INC)/perlvars.h \ + $(PERL_INC)/perly.h \ + $(PERL_INC)/pp.h \ + $(PERL_INC)/pp_proto.h \ + $(PERL_INC)/proto.h \ + $(PERL_INC)/regcomp.h \ + $(PERL_INC)/regexp.h \ + $(PERL_INC)/regnodes.h \ + $(PERL_INC)/scope.h \ + $(PERL_INC)/sv.h \ + $(PERL_INC)/thread.h \ + $(PERL_INC)/unixish.h \ + $(PERL_INC)/util.h + +$(OBJECT) : $(PERL_HDRS) +} if $self->{OBJECT}; + + push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; + + join "\n", @m; +} + + +=item pm_to_blib + +Defines target that copies all files in the hash PM to their +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> + +=cut + +sub pm_to_blib { + my $self = shift; + my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my $r = q{ +pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM) +}; + + # VMS will swallow '' and PM_FILTER is often empty. So use q[] + my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']); +pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)') +CODE + + my @cmds = $self->split_command($pm_to_blib, %{$self->{PM}}); + + $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds; + $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n}; + + return $r; +} + +=item post_constants (o) + +Returns an empty string per default. Dedicated to overrides from +within Makefile.PL after all constants have been defined. + +=cut + +sub post_constants{ + ""; +} + +=item post_initialize (o) + +Returns an empty string per default. Used in Makefile.PLs to add some +chunk of text to the Makefile after the object is initialized. + +=cut + +sub post_initialize { + ""; +} + +=item postamble (o) + +Returns an empty string. Can be used in Makefile.PLs to write some +text to the Makefile at the end. + +=cut + +sub postamble { + ""; +} + +# transform dot-separated version string into comma-separated quadruple +# examples: '1.2.3.4.5' => '1,2,3,4' +# '1.2.3' => '1,2,3,0' +sub _ppd_version { + my ($self, $string) = @_; + return join ',', ((split /\./, $string), (0) x 4)[0..3]; +} + +=item ppd + +Defines target that creates a PPD (Perl Package Description) file +for a binary distribution. + +=cut + +sub ppd { + my($self) = @_; + + my $abstract = $self->{ABSTRACT} || ''; + $abstract =~ s/\n/\\n/sg; + $abstract =~ s/</</g; + $abstract =~ s/>/>/g; + + my $author = $self->{AUTHOR} || ''; + $author =~ s/</</g; + $author =~ s/>/>/g; + + my $ppd_xml = sprintf <<'PPD_HTML', $self->{VERSION}, $abstract, $author; +<SOFTPKG NAME="$(DISTNAME)" VERSION="%s"> + <ABSTRACT>%s</ABSTRACT> + <AUTHOR>%s</AUTHOR> +PPD_HTML + + $ppd_xml .= " <IMPLEMENTATION>\n"; + if ( $self->{MIN_PERL_VERSION} ) { + my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION}); + $ppd_xml .= sprintf <<'PPD_PERLVERS', $min_perl_version; + <PERLCORE VERSION="%s" /> +PPD_PERLVERS + + } + + # Don't add "perl" to requires. perl dependencies are + # handles by ARCHITECTURE. + my %prereqs = %{$self->{PREREQ_PM}}; + delete $prereqs{perl}; + + # Build up REQUIRE + foreach my $prereq (sort keys %prereqs) { + my $name = $prereq; + $name .= '::' unless $name =~ /::/; + my $version = $prereqs{$prereq}+0; # force numification + + my %attrs = ( NAME => $name ); + $attrs{VERSION} = $version if $version; + my $attrs = join " ", map { qq[$_="$attrs{$_}"] } keys %attrs; + $ppd_xml .= qq( <REQUIRE $attrs />\n); + } + + 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 .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}"; + } + $ppd_xml .= sprintf <<'PPD_OUT', $archname; + <ARCHITECTURE NAME="%s" /> +PPD_OUT + + if ($self->{PPM_INSTALL_SCRIPT}) { + if ($self->{PPM_INSTALL_EXEC}) { + $ppd_xml .= sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n}, + $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT}; + } + else { + $ppd_xml .= sprintf qq{ <INSTALL>%s</INSTALL>\n}, + $self->{PPM_INSTALL_SCRIPT}; + } + } + + my ($bin_location) = $self->{BINARY_LOCATION} || ''; + $bin_location =~ s/\\/\\\\/g; + + $ppd_xml .= sprintf <<'PPD_XML', $bin_location; + <CODEBASE HREF="%s" /> + </IMPLEMENTATION> +</SOFTPKG> +PPD_XML + + my @ppd_cmds = $self->echo($ppd_xml, '$(DISTNAME).ppd'); + + return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds; +# Creates a PPD (Perl Package Description) for a binary distribution. +ppd : + %s +PPD_OUT + +} + +=item prefixify + + $MM->prefixify($var, $prefix, $new_prefix, $default); + +Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to +replace it's $prefix with a $new_prefix. + +Should the $prefix fail to match I<AND> a PREFIX was given as an +argument to WriteMakefile() it will set it to the $new_prefix + +$default. This is for systems whose file layouts don't neatly fit into +our ideas of prefixes. + +This is for heuristics which attempt to create directory structures +that mirror those of the installed perl. + +For example: + + $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1'); + +this will attempt to remove '/usr' from the front of the +$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir} +if necessary) and replace it with '/home/foo'. If this fails it will +simply use '/home/foo/man/man1'. + +=cut + +sub prefixify { + my($self,$var,$sprefix,$rprefix,$default) = @_; + + my $path = $self->{uc $var} || + $Config_Override{lc $var} || $Config{lc $var} || ''; + + $rprefix .= '/' if $sprefix =~ m|/$|; + + print STDERR " prefixify $var => $path\n" if $Verbose >= 2; + print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2; + + if( $self->{ARGS}{PREFIX} && + $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) + { + + print STDERR " cannot prefix, using default.\n" if $Verbose >= 2; + print STDERR " no default!\n" if !$default && $Verbose >= 2; + + $path = $self->catdir($rprefix, $default) if $default; + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; +} + + +=item processPL (o) + +Defines targets to run *.PL files. + +=cut + +sub processPL { + my $self = shift; + my $pl_files = $self->{PL_FILES}; + + return "" unless $pl_files; + + my $m = ''; + foreach my $plfile (sort keys %$pl_files) { + my $list = ref($pl_files->{$plfile}) + ? $pl_files->{$plfile} + : [$pl_files->{$plfile}]; + + foreach my $target (@$list) { + if( $Is{VMS} ) { + $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 + # blib in its @INC and load the just built modules. BUT if + # the generated module is something in $(TO_INST_PM) which + # pm_to_blib depends on then it can't depend on pm_to_blib + # else we have a dependency loop. + my $pm_dep; + my $perlrun; + if( defined $self->{PM}{$target} ) { + $pm_dep = ''; + $perlrun = 'PERLRUN'; + } + else { + $pm_dep = 'pm_to_blib'; + $perlrun = 'PERLRUNINST'; + } + + $m .= <<MAKE_FRAG; + +all :: $target + \$(NOECHO) \$(NOOP) + +$target :: $plfile $pm_dep + \$($perlrun) $plfile $target +MAKE_FRAG + + } + } + + return $m; +} + +=item quote_paren + +Backslashes parentheses C<()> in command line arguments. +Doesn't handle recursive Makefile C<$(...)> constructs, +but handles simple ones. + +=cut + +sub quote_paren { + my $arg = shift; + $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...) + $arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected + $arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...) + return $arg; +} + +=item replace_manpage_separator + + my $man_name = $MM->replace_manpage_separator($file_path); + +Takes the name of a package, which may be a nested package, in the +form 'Foo/Bar.pm' and replaces the slash with C<::> or something else +safe for a man page file name. Returns the replacement. + +=cut + +sub replace_manpage_separator { + my($self,$man) = @_; + + $man =~ s,/+,::,g; + return $man; +} + + +=item cd + +=cut + +sub cd { + my($self, $dir, @cmds) = @_; + + # No leading tab and no trailing newline makes for easier embedding + my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds; + + return $make_frag; +} + +=item oneliner + +=cut + +sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + my @cmds = split /\n/, $cmd; + $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; +} + + +=item quote_literal + +=cut + +sub quote_literal { + my($self, $text) = @_; + + # I think all we have to quote is single quotes and I think + # this is a safe way to do it. + $text =~ s{'}{'\\''}g; + + return "'$text'"; +} + + +=item escape_newlines + +=cut + +sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{\\\n}g; + + return $text; +} + + +=item max_exec_len + +Using POSIX::ARG_MAX. Otherwise falling back to 4096. + +=cut + +sub max_exec_len { + my $self = shift; + + if (!defined $self->{_MAX_EXEC_LEN}) { + if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) { + $self->{_MAX_EXEC_LEN} = $arg_max; + } + else { # POSIX minimum exec size + $self->{_MAX_EXEC_LEN} = 4096; + } + } + + return $self->{_MAX_EXEC_LEN}; +} + + +=item static (o) + +Defines the static target. + +=cut + +sub static { +# --- Static Loading Sections --- + + my($self) = shift; + ' +## $(INST_PM) has been moved to the all: target. +## It remains here for awhile to allow for old usage: "make static" +static :: $(FIRST_MAKEFILE) $(INST_STATIC) + $(NOECHO) $(NOOP) +'; +} + +=item static_lib (o) + +Defines how to produce the *.a (or equivalent) files. + +=cut + +sub static_lib { + my($self) = @_; + return '' unless $self->has_link_code; + + my(@m); + push(@m, <<'END'); + +$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(RM_RF) $@ +END + + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB}; + $(CP) $(MYEXTLIB) $@ +MAKE_FRAG + + my $ar; + if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) { + # Prefer the absolute pathed ar if available so that PATH + # doesn't confuse us. Perl itself is built with the full_ar. + $ar = 'FULL_AR'; + } else { + $ar = 'AR'; + } + push @m, sprintf <<'MAKE_FRAG', $ar; + $(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ + $(CHMOD) $(PERM_RWX) $@ + $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld +MAKE_FRAG + + # Old mechanism - still available: + push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs +MAKE_FRAG + + join('', @m); +} + +=item staticmake (o) + +Calls makeaperl. + +=cut + +sub staticmake { + my($self, %attribs) = @_; + my(@static); + + my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB}); + + # And as it's not yet built, we add the current extension + # but only if it has some C code (or XS code, which implies C code) + if (@{$self->{C}}) { + @static = $self->catfile($self->{INST_ARCHLIB}, + "auto", + $self->{FULLEXT}, + "$self->{BASEEXT}$self->{LIB_EXT}" + ); + } + + # Either we determine now, which libraries we will produce in the + # subdirectories or we do it at runtime of the make. + + # We could ask all subdir objects, but I cannot imagine, why it + # would be necessary. + + # Instead we determine all libraries for the new perl at + # runtime. + my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB}); + + $self->makeaperl(MAKE => $self->{MAKEFILE}, + DIRS => \@searchdirs, + STAT => \@static, + INCL => \@perlinc, + TARGET => $self->{MAP_TARGET}, + TMP => "", + LIBPERL => $self->{LIBPERL_A} + ); +} + +=item subdir_x (o) + +Helper subroutine for subdirs + +=cut + +sub subdir_x { + my($self, $subdir) = @_; + + my $subdir_cmd = $self->cd($subdir, + '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)' + ); + return sprintf <<'EOT', $subdir_cmd; + +subdirs :: + $(NOECHO) %s +EOT + +} + +=item subdirs (o) + +Defines targets to process subdirectories. + +=cut + +sub subdirs { +# --- Sub-directory Sections --- + my($self) = shift; + my(@m); + # This method provides a mechanism to automatically deal with + # subdirectories containing further Makefile.PL scripts. + # It calls the subdir_x() method for each subdirectory. + foreach my $dir (@{$self->{DIR}}){ + push(@m, $self->subdir_x($dir)); +#### print "Including $dir subdirectory\n"; + } + if (@m){ + unshift(@m, " +# The default clean, realclean and test targets in this Makefile +# have automatically been given entries for each subdir. + +"); + } else { + push(@m, "\n# none") + } + join('',@m); +} + +=item test (o) + +Defines the test targets. + +=cut + +sub test { +# --- Test and Installation Sections --- + + my($self, %attribs) = @_; + my $tests = $attribs{TESTS} || ''; + if (!$tests && -d 't') { + $tests = $self->find_tests; + } + # note: 'test.pl' name is also hardcoded in init_dirscan() + my(@m); + push(@m," +TEST_VERBOSE=0 +TEST_TYPE=test_\$(LINKTYPE) +TEST_FILE = test.pl +TEST_FILES = $tests +TESTDB_SW = -d + +testdb :: testdb_\$(LINKTYPE) + +test :: \$(TEST_TYPE) subdirs-test + +subdirs-test :: + \$(NOECHO) \$(NOOP) + +"); + + foreach my $dir (@{ $self->{DIR} }) { + my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)'); + + push @m, <<END +subdirs-test :: + \$(NOECHO) $test + +END + } + + push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n") + unless $tests or -f "test.pl" or @{$self->{DIR}}; + push(@m, "\n"); + + push(@m, "test_dynamic :: pure_all\n"); + push(@m, $self->test_via_harness('$(FULLPERLRUN)', '$(TEST_FILES)')) + if $tests; + push(@m, $self->test_via_script('$(FULLPERLRUN)', '$(TEST_FILE)')) + if -f "test.pl"; + push(@m, "\n"); + + push(@m, "testdb_dynamic :: pure_all\n"); + push(@m, $self->test_via_script('$(FULLPERLRUN) $(TESTDB_SW)', + '$(TEST_FILE)')); + push(@m, "\n"); + + # Occasionally we may face this degenerate target: + push @m, "test_ : test_dynamic\n\n"; + + if ($self->needs_linking()) { + push(@m, "test_static :: pure_all \$(MAP_TARGET)\n"); + push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl"; + push(@m, "\n"); + push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n"); + push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)')); + push(@m, "\n"); + } else { + push @m, "test_static :: test_dynamic\n"; + push @m, "testdb_static :: testdb_dynamic\n"; + } + join("", @m); +} + +=item test_via_harness (override) + +For some reason which I forget, Unix machines like to have +PERL_DL_NONLAZY set for tests. + +=cut + +sub test_via_harness { + my($self, $perl, $tests) = @_; + return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests); +} + +=item test_via_script (override) + +Again, the PERL_DL_NONLAZY thing. + +=cut + +sub test_via_script { + my($self, $perl, $script) = @_; + return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script); +} + + +=item tool_xsubpp (o) + +Determines typemaps, xsubpp version, prototype behaviour. + +=cut + +sub tool_xsubpp { + my($self) = shift; + return "" unless $self->needs_linking; + + my $xsdir; + my @xsubpp_dirs = @INC; + + # Make sure we pick up the new xsubpp if we're building perl. + unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE}; + + foreach my $dir (@xsubpp_dirs) { + $xsdir = $self->catdir($dir, 'ExtUtils'); + if( -r $self->catfile($xsdir, "xsubpp") ) { + last; + } + } + + my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils"); + my(@tmdeps) = $self->catfile($tmdir,'typemap'); + if( $self->{TYPEMAPS} ){ + foreach my $typemap (@{$self->{TYPEMAPS}}){ + if( ! -f $typemap ) { + warn "Typemap $typemap not found.\n"; + } + else { + push(@tmdeps, $typemap); + } + } + } + push(@tmdeps, "typemap") if -f "typemap"; + my(@tmargs) = map("-typemap $_", @tmdeps); + if( exists $self->{XSOPT} ){ + unshift( @tmargs, $self->{XSOPT} ); + } + + if ($Is{VMS} && + $Config{'ldflags'} && + $Config{'ldflags'} =~ m!/Debug!i && + (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/) + ) + { + unshift(@tmargs,'-nolinenumbers'); + } + + + $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG}; + + return qq{ +XSUBPPDIR = $xsdir +XSUBPP = \$(XSUBPPDIR)\$(DFSEP)xsubpp +XSUBPPRUN = \$(PERLRUN) \$(XSUBPP) +XSPROTOARG = $self->{XSPROTOARG} +XSUBPPDEPS = @tmdeps \$(XSUBPP) +XSUBPPARGS = @tmargs +XSUBPP_EXTRA_ARGS = +}; +}; + + +=item all_target + +Build man pages, too + +=cut + +sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; +all :: pure_all manifypods + $(NOECHO) $(NOOP) +MAKE_EXT +} + +=item top_targets (o) + +Defines the targets all, subdirs, config, and O_FILES + +=cut + +sub top_targets { +# --- Target Sections --- + + my($self) = shift; + my(@m); + + push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'}; + + push @m, ' +pure_all :: config pm_to_blib subdirs linkext + $(NOECHO) $(NOOP) + +subdirs :: $(MYEXTLIB) + $(NOECHO) $(NOOP) + +config :: $(FIRST_MAKEFILE) blibdirs + $(NOECHO) $(NOOP) +'; + + push @m, ' +$(O_FILES): $(H_FILES) +' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; + + push @m, q{ +help : + perldoc ExtUtils::MakeMaker +}; + + join('',@m); +} + +=item writedoc + +Obsolete, deprecated method. Not used since Version 5.21. + +=cut + +sub writedoc { +# --- perllocal.pod section --- + my($self,$what,$name,@attribs)=@_; + my $time = localtime; + print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n"; + print join "\n\n=item *\n\n", map("C<$_>",@attribs); + print "\n\n=back\n\n"; +} + +=item xs_c (o) + +Defines the suffix rules to compile XS files to C. + +=cut + +sub xs_c { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.c: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c +'; +} + +=item xs_cpp (o) + +Defines the suffix rules to compile XS files to C++. + +=cut + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp +'; +} + +=item xs_o (o) + +Defines suffix rules to go from XS to object files directly. This is +only intended for broken make implementations. + +=cut + +sub xs_o { # many makes are too dumb to use xs_c then c_o + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs$(OBJ_EXT): + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c + $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c +'; +} + + +1; + +=back + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + +__END__ diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_VMS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_VMS.pm new file mode 100644 index 00000000000..2066d035976 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_VMS.pm @@ -0,0 +1,1994 @@ +package ExtUtils::MM_VMS; + +use strict; + +use ExtUtils::MakeMaker::Config; +require Exporter; + +BEGIN { + # so we can compile the thing on non-VMS platforms. + if( $^O eq 'VMS' ) { + require VMS::Filespec; + VMS::Filespec->import; + } +} + +use File::Basename; + +our $VERSION = '6.56'; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + +use ExtUtils::MakeMaker qw($Verbose neatvalue); +our $Revision = $ExtUtils::MakeMaker::Revision; + + +=head1 NAME + +ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + Do not use this directly. + Instead, use ExtUtils::MM and it will figure out which MM_* + class to use for you. + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=head2 Methods always loaded + +=over 4 + +=item wraplist + +Converts a list into a string wrapped at approximately 80 columns. + +=cut + +sub wraplist { + my($self) = shift; + my($line,$hlen) = ('',0); + + foreach my $word (@_) { + # Perl bug -- seems to occasionally insert extra elements when + # traversing array (scalar(@array) doesn't show them, but + # foreach(@array) does) (5.00307) + next unless $word =~ /\w/; + $line .= ' ' if length($line); + if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } + $line .= $word; + $hlen += length($word) + 2; + } + $line; +} + + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist::Kid. +# XXX This hackery will die soon. --Schwern +sub ext { + require ExtUtils::Liblist::Kid; + goto &ExtUtils::Liblist::Kid::ext; +} + +=back + +=head2 Methods + +Those methods which override default MM_Unix methods are marked +"(override)", while methods unique to MM_VMS are marked "(specific)". +For overridden methods, documentation is limited to an explanation +of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix +documentation for more details. + +=over 4 + +=item guess_name (override) + +Try to determine name of extension being built. We begin with the name +of the current directory. Since VMS filenames are case-insensitive, +however, we look for a F<.pm> file whose name matches that of the current +directory (presumably the 'main' F<.pm> file for this extension), and try +to find a C<package> statement from which to obtain the Mixed::Case +package name. + +=cut + +sub guess_name { + my($self) = @_; + my($defname,$defpm,@pm,%xs); + local *PM; + + $defname = basename(fileify($ENV{'DEFAULT'})); + $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version + $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = glob('*.pm'); + s/.pm$// for @pm; + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic + if (keys %xs) { + foreach my $pm (@pm) { + $defpm = $pm, last if exists $xs{$pm}; + } + } + } + } + if (open(my $pm, '<', "${defpm}.pm")){ + while (<$pm>) { + if (/^\s*package\s+([^;]+)/i) { + $defname = $1; + last; + } + } + print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", + "defaulting package name to $defname\n" + if eof($pm); + close $pm; + } + else { + print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", + "defaulting package name to $defname\n"; + } + $defname =~ s#[\d.\-_]+$##; + $defname; +} + +=item find_perl (override) + +Use VMS file specification syntax and CLI commands to find and +invoke Perl images. + +=cut + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + my($vmsfile,@sdirs,@snames,@cand); + my($rslt); + my($inabs) = 0; + local *TCF; + + if( $self->{PERL_CORE} ) { + # Check in relative directories first, so we pick up the current + # version of Perl if we're running MakeMaker as part of the main build. + @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); + my($absb) = $self->file_name_is_absolute($b); + if ($absa && $absb) { return $a cmp $b } + else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } + } @$dirs; + # Check miniperl before perl, and check names likely to contain + # version numbers before "generic" names, so we pick up an + # executable that's less likely to be from an old installation. + @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename + my($bb) = $b =~ m!([^:>\]/]+)$!; + my($ahasdir) = (length($a) - length($ba) > 0); + my($bhasdir) = (length($b) - length($bb) > 0); + if ($ahasdir and not $bhasdir) { return 1; } + elsif ($bhasdir and not $ahasdir) { return -1; } + else { $bb =~ /\d/ <=> $ba =~ /\d/ + or substr($ba,0,1) cmp substr($bb,0,1) + or length($bb) <=> length($ba) } } @$names; + } + else { + @sdirs = @$dirs; + @snames = @$names; + } + + # Image names containing Perl version use '_' instead of '.' under VMS + s/\.(\d+)$/_$1/ for @snames; + if ($trace >= 2){ + print "Looking for perl $ver by these names:\n"; + print "\t@snames,\n"; + print "in these dirs:\n"; + print "\t@sdirs\n"; + } + foreach my $dir (@sdirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + $inabs++ if $self->file_name_is_absolute($dir); + if ($inabs == 1) { + # We've covered relative dirs; everything else is an absolute + # dir (probably an installed location). First, we'll try + # potential command names, to see whether we can avoid a long + # MCR expression. + foreach my $name (@snames) { + push(@cand,$name) if $name =~ /^[\w\-\$]+$/; + } + $inabs++; # Should happen above in next $dir, but just in case... + } + foreach my $name (@snames){ + push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name) + : $self->fixpath($name,0); + } + } + foreach my $name (@cand) { + print "Checking $name\n" if $trace >= 2; + # If it looks like a potential command, try it without the MCR + if ($name =~ /^[\w\-\$]+$/) { + open(my $tcf, ">", "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; + close $tcf; + $rslt = `\@temp_mmvms.com` ; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=$name\n" if $trace; + return $name; + } + } + next unless $vmsfile = $self->maybe_command($name); + $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well + print "Executing $vmsfile\n" if ($trace >= 2); + open(my $tcf, '>', "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; + close $tcf; + $rslt = `\@temp_mmvms.com`; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=MCR $vmsfile\n" if $trace; + return "MCR $vmsfile"; + } + } + print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + +=item maybe_command (override) + +Follows VMS naming conventions for executable files. +If the name passed in doesn't exactly match an executable file, +appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> +to check for DCL procedure. If this fails, checks directories in DCL$PATH +and finally F<Sys$System:> for an executable file having the name specified, +with or without the F<.Exe>-equivalent suffix. + +=cut + +sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d _; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + + if ($file !~ m![/:>\]]!) { + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + my $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach my $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach my $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } + } + return 0; +} + + +=item pasthru (override) + +VMS has $(MMSQUALIFIERS) which is a listing of all the original command line +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. + +=cut + +sub pasthru { + return "PASTHRU=\n"; +} + + +=item pm_to_blib (override) + +VMS wants a dot in every file so we can't have one called 'pm_to_blib', +it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when +you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'. + +So in VMS its pm_to_blib.ts. + +=cut + +sub pm_to_blib { + my $self = shift; + + my $make = $self->SUPER::pm_to_blib; + + $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m; + $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts}; + + $make = <<'MAKE' . $make; +# Dummy target to match Unix target name; we use pm_to_blib.ts as +# timestamp file to avoid repeated invocations under VMS +pm_to_blib : pm_to_blib.ts + $(NOECHO) $(NOOP) + +MAKE + + return $make; +} + + +=item perl_script (override) + +If name passed in doesn't specify a readable file, appends F<.com> or +F<.pl> and tries again, since it's customary to have file types on all files +under VMS. + +=cut + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && ! -d _; + return "$file.com" if -r "$file.com"; + return "$file.pl" if -r "$file.pl"; + return ''; +} + + +=item replace_manpage_separator + +Use as separator a character which is legal in a VMS-syntax file name. + +=cut + +sub replace_manpage_separator { + my($self,$man) = @_; + $man = unixify($man); + $man =~ s#/+#__#g; + $man; +} + +=item init_DEST + +(override) Because of the difficulty concatenating VMS filepaths we +must pre-expand the DEST* variables. + +=cut + +sub init_DEST { + my $self = shift; + + $self->SUPER::init_DEST; + + # Expand DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} = $self->eliminate_macros($self->{$destvar}); + } +} + + +=item init_DIRFILESEP + +No seperator between a directory path and a filename on VMS. + +=cut + +sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = ''; + return 1; +} + + +=item init_main (override) + + +=cut + +sub init_main { + my($self) = shift; + + $self->SUPER::init_main; + + $self->{DEFINE} ||= ''; + if ($self->{DEFINE} ne '') { + my(@terms) = split(/\s+/,$self->{DEFINE}); + my(@defs,@udefs); + foreach my $def (@terms) { + next unless $def; + my $targ = \@defs; + if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition + $targ = \@udefs if $1 eq 'U'; + $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' + $def =~ s/^'(.*)'$/$1/; # from entire term or argument + } + if ($def =~ /=/) { + $def =~ s/"/""/g; # Protect existing " from DCL + $def = qq["$def"]; # and quote to prevent parsing of = + } + push @$targ, $def; + } + + $self->{DEFINE} = ''; + if (@defs) { + $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; + } + if (@udefs) { + $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; + } + } +} + +=item init_others (override) + +Provide VMS-specific forms of various utility commands, then hand +off to the default MM_Unix method. + +DEV_NULL should probably be overriden with something. + +Also changes EQUALIZE_TIMESTAMP to set revision date of target file to +one second later than source file, since MMK interprets precisely +equal revision dates for a source and target file as a sign that the +target needs to be updated. + +=cut + +sub init_others { + my($self) = @_; + + $self->{NOOP} = 'Continue'; + $self->{NOECHO} ||= '@ '; + + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS'; + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; + $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; + $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} ||= ')'; + $self->{USEMAKEFILE} ||= '/Descrip='; + + $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"'; + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); +install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); +CODE + + $self->SUPER::init_others; + + $self->{SHELL} ||= 'Posix'; + + $self->{UMASK_NULL} = '! '; + + # Redirection on VMS goes before the command, not after as on Unix. + # $(DEV_NULL) is used once and its not worth going nuts over making + # it work. However, Unix's DEV_NULL is quite wrong for VMS. + $self->{DEV_NULL} = ''; + + if ($self->{OBJECT} =~ /\s/) { + $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; + $self->{OBJECT} = $self->wraplist( + map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT} + ); + } + + $self->{LDFROM} = $self->wraplist( + map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM} + ); +} + + +=item init_platform (override) + +Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION. + +MM_VMS_REVISION is for backwards compatibility before MM_VMS had a +$VERSION. + +=cut + +sub init_platform { + my($self) = shift; + + $self->{MM_VMS_REVISION} = $Revision; + $self->{MM_VMS_VERSION} = $VERSION; + $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS') + if $self->{PERL_SRC}; +} + + +=item platform_constants + +=cut + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +=item init_VERSION (override) + +Override the *DEFINE_VERSION macros with VMS semantics. Translate the +MAKEMAKER filepath to VMS style. + +=cut + +sub init_VERSION { + my $self = shift; + + $self->SUPER::init_VERSION; + + $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""'; + $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'; + $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'}); +} + + +=item constants (override) + +Fixes up numerous file and directory macros to insure VMS syntax +regardless of input syntax. Also makes lists of files +comma-separated. + +=cut + +sub constants { + my($self) = @_; + + # Be kind about case for pollution + for (@ARGV) { $_ = uc($_) if /POLLUTE/i; } + + # Cleanup paths for directories in MMS macros. + foreach my $macro ( qw [ + INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB + PERL_LIB PERL_ARCHLIB + PERL_INC PERL_SRC ], + (map { 'INSTALL'.$_ } $self->installvars) + ) + { + next unless defined $self->{$macro}; + next if $macro =~ /MAN/ && $self->{$macro} eq 'none'; + $self->{$macro} = $self->fixpath($self->{$macro},1); + } + + # Cleanup paths for files in MMS macros. + foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD + MAKE_APERL_FILE MYEXTLIB] ) + { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + # Fixup files for MMS macros + # XXX is this list complete? + for my $macro (qw/ + FULLEXT VERSION_FROM OBJECT LDFROM + / ) { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + + for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) { + # Where is the space coming from? --jhi + next unless $self ne " " && defined $self->{$macro}; + my %tmp = (); + for my $key (keys %{$self->{$macro}}) { + $tmp{$self->fixpath($key,0)} = + $self->fixpath($self->{$macro}{$key},0); + } + $self->{$macro} = \%tmp; + } + + for my $macro (qw/ C O_FILES H /) { + next unless defined $self->{$macro}; + my @tmp = (); + for my $val (@{$self->{$macro}}) { + push(@tmp,$self->fixpath($val,0)); + } + $self->{$macro} = \@tmp; + } + + # mms/k does not define a $(MAKE) macro. + $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)'; + + return $self->SUPER::constants; +} + + +=item special_targets + +Clear the default .SUFFIXES and put in our own list. + +=cut + +sub special_targets { + my $self = shift; + + my $make_frag .= <<'MAKE_FRAG'; +.SUFFIXES : +.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs + +MAKE_FRAG + + return $make_frag; +} + +=item cflags (override) + +Bypass shell script and produce qualifiers for CC directly (but warn +user if a shell script for this extension exists). Fold multiple +/Defines into one, since some C compilers pay attention to only one +instance of this qualifier on the command line. + +=cut + +sub cflags { + my($self,$libperl) = @_; + my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; + my($definestr,$undefstr,$flagoptstr) = ('','',''); + my($incstr) = '/Include=($(PERL_INC)'; + my($name,$sys,@m); + + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. + " required to modify CC command for $self->{'BASEEXT'}\n" + if ($Config{$name}); + + if ($quals =~ / -[DIUOg]/) { + while ($quals =~ / -([Og])(\d*)\b/) { + my($type,$lvl) = ($1,$2); + $quals =~ s/ -$type$lvl\b\s*//; + if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } + else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } + } + while ($quals =~ / -([DIU])(\S+)/) { + my($type,$def) = ($1,$2); + $quals =~ s/ -$type$def\s*//; + $def =~ s/"/""/g; + if ($type eq 'D') { $definestr .= qq["$def",]; } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } + else { $undefstr .= qq["$def",]; } + } + } + if (length $quals and $quals !~ m!/!) { + warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; + $quals = ''; + } + $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE}; + if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } + if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } + # Deal with $self->{DEFINE} here since some C compilers pay attention + # to only one /Define clause on command line, so we have to + # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} + # ($self->{DEFINE} has already been VMSified in constants() above) + if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } + for my $type (qw(Def Undef)) { + my(@terms); + while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { + my $term = $1; + $term =~ s:^\((.+)\)$:$1:; + push @terms, $term; + } + if ($type eq 'Def') { + push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ]; + } + if (@terms) { + $quals =~ s:/${type}i?n?e?=[^/]+::ig; + $quals .= "/${type}ine=(" . join(',',@terms) . ')'; + } + } + + $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; + + # Likewise with $self->{INC} and /Include + if ($self->{'INC'}) { + my(@includes) = split(/\s+/,$self->{INC}); + foreach (@includes) { + s/^-I//; + $incstr .= ','.$self->fixpath($_,1); + } + } + $quals .= "$incstr)"; +# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g; + $self->{CCFLAGS} = $quals; + + $self->{PERLTYPE} ||= ''; + + $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; + if ($self->{OPTIMIZE} !~ m!/!) { + if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } + elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { + $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); + } + else { + warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; + $self->{OPTIMIZE} = '/Optimize'; + } + } + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; +} + +=item const_cccmd (override) + +Adds directives to point C preprocessor to the right place when +handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC +command line a bit differently than MM_Unix method. + +=cut + +sub const_cccmd { + my($self,$libperl) = @_; + my(@m); + + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + if ($Config{'vms_cc_type'} eq 'gcc') { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]'; + } + elsif ($Config{'vms_cc_type'} eq 'vaxc') { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include'; + } + else { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ', + ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),' + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include'; + } + + push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n"); + + $self->{CONST_CCCMD} = join('',@m); +} + + +=item tools_other (override) + +Throw in some dubious extra macros for Makefile args. + +Also keep around the old $(SAY) macro in case somebody's using it. + +=cut + +sub tools_other { + my($self) = @_; + + # XXX Are these necessary? Does anyone override them? They're longer + # than just typing the literal string. + my $extra_tools = <<'EXTRA_TOOLS'; + +# Just in case anyone is using the old macro. +USEMACROS = $(MACROSTART) +SAY = $(ECHO) + +EXTRA_TOOLS + + return $self->SUPER::tools_other . $extra_tools; +} + +=item init_dist (override) + +VMSish defaults for some values. + + macro description default + + ZIPFLAGS flags to pass to ZIP -Vu + + COMPRESS compression command to gzip + use for tarfiles + SUFFIX suffix to put on -gz + compressed files + + SHAR shar command to use vms_share + + DIST_DEFAULT default target to use to tardist + create a distribution + + DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM) + VERSION for the name + +=cut + +sub init_dist { + my($self) = @_; + $self->{ZIPFLAGS} ||= '-Vu'; + $self->{COMPRESS} ||= 'gzip'; + $self->{SUFFIX} ||= '-gz'; + $self->{SHAR} ||= 'vms_share'; + $self->{DIST_DEFAULT} ||= 'zipdist'; + + $self->SUPER::init_dist; + + $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}" + unless $self->{ARGS}{DISTVNAME}; + + return; +} + +=item c_o (override) + +Use VMS syntax on command line. In particular, $(DEFINE) and +$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros. + +=cut + +sub c_o { + my($self) = @_; + return '' unless $self->needs_linking(); + ' +.c$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c + +.cpp$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp + +.cxx$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx + +'; +} + +=item xs_c (override) + +Use MM[SK] macros. + +=cut + +sub xs_c { + my($self) = @_; + return '' unless $self->needs_linking(); + ' +.xs.c : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET) +'; +} + +=item xs_o (override) + +Use MM[SK] macros, and VMS command line for C compiler. + +=cut + +sub xs_o { # many makes are too dumb to use xs_c then c_o + my($self) = @_; + return '' unless $self->needs_linking(); + ' +.xs$(OBJ_EXT) : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c +'; +} + + +=item dlsyms (override) + +Create VMS linker options files specifying universal symbols for this +extension's shareable image, and listing other shareable images or +libraries to which it should be linked. + +=cut + +sub dlsyms { + my($self,%attribs) = @_; + + return '' unless $self->needs_linking(); + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; + my(@m); + + unless ($self->{SKIPHASH}{'dynamic'}) { + push(@m,' +dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt + $(NOECHO) $(NOOP) +'); + } + + push(@m,' +static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt + $(NOECHO) $(NOOP) +') unless $self->{SKIPHASH}{'static'}; + + push @m,' +$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt + $(CP) $(MMS$SOURCE) $(MMS$TARGET) + +$(BASEEXT).opt : Makefile.PL + $(PERLRUN) -e "use ExtUtils::Mksymlists;" - + ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ], + neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars), + q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n]; + + push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include='; + if ($self->{OBJECT} =~ /\bBASEEXT\b/ or + $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { + push @m, ($Config{d_vms_case_sensitive_symbols} + ? uc($self->{BASEEXT}) :'$(BASEEXT)'); + } + else { # We don't have a "main" object file, so pull 'em all in + # Upcase module names if linker is being case-sensitive + my($upcase) = $Config{d_vms_case_sensitive_symbols}; + my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT}); + for (@omods) { + s/\.[^.]*$//; # Trim off file type + s[\$\(\w+_EXT\)][]; # even as a macro + s/.*[:>\/\]]//; # Trim off dir spec + $_ = uc if $upcase; + }; + + my(@lines); + my $tmp = shift @omods; + foreach my $elt (@omods) { + $tmp .= ",$elt"; + if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } + } + push @lines, $tmp; + push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')'; + } + push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n"; + + if (length $self->{LDLOADLIBS}) { + my($line) = ''; + foreach my $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; + } + + join('',@m); + +} + +=item dynamic_lib (override) + +Use VMS Link command. + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code(); + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my $shr = $Config{'dbgprefix'} . 'PerlShr'; + my(@m); + push @m," + +OTHERLDFLAGS = $otherldflags +INST_DYNAMIC_DEP = $inst_dynamic_dep + +"; + push @m, ' +$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) + If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' + Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option +'; + + join('',@m); +} + + +=item static_lib (override) + +Use VMS commands to manipulate object library. + +=cut + +sub static_lib { + my($self) = @_; + return '' unless $self->needs_linking(); + + return ' +$(INST_STATIC) : + $(NOECHO) $(NOOP) +' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); + + my(@m); + push @m,' +# Rely on suffix rule for update action +$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists + +$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) +'; + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; + + push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); + + # if there was a library to copy, then we can't use MMS$SOURCE_LIST, + # 'cause it's a library and you can't stick them in other libraries. + # In that case, we use $OBJECT instead and hope for the best + if ($self->{MYEXTLIB}) { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n"); + } else { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); + } + + push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; + foreach my $lib (split ' ', $self->{EXTRALIBS}) { + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } + join('',@m); +} + + +=item extra_clean_files + +Clean up some OS specific files. Plus the temp file used to shorten +a lot of commands. + +=cut + +sub extra_clean_files { + return qw( + *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso + .MM_Tmp + ); +} + + +=item zipfile_target + +=item tarfile_target + +=item shdist_target + +Syntax for invoking shar, tar and zip differs from that for Unix. + +=cut + +sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + +sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) +MAKE_FRAG +} + +sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +shdist : distdir + $(PREOP) + $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + + +# --- Test and Installation Sections --- + +=item install (override) + +Work around DCL's 255 character limit several times,and use +VMS-style command line quoting in a few cases. + +=cut + +sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q[ +install :: all pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: all pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: all pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +doc__install : doc_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +# This hack brought to you by DCL's 255-character command line limit +pure_perl_install :: + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ + +# Likewise +pure_site_install :: + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ + +pure_vendor_install :: + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + +# Ditto +doc_perl_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +# And again +doc_site_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +doc_vendor_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +]; + + push @m, q[ +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ + $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience." + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ + $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience." +]; + + join('',@m); +} + +=item perldepend (override) + +Use VMS-style syntax for files; it's cheaper to just do it directly here +than to have the MM_Unix method call C<catfile> repeatedly. Also, if +we have to rebuild Config.pm, use MM[SK] to do it. + +=cut + +sub perldepend { + my($self) = @_; + my(@m); + + push @m, ' +$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h +$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h +$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h +$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h +$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h +$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h +$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h +$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h +$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h +$(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)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h + +' if $self->{OBJECT}; + + if ($self->{PERL_SRC}) { + my(@macros); + my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)'; + push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP'; + push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc'; + push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc'; + push(@macros,'SOCKET=1') if $Config{'d_has_sockets'}; + push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!; + $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros; + push(@m,q[ +# Check for unpropagated config.sh changes. Should never happen. +# We do NOT just update config.h because that is not sufficient. +# An out of date config.h is not fatal but complains loudly! +$(PERL_INC)config.h : $(PERL_SRC)config.sh + $(NOOP) + +$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh + $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" + olddef = F$Environment("Default") + Set Default $(PERL_SRC) + $(MMS)],$mmsquals,); + if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); + $target =~ s/\Q$prefix/[/; + push(@m," $target"); + } + else { push(@m,' $(MMS$TARGET)'); } + push(@m,q[ + Set Default 'olddef' +]); + } + + push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + if %{$self->{XS}}; + + join('',@m); +} + + +=item makeaperl (override) + +Undertake to build a new set of Perl images using VMS commands. Since +VMS does dynamic loading, it's not necessary to statically link each +extension into the Perl image, so this isn't the normal build path. +Consequently, it hasn't really been tested, and may well be incomplete. + +=cut + +our %olbs; # needs to be localized + +sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + my(@m); + push @m, " +# --- MakeMaker makeaperl section --- +MAP_TARGET = $target +"; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) + $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR=}, $dir, q{ \ + FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 }; + + push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{ + +$(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) +}; + push @m, "\n"; + + return join '', @m; + } + + + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); + + # The front matter of the linkcommand... + $linkcmd = join ' ', $Config{'ld'}, + grep($_, @Config{qw(large split ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + + # Which *.olb files could we make use of... + local(%olbs); # XXX can this be lexical? + $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; + require File::Find; + File::Find::find(sub { + return unless m/\Q$self->{LIB_EXT}\E$/; + return if m/^libperl/; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + $olbs{$ENV{DEFAULT}} = $_; + }, grep( -d $_, @{$searchdirs || []})); + + # We trust that what has been handed in as argument will be buildable + $static = [] unless $static; + @olbs{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + # Sort the object libraries in inverse order of + # filespec length to try to insure that dependent extensions + # will appear before their parents, so the linker will + # search the parent library to resolve references. + # (e.g. Intuit::DWIM will precede Intuit, so unresolved + # references from [.intuit.dwim]dwim.obj can be found + # in [.intuit]intuit.olb). + for (sort { length($a) <=> length($b) } keys %olbs) { + next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; + my($dir) = $self->fixpath($_,1); + my($extralibs) = $dir . "extralibs.ld"; + my($extopt) = $dir . $olbs{$_}; + $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need + if (-f $extralibs ) { + my %seenthis; + open my $list, "<", $extralibs or warn $!,next; + while (<$list>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } + } + # Get full name of extension for ExtUtils::Miniperl + if (-f $extopt) { + open my $opt, '<', $extopt or die $!; + while (<$opt>) { + next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; + my $pkg = $1; + $pkg =~ s#__*#::#g; + push @staticpkgs,$pkg; + } + } + } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; + + $target = "Perl$Config{'exe_ext'}" unless $target; + my $shrtarget; + ($shrtarget,$targdir) = fileparse($target); + $shrtarget =~ s/^([^.]*)/$1Shr/; + $shrtarget = $targdir . $shrtarget; + $target = "Perlshr.$Config{'dlext'}" unless $target; + $tmpdir = "[]" unless $tmpdir; + $tmpdir = $self->fixpath($tmpdir,1); + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; + if ($libperl) { + unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { + print STDOUT "Warning: $libperl not found\n"; + undef $libperl; + } + } + unless ($libperl) { + if (defined $self->{PERL_SRC}) { + $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); + } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { + } else { + print STDOUT "Warning: $libperl not found + If you're going to build a static perl binary, make sure perl is installed + otherwise ignore this warning\n"; + } + } + $libperldir = $self->fixpath((fileparse($libperl))[1],1); + + push @m, ' +# Fill in the target you want to produce if it\'s not perl +MAP_TARGET = ',$self->fixpath($target,0),' +MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," +MAP_LINKCMD = $linkcmd +MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," +MAP_EXTRA = $extralist +MAP_LIBPERL = ",$self->fixpath($libperl,0),' +'; + + + push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmpdir}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + + push @m,' +$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' +$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",' + $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option + $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say" + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" + $(NOECHO) $(ECHO) "To remove the intermediate files, say + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean" +'; + push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]; + } + + push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir; + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) %sWritemain.tmp +MAKE_FRAG + + push @m, q[ +# Still more from the 255-char line length limit +doc_inst_perl : + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp + $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp + $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp +]; + + push @m, " +inst_perl : pure_inst_perl doc_inst_perl + \$(NOECHO) \$(NOOP) + +pure_inst_perl : \$(MAP_TARGET) + $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," + $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," + +clean :: map_clean + \$(NOECHO) \$(NOOP) + +map_clean : + \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE) + \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET) +"; + + join '', @m; +} + + +# --- Output postprocessing section --- + +=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 +part of a filespec. + +=cut + +sub maketext_filter { + my($self, $text) = @_; + + $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg; + return $text; +} + +=item prefixify (override) + +prefixifying on VMS is simple. Each should simply be: + + perl_root:[some.dir] + +which can just be converted to: + + volume:[your.prefix.some.dir] + +otherwise you get the default layout. + +In effect, your search prefix is ignored and $Config{vms_prefix} is +used instead. + +=cut + +sub prefixify { + my($self, $var, $sprefix, $rprefix, $default) = @_; + + # Translate $(PERLPREFIX) to a real path. + $rprefix = $self->eliminate_macros($rprefix); + $rprefix = vmspath($rprefix) if $rprefix; + $sprefix = vmspath($sprefix) if $sprefix; + + $default = vmsify($default) + unless $default =~ /\[.*\]/; + + (my $var_no_install = $var) =~ s/^install//; + my $path = $self->{uc $var} || + $ExtUtils::MM_Unix::Config_Override{lc $var} || + $Config{lc $var} || $Config{lc $var_no_install}; + + if( !$path ) { + print STDERR " no Config found for $var.\n" if $Verbose >= 2; + $path = $self->_prefixify_default($rprefix, $default); + } + elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) { + # do nothing if there's no prefix or if its relative + } + elsif( $sprefix eq $rprefix ) { + print STDERR " no new prefix.\n" if $Verbose >= 2; + } + else { + + print STDERR " prefixify $var => $path\n" if $Verbose >= 2; + print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2; + + my($path_vol, $path_dirs) = $self->splitpath( $path ); + if( $path_vol eq $Config{vms_prefix}.':' ) { + print STDERR " $Config{vms_prefix}: seen\n" if $Verbose >= 2; + + $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; + $path = $self->_catprefix($rprefix, $path_dirs); + } + else { + $path = $self->_prefixify_default($rprefix, $default); + } + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; +} + + +sub _prefixify_default { + my($self, $rprefix, $default) = @_; + + print STDERR " cannot prefix, using default.\n" if $Verbose >= 2; + + if( !$default ) { + print STDERR "No default!\n" if $Verbose >= 1; + return; + } + if( !$rprefix ) { + print STDERR "No replacement prefix!\n" if $Verbose >= 1; + return ''; + } + + return $self->_catprefix($rprefix, $default); +} + +sub _catprefix { + my($self, $rprefix, $default) = @_; + + my($rvol, $rdirs) = $self->splitpath($rprefix); + if( $rvol ) { + return $self->catpath($rvol, + $self->catdir($rdirs, $default), + '' + ) + } + else { + return $self->catdir($rdirs, $default); + } +} + + +=item cd + +=cut + +sub cd { + my($self, $dir, @cmds) = @_; + + $dir = vmspath($dir); + + my $cmd = join "\n\t", map "$_", @cmds; + + # No leading tab makes it look right when embedded + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; +startdir = F$Environment("Default") + Set Default %s + %s + Set Default 'startdir' +MAKE_FRAG + + # No trailing newline makes this easier to embed + chomp $make_frag; + + return $make_frag; +} + + +=item oneliner + +=cut + +sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + $cmd = $self->quote_literal($cmd); + $cmd = $self->escape_newlines($cmd); + + # Switches must be quoted else they will be lowercased. + $switches = join ' ', map { qq{"$_"} } @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}; +} + + +=item B<echo> + +perl trips up on "<foo>" thinking it's an input redirect. So we use the +native Write command instead. Besides, its faster. + +=cut + +sub echo { + my($self, $text, $file, $appending) = @_; + $appending ||= 0; + + my $opencmd = $appending ? 'Open/Append' : 'Open/Write'; + + my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); + push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) } + split /\n/, $text; + push @cmds, '$(NOECHO) Close MMECHOFILE'; + return @cmds; +} + + +=item quote_literal + +=cut + +sub quote_literal { + my($self, $text) = @_; + + # I believe this is all we should need. + $text =~ s{"}{""}g; + + return qq{"$text"}; +} + +=item escape_newlines + +=cut + +sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{-\n}g; + + return $text; +} + +=item max_exec_len + +256 characters. + +=cut + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 256; +} + +=item init_linker + +=cut + +sub init_linker { + my $self = shift; + $self->{EXPORT_LIST} ||= '$(BASEEXT).opt'; + + my $shr = $Config{dbgprefix} . 'PERLSHR'; + if ($self->{PERL_SRC}) { + $self->{PERL_ARCHIVE} ||= + $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}"); + } + else { + $self->{PERL_ARCHIVE} ||= + $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"; + } + + $self->{PERL_ARCHIVE_AFTER} ||= ''; +} + + +=item catdir (override) + +=item catfile (override) + +Eliminate the macros in the output to the MMS/MMK file. + +(File::Spec::VMS used to do this for us, but it's being removed) + +=cut + +sub catdir { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $dir = $self->SUPER::catdir(@args); + + # Fix up the directory and force it to VMS format. + $dir = $self->fixpath($dir, 1); + + return $dir; +} + +sub catfile { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $file = $self->SUPER::catfile(@args); + + $file = vmsify($file); + + return $file +} + + +=item eliminate_macros + +Expands MM[KS]/Make macros in a text string, using the contents of +identically named elements of C<%$self>, and returns the result +as a file specification in Unix syntax. + +NOTE: This is the canonical version of the method. The version in +File::Spec::VMS is deprecated. + +=cut + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + + if ($path =~ /\s/) { + return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; + } + + my($npath) = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { + if (defined $self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +=item fixpath + + my $path = $mm->fixpath($path); + my $path = $mm->fixpath($path, $is_dir); + +Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +in any directory specification, in order to avoid juxtaposing two +VMS-syntax directories when MM[SK] is run. Also expands expressions which +are all macro, so that we can tell how long the expansion is, and avoid +overrunning DCL's command buffer when MM[KS] is running. + +fixpath() checks to see whether the result matches the name of a +directory in the current default directory and returns a directory or +file specification accordingly. C<$is_dir> can be set to true to +force fixpath() to consider the path to be a directory or false to force +it to be a file. + +NOTE: This is the canonical version of the method. The version in +File::Spec::VMS is deprecated. + +=cut + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {}, $self unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ /[ \t]/) { + return join ' ', + map { $self->fixpath($_,$force_path) } + split /[ \t]+/, $path; + } + + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + + return $fixedpath; +} + + +=item os_flavor + +VMS is VMS. + +=cut + +sub os_flavor { + return('VMS'); +} + +=back + + +=head1 AUTHOR + +Original author Charles Bailey F<bailey@newman.upenn.edu> + +Maintained by Michael G Schwern F<schwern@pobox.com> + +See L<ExtUtils::MakeMaker> for patching and contact information. + + +=cut + +1; + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_VOS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_VOS.pm new file mode 100644 index 00000000000..1814a1dae4c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_VOS.pm @@ -0,0 +1,50 @@ +package ExtUtils::MM_VOS; + +use strict; +our $VERSION = '6.56'; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + +=head1 NAME + +ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix + +=head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Unix which contains functionality for +VOS. + +Unless otherwise stated it works just like ExtUtils::MM_Unix + +=head2 Overridden methods + +=head3 extra_clean_files + +Cleanup VOS core files + +=cut + +sub extra_clean_files { + return qw(*.kp); +} + + +=head1 AUTHOR + +Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win32.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win32.pm new file mode 100644 index 00000000000..19e462de593 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win32.pm @@ -0,0 +1,585 @@ +package ExtUtils::MM_Win32; + +use strict; + + +=head1 NAME + +ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=cut + +use ExtUtils::MakeMaker::Config; +use File::Basename; +use File::Spec; +use ExtUtils::MakeMaker qw( neatvalue ); + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); +our $VERSION = '6.56'; + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +my $BORLAND = $Config{'cc'} =~ /^bcc/i ? 1 : 0; +my $GCC = $Config{'cc'} =~ /\bgcc$/i ? 1 : 0; +my $DLLTOOL = $Config{'dlltool'} || 'dlltool'; + + +=head2 Overridden methods + +=over 4 + +=item B<dlsyms> + +=cut + +sub dlsyms { + my($self,%attribs) = @_; + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; + my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; + my(@m); + + if (not $self->{SKIPHASH}{'dynamic'}) { + push(@m," +$self->{BASEEXT}.def: Makefile.PL +", + q! $(PERLRUN) -MExtUtils::Mksymlists \\ + -e "Mksymlists('NAME'=>\"!, $self->{NAME}, + q!\", 'DLBASE' => '!,$self->{DLBASE}, + # The above two lines quoted differently to work around + # a bug in the 4DOS/4NT command line interpreter. The visible + # result of the bug was files named q('extension_name',) *with the + # single quotes and the comma* in the extension build directories. + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars), q!);" +!); + } + join('',@m); +} + +=item replace_manpage_separator + +Changes the path separator with . + +=cut + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + + +=item B<maybe_command> + +Since Windows has nothing as simple as an executable bit, we check the +file extension. + +The PATHEXT env variable will be used to get a list of extensions that +might indicate a command, otherwise .com, .exe, .bat and .cmd will be +used by default. + +=cut + +sub maybe_command { + my($self,$file) = @_; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } + return; +} + + +=item B<init_DIRFILESEP> + +Using \ for Windows. + +=cut + +sub init_DIRFILESEP { + my($self) = shift; + + # The ^ makes sure its not interpreted as an escape in nmake + $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' : + $self->is_make_type('dmake') ? '\\\\' + : '\\'; +} + +=item B<init_others> + +Override some of the Unix specific commands with portable +ExtUtils::Command ones. + +Also provide defaults for LD and AR in case the %Config values aren't +set. + +LDLOADLIBS's default is changed to $Config{libs}. + +Adjustments are made for Borland's quirks needing -L to come first. + +=cut + +sub init_others { + my ($self) = @_; + + $self->{NOOP} ||= 'rem'; + $self->{DEV_NULL} ||= '> NUL'; + + $self->{FIXIN} ||= $self->{PERL_CORE} ? + "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" : + 'pl2bat.bat'; + + $self->{LD} ||= 'link'; + $self->{AR} ||= 'lib'; + + $self->SUPER::init_others; + + # Setting SHELL from $Config{sh} can break dmake. Its ok without it. + delete $self->{SHELL}; + + $self->{LDLOADLIBS} ||= $Config{libs}; + # -Lfoo must come first for Borland, so we put it in LDDLFLAGS + if ($BORLAND) { + my $libs = $self->{LDLOADLIBS}; + my $libpath = ''; + while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { + $libpath .= ' ' if length $libpath; + $libpath .= $1; + } + $self->{LDLOADLIBS} = $libs; + $self->{LDDLFLAGS} ||= $Config{lddlflags}; + $self->{LDDLFLAGS} .= " $libpath"; + } + + return 1; +} + + +=item init_platform + +Add MM_Win32_VERSION. + +=item platform_constants + +=cut + +sub init_platform { + my($self) = shift; + + $self->{MM_Win32_VERSION} = $VERSION; +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Win32_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +=item special_targets + +Add .USESHELL target for dmake. + +=cut + +sub special_targets { + my($self) = @_; + + my $make_frag = $self->SUPER::special_targets; + + $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake'); +.USESHELL : +MAKE_FRAG + + return $make_frag; +} + + +=item static_lib + +Changes how to run the linker. + +The rest is duplicate code from MM_Unix. Should move the linker code +to its own method. + +=cut + +sub static_lib { + my($self) = @_; + return '' unless $self->has_link_code; + + my(@m); + push(@m, <<'END'); +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists + $(RM_RF) $@ +END + + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB}; + $(CP) $(MYEXTLIB) $@ +MAKE_FRAG + + push @m, +q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")' + : ($GCC ? '-ru $@ $(OBJECT)' + : '-out:$@ $(OBJECT)')).q{ + $(CHMOD) $(PERM_RWX) $@ + $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld +}; + + # Old mechanism - still available: + push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs +MAKE_FRAG + + join('', @m); +} + + +=item dynamic_lib + +Complicated stuff for Win32 that I don't understand. :( + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($ldfrom) = '$(LDFROM)'; + my(@m); + +# one thing for GCC/Mingw32: +# we try to overcome non-relocateable-DLL problems by generating +# a (hopefully unique) image-base from the dll's name +# -- BKS, 10-19-1999 + if ($GCC) { + my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT}; + $dllname =~ /(....)(.{0,4})/; + my $baseaddr = unpack("n", $1 ^ $2); + $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr); + } + + push(@m,' +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +OTHERLDFLAGS = '.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' + +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +'); + if ($GCC) { + push(@m, + q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp + $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp + }.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp + $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp }); + } elsif ($BORLAND) { + push(@m, + q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,} + .($self->is_make_type('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))}) + .q{,$(RESFILES)}); + } else { # VC + push(@m, + q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } + .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); + + # Embed the manifest file if it exists + push(@m, q{ + if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 + if exist $@.manifest del $@.manifest}); + } + push @m, ' + $(CHMOD) $(PERM_RWX) $@ +'; + + join('',@m); +} + +=item extra_clean_files + +Clean out some extra dll.{base,exp} files which might be generated by +gcc. Otherwise, take out all *.pdb files. + +=cut + +sub extra_clean_files { + my $self = shift; + + return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb'); +} + +=item init_linker + +=cut + +sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}"; + $self->{PERL_ARCHIVE_AFTER} = ''; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; +} + + +=item perl_script + +Checks for the perl program under several common perl extensions. + +=cut + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return "$file.pl" if -r "$file.pl" && -f _; + return "$file.plx" if -r "$file.plx" && -f _; + return "$file.bat" if -r "$file.bat" && -f _; + return; +} + + +=item xs_o + +This target is stubbed out. Not sure why. + +=cut + +sub xs_o { + return '' +} + + +=item pasthru + +All we send is -nologo to nmake to prevent it from printing its damned +banner. + +=cut + +sub pasthru { + my($self) = shift; + return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : ""); +} + + +=item arch_check (override) + +Normalize all arguments for consistency of comparison. + +=cut + +sub arch_check { + my $self = shift; + + # Win32 is an XS module, minperl won't have it. + # arch_check() is not critical, so just fake it. + return 1 unless $self->can_load_xs; + return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_); +} + +sub _normalize_path_name { + my $self = shift; + my $file = shift; + + require Win32; + my $short = Win32::GetShortPathName($file); + return defined $short ? lc $short : lc $file; +} + + +=item oneliner + +These are based on what command.com does on Win98. They may be wrong +for other Windows shells, I don't know. + +=cut + +sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + $cmd = $self->quote_literal($cmd); + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; +} + + +sub quote_literal { + my($self, $text) = @_; + + # I don't know if this is correct, but it seems to work on + # Win98's command.com + $text =~ s{"}{\\"}g; + + # dmake eats '{' inside double quotes and leaves alone { outside double + # quotes; however it transforms {{ into { either inside and outside double + # quotes. It also translates }} into }. The escaping below is not + # 100% correct. + if( $self->is_make_type('dmake') ) { + $text =~ s/{/{{/g; + $text =~ s/}}/}}}/g; + } + + return qq{"$text"}; +} + + +sub escape_newlines { + my($self, $text) = @_; + + # Escape newlines + $text =~ s{\n}{\\\n}g; + + return $text; +} + + +=item cd + +dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It +wants: + + cd dir1\dir2 + command + another_command + cd ..\.. + +=cut + +sub cd { + my($self, $dir, @cmds) = @_; + + return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('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, $updirs; +cd %s + %s + cd %s +MAKE_FRAG + + chomp $make_frag; + + return $make_frag; +} + + +=item max_exec_len + +nmake 1.50 limits command length to 2048 characters. + +=cut + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 2 * 1024; +} + + +=item os_flavor + +Windows is Win32. + +=cut + +sub os_flavor { + return('Win32'); +} + + +=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} +}; + +} + +sub is_make_type { + my($self, $type) = @_; + return !! ($self->make =~ /\b$type(?:\.exe)?$/); +} + +1; +__END__ + +=back + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win95.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win95.pm new file mode 100644 index 00000000000..c47147695e8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MM_Win95.pm @@ -0,0 +1,124 @@ +package ExtUtils::MM_Win95; + +use strict; + +our $VERSION = '6.56'; + +require ExtUtils::MM_Win32; +our @ISA = qw(ExtUtils::MM_Win32); + +use ExtUtils::MakeMaker::Config; + + +=head1 NAME + +ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X + +=head1 SYNOPSIS + + You should not be using this module directly. + +=head1 DESCRIPTION + +This is a subclass of ExtUtils::MM_Win32 containing changes necessary +to get MakeMaker playing nice with command.com and other Win9Xisms. + +=head2 Overridden methods + +Most of these make up for limitations in the Win9x/nmake command shell. +Mostly its lack of &&. + +=over 4 + + +=item xs_c + +The && problem. + +=cut + +sub xs_c { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.c: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c + ' +} + + +=item xs_cpp + +The && problem + +=cut + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp + '; +} + +=item xs_o + +The && problem. + +=cut + +sub xs_o { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs$(OBJ_EXT): + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c + '; +} + + +=item max_exec_len + +Win98 chokes on things like Encode if we set the max length to nmake's max +of 2K. So we go for a more conservative value of 1K. + +=cut + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 1024; +} + + +=item os_flavor + +Win95 and Win98 and WinME are collectively Win9x and Win32 + +=cut + +sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Win9x'); +} + + +=back + + +=head1 AUTHOR + +Code originally inside MM_Win32. Original author unknown. + +Currently maintained by Michael G Schwern C<schwern@pobox.com>. + +Send patches and ideas to C<makemaker@perl.org>. + +See http://www.makemaker.org. + +=cut + + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MY.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MY.pm new file mode 100644 index 00000000000..bed177d210a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MY.pm @@ -0,0 +1,40 @@ +package ExtUtils::MY; + +use strict; +require ExtUtils::MM; + +our $VERSION = 6.56; +our @ISA = qw(ExtUtils::MM); + +{ + package MY; + our @ISA = qw(ExtUtils::MY); +} + +sub DESTROY {} + + +=head1 NAME + +ExtUtils::MY - ExtUtils::MakeMaker subclass for customization + +=head1 SYNOPSIS + + # in your Makefile.PL + sub MY::whatever { + ... + } + +=head1 DESCRIPTION + +B<FOR INTERNAL USE ONLY> + +ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your +Makefile.PL for you to add and override MakeMaker functionality. + +It also provides a convenient alias via the MY class. + +ExtUtils::MY might turn out to be a temporary solution, but MY won't +go away. + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker.pm new file mode 100644 index 00000000000..4422b686ce7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker.pm @@ -0,0 +1,2807 @@ +# $Id$ +package ExtUtils::MakeMaker; + +use strict; + +BEGIN {require 5.006;} + +require Exporter; +use ExtUtils::MakeMaker::Config; +use Carp (); +use File::Path; + +our $Verbose = 0; # exported +our @Parent; # needs to be localized +our @Get_from_Config; # referenced by MM_Unix +our @MM_Sections; +our @Overridable; +my @Prepend_parent; +my %Recognized_Att_Keys; + +our $VERSION = '6.56'; + +# Emulate something resembling CVS $Revision$ +(our $Revision = $VERSION) =~ s{_}{}; +$Revision = int $Revision * 10000; + +our $Filename = __FILE__; # referenced outside MakeMaker + +our @ISA = qw(Exporter); +our @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); +our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists + &WriteEmptyMakefile); + +# These will go away once the last of the Win32 & VMS specific code is +# purged. +my $Is_VMS = $^O eq 'VMS'; +my $Is_Win32 = $^O eq 'MSWin32'; + +full_setup(); + +require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker + # will give them MM. + +require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect + # loading ExtUtils::MakeMaker will give them MY. + # This will go when Embed is its own CPAN module. + + +sub WriteMakefile { + Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; + + require ExtUtils::MY; + my %att = @_; + + _verify_att(\%att); + + my $mm = MM->new(\%att); + $mm->flush; + + return $mm; +} + + +# Basic signatures of the attributes WriteMakefile takes. Each is the +# reference type. Empty value indicate it takes a non-reference +# 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', + META_ADD => 'HASH', + META_MERGE => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + BUILD_REQUIRES => 'HASH', + CONFIGURE_REQUIRES => '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', +); + +@Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys; +@Att_Sigs{keys %Special_Sigs} = values %Special_Sigs; + + +sub _verify_att { + my($att) = @_; + + while( my($key, $val) = each %$att ) { + my $sig = $Att_Sigs{$key}; + unless( defined $sig ) { + warn "WARNING: $key is not a known parameter.\n"; + next; + } + + my @sigs = ref $sig ? @$sig : $sig; + my $given = ref $val; + unless( grep { _is_of_type($val, $_) } @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"; + } + } +} + + +# Check if a given thing is a reference or instance of $type +sub _is_of_type { + my($thing, $type) = @_; + + return 1 if ref $thing eq $type; + + local $SIG{__DIE__}; + return 1 if eval{ $thing->isa($type) }; + + return 0; +} + + +sub _format_att { + my $given = shift; + + return $given eq '' ? "string/number" + : uc $given eq $given ? "$given reference" + : "$given object" + ; +} + + +sub prompt ($;$) { ## no critic + my($mess, $def) = @_; + Carp::confess("prompt function called without an argument") + unless defined $mess; + + my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; + + my $dispdef = defined $def ? "[$def] " : " "; + $def = defined $def ? $def : ""; + + local $|=1; + local $\; + print "$mess $dispdef"; + + my $ans; + if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) { + print "$def\n"; + } + else { + $ans = <STDIN>; + if( defined $ans ) { + chomp $ans; + } + else { # user hit ctrl-D + print "\n"; + } + } + + return (!defined $ans || $ans eq '') ? $def : $ans; +} + +sub eval_in_subdirs { + my($self) = @_; + use Cwd qw(cwd abs_path); + my $pwd = cwd() || die "Can't figure out your cwd!"; + + local @INC = map eval {abs_path($_) if -e} || $_, @INC; + push @INC, '.'; # '.' has to always be at the end of @INC + + foreach my $dir (@{$self->{DIR}}){ + my($abs) = $self->catdir($pwd,$dir); + eval { $self->eval_in_x($abs); }; + last if $@; + } + chdir $pwd; + die $@ if $@; +} + +sub eval_in_x { + my($self,$dir) = @_; + chdir $dir or Carp::carp("Couldn't change to directory $dir: $!"); + + { + package main; + do './Makefile.PL'; + }; + if ($@) { +# if ($@ =~ /prerequisites/) { +# die "MakeMaker WARNING: $@"; +# } else { +# warn "WARNING from evaluation of $dir/Makefile.PL: $@"; +# } + die "ERROR from evaluation of $dir/Makefile.PL: $@"; + } +} + + +# package name for the classes into which the first object will be blessed +my $PACKNAME = 'PACK000'; + +sub full_setup { + $Verbose ||= 0; + + my @attrib_help = qw/ + + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME + DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE + FULLPERL FULLPERLRUN FULLPERLRUNINST + FUNCLIST H IMPORTS + + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR + INSTALLDIRS + DESTDIR PREFIX INSTALL_BASE + PERLPREFIX SITEPREFIX VENDORPREFIX + INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB + INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH + INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN + INSTALLMAN1DIR INSTALLMAN3DIR + INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR + INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR + INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT + PERL_LIB PERL_ARCHLIB + SITELIBEXP SITEARCHEXP + + INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS LICENSE + LINKTYPE MAKE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET + META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES + MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NORECURS NO_VC OBJECT OPTIMIZE + PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE + PERL_SRC PERM_DIR PERM_RW PERM_RWX + 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 + tool_autosplit + + MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC + MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED + /; + + # IMPORTS is used under OS/2 and Win32 + + # @Overridable is close to @MM_Sections but not identical. The + # order is important. Many subroutines declare macros. These + # depend on each other. Let's try to collect the macros up front, + # then pasthru, then the rules. + + # MM_Sections are the sections we have to call explicitly + # in Overridable we have subroutines that are used indirectly + + + @MM_Sections = + qw( + + post_initialize const_config constants platform_constants + tool_autosplit tool_xsubpp tools_other + + makemakerdflt + + dist macro depend cflags const_loadlibs const_cccmd + post_constants + + pasthru + + special_targets + c_o xs_c xs_o + top_targets blibdirs linkext dlsyms dynamic dynamic_bs + dynamic_lib static static_lib manifypods processPL + installbin subdirs + clean_subdirs clean realclean_subdirs realclean + metafile signature + dist_basics dist_core distdir dist_test dist_ci distmeta distsignature + install force perldepend makefile staticmake test ppd + + ); # loses section ordering + + @Overridable = @MM_Sections; + push @Overridable, qw[ + + libscan makeaperl needs_linking + 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[ + + pm_to_blib selfdocument + + ]; + + # Postamble needs to be the last that was always the case + push @MM_Sections, "postamble"; + push @Overridable, "postamble"; + + # All sections are valid keys. + @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections; + + # we will use all these variables in the Makefile + @Get_from_Config = + qw( + 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 + push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006; + + foreach my $item (@attrib_help){ + $Recognized_Att_Keys{$item} = 1; + } + foreach my $item (@Get_from_Config) { + $Recognized_Att_Keys{uc $item} = $Config{$item}; + print "Attribute '\U$item\E' => '$Config{$item}'\n" + if ($Verbose >= 2); + } + + # + # When we eval a Makefile.PL in a subdirectory, that one will ask + # us (the parent) for the values and will prepend "..", so that + # all files to be installed end up below OUR ./blib + # + @Prepend_parent = qw( + INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT + MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC + PERL FULLPERL + ); +} + +sub writeMakefile { + die <<END; + +The extension you are trying to build apparently is rather old and +most probably outdated. We detect that from the fact, that a +subroutine "writeMakefile" is called, and this subroutine is not +supported anymore since about October 1994. + +Please contact the author or look into CPAN (details about CPAN can be +found in the FAQ and at http:/www.perl.com) for a more recent version +of the extension. If you're really desperate, you can try to change +the subroutine name from writeMakefile to WriteMakefile and rerun +'perl Makefile.PL', but you're most probably left alone, when you do +so. + +The MakeMaker team + +END +} + +sub new { + my($class,$self) = @_; + my($key); + + # Store the original args passed to WriteMakefile() + foreach my $k (keys %$self) { + $self->{ARGS}{$k} = $self->{$k}; + } + + $self = {} unless defined $self; + + $self->{PREREQ_PM} ||= {}; + $self->{BUILD_REQUIRES} ||= {}; + + # Temporarily bless it into MM so it can be used as an + # object. It will be blessed into a temp package later. + bless $self, "MM"; + + if ("@ARGV" =~ /\bPREREQ_PRINT\b/) { + $self->_PREREQ_PRINT; + } + + # PRINT_PREREQ is RedHatism. + if ("@ARGV" =~ /\bPRINT_PREREQ\b/) { + $self->_PRINT_PREREQ; + } + + print STDOUT "MakeMaker (v$VERSION)\n" if $Verbose; + if (-f "MANIFEST" && ! -f "Makefile"){ + check_manifest(); + } + + check_hints($self); + + # Translate X.Y.Z to X.00Y00Z + if( defined $self->{MIN_PERL_VERSION} ) { + $self->{MIN_PERL_VERSION} =~ s{ ^ (\d+) \. (\d+) \. (\d+) $ } + {sprintf "%d.%03d%03d", $1, $2, $3}ex; + } + + my $perl_version_ok = eval { + local $SIG{__WARN__} = sub { + # simulate "use warnings FATAL => 'all'" for vintage perls + die @_; + }; + !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $] + }; + if (!$perl_version_ok) { + if (!defined $perl_version_ok) { + warn <<'END'; +Warning: MIN_PERL_VERSION is not in a recognized format. +Recommended is a quoted numerical value like '5.005' or '5.008001'. +END + } + elsif ($self->{PREREQ_FATAL}) { + die sprintf <<"END", $self->{MIN_PERL_VERSION}, $]; +MakeMaker FATAL: perl version too low for this distribution. +Required is %s. We run %s. +END + } + else { + warn sprintf + "Warning: Perl version %s or higher required. We run %s.\n", + $self->{MIN_PERL_VERSION}, $]; + } + } + + my %configure_att; # record &{$self->{CONFIGURE}} attributes + my(%initial_att) = %$self; # record initial attributes + + my(%unsatisfied) = (); + my $prereqs = $self->_all_prereqs; + foreach my $prereq (sort keys %$prereqs) { + my $required_version = $prereqs->{$prereq}; + + my $installed_file = MM->_installed_file_for_module($prereq); + my $pr_version = 0; + $pr_version = MM->parse_version($installed_file) if $installed_file; + $pr_version = 0 if $pr_version eq 'undef'; + + # convert X.Y_Z alpha version #s to X.YZ for easier comparisons + $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/; + + if (!$installed_file) { + warn sprintf "Warning: prerequisite %s %s not found.\n", + $prereq, $required_version + unless $self->{PREREQ_FATAL}; + + $unsatisfied{$prereq} = 'not installed'; + } + elsif ($pr_version < $required_version ){ + warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n", + $prereq, $required_version, ($pr_version || 'unknown version') + unless $self->{PREREQ_FATAL}; + + $unsatisfied{$prereq} = $required_version ? $required_version : 'unknown version' ; + } + } + + 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}}}; + $self = { %$self, %configure_att }; + } else { + Carp::croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n"; + } + } + + # This is for old Makefiles written pre 5.00, will go away + if ( Carp::longmess("") =~ /runsubdirpl/s ){ + Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n"); + } + + my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits + { + print "Blessing Object into class [$newclass]\n" if $Verbose>=2; + mv_all_methods("MY",$newclass); + bless $self, $newclass; + push @Parent, $self; + require ExtUtils::MY; + + no strict 'refs'; ## no critic; + @{"$newclass\:\:ISA"} = 'MM'; + } + + if (defined $Parent[-2]){ + $self->{PARENT} = $Parent[-2]; + for my $key (@Prepend_parent) { + next unless defined $self->{PARENT}{$key}; + + # Don't stomp on WriteMakefile() args. + next if defined $self->{ARGS}{$key} and + $self->{ARGS}{$key} eq $self->{$key}; + + $self->{$key} = $self->{PARENT}{$key}; + + unless ($Is_VMS && $key =~ /PERL$/) { + $self->{$key} = $self->catdir("..",$self->{$key}) + unless $self->file_name_is_absolute($self->{$key}); + } else { + # PERL or FULLPERL will be a command verb or even a + # command with an argument instead of a full file + # specification under VMS. So, don't turn the command + # into a filespec, but do add a level to the path of + # the argument if not already absolute. + my @cmd = split /\s+/, $self->{$key}; + $cmd[1] = $self->catfile('[-]',$cmd[1]) + unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]); + $self->{$key} = join(' ', @cmd); + } + } + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE)) { + if (exists $self->{PARENT}->{$opt} + and not exists $self->{$opt}) + { + # inherit, but only if already unspecified + $self->{$opt} = $self->{PARENT}->{$opt}; + } + } + } + my @fm = grep /^FIRST_MAKEFILE=/, @ARGV; + parse_args($self,@fm) if @fm; + } else { + 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; + $self->init_INST; + $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; + + $self->arch_check( + $INC{'Config.pm'}, + $self->catfile($Config{'archlibexp'}, "Config.pm") + ); + + $self->init_others(); + $self->init_platform(); + $self->init_PERM(); + my($argv) = neatvalue(\@ARGV); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; + + push @{$self->{RESULT}}, <<END; +# This Makefile is for the $self->{NAME} extension to perl. +# +# It was generated automatically by MakeMaker version +# $VERSION (Revision: $Revision) from the contents of +# Makefile.PL. Don't edit this file, edit Makefile.PL instead. +# +# ANY CHANGES MADE HERE WILL BE LOST! +# +# MakeMaker ARGV: $argv +# +END + + push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att); + + if (defined $self->{CONFIGURE}) { + push @{$self->{RESULT}}, <<END; + +# MakeMaker 'CONFIGURE' Parameters: +END + if (scalar(keys %configure_att) > 0) { + foreach my $key (sort keys %configure_att){ + next if $key eq 'ARGS'; + my($v) = neatvalue($configure_att{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @{$self->{RESULT}}, "# $key => $v"; + } + } + else + { + push @{$self->{RESULT}}, "# no values returned"; + } + undef %configure_att; # free memory + } + + # turn the SKIP array into a SKIPHASH hash + for my $skip (@{$self->{SKIP} || []}) { + $self->{SKIPHASH}{$skip} = 1; + } + delete $self->{SKIP}; # free memory + + if ($self->{PARENT}) { + for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) { + $self->{SKIPHASH}{$_} = 1; + } + } + + # We run all the subdirectories now. They don't have much to query + # from the parent, but the parent has to query them: if they need linking! + unless ($self->{NORECURS}) { + $self->eval_in_subdirs if @{$self->{DIR}}; + } + + foreach my $section ( @MM_Sections ){ + # Support for new foo_target() methods. + my $method = $section; + $method .= '_target' unless $self->can($method); + + print "Processing Makefile '$section' section\n" if ($Verbose >= 2); + my($skipit) = $self->skipcheck($section); + if ($skipit){ + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit."; + } else { + my(%a) = %{$self->{$section} || {}}; + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; + push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; + push @{$self->{RESULT}}, $self->maketext_filter( + $self->$method( %a ) + ); + } + } + + push @{$self->{RESULT}}, "\n# End."; + + $self; +} + +sub WriteEmptyMakefile { + Carp::croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; + + my %att = @_; + my $self = MM->new(\%att); + + my $new = $self->{MAKEFILE}; + my $old = $self->{MAKEFILE_OLD}; + if (-f $old) { + _unlink($old) or warn "unlink $old: $!"; + } + if ( -f $new ) { + _rename($new, $old) or warn "rename $new => $old: $!" + } + open my $mfh, '>', $new or die "open $new for write: $!"; + print $mfh <<'EOP'; +all : + +clean : + +install : + +makemakerdflt : + +test : + +EOP + close $mfh or die "close $new for write: $!"; +} + + +=begin private + +=head3 _installed_file_for_module + + my $file = MM->_installed_file_for_module($module); + +Return the first installed .pm $file associated with the $module. The +one which will show up when you C<use $module>. + +$module is something like "strict" or "Test::More". + +=end private + +=cut + +sub _installed_file_for_module { + my $class = shift; + my $prereq = shift; + + my $file = "$prereq.pm"; + $file =~ s{::}{/}g; + + my $path; + for my $dir (@INC) { + my $tmp = File::Spec->catfile($dir, $file); + if ( -r $tmp ) { + $path = $tmp; + last; + } + } + + return $path; +} + + +# Extracted from MakeMaker->new so we can test it +sub _MakeMaker_Parameters_section { + my $self = shift; + my $att = shift; + + my @result = <<'END'; +# MakeMaker Parameters: +END + + foreach my $key (sort keys %$att){ + next if $key eq 'ARGS'; + my ($v) = neatvalue($att->{$key}); + if ($key eq 'PREREQ_PM') { + # CPAN.pm takes prereqs from this field in 'Makefile' + # and does not know about BUILD_REQUIRES + $v = neatvalue({ %{ $att->{PREREQ_PM} || {} }, %{ $att->{BUILD_REQUIRES} || {} } }); + } else { + $v = neatvalue($att->{$key}); + } + + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @result, "# $key => $v"; + } + + return @result; +} + + +sub check_manifest { + print STDOUT "Checking if your kit is complete...\n"; + require ExtUtils::Manifest; + # avoid warning + $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1; + my(@missed) = ExtUtils::Manifest::manicheck(); + if (@missed) { + print STDOUT "Warning: the following files are missing in your kit:\n"; + print "\t", join "\n\t", @missed; + print STDOUT "\n"; + print STDOUT "Please inform the author.\n"; + } else { + print STDOUT "Looks good\n"; + } +} + +sub parse_args{ + my($self, @args) = @_; + foreach (@args) { + unless (m/(.*?)=(.*)/) { + ++$Verbose if m/^verb/; + next; + } + my($name, $value) = ($1, $2); + if ($value =~ m/^~(\w+)?/) { # tilde with optional username + $value =~ s [^~(\w*)] + [$1 ? + ((getpwnam($1))[7] || "~$1") : + (getpwuid($>))[7] + ]ex; + } + + # Remember the original args passed it. It will be useful later. + $self->{ARGS}{uc $name} = $self->{uc $name} = $value; + } + + # catch old-style 'potential_libs' and inform user how to 'upgrade' + if (defined $self->{potential_libs}){ + my($msg)="'potential_libs' => '$self->{potential_libs}' should be"; + if ($self->{potential_libs}){ + print STDOUT "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; + } else { + print STDOUT "$msg deleted.\n"; + } + $self->{LIBS} = [$self->{potential_libs}]; + delete $self->{potential_libs}; + } + # catch old-style 'ARMAYBE' and inform user how to 'upgrade' + if (defined $self->{ARMAYBE}){ + my($armaybe) = $self->{ARMAYBE}; + print STDOUT "ARMAYBE => '$armaybe' should be changed to:\n", + "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n"; + my(%dl) = %{$self->{dynamic_lib} || {}}; + $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe}; + delete $self->{ARMAYBE}; + } + if (defined $self->{LDTARGET}){ + print STDOUT "LDTARGET should be changed to LDFROM\n"; + $self->{LDFROM} = $self->{LDTARGET}; + delete $self->{LDTARGET}; + } + # Turn a DIR argument on the command line into an array + if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { + # So they can choose from the command line, which extensions they want + # the grep enables them to have some colons too much in case they + # have to build a list with the shell + $self->{DIR} = [grep $_, split ":", $self->{DIR}]; + } + # Turn a INCLUDE_EXT argument on the command line into an array + if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') { + $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}]; + } + # Turn a EXCLUDE_EXT argument on the command line into an array + if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') { + $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}]; + } + + foreach my $mmkey (sort keys %$self){ + next if $mmkey eq 'ARGS'; + print STDOUT " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; + print STDOUT "'$mmkey' is not a known MakeMaker parameter name.\n" + unless exists $Recognized_Att_Keys{$mmkey}; + } + $| = 1 if $Verbose; +} + +sub check_hints { + my($self) = @_; + # We allow extension-specific hints files. + + require File::Spec; + my $curdir = File::Spec->curdir; + + my $hint_dir = File::Spec->catdir($curdir, "hints"); + return unless -d $hint_dir; + + # First we look for the best hintsfile we have + my($hint)="${^O}_$Config{osvers}"; + $hint =~ s/\./_/g; + $hint =~ s/_$//; + return unless $hint; + + # Also try without trailing minor version numbers. + while (1) { + last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found + } continue { + last unless $hint =~ s/_[^_]*$//; # nothing to cut off + } + my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl"); + + return unless -f $hint_file; # really there + + _run_hintfile($self, $hint_file); +} + +sub _run_hintfile { + our $self; + local($self) = shift; # make $self available to the hint file. + my($hint_file) = shift; + + local($@, $!); + print STDERR "Processing hints file $hint_file\n"; + + # Just in case the ./ isn't on the hint file, which File::Spec can + # often strip off, we bung the curdir into @INC + local @INC = (File::Spec->curdir, @INC); + my $ret = do $hint_file; + if( !defined $ret ) { + my $error = $@ || $!; + print STDERR $error; + } +} + +sub mv_all_methods { + my($from,$to) = @_; + + # Here you see the *current* list of methods that are overridable + # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm + # still trying to reduce the list to some reasonable minimum -- + # because I want to make it easier for the user. A.K. + + local $SIG{__WARN__} = sub { + # can't use 'no warnings redefined', 5.6 only + warn @_ unless $_[0] =~ /^Subroutine .* redefined/ + }; + foreach my $method (@Overridable) { + + # We cannot say "next" here. Nick might call MY->makeaperl + # which isn't defined right now + + # Above statement was written at 4.23 time when Tk-b8 was + # around. As Tk-b9 only builds with 5.002something and MM 5 is + # standard, we try to enable the next line again. It was + # commented out until MM 5.23 + + next unless defined &{"${from}::$method"}; + + { + no strict 'refs'; ## no critic + *{"${to}::$method"} = \&{"${from}::$method"}; + + # If we delete a method, then it will be undefined and cannot + # be called. But as long as we have Makefile.PLs that rely on + # %MY:: being intact, we have to fill the hole with an + # inheriting method: + + { + package MY; + my $super = "SUPER::".$method; + *{$method} = sub { + shift->$super(@_); + }; + } + } + } + + # We have to clean out %INC also, because the current directory is + # changed frequently and Graham Barr prefers to get his version + # out of a History.pl file which is "required" so woudn't get + # loaded again in another extension requiring a History.pl + + # With perl5.002_01 the deletion of entries in %INC caused Tk-b11 + # to core dump in the middle of a require statement. The required + # file was Tk/MMutil.pm. The consequence is, we have to be + # extremely careful when we try to give perl a reason to reload a + # library with same name. The workaround prefers to drop nothing + # from %INC and teach the writers not to use such libraries. + +# my $inc; +# foreach $inc (keys %INC) { +# #warn "***$inc*** deleted"; +# delete $INC{$inc}; +# } +} + +sub skipcheck { + my($self) = shift; + my($section) = @_; + if ($section eq 'dynamic') { + print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_lib'\n" + if $self->{SKIPHASH}{dynamic_lib} && $Verbose; + } + if ($section eq 'dynamic_lib') { + print STDOUT "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ", + "targets in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + } + if ($section eq 'static') { + print STDOUT "Warning (non-fatal): Target 'static' depends on targets ", + "in skipped section 'static_lib'\n" + if $self->{SKIPHASH}{static_lib} && $Verbose; + } + return 'skipped' if $self->{SKIPHASH}{$section}; + return ''; +} + +sub flush { + my $self = shift; + + my $finalname = $self->{MAKEFILE}; + print STDOUT "Writing $finalname for $self->{NAME}\n"; + + unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); + open(my $fh,">", "MakeMaker.tmp") + or die "Unable to open MakeMaker.tmp: $!"; + + for my $chunk (@{$self->{RESULT}}) { + print $fh "$chunk\n"; + } + + close $fh; + _rename("MakeMaker.tmp", $finalname) or + warn "rename MakeMaker.tmp => $finalname: $!"; + chmod 0644, $finalname unless $Is_VMS; + + my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE); + + if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) { + foreach (keys %$self) { # safe memory + delete $self->{$_} unless $keep{$_}; + } + } + + system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":"; +} + + +# This is a rename for OS's where the target must be unlinked first. +sub _rename { + my($src, $dest) = @_; + chmod 0666, $dest; + unlink $dest; + return rename $src, $dest; +} + +# This is an unlink for OS's where the target must be writable first. +sub _unlink { + my @files = @_; + chmod 0666, @files; + return unlink @files; +} + + +# The following mkbootstrap() is only for installations that are calling +# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker +# writes Makefiles, that use ExtUtils::Mkbootstrap directly. +sub mkbootstrap { + die <<END; +!!! Your Makefile has been built such a long time ago, !!! +!!! that is unlikely to work with current MakeMaker. !!! +!!! Please rebuild your Makefile !!! +END +} + +# Ditto for mksymlists() as of MakeMaker 5.17 +sub mksymlists { + die <<END; +!!! Your Makefile has been built such a long time ago, !!! +!!! that is unlikely to work with current MakeMaker. !!! +!!! Please rebuild your Makefile !!! +END +} + +sub neatvalue { + my($v) = @_; + return "undef" unless defined $v; + my($t) = ref $v; + return "q[$v]" unless $t; + if ($t eq 'ARRAY') { + my(@m, @neat); + push @m, "["; + foreach my $elem (@$v) { + push @neat, "q[$elem]"; + } + push @m, join ", ", @neat; + push @m, "]"; + return join "", @m; + } + return "$v" unless $t eq 'HASH'; + my(@m, $key, $val); + while (($key,$val) = each %$v){ + last unless defined $key; # cautious programming in case (undef,undef) is true + push(@m,"$key=>".neatvalue($val)) ; + } + return "{ ".join(', ',@m)." }"; +} + +sub selfdocument { + my($self) = @_; + my(@m); + if ($Verbose){ + push @m, "\n# Full list of MakeMaker attribute values:"; + foreach my $key (sort keys %$self){ + next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/; + my($v) = neatvalue($self->{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @m, "# $key => $v"; + } + } + join "\n", @m; +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::MakeMaker - Create a module Makefile + +=head1 SYNOPSIS + + use ExtUtils::MakeMaker; + + WriteMakefile( ATTRIBUTE => VALUE [, ...] ); + +=head1 DESCRIPTION + +This utility is designed to write a Makefile for an extension module +from a Makefile.PL. It is based on the Makefile.SH model provided by +Andy Dougherty and the perl5-porters. + +It splits the task of generating the Makefile into several subroutines +that can be individually overridden. Each subroutine returns the text +it wishes to have written to the Makefile. + +MakeMaker is object oriented. Each directory below the current +directory that contains a Makefile.PL is treated as a separate +object. This makes it possible to write an unlimited number of +Makefiles with a single invocation of WriteMakefile(). + +=head2 How To Write A Makefile.PL + +See ExtUtils::MakeMaker::Tutorial. + +The long answer is the rest of the manpage :-) + +=head2 Default Makefile Behaviour + +The generated Makefile enables the user of the extension to invoke + + perl Makefile.PL # optionally "perl Makefile.PL verbose" + make + make test # optionally set TEST_VERBOSE=1 + make install # See below + +The Makefile to be produced may be altered by adding arguments of the +form C<KEY=VALUE>. E.g. + + perl Makefile.PL INSTALL_BASE=~ + +Other interesting targets in the generated Makefile are + + make config # to check if the Makefile is up-to-date + make clean # delete local temp files (Makefile gets renamed) + make realclean # delete derived files (including ./blib) + make ci # check in all the files in the MANIFEST file + make dist # see below the Distribution Support section + +=head2 make test + +MakeMaker checks for the existence of a file named F<test.pl> in the +current directory and if it exists it execute the script with the +proper set of perl C<-I> options. + +MakeMaker also checks for any files matching glob("t/*.t"). It will +execute all matching files in alphabetical order via the +L<Test::Harness> module with the C<-I> switches set correctly. + +If you'd like to see the raw output of your tests, set the +C<TEST_VERBOSE> variable to true. + + make test TEST_VERBOSE=1 + +=head2 make testdb + +A useful variation of the above is the target C<testdb>. It runs the +test under the Perl debugger (see L<perldebug>). If the file +F<test.pl> exists in the current directory, it is used for the test. + +If you want to debug some other testfile, set the C<TEST_FILE> variable +thusly: + + make testdb TEST_FILE=t/mytest.t + +By default the debugger is called using C<-d> option to perl. If you +want to specify some other option, set the C<TESTDB_SW> variable: + + make testdb TESTDB_SW=-Dx + +=head2 make install + +make alone puts all relevant files into directories that are named by +the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and +INST_MAN3DIR. All these default to something below ./blib if you are +I<not> building below the perl source directory. If you I<are> +building below the perl source, INST_LIB and INST_ARCHLIB default to +../../lib, and INST_SCRIPT is not defined. + +The I<install> target of the generated Makefile copies the files found +below each of the INST_* directories to their INSTALL* +counterparts. Which counterparts are chosen depends on the setting of +INSTALLDIRS according to the following table: + + INSTALLDIRS set to + perl site vendor + + PERLPREFIX SITEPREFIX VENDORPREFIX + INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH + INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB + INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN + INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT + INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR + INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR + +The INSTALL... macros in turn default to their %Config +($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts. + +You can check the values of these variables on your system with + + perl '-V:install.*' + +And to check the sequence in which the library directories are +searched by perl, run + + perl -le 'print join $/, @INC' + +Sometimes older versions of the module you're installing live in other +directories in @INC. Because Perl loads the first version of a module it +finds, not the newest, you might accidentally get one of these older +versions even after installing a brand new version. To delete I<all other +versions of the module you're installing> (not simply older ones) set the +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. Here's an example for installing into your home directory. + + # 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). 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. + + perl Makefile.PL LIB=~/lib + +This will install the module's architecture-independent files into +~/lib, the architecture-dependent files into ~/lib/$archname. + +Note, that in both cases the tilde expansion is done by MakeMaker, not +by perl by default, nor by make. + +Conflicts between parameters LIB, PREFIX and the various INSTALL* +arguments are resolved so that: + +=over 4 + +=item * + +setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB, +INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX); + +=item * + +without LIB, setting PREFIX replaces the initial C<$Config{prefix}> +part of those INSTALL* arguments, even if the latter are explicitly +set (but are set to still start with C<$Config{prefix}>). + +=back + +If the user has superuser privileges, and is not working on AFS or +relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, +INSTALLSCRIPT, etc. will be appropriate, and this incantation will be +the best: + + perl Makefile.PL; + make; + make test + make install + +make install per default writes some documentation of what has been +done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature +can be bypassed by calling make pure_install. + +=head2 AFS users + +will have to specify the installation directories as these most +probably have changed since perl itself has been installed. They will +have to do this by calling + + perl Makefile.PL INSTALLSITELIB=/afs/here/today \ + INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages + make + +Be careful to repeat this procedure every time you recompile an +extension, unless you are sure the AFS installation directories are +still valid. + +=head2 Static Linking of a new Perl Binary + +An extension that is built with the above steps is ready to use on +systems supporting dynamic loading. On systems that do not support +dynamic loading, any newly created extension has to be linked together +with the available resources. MakeMaker supports the linking process +by creating appropriate targets in the Makefile whenever an extension +is built. You can invoke the corresponding section of the makefile with + + make perl + +That produces a new perl binary in the current directory with all +extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP, +and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on +UNIX, this is called Makefile.aperl (may be system dependent). If you +want to force the creation of a new perl, it is recommended, that you +delete this Makefile.aperl, so the directories are searched-through +for linkable libraries again. + +The binary can be installed into the directory where perl normally +resides on your machine with + + make inst_perl + +To produce a perl binary with a different name than C<perl>, either say + + perl Makefile.PL MAP_TARGET=myperl + make myperl + make inst_perl + +or say + + perl Makefile.PL + make myperl MAP_TARGET=myperl + make inst_perl MAP_TARGET=myperl + +In any case you will be prompted with the correct invocation of the +C<inst_perl> target that installs the new binary into INSTALLBIN. + +make inst_perl per default writes some documentation of what has been +done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This +can be bypassed by calling make pure_inst_perl. + +Warning: the inst_perl: target will most probably overwrite your +existing perl binary. Use with care! + +Sometimes you might want to build a statically linked perl although +your system supports dynamic loading. In this case you may explicitly +set the linktype with the invocation of the Makefile.PL or make: + + perl Makefile.PL LINKTYPE=static # recommended + +or + + make LINKTYPE=static # works on most systems + +=head2 Determination of Perl Library and Installation Locations + +MakeMaker needs to know, or to guess, where certain things are +located. Especially INST_LIB and INST_ARCHLIB (where to put the files +during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read +existing modules from), and PERL_INC (header files and C<libperl*.*>). + +Extensions may be built either using the contents of the perl source +directory tree or from the installed perl library. The recommended way +is to build extensions after you have run 'make install' on perl +itself. You can do that in any directory on your hard disk that is not +below the perl source tree. The support for extensions below the ext +directory of the perl distribution is only good for the standard +extensions that come with perl. + +If an extension is being built below the C<ext/> directory of the perl +source then MakeMaker will set PERL_SRC automatically (e.g., +C<../..>). If PERL_SRC is defined and the extension is recognized as +a standard extension, then other variables default to the following: + + PERL_INC = PERL_SRC + PERL_LIB = PERL_SRC/lib + PERL_ARCHLIB = PERL_SRC/lib + INST_LIB = PERL_LIB + INST_ARCHLIB = PERL_ARCHLIB + +If an extension is being built away from the perl source then MakeMaker +will leave PERL_SRC undefined and default to using the installed copy +of the perl library. The other variables default to the following: + + PERL_INC = $archlibexp/CORE + PERL_LIB = $privlibexp + PERL_ARCHLIB = $archlibexp + INST_LIB = ./blib/lib + INST_ARCHLIB = ./blib/arch + +If perl has not yet been installed then PERL_SRC can be defined on the +command line as shown in the previous section. + + +=head2 Which architecture dependent directory? + +If you don't want to keep the defaults for the INSTALL* macros, +MakeMaker helps you to minimize the typing needed: the usual +relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined +by Configure at perl compilation time. MakeMaker supports the user who +sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not, +then MakeMaker defaults the latter to be the same subdirectory of +INSTALLPRIVLIB as Configure decided for the counterparts in %Config , +otherwise it defaults to INSTALLPRIVLIB. The same relationship holds +for INSTALLSITELIB and INSTALLSITEARCH. + +MakeMaker gives you much more freedom than needed to configure +internal variables and get different results. It is worth to mention, +that make(1) also lets you configure most of the variables that are +used in the Makefile. But in the majority of situations this will not +be necessary, and should only be done if the author of a package +recommends it (or you know what you're doing). + +=head2 Using Attributes and Parameters + +The following attributes may be specified as arguments to WriteMakefile() +or as NAME=VALUE pairs on the command line. + +=over 2 + +=item ABSTRACT + +One line description of the module. Will be included in PPD file. + +=item ABSTRACT_FROM + +Name of the file that contains the package description. MakeMaker looks +for a line in the POD matching /^($package\s-\s)(.*)/. This is typically +the first line in the "=head1 NAME" section. $2 becomes the abstract. + +=item AUTHOR + +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + +=item BINARY_LOCATION + +Used when creating PPD files for binary packages. It can be set to a +full or relative path or URL to the binary archive for a particular +architecture. For example: + + perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz + +builds a PPD package that references a binary of the C<Agent> package, +located in the C<x86> directory relative to the PPD itself. + +=item BUILD_REQUIRES + +A hash of modules that are needed to build your module but not run it. + +This will go into the C<build_requires> field of your F<META.yml>. + +The format is the same as PREREQ_PM. + +=item C + +Ref to array of *.c file names. Initialised from a directory scan +and the values portion of the XS attribute hash. This is not +currently used by MakeMaker but may be handy in Makefile.PLs. + +=item CCFLAGS + +String that will be included in the compiler call command line between +the arguments INC and OPTIMIZE. + +=item CONFIG + +Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from +config.sh. MakeMaker will add to CONFIG the following values anyway: +ar +cc +cccdlflags +ccdlflags +dlext +dlsrc +ld +lddlflags +ldflags +libc +lib_ext +obj_ext +ranlib +sitelibexp +sitearchexp +so + +=item CONFIGURE + +CODE reference. The subroutine should return a hash reference. The +hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to +be determined by some evaluation method. + +=item CONFIGURE_REQUIRES + +A hash of modules that are required to run Makefile.PL itself, but not +to run your distribution. + +This will go into the C<configure_requires> field of your F<META.yml>. + +Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> + +The format is the same as PREREQ_PM. + +=item DEFINE + +Something like C<"-DHAVE_UNISTD_H"> + +=item DESTDIR + +This is the root directory into which the code will be installed. It +I<prepends itself to the normal prefix>. For example, if your code +would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/ +and installation would go into F<~/tmp/usr/local/lib/perl>. + +This is primarily of use for people who repackage Perl modules. + +NOTE: Due to the nature of make, it is important that you put the trailing +slash on your DESTDIR. F<~/tmp/> not F<~/tmp>. + +=item DIR + +Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm'] +in ext/SDBM_File + +=item DISTNAME + +A safe filename for the package. + +Defaults to NAME above but with :: replaced with -. + +For example, Foo::Bar becomes Foo-Bar. + +=item DISTVNAME + +Your name for distributing the package with the version number +included. This is used by 'make dist' to name the resulting archive +file. + +Defaults to DISTNAME-VERSION. + +For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04. + +On some OS's where . has special meaning VERSION_SYM may be used in +place of VERSION. + +=item DL_FUNCS + +Hashref of symbol names for routines to be made available as universal +symbols. Each key/value pair consists of the package name and an +array of routine names in that package. Used only under AIX, OS/2, +VMS and Win32 at present. The routine names supplied will be expanded +in the same way as XSUB names are expanded by the XS() macro. +Defaults to + + {"$(NAME)" => ["boot_$(NAME)" ] } + +e.g. + + {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], + "NetconfigPtr" => [ 'DESTROY'] } + +Please see the L<ExtUtils::Mksymlists> documentation for more information +about the DL_FUNCS, DL_VARS and FUNCLIST attributes. + +=item DL_VARS + +Array of symbol names for variables to be made available as universal symbols. +Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. +(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) + +=item EXCLUDE_EXT + +Array of extension names to exclude when doing a static build. This +is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more +details. (e.g. [ qw( Socket POSIX ) ] ) + +This attribute may be most useful when specified as a string on the +command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' + +=item EXE_FILES + +Ref to array of executable files. The files will be copied to the +INST_SCRIPT directory. Make realclean will delete them from there +again. + +If your executables start with something like #!perl or +#!/usr/bin/perl MakeMaker will change this to the path of the perl +'Makefile.PL' was invoked with so the programs will be sure to run +properly even if perl is not in /usr/bin/perl. + +=item FIRST_MAKEFILE + +The name of the Makefile to be produced. This is used for the second +Makefile that will be produced for the MAP_TARGET. + +Defaults to 'Makefile' or 'Descrip.MMS' on VMS. + +(Note: we couldn't use MAKEFILE because dmake uses this for something +else). + +=item FULLPERL + +Perl binary able to run this extension, load XS modules, etc... + +=item FULLPERLRUN + +Like PERLRUN, except it uses FULLPERL. + +=item FULLPERLRUNINST + +Like PERLRUNINST, except it uses FULLPERL. + +=item FUNCLIST + +This provides an alternate means to specify function names to be +exported from the extension. Its value is a reference to an +array of function names to be exported by the extension. These +names are passed through unaltered to the linker options file. + +=item H + +Ref to array of *.h file names. Similar to C. + +=item IMPORTS + +This attribute is used to specify names to be imported into the +extension. Takes a hash ref. + +It is only used on OS/2 and Win32. + +=item INC + +Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> + +=item INCLUDE_EXT + +Array of extension names to be included when doing a static build. +MakeMaker will normally build with all of the installed extensions when +doing a static build, and that is usually the desired behavior. If +INCLUDE_EXT is present then MakeMaker will build only with those extensions +which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ]) + +It is not necessary to mention DynaLoader or the current extension when +filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then +only DynaLoader and the current extension will be included in the build. + +This attribute may be most useful when specified as a string on the +command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' + +=item INSTALLARCHLIB + +Used by 'make install', which copies files from INST_ARCHLIB to this +directory if INSTALLDIRS is set to perl. + +=item INSTALLBIN + +Directory to install binary files (e.g. tkperl) into if +INSTALLDIRS=perl. + +=item INSTALLDIRS + +Determines which of the sets of installation directories to choose: +perl, site or vendor. Defaults to site. + +=item INSTALLMAN1DIR + +=item INSTALLMAN3DIR + +These directories get the man pages at 'make install' time if +INSTALLDIRS=perl. Defaults to $Config{installman*dir}. + +If set to 'none', no man pages will be installed. + +=item INSTALLPRIVLIB + +Used by 'make install', which copies files from INST_LIB to this +directory if INSTALLDIRS is set to perl. + +Defaults to $Config{installprivlib}. + +=item INSTALLSCRIPT + +Used by 'make install' which copies files from INST_SCRIPT to this +directory if INSTALLDIRS=perl. + +=item INSTALLSITEARCH + +Used by 'make install', which copies files from INST_ARCHLIB to this +directory if INSTALLDIRS is set to site (default). + +=item INSTALLSITEBIN + +Used by 'make install', which copies files from INST_BIN to this +directory if INSTALLDIRS is set to site (default). + +=item INSTALLSITELIB + +Used by 'make install', which copies files from INST_LIB to this +directory if INSTALLDIRS is set to site (default). + +=item INSTALLSITEMAN1DIR + +=item INSTALLSITEMAN3DIR + +These directories get the man pages at 'make install' time if +INSTALLDIRS=site (default). Defaults to +$(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 +directory if INSTALLDIRS is set to vendor. + +=item INSTALLVENDORBIN + +Used by 'make install', which copies files from INST_BIN to this +directory if INSTALLDIRS is set to vendor. + +=item INSTALLVENDORLIB + +Used by 'make install', which copies files from INST_LIB to this +directory if INSTALLDIRS is set to vendor. + +=item INSTALLVENDORMAN1DIR + +=item INSTALLVENDORMAN3DIR + +These directories get the man pages at 'make install' time if +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 vendor. + +=item INST_ARCHLIB + +Same as INST_LIB for architecture dependent files. + +=item INST_BIN + +Directory to put real binary files during 'make'. These will be copied +to INSTALLBIN during 'make install' + +=item INST_LIB + +Directory where we put library files of this extension while building +it. + +=item INST_MAN1DIR + +Directory to hold the man pages at 'make' time + +=item INST_MAN3DIR + +Directory to hold the man pages at 'make' time + +=item INST_SCRIPT + +Directory, where executable files should be installed during +'make'. Defaults to "./blib/script", just to have a dummy location during +testing. make install will copy the files in INST_SCRIPT to +INSTALLSCRIPT. + +=item LD + +Program to be used to link libraries for dynamic loading. + +Defaults to $Config{ld}. + +=item LDDLFLAGS + +Any special flags that might need to be passed to ld to create a +shared library suitable for dynamic loading. It is up to the makefile +to use it. (See L<Config/lddlflags>) + +Defaults to $Config{lddlflags}. + +=item LDFROM + +Defaults to "$(OBJECT)" and is used in the ld command to specify +what files to link/load from (also see dynamic_lib below for how to +specify ld flags) + +=item LIB + +LIB should only be set at C<perl Makefile.PL> time but is allowed as a +MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB +and INSTALLSITELIB to that value regardless any explicit setting of +those arguments (or of PREFIX). INSTALLARCHLIB and INSTALLSITEARCH +are set to the corresponding architecture subdirectory. + +=item LIBPERL_A + +The filename of the perllibrary that will be used together with this +extension. Defaults to libperl.a. + +=item LIBS + +An anonymous array of alternative library +specifications to be searched for (in order) until +at least one library is found. E.g. + + 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"] + +Mind, that any element of the array +contains a complete set of arguments for the ld +command. So do not specify + + 'LIBS' => ["-ltcl", "-ltk", "-lX11"] + +See ODBM_File/Makefile.PL for an example, where an array is needed. If +you specify a scalar as in + + 'LIBS' => "-ltcl -ltk -lX11" + +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::API> 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 +make a perl. This is handled automatically as a switch by +MakeMaker. The user normally does not need it. + +=item MAKEFILE_OLD + +When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be +backed up at this location. + +Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS. + +=item MAN1PODS + +Hashref of pod-containing files. MakeMaker will default this to all +EXE_FILES files that include POD directives. The files listed +here will be converted to man pages and installed as was requested +at Configure time. + +This hash should map POD files (or scripts containing POD) to the +man file names under the C<blib/man1/> directory, as in the following +example: + + MAN1PODS => { + 'doc/command.pod' => 'blib/man1/command.1', + 'scripts/script.pl' => 'blib/man1/script.1', + } + +=item MAN3PODS + +Hashref that assigns to *.pm and *.pod files the files into which the +manpages are to be written. MakeMaker parses all *.pod and *.pm files +for POD directives. Files that contain POD will be the default keys of +the MAN3PODS hashref. These will then be converted to man pages during +C<make> and will be installed during C<make install>. + +Example similar to MAN1PODS. + +=item MAP_TARGET + +If it is intended, that a new perl binary be produced, this variable +may hold a name for that binary. Defaults to perl + +=item META_ADD + +=item META_MERGE + +A hashrefs of items to add to the F<META.yml>. + +They differ in how they behave if they have the same key as the +default metadata. META_ADD will override the default value with it's +own. META_MERGE will merge its value with the default. + +Unless you want to override the defaults, prefer META_MERGE so as to +get the advantage of any future defaults. + +=item MIN_PERL_VERSION + +The minimum required version of Perl for this distribution. + +Either 5.006001 or 5.6.1 format is acceptable. + +=item MYEXTLIB + +If the extension links to a library that it builds set this to the +name of the library (see SDBM_File) + +=item NAME + +Perl module name for this extension (DBD::Oracle). This will default +to the directory name but should be explicitly defined in the +Makefile.PL. + +=item NEEDS_LINKING + +MakeMaker will figure out if an extension contains linkable code +anywhere down the directory tree, and will set this variable +accordingly, but you can speed it up a very little bit if you define +this boolean variable yourself. + +=item NOECHO + +Command so make does not print the literal commands its running. + +By setting it to an empty string you can generate a Makefile that +prints all commands. Mainly used in debugging MakeMaker itself. + +Defaults to C<@>. + +=item NORECURS + +Boolean. Attribute to inhibit descending into subdirectories. + +=item NO_META + +When true, suppresses the generation and addition to the MANIFEST of +the META.yml module meta-data file during 'make distdir'. + +Defaults to false. + +=item NO_VC + +In general, any generated Makefile checks for the current version of +MakeMaker and the version the Makefile was built under. If NO_VC is +set, the version check is neglected. Do not write this into your +Makefile.PL, use it interactively instead. + +=item OBJECT + +List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long +string containing all object files, e.g. "tkpBind.o +tkpButton.o tkpCanvas.o" + +(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) + +=item OPTIMIZE + +Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is +passed to subdirectory makes. + +=item PERL + +Perl binary for tasks that can be done by miniperl + +=item PERL_CORE + +Set only when MakeMaker is building the extensions of the Perl core +distribution. + +=item PERLMAINCC + +The call to the program that is able to compile perlmain.c. Defaults +to $(CC). + +=item PERL_ARCHLIB + +Same as for PERL_LIB, but for architecture dependent files. + +Used only when MakeMaker is building the extensions of the Perl core +distribution (because normally $(PERL_ARCHLIB) is automatically in @INC, +and adding it would get in the way of PERL5LIB). + +=item PERL_LIB + +Directory containing the Perl library to use. + +Used only when MakeMaker is building the extensions of the Perl core +distribution (because normally $(PERL_LIB) is automatically in @INC, +and adding it would get in the way of PERL5LIB). + +=item PERL_MALLOC_OK + +defaults to 0. Should be set to TRUE if the extension can work with +the memory allocation routines substituted by the Perl malloc() subsystem. +This should be applicable to most extensions with exceptions of those + +=over 4 + +=item * + +with bugs in memory allocations which are caught by Perl's malloc(); + +=item * + +which interact with the memory allocator in other ways than via +malloc(), realloc(), free(), calloc(), sbrk() and brk(); + +=item * + +which rely on special alignment which is not provided by Perl's malloc(). + +=back + +B<NOTE.> Negligence to set this flag in I<any one> of loaded extension +nullifies many advantages of Perl's malloc(), such as better usage of +system resources, error detection, memory usage reporting, catchable failure +of memory allocations, etc. + +=item PERLPREFIX + +Directory under which core modules are to be installed. + +Defaults to $Config{installprefixexp} falling back to +$Config{installprefix}, $Config{prefixexp} or $Config{prefix} should +$Config{installprefixexp} not exist. + +Overridden by PREFIX. + +=item PERLRUN + +Use this instead of $(PERL) when you wish to run perl. It will set up +extra necessary flags for you. + +=item PERLRUNINST + +Use this instead of $(PERL) when you wish to run perl to work with +modules. It will add things like -I$(INST_ARCH) and other necessary +flags so perl can see the modules you're about to install. + +=item PERL_SRC + +Directory containing the Perl source code (use of this should be +avoided, it may be undefined) + +=item PERM_DIR + +Desired permission for directories. Defaults to C<755>. + +=item PERM_RW + +Desired permission for read/writable files. Defaults to C<644>. + +=item PERM_RWX + +Desired permission for executable files. Defaults to C<755>. + +=item PL_FILES + +MakeMaker can run programs to generate files for you at build time. +By default any file named *.PL (except Makefile.PL and Build.PL) in +the top level directory will be assumed to be a Perl program and run +passing its own basename in as an argument. For example... + + perl foo.PL foo + +This behavior can be overridden by supplying your own set of files to +search. PL_FILES accepts a hash ref, the key being the file to run +and the value is passed in as the first argument when the PL file is run. + + PL_FILES => {'bin/foobar.PL' => 'bin/foobar'} + +Would run bin/foobar.PL like this: + + perl bin/foobar.PL bin/foobar + +If multiple files from one program are desired an array ref can be used. + + PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]} + +In this case the program will be run multiple times using each target file. + + perl bin/foobar.PL bin/foobar1 + perl bin/foobar.PL bin/foobar2 + +PL files are normally run B<after> pm_to_blib and include INST_LIB and +INST_ARCH in its C<@INC> so the just built modules can be +accessed... unless the PL file is making a module (or anything else in +PM) in which case it is run B<before> pm_to_blib and does not include +INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior +is there for backwards compatibility (and its somewhat DWIM). + + +=item PM + +Hashref of .pm files and *.pl files to be installed. e.g. + + {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'} + +By default this will include *.pm and *.pl and the files found in +the PMLIBDIRS directories. Defining PM in the +Makefile.PL will override PMLIBDIRS. + +=item PMLIBDIRS + +Ref to array of subdirectories containing library files. Defaults to +[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files +they contain will be installed in the corresponding location in the +library. A libscan() method can be used to alter the behaviour. +Defining PM in the Makefile.PL will override PMLIBDIRS. + +(Where BASEEXT is the last component of NAME.) + +=item PM_FILTER + +A filter program, in the traditional Unix sense (input from stdin, output +to stdout) that is passed on each .pm file during the build (in the +pm_to_blib() phase). It is empty by default, meaning no filtering is done. + +Great care is necessary when defining the command if quoting needs to be +done. For instance, you would need to say: + + {'PM_FILTER' => 'grep -v \\"^\\#\\"'} + +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 +# is escaped for the Makefile, since what is going to be generated will then +be: + + PM_FILTER = grep -v \"^\#\" + +Without the \\ before the #, we'd have the start of a Makefile comment, +and the macro would be incorrectly defined. + +=item POLLUTE + +Release 5.005 grandfathered old global symbol names by providing preprocessor +macros for extension source compatibility. As of release 5.6, these +preprocessor definitions are not available by default. The POLLUTE flag +specifies that the old names should still be defined: + + perl Makefile.PL POLLUTE=1 + +Please inform the module author if this is necessary to successfully install +a module under 5.6 or later. + +=item PPM_INSTALL_EXEC + +Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) + +=item PPM_INSTALL_SCRIPT + +Name of the script that gets executed by the Perl Package Manager after +the installation of a package. + +=item PREFIX + +This overrides all the default install locations. Man pages, +libraries, scripts, etc... MakeMaker will try to make an educated +guess about where to place things under the new PREFIX based on your +Config defaults. Failing that, it will fall back to a structure +which should be sensible for your platform. + +If you specify LIB or any INSTALL* variables they will not be effected +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. C<perl Makefile.PL> +will C<die> instead of simply informing the user of the 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. + +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>. + +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 + +A hash of modules that are needed to run your module. The keys are +the module names ie. Test::More, and the minimum version is the +value. If the required version number is 0 any version will do. + +This will go into the C<requires> field of your F<META.yml>. + + PREREQ_PM => { + # Require Test::More at least 0.47 + "Test::More" => "0.47", + + # Require any version of Acme::Buffy + "Acme::Buffy" => 0, + } + +=item PREREQ_PRINT + +Bool. If this parameter is true, the prerequisites will be printed to +stdout and MakeMaker will exit. The output format is an evalable hash +ref. + + $PREREQ_PM = { + 'A::B' => Vers1, + 'C::D' => Vers2, + ... + }; + +If a distribution defines a minimal required perl version, this is +added to the output as an additional line of the form: + + $MIN_PERL_VERSION = '5.008001'; + +If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hasref. + +=item PRINT_PREREQ + +RedHatism for C<PREREQ_PRINT>. The output format is different, though: + + perl(A::B)>=Vers1 perl(C::D)>=Vers2 ... + +A minimal required perl version, if present, will look like this: + + perl(perl)>=5.008001 + +=item SITEPREFIX + +Like PERLPREFIX, but only for the site install locations. + +Defaults to $Config{siteprefixexp}. Perls prior to 5.6.0 didn't have +an explicit siteprefix in the Config. In those cases +$Config{installprefix} will be used. + +Overridable by PREFIX + +=item SIGN + +When true, perform the generation and addition to the MANIFEST of the +SIGNATURE file in the distdir during 'make distdir', via 'cpansign +-s'. + +Note that you need to install the Module::Signature module to +perform this operation. + +Defaults to false. + +=item SKIP + +Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the +Makefile. Caution! Do not use the SKIP attribute for the negligible +speedup. It may seriously damage the resulting Makefile. Only use it +if you really need it. + +=item TYPEMAPS + +Ref to array of typemap file names. Use this when the typemaps are +in some directory other than the current directory or when they are +not named B<typemap>. The last typemap in the list takes +precedence. A typemap in the current directory has highest +precedence, even if it isn't listed in TYPEMAPS. The default system +typemap has lowest precedence. + +=item VENDORPREFIX + +Like PERLPREFIX, but only for the vendor install locations. + +Defaults to $Config{vendorprefixexp}. + +Overridable by PREFIX + +=item VERBINST + +If true, make install will be verbose + +=item VERSION + +Your version number for distributing the package. This defaults to +0.1. + +=item VERSION_FROM + +Instead of specifying the VERSION in the Makefile.PL you can let +MakeMaker parse a file to determine the version number. The parsing +routine requires that the file named by VERSION_FROM contains one +single line to compute the version number. The first line in the file +that contains something like a $VERSION assignment or C<package Name +VERSION> will be used. The following lines will be parsed o.k.: + + # Good + package Foo::Bar 1.23; # 1.23 + $VERSION = '1.00'; # 1.00 + *VERSION = \'1.01'; # 1.01 + ($VERSION) = q$Revision$ =~ /(\d+)/g; # The digits in $Revision$ + $FOO::VERSION = '1.10'; # 1.10 + *FOO::VERSION = \'1.11'; # 1.11 + +but these will fail: + + # Bad + my $VERSION = '1.01'; + local $VERSION = '1.02'; + local $FOO::VERSION = '1.30'; + +"Version strings" are incompatible should not be used. + + # Bad + $VERSION = 1.2.3; + $VERSION = v1.2.3; + +L<version> objects are fine. As of MakeMaker 6.35 version.pm will be +automatically loaded, but you must declare the dependency on version.pm. +For compatibility with older MakeMaker you should load on the same line +as $VERSION is declared. + + # 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 +Makefile. This is not really correct, but it would be a major pain +during development to have to rewrite the Makefile for any smallish +change in that file. If you want to make sure that the Makefile +contains the correct VERSION macro after any change of the file, you +would have to do something like + + depend => { Makefile => '$(VERSION_FROM)' } + +See attribute C<depend> below. + +=item VERSION_SYM + +A sanitized VERSION with . replaced by _. For places where . has +special meaning (some filesystems, RCS labels, etc...) + +=item XS + +Hashref of .xs files. MakeMaker will default this. e.g. + + {'name_of_file.xs' => 'name_of_file.c'} + +The .c files will automatically be included in the list of files +deleted by a make clean. + +=item XSOPT + +String of options to pass to xsubpp. This might include C<-C++> or +C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for +that purpose. + +=item XSPROTOARG + +May be set to an empty string, which is identical to C<-prototypes>, or +C<-noprototypes>. See the xsubpp documentation for details. MakeMaker +defaults to the empty string. + +=item XS_VERSION + +Your version number for the .xs file of this package. This defaults +to the value of the VERSION attribute. + +=back + +=head2 Additional lowercase attributes + +can be used to pass parameters to the methods which implement that +part of the Makefile. Parameters are specified as a hash ref but are +passed to the method as a hash. + +=over 2 + +=item clean + + {FILES => "*.xyz foo"} + +=item depend + + {ANY_TARGET => ANY_DEPENDENCY, ...} + +(ANY_TARGET must not be given a double-colon rule by MakeMaker.) + +=item dist + + {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', + SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip', + ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' } + +If you specify COMPRESS, then SUFFIX should also be altered, as it is +needed to tell make the target file of the compression. Setting +DIST_CP to ln can be useful, if you need to preserve the timestamps on +your files. DIST_CP can take the values 'cp', which copies the file, +'ln', which links the file, and 'best' which copies symbolic links and +links the rest. Default is 'best'. + +=item dynamic_lib + + {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} + +=item linkext + + {LINKTYPE => 'static', 'dynamic' or ''} + +NB: Extensions that have nothing but *.pm files had to say + + {LINKTYPE => ''} + +with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line +can be deleted safely. MakeMaker recognizes when there's nothing to +be linked. + +=item macro + + {ANY_MACRO => ANY_VALUE, ...} + +=item postamble + +Anything put here will be passed to MY::postamble() if you have one. + +=item realclean + + {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} + +=item test + + {TESTS => 't/*.t'} + +=item tool_autosplit + + {MAXLEN => 8} + +=back + +=head2 Overriding MakeMaker Methods + +If you cannot achieve the desired Makefile behaviour by specifying +attributes you may define private subroutines in the Makefile.PL. +Each subroutine returns the text it wishes to have written to +the Makefile. To override a section of the Makefile you can +either say: + + sub MY::c_o { "new literal text" } + +or you can edit the default by saying something like: + + package MY; # so that "SUPER" works right + sub c_o { + my $inherited = shift->SUPER::c_o(@_); + $inherited =~ s/old text/new text/; + $inherited; + } + +If you are running experiments with embedding perl as a library into +other applications, you might find MakeMaker is not sufficient. You'd +better have a look at ExtUtils::Embed which is a collection of utilities +for embedding. + +If you still need a different solution, try to develop another +subroutine that fits your needs and submit the diffs to +C<makemaker@perl.org> + +For a complete description of all MakeMaker methods see +L<ExtUtils::MM_Unix>. + +Here is a simple example of how to add a new target to the generated +Makefile: + + sub MY::postamble { + return <<'MAKE_FRAG'; + $(MYEXTLIB): sdbm/Makefile + cd sdbm && $(MAKE) all + + MAKE_FRAG + } + +=head2 The End Of Cargo Cult Programming + +WriteMakefile() now does some basic sanity checks on its parameters to +protect against typos and malformatted values. This means some things +which happened to work in the past will now throw warnings and +possibly produce internal errors. + +Some of the most common mistakes: + +=over 2 + +=item C<< 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. + +The correct code is C<< MAN3PODS => { } >>. + +=back + + +=head2 Hintsfile support + +MakeMaker.pm uses the architecture specific information from +Config.pm. In addition it evaluates architecture specific hints files +in a C<hints/> directory. The hints files are expected to be named +like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file +name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by +MakeMaker within the WriteMakefile() subroutine, and can be used to +execute commands as well as to include special variables. The rules +which hintsfile is chosen are the same as in Configure. + +The hintsfile is eval()ed immediately after the arguments given to +WriteMakefile are stuffed into a hash reference $self but before this +reference becomes blessed. So if you want to do the equivalent to +override or create an attribute you would say something like + + $self->{LIBS} = ['-ldbm -lucb -lc']; + +=head2 Distribution Support + +For authors of extensions MakeMaker provides several Makefile +targets. Most of the support comes from the ExtUtils::Manifest module, +where additional documentation can be found. + +=over 4 + +=item make distcheck + +reports which files are below the build directory but not in the +MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for +details) + +=item make skipcheck + +reports which files are skipped due to the entries in the +C<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for +details) + +=item make distclean + +does a realclean first and then the distcheck. Note that this is not +needed to build a new distribution as long as you are sure that the +MANIFEST file is ok. + +=item make manifest + +rewrites the MANIFEST file, adding all remaining files found (See +ExtUtils::Manifest::mkmanifest() for details) + +=item make distdir + +Copies all the files that are in the MANIFEST file to a newly created +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 MANIFEST. You can shut this +behavior off with the NO_META flag. + +=item make disttest + +Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and +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 $(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 +defaults to a null command. + +=item make dist + +Defaults to $(DIST_DEFAULT) which in turn defaults to tardist. + +=item make uutardist + +Runs a tardist first and uuencodes the tarfile. + +=item make shdist + +First does a distdir. Then a command $(PREOP) which defaults to a null +command. Next it runs C<shar> on that directory into a sharfile and +deletes the intermediate directory again. Finishes with a command +$(POSTOP) which defaults to a null command. Note: For shdist to work +properly a C<shar> program that can handle directories is mandatory. + +=item make zipdist + +First does a distdir. Then a command $(PREOP) which defaults to a null +command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a +zipfile. Then deletes that directory. Finishes with a command +$(POSTOP) which defaults to a null command. + +=item make ci + +Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file. + +=back + +Customization of the dist targets can be done by specifying a hash +reference to the dist attribute of the WriteMakefile call. The +following parameters are recognized: + + CI ('ci -u') + COMPRESS ('gzip --best') + POSTOP ('@ :') + PREOP ('@ :') + TO_UNIX (depends on the system) + RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):') + SHAR ('shar') + SUFFIX ('.gz') + TAR ('tar') + TARFLAGS ('cvf') + ZIP ('zip') + ZIPFLAGS ('-r') + +An example: + + WriteMakefile( + ...other options... + dist => { + COMPRESS => "bzip2", + SUFFIX => ".bz2" + } + ); + + +=head2 Module Meta-Data + +Long plaguing users of MakeMaker based modules has been the problem of +getting basic information about the module out of the sources +I<without> running the F<Makefile.PL> and doing a bunch of messy +heuristics on the resulting F<Makefile>. To this end a simple module +meta-data file has been introduced, F<META.yml>. + +F<META.yml> is a YAML document (see http://www.yaml.org) containing +basic information about the module (name, version, prerequisites...) +in an easy to read format. The format is developed and defined by the +Module::Build developers (see +http://module-build.sourceforge.net/META-spec.html) + +MakeMaker will automatically generate a F<META.yml> file for you and +add it to your F<MANIFEST> as part of the 'distdir' target (and thus +the 'dist' target). This is intended to seamlessly and rapidly +populate CPAN with module meta-data. If you wish to shut this feature +off, set the C<NO_META> C<WriteMakefile()> flag to true. + + +=head2 Disabling an extension + +If some events detected in F<Makefile.PL> imply that there is no way +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 + + use ExtUtils::MakeMaker qw(WriteEmptyMakefile); + WriteEmptyMakefile(); + +instead of WriteMakefile(). + +This may be useful if other modules expect this module to be I<built> +OK, as opposed to I<work> OK (say, this system-dependent module builds +in a subdirectory of some other distribution, or is listed as a +dependency in a CPAN::Bundle, but the functionality is supported by +different means on the current architecture). + +=head2 Other Handy Functions + +=over 4 + +=item prompt + + my $value = prompt($message); + my $value = prompt($message, $default); + +The C<prompt()> function provides an easy way to request user input +used to write a makefile. It displays the $message as a prompt for +input. If a $default is provided it will be used as a default. The +function returns the $value selected by the user. + +If C<prompt()> detects that it is not running interactively and there +is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable +is set to true, the $default will be used without prompting. This +prevents automated processes from blocking on user input. + +If no $default is provided an empty string will be used instead. + +=back + + +=head1 ENVIRONMENT + +=over 4 + +=item PERL_MM_OPT + +Command line options used by C<MakeMaker-E<gt>new()>, and thus by +C<WriteMakefile()>. The string is split on whitespace, and the result +is processed before any actual command line arguments are processed. + +=item PERL_MM_USE_DEFAULT + +If set to a true value then MakeMaker's prompt function will +always return the default without waiting for user input. + +=item PERL_CORE + +Same as the PERL_CORE parameter. The parameter overrides this. + +=back + +=head1 SEE ALSO + +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 + +Andy Dougherty C<doughera@lafayette.edu>, Andreas KE<ouml>nig +C<andreas.koenig@mind.de>, Tim Bunce C<timb@cpan.org>. VMS +support by Charles Bailey C<bailey@newman.upenn.edu>. OS/2 support +by Ilya Zakharevich C<ilya@math.ohio-state.edu>. + +Currently maintained by Michael G Schwern C<schwern@pobox.com> + +Send patches and ideas to C<makemaker@perl.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 +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Config.pm b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Config.pm new file mode 100644 index 00000000000..38b60affdda --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Config.pm @@ -0,0 +1,39 @@ +package ExtUtils::MakeMaker::Config; + +use strict; + +our $VERSION = '6.56'; + +use Config (); + +# Give us an overridable config. +our %Config = %Config::Config; + +sub import { + my $caller = caller; + + no strict 'refs'; ## no critic + *{$caller.'::Config'} = \%Config; +} + +1; + + +=head1 NAME + +ExtUtils::MakeMaker::Config - Wrapper around Config.pm + + +=head1 SYNOPSIS + + use ExtUtils::MakeMaker::Config; + print $Config{installbin}; # or whatever + + +=head1 DESCRIPTION + +B<FOR INTERNAL USE ONLY> + +A very thin wrapper around Config.pm so MakeMaker is easier to test. + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/FAQ.pod b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/FAQ.pod new file mode 100644 index 00000000000..d33f82e53b9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/FAQ.pod @@ -0,0 +1,431 @@ +package ExtUtils::MakeMaker::FAQ; + +our $VERSION = '1.12'; + +1; +__END__ + +=head1 NAME + +ExtUtils::MakeMaker::FAQ - Frequently Asked Questions About MakeMaker + +=head1 DESCRIPTION + +FAQs, tricks and tips for C<ExtUtils::MakeMaker>. + + +=head2 Module Installation + +=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 +operating systems. + +For an individual module: + + perl Makefile.PL INSTALLMAN1DIR=none INSTALLMAN3DIR=none + +If you want to suppress man page installation for all modules you have +to reconfigure Perl and tell it 'none' when it asks where to install +man pages. + + +=item How do I use a module without installing it? + +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 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 + +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 + + +=head2 Philosophy and History + +=over 4 + +=item Why not just use <insert other build config tool here>? + +Why did MakeMaker reinvent the build configuration wheel? Why not +just use autoconf or automake or ppm or Ant or ... + +There are many reasons, but the major one is cross-platform +compatibility. + +Perl is one of the most ported pieces of software ever. It works on +operating systems I've never even heard of (see perlport for details). +It needs a build tool that can work on all those platforms and with +any wacky C compilers and linkers they might have. + +No such build tool exists. Even make itself has wildly different +dialects. So we have to build our own. + + +=item What is Module::Build and how does it relate to MakeMaker? + +Module::Build is a project by Ken Williams to supplant MakeMaker. +Its primary advantages are: + +=over 8 + +=item * pure perl. no make, no shell commands + +=item * easier to customize + +=item * cleaner internals + +=item * less cruft + +=back + +Module::Build is the official heir apparent to MakeMaker and we +encourage people to work on M::B rather than spending time adding features +to MakeMaker. + +=back + + +=head2 Module Writing + +=over 4 + +=item How do I keep my $VERSION up to date without resetting it manually? + +Often you want to manually set the $VERSION in the main module +distribution because this is the version that everybody sees on CPAN +and maybe you want to customize it a bit. But for all the other +modules in your dist, $VERSION is really just bookkeeping and all that's +important is it goes up every time the module is changed. Doing this +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$ (see the documentation of your +version control system for details). Every time the file is checked +in the $Revision$ will be updated, updating your $VERSION. + +SVN uses a simple integer for $Revision$ so you can adapt it for your +$VERSION like so: + + ($VERSION) = q$Revision$ =~ /(\d+)/; + +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. + + $VERSION = sprintf "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/g; + +If branches are involved (ie. $Revision: 1.5.3.4$) its a little more +complicated. + + # must be all on one line or MakeMaker will get confused. + $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r }; + +In SVN, $Revision$ 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$ per file so each file will have a differnt $VERSION. +Distributed version control systems, such as SVK, may have a different +$Revision$ 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>?! + +F<META.yml> is a module meta-data file pioneered by Module::Build and +automatically generated as part of the 'distdir' target (and thus +'dist'). See L<ExtUtils::MakeMaker/"Module Meta-Data">. + +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 + }, + "." + ); + + +=item Which zip should I use on Windows for '[nd]make zipdist'? + +We recommend InfoZIP: L<http://www.info-zip.org/Zip.html> + + +=back + +=head2 XS + +=over 4 + +=item How to I prevent "object version X.XX does not match bootstrap parameter Y.YY" errors? + +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 rerunning Makefile.PL the old +version number will remain in the Makefile causing the XS code to be built +with the wrong number. + +To avoid this, you can force the Makefile to be rebuilt whenever you +change the module containing the version number by adding this to your +WriteMakefile() arguments. + + depend => { '$(FIRST_MAKEFILE)' => '$(VERSION_FROM)' } + + +=item How do I make two or more XS files coexist in the same directory? + +Sometimes you need to have two and more XS files in the same package. +One way to go is to put them into separate directories, but sometimes +this is not the most suitable solution. The following technique allows +you to put two (and more) XS files in the same directory. + +Let's assume that we have a package C<Cool::Foo>, which includes +C<Cool::Foo> and C<Cool::Bar> modules each having a separate XS +file. First we use the following I<Makefile.PL>: + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => 'Cool::Foo', + VERSION_FROM => 'Foo.pm', + OBJECT => q/$(O_FILES)/, + # ... other attrs ... + ); + +Notice the C<OBJECT> attribute. MakeMaker generates the following +variables in I<Makefile>: + + # Handy lists of source code files: + XS_FILES= Bar.xs \ + Foo.xs + C_FILES = Bar.c \ + Foo.c + O_FILES = Bar.o \ + Foo.o + +Therefore we can use the C<O_FILES> variable to tell MakeMaker to use +these objects into the shared library. + +That's pretty much it. Now write I<Foo.pm> and I<Foo.xs>, I<Bar.pm> +and I<Bar.xs>, where I<Foo.pm> bootstraps the shared library and +I<Bar.pm> simply loading I<Foo.pm>. + +The only issue left is to how to bootstrap I<Bar.xs>. This is done +from I<Foo.xs>: + + MODULE = Cool::Foo PACKAGE = Cool::Foo + + BOOT: + # boot the second XS file + boot_Cool__Bar(aTHX_ cv); + +If you have more than two files, this is the place where you should +boot extra XS files from. + +The following four files sum up all the details discussed so far. + + Foo.pm: + ------- + package Cool::Foo; + + require DynaLoader; + + our @ISA = qw(DynaLoader); + our $VERSION = '0.01'; + bootstrap Cool::Foo $VERSION; + + 1; + + Bar.pm: + ------- + package Cool::Bar; + + use Cool::Foo; # bootstraps Bar.xs + + 1; + + Foo.xs: + ------- + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + MODULE = Cool::Foo PACKAGE = Cool::Foo + + BOOT: + # boot the second XS file + boot_Cool__Bar(aTHX_ cv); + + MODULE = Cool::Foo PACKAGE = Cool::Foo PREFIX = cool_foo_ + + void + cool_foo_perl_rules() + + CODE: + fprintf(stderr, "Cool::Foo says: Perl Rules\n"); + + Bar.xs: + ------- + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + MODULE = Cool::Bar PACKAGE = Cool::Bar PREFIX = cool_bar_ + + void + cool_bar_perl_rules() + + CODE: + fprintf(stderr, "Cool::Bar says: Perl Rules\n"); + +And of course a very basic test: + + t/cool.t: + -------- + use Test; + BEGIN { plan tests => 1 }; + use Cool::Foo; + use Cool::Bar; + Cool::Foo::perl_rules(); + Cool::Bar::perl_rules(); + ok 1; + +This tip has been brought to you by Nick Ing-Simmons and Stas Bekman. + +=back + +=head1 PATCHING + +If you have a question you'd like to see added to the FAQ (whether or +not you have the answer) please send it to makemaker@perl.org. + +=head1 AUTHOR + +The denizens of makemaker@perl.org. + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Tutorial.pod b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Tutorial.pod new file mode 100644 index 00000000000..8ad72649b1a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/MakeMaker/Tutorial.pod @@ -0,0 +1,180 @@ +package ExtUtils::MakeMaker::Tutorial; + +our $VERSION = 0.02; + + +=head1 NAME + +ExtUtils::MakeMaker::Tutorial - Writing a module with MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => 'Your::Module', + VERSION_FROM => 'lib/Your/Module.pm' + ); + +=head1 DESCRIPTION + +This is a short tutorial on writing a simple module with MakeMaker. +Its really not that hard. + + +=head2 The Mantra + +MakeMaker modules are installed using this simple mantra + + perl Makefile.PL + make + make test + make install + +There are lots more commands and options, but the above will do it. + + +=head2 The Layout + +The basic files in a module look something like this. + + Makefile.PL + MANIFEST + lib/Your/Module.pm + +That's all that's strictly necessary. There's additional files you might +want: + + lib/Your/Other/Module.pm + t/some_test.t + t/some_other_test.t + Changes + README + INSTALL + MANIFEST.SKIP + bin/some_program + +=over 4 + +=item Makefile.PL + +When you run Makefile.PL, it makes a Makefile. That's the whole point of +MakeMaker. The Makefile.PL is a simple program which loads +ExtUtils::MakeMaker and runs the WriteMakefile() function to generate a +Makefile. + +Here's an example of what you need for a simple module: + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => 'Your::Module', + VERSION_FROM => 'lib/Your/Module.pm' + ); + +NAME is the top-level namespace of your module. VERSION_FROM is the file +which contains the $VERSION variable for the entire distribution. Typically +this is the same as your top-level module. + + +=item MANIFEST + +A simple listing of all the files in your distribution. + + Makefile.PL + MANIFEST + lib/Your/Module.pm + +File paths in a MANIFEST always use Unix conventions (ie. /) even if you're +not on Unix. + +You can write this by hand or generate it with 'make manifest'. + +See L<ExtUtils::Manifest> for more details. + + +=item lib/ + +This is the directory where your .pm and .pod files you wish to have +installed go. They are layed out according to namespace. So Foo::Bar +is F<lib/Foo/Bar.pm>. + + +=item t/ + +Tests for your modules go here. Each test filename ends with a .t. +So F<t/foo.t>/ 'make test' will run these tests. The directory is flat, +you cannot, for example, have t/foo/bar.t run by 'make test'. + +Tests are run from the top level of your distribution. So inside a test +you would refer to ./lib to enter the lib directory, for example. + + +=item Changes + +A log of changes you've made to this module. The layout is free-form. +Here's an example: + + 1.01 Fri Apr 11 00:21:25 PDT 2003 + - thing() does some stuff now + - fixed the wiggy bug in withit() + + 1.00 Mon Apr 7 00:57:15 PDT 2003 + - "Rain of Frogs" now supported + + +=item README + +A short description of your module, what it does, why someone would use it +and its limitations. CPAN automatically pulls your README file out of +the archive and makes it available to CPAN users, it is the first thing +they will read to decide if your module is right for them. + + +=item INSTALL + +Instructions on how to install your module along with any dependencies. +Suggested information to include here: + + any extra modules required for use + the minimum version of Perl required + if only works on certain operating systems + + +=item MANIFEST.SKIP + +A file full of regular expressions to exclude when using 'make +manifest' to generate the MANIFEST. These regular expressions +are checked against each file path found in the distribution (so +you're matching against "t/foo.t" not "foo.t"). + +Here's a sample: + + ~$ # ignore emacs and vim backup files + .bak$ # ignore manual backups + \# # ignore CVS old revision files and emacs temp files + +Since # can be used for comments, # must be escaped. + +MakeMaker comes with a default MANIFEST.SKIP to avoid things like +version control directories and backup files. Specifying your own +will override this default. + + +=item bin/ + + +=back + +=head1 SEE ALSO + +L<perlmodstyle> gives stylistic help writing a module. + +L<perlnewmod> gives more information about how to write a module. + +There are modules to help you through the process of writing a module: +L<ExtUtils::ModuleMaker>, L<Module::Install>, L<PAR> + +=cut + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Manifest.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Manifest.pm new file mode 100644 index 00000000000..df621d5f435 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Manifest.pm @@ -0,0 +1,881 @@ +package ExtUtils::Manifest; + +require Exporter; +use Config; +use File::Basename; +use File::Copy 'copy'; +use File::Find; +use File::Spec; +use Carp; +use strict; + +use vars qw($VERSION @ISA @EXPORT_OK + $Is_MacOS $Is_VMS $Is_VMS_mode $Is_VMS_lc $Is_VMS_nodot + $Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP); + +$VERSION = '1.57'; +@ISA=('Exporter'); +@EXPORT_OK = qw(mkmanifest + manicheck filecheck fullcheck skipcheck + manifind maniread manicopy maniadd + maniskip + ); + +$Is_MacOS = $^O eq 'MacOS'; +$Is_VMS = $^O eq 'VMS'; +$Is_VMS_mode = 0; +$Is_VMS_lc = 0; +$Is_VMS_nodot = 0; # No dots in dir names or double dots in files + +if ($Is_VMS) { + require VMS::Filespec if $Is_VMS; + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + $Is_VMS_mode = 1; + $Is_VMS_lc = 1; + $Is_VMS_nodot = 1; + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_lc = 0 if ($vms_case); + $Is_VMS_mode = 0 if ($vms_unix_rpt); + $Is_VMS_nodot = 0 if ($vms_efs); +} + +$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; +$Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? + $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; +$Quiet = 0; +$MANIFEST = 'MANIFEST'; + +$DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); + + +=head1 NAME + +ExtUtils::Manifest - utilities to write and check a MANIFEST file + +=head1 SYNOPSIS + + use ExtUtils::Manifest qw(...funcs to import...); + + mkmanifest(); + + my @missing_files = manicheck; + my @skipped = skipcheck; + my @extra_files = filecheck; + my($missing, $extra) = fullcheck; + + my $found = manifind(); + + my $manifest = maniread(); + + manicopy($read,$target); + + maniadd({$file => $comment, ...}); + + +=head1 DESCRIPTION + +=head2 Functions + +ExtUtils::Manifest exports no functions by default. The following are +exported on request + +=over 4 + +=item mkmanifest + + mkmanifest(); + +Writes all files in and below the current directory to your F<MANIFEST>. +It works similar to the result of the Unix command + + find . > MANIFEST + +All files that match any regular expression in a file F<MANIFEST.SKIP> +(if it exists) are ignored. + +Any existing F<MANIFEST> file will be saved as F<MANIFEST.bak>. + +=cut + +sub _sort { + return sort { lc $a cmp lc $b } @_; +} + +sub mkmanifest { + my $manimiss = 0; + my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; + $read = {} if $manimiss; + local *M; + my $bakbase = $MANIFEST; + $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots + rename $MANIFEST, "$bakbase.bak" unless $manimiss; + open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!"; + my $skip = maniskip(); + my $found = manifind(); + my($key,$val,$file,%all); + %all = (%$found, %$read); + $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') . + 'This list of files' + if $manimiss; # add new MANIFEST to known file list + foreach $file (_sort keys %all) { + if ($skip->($file)) { + # Policy: only remove files if they're listed in MANIFEST.SKIP. + # Don't remove files just because they don't exist. + warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file}; + next; + } + if ($Verbose){ + warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; + } + my $text = $all{$file}; + $file = _unmacify($file); + my $tabs = (5 - (length($file)+1)/8); + $tabs = 1 if $tabs < 1; + $tabs = 0 unless $text; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + print M $file, "\t" x $tabs, $text, "\n"; + } + close M; +} + +# Geez, shouldn't this use File::Spec or File::Basename or something? +# Why so careful about dependencies? +sub clean_up_filename { + my $filename = shift; + $filename =~ s|^\./||; + $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS; + return $filename; +} + + +=item manifind + + my $found = manifind(); + +returns a hash reference. The keys of the hash are the files found +below the current directory. + +=cut + +sub manifind { + my $p = shift || {}; + my $found = {}; + + my $wanted = sub { + my $name = clean_up_filename($File::Find::name); + warn "Debug: diskfile $name\n" if $Debug; + return if -d $_; + + if( $Is_VMS_lc ) { + $name =~ s#(.*)\.$#\L$1#; + $name = uc($name) if $name =~ /^MANIFEST(\.SKIP)?$/i; + } + $found->{$name} = ""; + }; + + # We have to use "$File::Find::dir/$_" in preprocess, because + # $File::Find::name is unavailable. + # Also, it's okay to use / here, because MANIFEST files use Unix-style + # paths. + find({wanted => $wanted}, + $Is_MacOS ? ":" : "."); + + return $found; +} + + +=item manicheck + + my @missing_files = manicheck(); + +checks if all the files within a C<MANIFEST> in the current directory +really do exist. If C<MANIFEST> and the tree below the current +directory are in sync it silently returns an empty list. +Otherwise it returns a list of files which are listed in the +C<MANIFEST> but missing from the directory, and by default also +outputs these names to STDERR. + +=cut + +sub manicheck { + return _check_files(); +} + + +=item filecheck + + my @extra_files = filecheck(); + +finds files below the current directory that are not mentioned in the +C<MANIFEST> file. An optional file C<MANIFEST.SKIP> will be +consulted. Any file matching a regular expression in such a file will +not be reported as missing in the C<MANIFEST> file. The list of any +extraneous files found is returned, and by default also reported to +STDERR. + +=cut + +sub filecheck { + return _check_manifest(); +} + + +=item fullcheck + + my($missing, $extra) = fullcheck(); + +does both a manicheck() and a filecheck(), returning then as two array +refs. + +=cut + +sub fullcheck { + return [_check_files()], [_check_manifest()]; +} + + +=item skipcheck + + my @skipped = skipcheck(); + +lists all the files that are skipped due to your C<MANIFEST.SKIP> +file. + +=cut + +sub skipcheck { + my($p) = @_; + my $found = manifind(); + my $matches = maniskip(); + + my @skipped = (); + foreach my $file (_sort keys %$found){ + if (&$matches($file)){ + warn "Skipping $file\n" unless $Quiet; + push @skipped, $file; + next; + } + } + + return @skipped; +} + + +sub _check_files { + my $p = shift; + my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); + my $read = maniread() || {}; + my $found = manifind($p); + + my(@missfile) = (); + foreach my $file (_sort keys %$read){ + warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; + if ($dosnames){ + $file = lc $file; + $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; + $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; + } + unless ( exists $found->{$file} ) { + warn "No such file: $file\n" unless $Quiet; + push @missfile, $file; + } + } + + return @missfile; +} + + +sub _check_manifest { + my($p) = @_; + my $read = maniread() || {}; + my $found = manifind($p); + my $skip = maniskip(); + + my @missentry = (); + foreach my $file (_sort keys %$found){ + next if $skip->($file); + warn "Debug: manicheck checking from disk $file\n" if $Debug; + unless ( exists $read->{$file} ) { + my $canon = $Is_MacOS ? "\t" . _unmacify($file) : ''; + warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; + push @missentry, $file; + } + } + + return @missentry; +} + + +=item maniread + + my $manifest = maniread(); + my $manifest = maniread($manifest_file); + +reads a named C<MANIFEST> file (defaults to C<MANIFEST> in the current +directory) and returns a HASH reference with files being the keys and +comments being the values of the HASH. Blank lines and lines which +start with C<#> in the C<MANIFEST> file are discarded. + +=cut + +sub maniread { + my ($mfile) = @_; + $mfile ||= $MANIFEST; + my $read = {}; + local *M; + unless (open M, "< $mfile"){ + warn "Problem opening $mfile: $!"; + return $read; + } + local $_; + while (<M>){ + chomp; + next if /^\s*#/; + + my($file, $comment); + + # filename may contain spaces if enclosed in '' + # (in which case, \\ and \' are escapes) + if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) { + $file =~ s/\\([\\'])/$1/g; + } + else { + ($file, $comment) = /^(\S+)\s*(.*)/; + } + next unless $file; + + if ($Is_MacOS) { + $file = _macify($file); + $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; + } + elsif ($Is_VMS_mode) { + require File::Basename; + my($base,$dir) = File::Basename::fileparse($file); + # Resolve illegal file specifications in the same way as tar + if ($Is_VMS_nodot) { + $dir =~ tr/./_/; + my(@pieces) = split(/\./,$base); + if (@pieces > 2) + { $base = shift(@pieces) . '.' . join('_',@pieces); } + my $okfile = "$dir$base"; + warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; + $file = $okfile; + } + $file = lc($file) + unless $Is_VMS_lc &&($file =~ /^MANIFEST(\.SKIP)?$/); + } + + $read->{$file} = $comment; + } + close M; + $read; +} + +=item maniskip + + my $skipchk = maniskip(); + my $skipchk = maniskip($manifest_skip_file); + + if ($skipchk->($file)) { .. } + +reads a named C<MANIFEST.SKIP> file (defaults to C<MANIFEST.SKIP> in +the current directory) and returns a CODE reference that tests whether +a given filename should be skipped. + +=cut + +# returns an anonymous sub that decides if an argument matches +sub maniskip { + my @skip ; + my $mfile = shift || "$MANIFEST.SKIP"; + _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//; + $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; + #my $comment = $3; + my $filename = $2; + if ( defined($1) ) { + $filename = $1; + $filename =~ s/\\(['\\])/$1/g; + } + next if (not defined($filename) or not $filename); + push @skip, _macify($filename); + } + close M; + return sub {0} unless (scalar @skip > 0); + + my $opts = $Is_VMS_mode ? '(?i)' : ''; + + # Make sure each entry is isolated in its own parentheses, in case + # any of them contain alternations + my $regex = join '|', map "(?:$_)", @skip; + + 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_nodot; # 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); + manicopy(\%src, $dest_dir, $how); + +Copies the files that are the keys in %src to the $dest_dir. %src is +typically returned by the maniread() function. + + manicopy( maniread(), $dest_dir ); + +This function is useful for producing a directory tree identical to the +intended distribution tree. + +$how can be used to specify a different methods of "copying". Valid +values are C<cp>, which actually copies the files, C<ln> which creates +hard links, and C<best> which mostly links the files but copies any +symbolic link to make a tree without any symbolic link. C<cp> is the +default. + +=cut + +sub manicopy { + my($read,$target,$how)=@_; + croak "manicopy() called without target argument" unless defined $target; + $how ||= 'cp'; + require File::Path; + require File::Basename; + + $target = VMS::Filespec::unixify($target) if $Is_VMS_mode; + File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); + foreach my $file (keys %$read){ + if ($Is_MacOS) { + if ($file =~ m!:!) { + my $dir = _maccat($target, $file); + $dir =~ s/[^:]+$//; + File::Path::mkpath($dir,1,0755); + } + cp_if_diff($file, _maccat($target, $file), $how); + } else { + $file = VMS::Filespec::unixify($file) if $Is_VMS_mode; + if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? + my $dir = File::Basename::dirname($file); + $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode; + File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); + } + cp_if_diff($file, "$target/$file", $how); + } + } +} + +sub cp_if_diff { + my($from, $to, $how)=@_; + if (! -f $from) { + carp "$from not found"; + return; + } + my($diff) = 0; + local(*F,*T); + open(F,"< $from\0") or die "Can't read $from: $!\n"; + if (open(T,"< $to\0")) { + local $_; + while (<F>) { $diff++,last if $_ ne <T>; } + $diff++ unless eof(T); + close T; + } + else { $diff++; } + close F; + if ($diff) { + if (-e $to) { + unlink($to) or confess "unlink $to: $!"; + } + STRICT_SWITCH: { + best($from,$to), last STRICT_SWITCH if $how eq 'best'; + cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; + ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; + croak("ExtUtils::Manifest::cp_if_diff " . + "called with illegal how argument [$how]. " . + "Legal values are 'best', 'cp', and 'ln'."); + } + } +} + +sub cp { + my ($srcFile, $dstFile) = @_; + my ($access,$mod) = (stat $srcFile)[8,9]; + + copy($srcFile,$dstFile); + utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; + _manicopy_chmod($srcFile, $dstFile); +} + + +sub ln { + my ($srcFile, $dstFile) = @_; + # Fix-me - VMS can support links. + return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); + link($srcFile, $dstFile); + + unless( _manicopy_chmod($srcFile, $dstFile) ) { + unlink $dstFile; + return; + } + 1; +} + +# 1) Strip off all group and world permissions. +# 2) Let everyone read it. +# 3) If the owner can execute it, everyone can. +sub _manicopy_chmod { + my($srcFile, $dstFile) = @_; + + 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. +my @Exceptions = qw(MANIFEST META.yml SIGNATURE); +sub best { + my ($srcFile, $dstFile) = @_; + + my $is_exception = grep $srcFile =~ /$_/, @Exceptions; + if ($is_exception or !$Config{d_link} or -l $srcFile) { + cp($srcFile, $dstFile); + } else { + ln($srcFile, $dstFile) or cp($srcFile, $dstFile); + } +} + +sub _macify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^\./||; + if ($file =~ m|/|) { + $file =~ s|/+|:|g; + $file = ":$file"; + } + + $file; +} + +sub _maccat { + my($f1, $f2) = @_; + + return "$f1/$f2" unless $Is_MacOS; + + $f1 .= ":$f2"; + $f1 =~ s/([^:]:):/$1/g; + return $f1; +} + +sub _unmacify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^:||; + $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; + $file =~ y|:|/|; + + $file; +} + + +=item maniadd + + maniadd({ $file => $comment, ...}); + +Adds an entry to an existing F<MANIFEST> unless its already there. + +$file will be normalized (ie. Unixified). B<UNIMPLEMENTED> + +=cut + +sub maniadd { + my($additions) = shift; + + _normalize($additions); + _fix_manifest($MANIFEST); + + my $manifest = maniread(); + my @needed = grep { !exists $manifest->{$_} } keys %$additions; + return 1 unless @needed; + + open(MANIFEST, ">>$MANIFEST") or + die "maniadd() could not open $MANIFEST: $!"; + + foreach my $file (_sort @needed) { + my $comment = $additions->{$file} || ''; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + printf MANIFEST "%-40s %s\n", $file, $comment; + } + close MANIFEST or die "Error closing $MANIFEST: $!"; + + return 1; +} + + +# Sometimes MANIFESTs are missing a trailing newline. Fix this. +sub _fix_manifest { + my $manifest_file = shift; + + open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; + + # Yes, we should be using seek(), but I'd like to avoid loading POSIX + # to get SEEK_* + my @manifest = <MANIFEST>; + close MANIFEST; + + unless( $manifest[-1] =~ /\n\z/ ) { + open MANIFEST, ">>$MANIFEST" or die "Could not open $MANIFEST: $!"; + print MANIFEST "\n"; + close MANIFEST; + } +} + + +# UNIMPLEMENTED +sub _normalize { + return; +} + + +=back + +=head2 MANIFEST + +A list of files in the distribution, one file per line. The MANIFEST +always uses Unix filepath conventions even if you're not on Unix. This +means F<foo/bar> style not F<foo\bar>. + +Anything between white space and an end of line within a C<MANIFEST> +file is considered to be a comment. Any line beginning with # is also +a comment. Beginning with ExtUtils::Manifest 1.52, a filename may +contain whitespace characters if it is enclosed in single quotes; single +quotes or backslashes in that filename must be backslash-escaped. + + # this a comment + some/file + some/other/file comment about some/file + 'some/third file' comment + + +=head2 MANIFEST.SKIP + +The file MANIFEST.SKIP may contain regular expressions of files that +should be ignored by mkmanifest() and filecheck(). The regular +expressions should appear one on each line. Blank lines and lines +which start with C<#> are skipped. Use C<\#> if you need a regular +expression to start with a C<#>. + +For example: + + # Version control files and dirs. + \bRCS\b + \bCVS\b + ,v$ + \B\.svn\b + + # Makemaker generated files and dirs. + ^MANIFEST\. + ^Makefile$ + ^blib/ + ^MakeMaker-\d + + # Temp, old and emacs backup files. + ~$ + \.old$ + ^#.*#$ + ^\.# + +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 + +C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, +C<&maniread>, and C<&manicopy> are exportable. + +=head2 GLOBAL VARIABLES + +C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it +results in both a different C<MANIFEST> and a different +C<MANIFEST.SKIP> file. This is useful if you want to maintain +different distributions for different audiences (say a user version +and a developer version including RCS). + +C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, +all functions act silently. + +C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, +or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be +produced. + +=head1 DIAGNOSTICS + +All diagnostic output is sent to C<STDERR>. + +=over 4 + +=item C<Not in MANIFEST:> I<file> + +is reported if a file is found which is not in C<MANIFEST>. + +=item C<Skipping> I<file> + +is reported if a file is skipped due to an entry in C<MANIFEST.SKIP>. + +=item C<No such file:> I<file> + +is reported if a file mentioned in a C<MANIFEST> file does not +exist. + +=item C<MANIFEST:> I<$!> + +is reported if C<MANIFEST> could not be opened. + +=item C<Added to MANIFEST:> I<file> + +is reported by mkmanifest() if $Verbose is set and a file is added +to MANIFEST. $Verbose is set to 1 by default. + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item B<PERL_MM_MANIFEST_DEBUG> + +Turns on debugging + +=back + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. + +=head1 AUTHOR + +Andreas Koenig C<andreas.koenig@anima.de> + +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 + +1; diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Miniperl.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Miniperl.pm new file mode 100644 index 00000000000..493cb347e44 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Miniperl.pm @@ -0,0 +1,280 @@ +# This File keeps the contents of miniperlmain.c. +# +# It was generated automatically by minimod.PL from the contents +# of miniperlmain.c. Don't edit this file! +# +# ANY CHANGES MADE HERE WILL BE LOST! +# + + +package ExtUtils::Miniperl; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(&writemain); + +$head= <<'EOF!HEAD'; +/* miniperlmain.c + * + * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007, by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * The Road goes ever on and on + * Down from the door where it began. + * + * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] + * [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"] + */ + +/* This file contains the main() function for the perl interpreter. + * Note that miniperlmain.c contains main() for the 'miniperl' binary, + * while perlmain.c contains main() for the 'perl' binary. + * + * Miniperl is like perl except that it does not support dynamic loading, + * and in fact is used to build the dynamic modules needed for the 'real' + * perl executable. + */ + +#ifdef OEMVS +#ifdef MYMALLOC +/* sbrk is limited to first heap segment so make it big */ +#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#else +#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#endif +#endif + + +#include "EXTERN.h" +#define PERL_IN_MINIPERLMAIN_C +#include "perl.h" +#include "XSUB.h" + +static void xs_init (pTHX); +static PerlInterpreter *my_perl; + +#if defined (atarist) +/* The Atari operating system doesn't have a dynamic stack. The + stack size is determined from this value. */ +long _stksize = 64 * 1024; +#endif + +#if defined(PERL_GLOBAL_STRUCT_PRIVATE) +/* The static struct perl_vars* may seem counterproductive since the + * whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note + * that this static is not in the shared perl library, the globals PL_Vars + * and PL_VarsPtr will stay away. */ +static struct perl_vars* my_plvarsp; +struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; } +#endif + +#ifdef NO_ENV_ARRAY_IN_MAIN +extern char **environ; +int +main(int argc, char **argv) +#else +int +main(int argc, char **argv, char **env) +#endif +{ + dVAR; + int exitstatus, i; +#ifdef PERL_GLOBAL_STRUCT + struct perl_vars *plvarsp = init_global_struct(); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + my_vars = my_plvarsp = plvarsp; +# endif +#endif /* PERL_GLOBAL_STRUCT */ + (void)env; +#ifndef PERL_USE_SAFE_PUTENV + PL_use_safe_putenv = 0; +#endif /* PERL_USE_SAFE_PUTENV */ + + /* if user wants control of gprof profiling off by default */ + /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */ + PERL_GPROF_MONCONTROL(0); + +#ifdef NO_ENV_ARRAY_IN_MAIN + PERL_SYS_INIT3(&argc,&argv,&environ); +#else + PERL_SYS_INIT3(&argc,&argv,&env); +#endif + +#if defined(USE_ITHREADS) + /* XXX Ideally, this should really be happening in perl_alloc() or + * perl_construct() to keep libperl.a transparently fork()-safe. + * It is currently done here only because Apache/mod_perl have + * problems due to lack of a call to cancel pthread_atfork() + * handlers when shared objects that contain the handlers may + * be dlclose()d. This forces applications that embed perl to + * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't + * been called at least once before in the current process. + * --GSAR 2001-07-20 */ + PTHREAD_ATFORK(Perl_atfork_lock, + Perl_atfork_unlock, + Perl_atfork_unlock); +#endif + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct(my_perl); + PL_perl_destruct_level = 0; + } + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL); + if (!exitstatus) + perl_run(my_perl); + + /* Unregister our signal handler before destroying my_perl */ + for (i = 0; PL_sig_name[i]; i++) { + if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) { + rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL); + } + } + + exitstatus = perl_destruct(my_perl); + + perl_free(my_perl); + +#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN) + /* + * The old environment may have been freed by perl_free() + * when PERL_TRACK_MEMPOOL is defined, but without having + * been restored by perl_destruct() before (this is only + * done if destruct_level > 0). + * + * It is important to have a valid environment for atexit() + * routines that are eventually called. + */ + environ = env; +#endif + +#ifdef PERL_GLOBAL_STRUCT + free_global_struct(plvarsp); +#endif /* PERL_GLOBAL_STRUCT */ + + PERL_SYS_TERM(); + + exit(exitstatus); + return exitstatus; +} + +/* Register any extra external extensions */ + +EOF!HEAD +$tail=<<'EOF!TAIL'; + +static void +xs_init(pTHX) +{ + PERL_UNUSED_CONTEXT; +} + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */ +EOF!TAIL + +sub writemain{ + my(@exts) = @_; + + my($pname); + my($dl) = canon('/','DynaLoader'); + print $head; + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n"; + } + + my ($tail1,$tail2,$tail3) = ( $tail =~ /\A(.*{\s*\n)(.*\n)(\s*\}.*)\Z/s ); + + print $tail1; + print "\tconst char file[] = __FILE__;\n"; + print "\tdXSUB_SYS;\n" if $] > 5.002; + print $tail2; + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname, $ccode); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + print "\t{\n"; + if ($pname eq $dl){ + # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! + # boot_DynaLoader is called directly in DynaLoader.pm + $ccode = "\t/* DynaLoader is a special case */\n +\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n"; + print $ccode unless $SEEN{$ccode}++; + } else { + $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n"; + print $ccode unless $SEEN{$ccode}++; + } + print "\t}\n"; + } + print $tail3; +} + +sub canon{ + my($as, @ext) = @_; + foreach(@ext){ + # might be X::Y or lib/auto/X/Y/Y.a + next if s!::!/!g; + s:^(lib|ext)/(auto/)?::; + s:/\w+\.\w+$::; + } + grep(s:/:$as:, @ext) if ($as ne '/'); + @ext; +} + +1; +__END__ + +=head1 NAME + +ExtUtils::Miniperl, writemain - write the C code for perlmain.c + +=head1 SYNOPSIS + +C<use ExtUtils::Miniperl;> + +C<writemain(@directories);> + +=head1 DESCRIPTION + +This whole module is written when perl itself is built from a script +called minimod.PL. In case you want to patch it, please patch +minimod.PL in the perl distribution instead. + +writemain() takes an argument list of directories containing archive +libraries that relate to perl modules and should be linked into a new +perl binary. It writes to STDOUT a corresponding perlmain.c file that +is a plain C file containing all the bootstrap code to make the +modules associated with the libraries available from within perl. + +The typical usage is from within a Makefile generated by +ExtUtils::MakeMaker. So under normal circumstances you won't have to +deal with this module directly. + +=head1 SEE ALSO + +L<ExtUtils::MakeMaker> + +=cut + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Mkbootstrap.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Mkbootstrap.pm new file mode 100644 index 00000000000..707466a98dd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Mkbootstrap.pm @@ -0,0 +1,109 @@ +package ExtUtils::Mkbootstrap; + +# There's just too much Dynaloader incest here to turn on strict vars. +use strict 'refs'; + +our $VERSION = '6.56'; + +require Exporter; +our @ISA = ('Exporter'); +our @EXPORT = ('&Mkbootstrap'); + +use Config; + +our $Verbose = 0; + + +sub Mkbootstrap { + my($baseext, @bsloadlibs)=@_; + @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs + + print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose; + + # We need DynaLoader here because we and/or the *_BS file may + # call dl_findfile(). We don't say `use' here because when + # first building perl extensions the DynaLoader will not have + # been built when MakeMaker gets first used. + require DynaLoader; + + rename "$baseext.bs", "$baseext.bso" + if -s "$baseext.bs"; + + if (-f "${baseext}_BS"){ + $_ = "${baseext}_BS"; + package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)}; + $bscode = ""; + unshift @INC, "."; + require $_; + shift @INC; + } + + if ($Config{'dlsrc'} =~ /^dl_dld/){ + package DynaLoader; + push(@dl_resolve_using, dl_findfile('-lc')); + } + + my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using); + my($method) = ''; + if (@all){ + open my $bs, ">", "$baseext.bs" + or die "Unable to open $baseext.bs: $!"; + print STDOUT "Writing $baseext.bs\n"; + print STDOUT " containing: @all" if $Verbose; + print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; + print $bs "# Do not edit this file, changes will be lost.\n"; + print $bs "# This file was automatically generated by the\n"; + print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; + print $bs "\@DynaLoader::dl_resolve_using = "; + # If @all contains names in the form -lxxx or -Lxxx then it's asking for + # runtime library location so we automatically add a call to dl_findfile() + if (" @all" =~ m/ -[lLR]/){ + print $bs " dl_findfile(qw(\n @all\n ));\n"; + }else{ + print $bs " qw(@all);\n"; + } + # write extra code if *_BS says so + print $bs $DynaLoader::bscode if $DynaLoader::bscode; + print $bs "\n1;\n"; + close $bs; + } +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader + +=head1 SYNOPSIS + +C<Mkbootstrap> + +=head1 DESCRIPTION + +Mkbootstrap typically gets called from an extension Makefile. + +There is no C<*.bs> file supplied with the extension. Instead, there may +be a C<*_BS> file which has code for the special cases, like posix for +berkeley db on the NeXT. + +This file will get parsed, and produce a maybe empty +C<@DynaLoader::dl_resolve_using> array for the current architecture. +That will be extended by $BSLOADLIBS, which was computed by +ExtUtils::Liblist::ext(). If this array still is empty, we do nothing, +else we write a .bs file with an C<@DynaLoader::dl_resolve_using> +array. + +The C<*_BS> file can put some code into the generated C<*.bs> file by +placing it in C<$bscode>. This is a handy 'escape' mechanism that may +prove useful in complex situations. + +If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then +Mkbootstrap will automatically add a dl_findfile() call to the +generated C<*.bs> file. + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Mksymlists.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Mksymlists.pm new file mode 100644 index 00000000000..962c67fd57f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Mksymlists.pm @@ -0,0 +1,312 @@ +package ExtUtils::Mksymlists; + +use 5.006; +use strict qw[ subs refs ]; +# no strict 'vars'; # until filehandles are exempted + +use Carp; +use Exporter; +use Config; + +our @ISA = qw(Exporter); +our @EXPORT = qw(&Mksymlists); +our $VERSION = '6.56'; + +sub Mksymlists { + my(%spec) = @_; + my($osname) = $^O; + + croak("Insufficient information specified to Mksymlists") + unless ( $spec{NAME} or + ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) ); + + $spec{DL_VARS} = [] unless $spec{DL_VARS}; + ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + $spec{DL_FUNCS} = { $spec{NAME} => [] } + unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or + @{$spec{FUNCLIST}}); + if (defined $spec{DL_FUNCS}) { + foreach my $package (keys %{$spec{DL_FUNCS}}) { + my($packprefix,$bootseen); + ($packprefix = $package) =~ s/\W/_/g; + foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) { + if ($sym =~ /^boot_/) { + push(@{$spec{FUNCLIST}},$sym); + $bootseen++; + } + else { + push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym"); + } + } + push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen; + } + } + +# We'll need this if we ever add any OS which uses mod2fname +# not as pseudo-builtin. +# require DynaLoader; + if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { + $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); + } + + if ($osname eq 'aix') { _write_aix(\%spec); } + elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } + elsif ($osname eq 'VMS') { _write_vms(\%spec) } + elsif ($osname eq 'os2') { _write_os2(\%spec) } + elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } + else { + croak("Don't know how to create linker option file for $osname\n"); + } +} + + +sub _write_aix { + my($data) = @_; + + rename "$data->{FILE}.exp", "$data->{FILE}.exp_old"; + + open( my $exp, ">", "$data->{FILE}.exp") + or croak("Can't create $data->{FILE}.exp: $!\n"); + print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + close $exp; +} + + +sub _write_os2 { + my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); + + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + my $distname = $data->{DISTNAME} || $data->{NAME}; + $distname = "Distribution $distname"; + my $patchlevel = " pl$Config{perl_patchlevel}" || ''; + my $comment = sprintf "Perl (v%s%s%s) module %s", + $Config::Config{version}, $threaded, $patchlevel, $data->{NAME}; + chomp $comment; + if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { + $distname = 'perl5-porters@perl.org'; + $comment = "Core $comment"; + } + $comment = "$comment (Perl-config: $Config{config_args})"; + $comment = substr($comment, 0, 200) . "...)" if length $comment > 203; + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open(my $def, ">", "$data->{FILE}.def") + or croak("Can't create $data->{FILE}.def: $!\n"); + print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n"; + print $def "CODE LOADONCALL\n"; + print $def "DATA LOADONCALL NONSHARED MULTIPLE\n"; + print $def "EXPORTS\n "; + print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + if (%{$data->{IMPORTS}}) { + print $def "IMPORTS\n"; + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print $def " $name=$exp\n"; + } + } + close $def; +} + +sub _write_win32 { + my($data) = @_; + + require Config; + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open( my $def, ">", "$data->{FILE}.def" ) + or croak("Can't create $data->{FILE}.def: $!\n"); + # put library name in quotes (it could be a keyword, like 'Alias') + if ($Config::Config{'cc'} !~ /^gcc/i) { + print $def "LIBRARY \"$data->{DLBASE}\"\n"; + } + print $def "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from different compilers + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 + if ($Config::Config{'cc'} =~ /^bcc/i) { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "_$_", "$_ = _$_"; + } + } + else { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "$_", "_$_ = $_"; + } + } + print $def join("\n ",@syms, "\n") if @syms; + if (%{$data->{IMPORTS}}) { + print $def "IMPORTS\n"; + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print $def " $name=$exp\n"; + } + } + close $def; +} + + +sub _write_vms { + my($data) = @_; + + require Config; # a reminder for once we do $^O + require ExtUtils::XSSymSet; + + my($isvax) = $Config::Config{'archname'} =~ /VAX/i; + my($set) = new ExtUtils::XSSymSet; + + rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; + + open(my $opt,">", "$data->{FILE}.opt") + or croak("Can't create $data->{FILE}.opt: $!\n"); + + # Options file declaring universal symbols + # Used when linking shareable image for dynamic extension, + # or when linking PerlShr into which we've added this package + # as a static extension + # We don't do anything to preserve order, so we won't relax + # the GSMATCH criteria for a dynamic extension + + print $opt "case_sensitive=yes\n" + if $Config::Config{d_vms_case_sensitive_symbols}; + + foreach my $sym (@{$data->{FUNCLIST}}) { + my $safe = $set->addsym($sym); + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } + } + + foreach my $sym (@{$data->{DL_VARS}}) { + my $safe = $set->addsym($sym); + print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; } + } + + close $opt; +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::Mksymlists - write linker options files for dynamic extension + +=head1 SYNOPSIS + + use ExtUtils::Mksymlists; + Mksymlists({ NAME => $name , + DL_VARS => [ $var1, $var2, $var3 ], + DL_FUNCS => { $pkg1 => [ $func1, $func2 ], + $pkg2 => [ $func3 ] }); + +=head1 DESCRIPTION + +C<ExtUtils::Mksymlists> produces files used by the linker under some OSs +during the creation of shared libraries for dynamic extensions. It is +normally called from a MakeMaker-generated Makefile when the extension +is built. The linker option file is generated by calling the function +C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>. +It takes one argument, a list of key-value pairs, in which the following +keys are recognized: + +=over 4 + +=item DLBASE + +This item specifies the name by which the linker knows the +extension, which may be different from the name of the +extension itself (for instance, some linkers add an '_' to the +name of the extension). If it is not specified, it is derived +from the NAME attribute. It is presently used only by OS2 and Win32. + +=item DL_FUNCS + +This is identical to the DL_FUNCS attribute available via MakeMaker, +from which it is usually taken. Its value is a reference to an +associative array, in which each key is the name of a package, and +each value is an a reference to an array of function names which +should be exported by the extension. For instance, one might say +C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], +Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The +function names should be identical to those in the XSUB code; +C<Mksymlists> will alter the names written to the linker option +file to match the changes made by F<xsubpp>. In addition, if +none of the functions in a list begin with the string B<boot_>, +C<Mksymlists> will add a bootstrap function for that package, +just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is +present in the list, it is passed through unchanged.) If +DL_FUNCS is not specified, it defaults to the bootstrap +function for the extension specified in NAME. + +=item DL_VARS + +This is identical to the DL_VARS attribute available via MakeMaker, +and, like DL_FUNCS, it is usually specified via MakeMaker. Its +value is a reference to an array of variable names which should +be exported by the extension. + +=item FILE + +This key can be used to specify the name of the linker option file +(minus the OS-specific extension), if for some reason you do not +want to use the default value, which is the last word of the NAME +attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>). + +=item FUNCLIST + +This provides an alternate means to specify function names to be +exported from the extension. Its value is a reference to an +array of function names to be exported by the extension. These +names are passed through unaltered to the linker options file. +Specifying a value for the FUNCLIST attribute suppresses automatic +generation of the bootstrap function for the package. To still create +the bootstrap name you have to specify the package name in the +DL_FUNCS hash: + + Mksymlists({ NAME => $name , + FUNCLIST => [ $func1, $func2 ], + DL_FUNCS => { $pkg => [] } }); + + +=item IMPORTS + +This attribute is used to specify names to be imported into the +extension. It is currently only used by OS/2 and Win32. + +=item NAME + +This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which +the linker option file will be produced. + +=back + +When calling C<Mksymlists>, one should always specify the NAME +attribute. In most cases, this is all that's necessary. In +the case of unusual extensions, however, the other attributes +can be used to provide additional information to the linker. + +=head1 AUTHOR + +Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> + +=head1 REVISION + +Last revised 14-Feb-1996, for Perl 5.002. diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Packlist.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Packlist.pm new file mode 100644 index 00000000000..b77a556be50 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/Packlist.pm @@ -0,0 +1,352 @@ +package ExtUtils::Packlist; + +use 5.00503; +use strict; +use Carp qw(); +use Config; +use vars qw($VERSION $Relocations); +$VERSION = '1.44'; +$VERSION = eval $VERSION; + +# Used for generating filehandle globs. IO::File might not be available! +my $fhname = "FH1"; + +=begin _undocumented + +=over + +=item mkfh() + +Make a filehandle. Same kind of idea as Symbol::gensym(). + +=cut + +sub mkfh() +{ +no strict; +my $fh = \*{$fhname++}; +use strict; +return($fh); +} + +=item __find_relocations + +Works out what absolute paths in the configuration have been located at run +time relative to $^X, and generates a regexp that matches them + +=end _undocumented + +=back + +=cut + +sub __find_relocations +{ + my %paths; + while (my ($raw_key, $raw_val) = each %Config) { + my $exp_key = $raw_key . "exp"; + next unless exists $Config{$exp_key}; + next unless $raw_val =~ m!\.\.\./!; + $paths{$Config{$exp_key}}++; + } + # Longest prefixes go first in the alternatives + my $alternations = join "|", map {quotemeta $_} + sort {length $b <=> length $a} keys %paths; + qr/^($alternations)/o; +} + +sub new($$) +{ +my ($class, $packfile) = @_; +$class = ref($class) || $class; +my %self; +tie(%self, $class, $packfile); +return(bless(\%self, $class)); +} + +sub TIEHASH +{ +my ($class, $packfile) = @_; +my $self = { packfile => $packfile }; +bless($self, $class); +$self->read($packfile) if (defined($packfile) && -f $packfile); +return($self); +} + +sub STORE +{ +$_[0]->{data}->{$_[1]} = $_[2]; +} + +sub FETCH +{ +return($_[0]->{data}->{$_[1]}); +} + +sub FIRSTKEY +{ +my $reset = scalar(keys(%{$_[0]->{data}})); +return(each(%{$_[0]->{data}})); +} + +sub NEXTKEY +{ +return(each(%{$_[0]->{data}})); +} + +sub EXISTS +{ +return(exists($_[0]->{data}->{$_[1]})); +} + +sub DELETE +{ +return(delete($_[0]->{data}->{$_[1]})); +} + +sub CLEAR +{ +%{$_[0]->{data}} = (); +} + +sub DESTROY +{ +} + +sub read($;$) +{ +my ($self, $packfile) = @_; +$self = tied(%$self) || $self; + +if (defined($packfile)) { $self->{packfile} = $packfile; } +else { $packfile = $self->{packfile}; } +Carp::croak("No packlist filename specified") if (! defined($packfile)); +my $fh = mkfh(); +open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!"); +$self->{data} = {}; +my ($line); +while (defined($line = <$fh>)) + { + chomp $line; + my ($key, $data) = $line; + if ($key =~ /^(.*?)( \w+=.*)$/) + { + $key = $1; + $data = { map { split('=', $_) } split(' ', $2)}; + + if ($Config{userelocatableinc} && $data->{relocate_as}) + { + require File::Spec; + require Cwd; + my ($vol, $dir) = File::Spec->splitpath($packfile); + my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as}); + $key = Cwd::realpath($newpath); + } + } + $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths + $self->{data}->{$key} = $data; + } +close($fh); +} + +sub write($;$) +{ +my ($self, $packfile) = @_; +$self = tied(%$self) || $self; +if (defined($packfile)) { $self->{packfile} = $packfile; } +else { $packfile = $self->{packfile}; } +Carp::croak("No packlist filename specified") if (! defined($packfile)); +my $fh = mkfh(); +open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!"); +foreach my $key (sort(keys(%{$self->{data}}))) + { + my $data = $self->{data}->{$key}; + if ($Config{userelocatableinc}) { + $Relocations ||= __find_relocations(); + if ($packfile =~ $Relocations) { + # We are writing into a subdirectory of a run-time relocated + # path. Figure out if the this file is also within a subdir. + my $prefix = $1; + if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix))) + { + # The relocated path is within the found prefix + my $packfile_prefix; + (undef, $packfile_prefix) + = File::Spec->splitpath($packfile); + + my $relocate_as + = File::Spec->abs2rel($key, $packfile_prefix); + + if (!ref $data) { + $data = {}; + } + $data->{relocate_as} = $relocate_as; + } + } + } + print $fh ("$key"); + if (ref($data)) + { + foreach my $k (sort(keys(%$data))) + { + print $fh (" $k=$data->{$k}"); + } + } + print $fh ("\n"); + } +close($fh); +} + +sub validate($;$) +{ +my ($self, $remove) = @_; +$self = tied(%$self) || $self; +my @missing; +foreach my $key (sort(keys(%{$self->{data}}))) + { + if (! -e $key) + { + push(@missing, $key); + delete($self->{data}{$key}) if ($remove); + } + } +return(@missing); +} + +sub packlist_file($) +{ +my ($self) = @_; +$self = tied(%$self) || $self; +return($self->{packfile}); +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::Packlist - manage .packlist files + +=head1 SYNOPSIS + + use ExtUtils::Packlist; + my ($pl) = ExtUtils::Packlist->new('.packlist'); + $pl->read('/an/old/.packlist'); + my @missing_files = $pl->validate(); + $pl->write('/a/new/.packlist'); + + $pl->{'/some/file/name'}++; + or + $pl->{'/some/other/file/name'} = { type => 'file', + from => '/some/file' }; + +=head1 DESCRIPTION + +ExtUtils::Packlist provides a standard way to manage .packlist files. +Functions are provided to read and write .packlist files. The original +.packlist format is a simple list of absolute pathnames, one per line. In +addition, this package supports an extended format, where as well as a filename +each line may contain a list of attributes in the form of a space separated +list of key=value pairs. This is used by the installperl script to +differentiate between files and links, for example. + +=head1 USAGE + +The hash reference returned by the new() function can be used to examine and +modify the contents of the .packlist. Items may be added/deleted from the +.packlist by modifying the hash. If the value associated with a hash key is a +scalar, the entry written to the .packlist by any subsequent write() will be a +simple filename. If the value is a hash, the entry written will be the +filename followed by the key=value pairs from the hash. Reading back the +.packlist will recreate the original entries. + +=head1 FUNCTIONS + +=over 4 + +=item new() + +This takes an optional parameter, the name of a .packlist. If the file exists, +it will be opened and the contents of the file will be read. The new() method +returns a reference to a hash. This hash holds an entry for each line in the +.packlist. In the case of old-style .packlists, the value associated with each +key is undef. In the case of new-style .packlists, the value associated with +each key is a hash containing the key=value pairs following the filename in the +.packlist. + +=item read() + +This takes an optional parameter, the name of the .packlist to be read. If +no file is specified, the .packlist specified to new() will be read. If the +.packlist does not exist, Carp::croak will be called. + +=item write() + +This takes an optional parameter, the name of the .packlist to be written. If +no file is specified, the .packlist specified to new() will be overwritten. + +=item validate() + +This checks that every file listed in the .packlist actually exists. If an +argument which evaluates to true is given, any missing files will be removed +from the internal hash. The return value is a list of the missing files, which +will be empty if they all exist. + +=item packlist_file() + +This returns the name of the associated .packlist file + +=back + +=head1 EXAMPLE + +Here's C<modrm>, a little utility to cleanly remove an installed module. + + #!/usr/local/bin/perl -w + + use strict; + use IO::Dir; + use ExtUtils::Packlist; + use ExtUtils::Installed; + + sub emptydir($) { + my ($dir) = @_; + my $dh = IO::Dir->new($dir) || return(0); + my @count = $dh->read(); + $dh->close(); + return(@count == 2 ? 1 : 0); + } + + # Find all the installed packages + print("Finding all installed modules...\n"); + my $installed = ExtUtils::Installed->new(); + + foreach my $module (grep(!/^Perl$/, $installed->modules())) { + my $version = $installed->version($module) || "???"; + print("Found module $module Version $version\n"); + print("Do you want to delete $module? [n] "); + my $r = <STDIN>; chomp($r); + if ($r && $r =~ /^y/i) { + # Remove all the files + foreach my $file (sort($installed->files($module))) { + print("rm $file\n"); + unlink($file); + } + my $pf = $installed->packlist($module)->packlist_file(); + print("rm $pf\n"); + unlink($pf); + foreach my $dir (sort($installed->directory_tree($module))) { + if (emptydir($dir)) { + print("rmdir $dir\n"); + rmdir($dir); + } + } + } + } + +=head1 AUTHOR + +Alan Burlison <Alan.Burlison@uk.sun.com> + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm b/Master/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm new file mode 100644 index 00000000000..05c3e690027 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm @@ -0,0 +1,2111 @@ +package ExtUtils::ParseXS; + +use 5.006; # We use /??{}/ in regexes +use Cwd; +use Config; +use File::Basename; +use File::Spec; +use Symbol; + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(process_file); + +# use strict; # One of these days... + +my(@XSStack); # Stack of conditionals and INCLUDEs +my($XSS_work_idx, $cpp_next_tmp); + +use vars qw($VERSION); +$VERSION = '2.21'; +$VERSION = eval $VERSION if $VERSION =~ /_/; + +use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback + $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers + $WantOptimize $process_inout $process_argtypes @tm + $dir $filename $filepathname %IncludedFiles + %type_kind %proto_letter + %targetable $BLOCK_re $lastline $lastline_no + $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg + $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof + $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set + $ProtoThisXSUB $ScopeThisXSUB $xsreturn + @line_no $ret_type $func_header $orig_args + ); # Add these just to get compilation to happen. + + +sub process_file { + + # Allow for $package->process_file(%hash) in the future + my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_); + + $ProtoUsed = exists $args{prototypes}; + + # Set defaults. + %args = ( + # 'C++' => 0, # Doesn't seem to *do* anything... + hiertype => 0, + except => 0, + prototypes => 0, + versioncheck => 1, + linenumbers => 1, + optimize => 1, + prototypes => 0, + inout => 1, + argtypes => 1, + typemap => [], + output => \*STDOUT, + csuffix => '.c', + %args, + ); + + # Global Constants + + 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; + } + @XSStack = ({type => 'none'}); + ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); + @InitFileCode = (); + $FH = Symbol::gensym(); + $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; + $Overload = 0; + $errors = 0; + $Fallback = '&PL_sv_undef'; + + # Most of the 1500 lines below uses these globals. We'll have to + # clean this up sometime, probably. For now, we just pull them out + # of %args. -Ken + + $cplusplus = $args{'C++'}; + $hiertype = $args{hiertype}; + $WantPrototypes = $args{prototypes}; + $WantVersionChk = $args{versioncheck}; + $except = $args{except} ? ' TRY' : ''; + $WantLineNumbers = $args{linenumbers}; + $WantOptimize = $args{optimize}; + $process_inout = $args{inout}; + $process_argtypes = $args{argtypes}; + @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap}); + + for ($args{filename}) { + die "Missing required parameter 'filename'" unless $_; + $filepathname = $_; + ($dir, $filename) = (dirname($_), basename($_)); + $filepathname =~ s/\\/\\\\/g; + $IncludedFiles{$_}++; + } + + # Open the input file + open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n"; + + # Open the output file if given as a string. If they provide some + # other kind of reference, trust them that we can print to it. + if (not ref $args{output}) { + open my($fh), "> $args{output}" or die "Can't create $args{output}: $!"; + $args{outfile} = $args{output}; + $args{output} = $fh; + } + + # Really, we shouldn't have to chdir() or select() in the first + # place. For now, just save & restore. + my $orig_cwd = cwd(); + my $orig_fh = select(); + + chdir($dir); + my $pwd = cwd(); + my $csuffix = $args{csuffix}; + + if ($WantLineNumbers) { + my $cfile; + if ( $args{outfile} ) { + $cfile = $args{outfile}; + } else { + $cfile = $args{filename}; + $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; + } + tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); + select PSEUDO_STDOUT; + } else { + select $args{output}; + } + + foreach my $typemap (@tm) { + die "Can't find $typemap in $pwd\n" unless -r $typemap; + } + + push @tm, standard_typemap_locations(); + + foreach my $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; + my $mode = 'Typemap'; + my $junk = "" ; + my $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 my $value (values %input_expr) { + $value =~ s/;*\s+\z//; + # Move C pre-processor instructions to column 1 to be strictly ANSI + # conformant. Some pre-processors are fussy about this. + $value =~ s/^\s+#/#/mg; + } + foreach my $value (values %output_expr) { + # And again. + $value =~ s/^\s+#/#/mg; + } + + my ($cast, $size); + our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced + $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast + $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) + + foreach my $key (keys %output_expr) { + # We can still bootstrap compile 're', because in code re.pm is + # available to miniperl, and does not attempt to load the XS code. + 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; + } + + my $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*:"; + + + our ($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; + + # Identify the version of xsubpp used + print <<EOM ; +/* + * This file was generated automatically by ExtUtils::ParseXS version $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 \"$filepathname\"\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. + # - Nicholas Clark + print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); + printf("#line %d \"$filepathname\"\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 ($Package, $Prefix) = + /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; + + print $_; + } + unless (defined $_) { + warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; + exit 0; # Not a fatal error for the caller process + } + + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + + print <<"EOF"; +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(var) if (0) var = var +#endif + +EOF + + print <<"EOF"; +#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) + +/* prototype to pass -Wmissing-prototypes */ +STATIC void +S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); + +STATIC void +S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) +{ + const GV *const gv = CvGV(cv); + + PERL_ARGS_ASSERT_CROAK_XS_USAGE; + + if (gv) { + const char *const gvname = GvNAME(gv); + const HV *const stash = GvSTASH(gv); + const char *const hvname = stash ? HvNAME(stash) : NULL; + + if (hvname) + Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); + else + Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); + } else { + /* Pants. I don't think that it should be possible to get here. */ + Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + } +} +#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE + +#ifdef PERL_IMPLICIT_CONTEXT +#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) +#else +#define croak_xs_usage S_croak_xs_usage +#endif + +#endif + +/* NOTE: the prototype of newXSproto() is different in versions of perls, + * so we define a portable version of newXSproto() + */ +#ifdef newXS_flags +#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) +#else +#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) +#endif /* !defined(newXS_flags) */ + +EOF + + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + + $lastline = $_; + $lastline_no = $.; + + 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/; + + my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return); + my (@fake_INPUT_pre); # For length(s) generated variables + my (@fake_INPUT); + + # initialize info arrays + undef(%args_match); + undef(%var_types); + undef(%defaults); + undef(%arg_list) ; + undef(@proto_arg) ; + undef($processing_arg_with_types) ; + undef(%argtype_seen) ; + undef(@outlist) ; + undef(%in_out) ; + undef(%lengthof) ; + 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 (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE|SCOPE")) { + &{"${kwd}_handler"}() ; + next PARAGRAPH unless @line ; + $_ = shift(@line); + } + + if (check_keyword("BOOT")) { + &check_cpp; + push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"") + 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 my $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 @args; + + 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 defined($pre) && 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); + } + my $extra_args = 0; + @args_num = (); + $num_args = 0; + my $report_args = ''; + foreach my $i (0 .. $#args) { + if ($args[$i] =~ s/\.\.\.//) { + $ellipsis = 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}) +#[[ +##ifdef dVAR +# dVAR; dXSARGS; +##else +# dXSARGS; +##endif +EOF + print Q(<<"EOF") if $ALIAS ; +# dXSI32; +EOF + print Q(<<"EOF") if $INTERFACE ; +# dXSFUNCTION($ret_type); +EOF + if ($ellipsis) { + $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($cond) { + print Q(<<"EOF"); +# if ($cond) +# croak_xs_usage(cv, "$report_args"); +EOF + } else { + # cv likely to be unused + print Q(<<"EOF"); +# PERL_UNUSED_VAR(cv); /* -W */ +EOF + } + + #gcc -Wall: if an xsub has PPCODE is used + #it is possible 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; +# 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/^\Q$args{'s'}// + if exists $args{'s'}; + $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; + print "\tXSprePUSH;" if $c and not $prepush_done; + 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 + + our $newXS = "newXS" ; + our $proto = "" ; + + # Build the prototype string for the xsub + if ($ProtoThisXSUB) { + $newXS = "newXSproto_portable"; + + if ($ProtoThisXSUB eq 2) { + # User has specified empty prototype + } + elsif ($ProtoThisXSUB eq 1) { + my $s = ';'; + if ($min_args < $num_args) { + $s = ''; + $proto_arg[$min_args] .= ";" ; + } + push @proto_arg, "$s\@" + if $ellipsis ; + + $proto = join ("", grep defined, @proto_arg); + } + else { + # User has specified a prototype + $proto = $ProtoThisXSUB; + } + $proto = qq{, "$proto"}; + } + + 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$proto); +# XSANY.any_i32 = $value ; +EOF + } + } + elsif (@Attributes) { + push(@InitFileCode, Q(<<"EOF")); +# cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto); +# 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$proto); +# $interface_macro_set(cv,$value) ; +EOF + } + } + else { + push(@InitFileCode, + " (void)${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) +#{ +# dXSARGS; +# 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. */ + (void)${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"); +#[[ +##ifdef dVAR +# dVAR; dXSARGS; +##else +# dXSARGS; +##endif +EOF + + #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const + #file name argument. If the wrong qualifier is used, it causes breakage with + #C++ compilers and warnings with recent gcc. + #-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; +##if (PERL_REVISION == 5 && PERL_VERSION < 9) +# char* file = __FILE__; +##else +# const char* file = __FILE__; +##endif +EOF + + print Q("#\n"); + + print Q(<<"EOF"); +# PERL_UNUSED_VAR(cv); /* -W */ +# PERL_UNUSED_VAR(items); /* -W */ +EOF + + 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'); +##if (PERL_REVISION == 5 && PERL_VERSION >= 9) +# if (PL_unitcheckav) +# call_list(PL_scopestack_ix, PL_unitcheckav); +##endif +EOF + + print Q(<<"EOF"); +# XSRETURN_YES; +#]] +# +EOF + + warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") + unless $ProtoUsed ; + + chdir($orig_cwd); + select($orig_fh); + untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; + close $FH; + + return 1; +} + +sub errors { $errors } + +sub standard_typemap_locations { + # Add all the default typemap locations to the search path + my @tm = qw(typemap); + + my $updir = File::Spec->updir; + foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2), + File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) { + + unshift @tm, File::Spec->catfile($dir, 'typemap'); + unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); + } + foreach my $dir (@INC) { + my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); + unshift @tm, $file if -e $file; + } + return @tm; +} + +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($_) ; + + $_ ; +} + +# 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; +} + +sub print_section { + # the "do" is required for right semantics + do { $_ = shift(@line) } while !/\S/ && @line; + + print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n") + if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; + for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { + print "$_\n"; + } + print 'ExtUtils::ParseXS::CountLines'->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;\n"; + } + + # 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) { + my $name = $_; + $name =~ s/^$Prefix//; + $Interfaces{$name} = $_; + } + 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, + " (void)${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 $VERSION.") + unless $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 ++ ; + + TrimWhitespace($_); + death ("Error: SCOPE: ENABLE/DISABLE") + unless /^(ENABLE|DISABLE)\b/i; + $ScopeThisXSUB = ( uc($1) eq 'ENABLE' ); + } + +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, + Filepathname => $filepathname, + Handle => $FH, + }) ; + + $FH = Symbol::gensym(); + + # open the new file + open ($FH, "$_") or death("Cannot open '$_': $!") ; + + print Q(<<"EOF"); +# +#/* INCLUDE: Including '$_' from '$filename' */ +# +EOF + + $filename = $_ ; + $filepathname = "$dir/$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 is the leafname, which for some reason isused for diagnostic + # messages, whereas $filepathname is the full pathname, and is used for + # #line directives. + $filename = $data->{Filename} ; + $filepathname = $data->{Filepathname} ; + $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; +} + +# 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; +} + +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; +} + + +######################################################### +package + ExtUtils::ParseXS::CountLines; +use strict; +use vars qw($SECTION_END_MARKER); + +sub TIEHANDLE { + my ($class, $cfile, $fh) = @_; + $cfile =~ s/\\/\\\\/g; + $SECTION_END_MARKER = qq{#line --- "$cfile"}; + + return bless {buffer => '', + fh => $fh, + line_no => 1, + }, $class; +} + +sub PRINT { + my $self = shift; + for (@_) { + $self->{buffer} .= $_; + while ($self->{buffer} =~ s/^([^\n]*\n)//) { + my $line = $1; + ++ $self->{line_no}; + $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; + print {$self->{fh}} $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 {$self->{fh}} $self->{buffer}; +} + +sub UNTIE { + # This sub does nothing, but is neccessary for references to be released. +} + +sub end_marker { + return $SECTION_END_MARKER; +} + + +1; +__END__ + +=head1 NAME + +ExtUtils::ParseXS - converts Perl XS code into C code + +=head1 SYNOPSIS + + use ExtUtils::ParseXS qw(process_file); + + process_file( filename => 'foo.xs' ); + + process_file( filename => 'foo.xs', + output => 'bar.c', + 'C++' => 1, + typemap => 'path/to/typemap', + hiertype => 1, + except => 1, + prototypes => 1, + versioncheck => 1, + linenumbers => 1, + optimize => 1, + prototypes => 1, + ); +=head1 DESCRIPTION + +C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs +necessary to let C functions manipulate Perl values and creates the glue +necessary to let Perl access those functions. The compiler uses typemaps to +determine how to map C function parameters and variables to Perl values. + +The compiler will search for typemap files called I<typemap>. It will use +the following search path to find default typemaps, with the rightmost +typemap taking precedence. + + ../../../typemap:../../typemap:../typemap:typemap + +=head1 EXPORT + +None by default. C<process_file()> may be exported upon request. + + +=head1 FUNCTIONS + +=over 4 + +=item process_xs() + +This function processes an XS file and sends output to a C file. +Named parameters control how the processing is done. The following +parameters are accepted: + +=over 4 + +=item B<C++> + +Adds C<extern "C"> to the C code. Default is false. + +=item B<hiertype> + +Retains C<::> in type names so that C++ hierachical types can be +mapped. Default is false. + +=item B<except> + +Adds exception handling stubs to the C code. Default is false. + +=item B<typemap> + +Indicates that a user-supplied typemap should take precedence over the +default typemaps. A single typemap may be specified as a string, or +multiple typemaps can be specified in an array reference, with the +last typemap having the highest precedence. + +=item B<prototypes> + +Generates prototype code for all xsubs. Default is false. + +=item B<versioncheck> + +Makes sure at run time that the object file (derived from the C<.xs> +file) and the C<.pm> files have the same version number. Default is +true. + +=item B<linenumbers> + +Adds C<#line> directives to the C output so error messages will look +like they came from the original XS file. Default is true. + +=item B<optimize> + +Enables certain optimizations. The only optimization that is currently +affected is the use of I<target>s by the output C code (see L<perlguts>). +Not optimizing may significantly slow down the generated code, but this is the way +B<xsubpp> of 5.005 and earlier operated. Default is to optimize. + +=item B<inout> + +Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> +declarations. Default is true. + +=item B<argtypes> + +Enable recognition of ANSI-like descriptions of function signature. +Default is true. + +=item B<s> + +I have no clue what this does. Strips function prefixes? + +=back + +=item errors() + +This function returns the number of [a certain kind of] errors +encountered during processing of the XS file. + +=back + +=head1 AUTHOR + +Based on xsubpp code, written by Larry Wall. + +Maintained by: + +=over 4 + +=item * + +Ken Williams, <ken@mathforum.org> + +=item * + +David Golden, <dagolden@cpan.org> + +=back + +=head1 COPYRIGHT + +Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All +rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5 +Porters, which was released under the same license terms. + +=head1 SEE ALSO + +L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/testlib.pm b/Master/tlpkg/tlperl/lib/ExtUtils/testlib.pm new file mode 100644 index 00000000000..fe01beb0e1e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/testlib.pm @@ -0,0 +1,41 @@ +package ExtUtils::testlib; + +use strict; +use warnings; + +our $VERSION = 6.56; + +use Cwd; +use File::Spec; + +# So the tests can chdir around and not break @INC. +# We use getcwd() because otherwise rel2abs will blow up under taint +# mode pre-5.8. We detaint is so @INC won't be tainted. This is +# no worse, and probably better, than just shoving an untainted, +# relative "blib/lib" onto @INC. +my $cwd; +BEGIN { + ($cwd) = getcwd() =~ /(.*)/; +} +use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib); +1; +__END__ + +=head1 NAME + +ExtUtils::testlib - add blib/* directories to @INC + +=head1 SYNOPSIS + + use ExtUtils::testlib; + +=head1 DESCRIPTION + +After an extension has been built and before it is installed it may be +desirable to test it bypassing C<make test>. By adding + + use ExtUtils::testlib; + +to a test program the intermediate directories used by C<make> are +added to @INC. + diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/typemap b/Master/tlpkg/tlperl/lib/ExtUtils/typemap new file mode 100644 index 00000000000..f88858762d5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/typemap @@ -0,0 +1,336 @@ +# basic C types +int T_IV +unsigned T_UV +unsigned int T_UV +long T_IV +unsigned long T_UV +short T_IV +unsigned short T_UV +char T_CHAR +unsigned char T_U_CHAR +char * T_PV +unsigned char * T_PV +const char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +# bool_t is defined in <rpc/rpc.h> +bool_t T_IV +size_t T_UV +ssize_t T_IV +time_t T_NV +unsigned long * T_OPAQUEPTR +char ** T_PACKEDARRAY +void * T_PTR +Time_t * T_PV +SV * T_SV +SVREF T_SVREF +AV * T_AVREF +HV * T_HVREF +CV * T_CVREF + +IV T_IV +UV T_UV +NV T_NV +I32 T_IV +I16 T_IV +I8 T_IV +STRLEN T_UV +U32 T_U_LONG +U16 T_U_SHORT +U8 T_UV +Result T_U_CHAR +Boolean T_BOOL +float T_FLOAT +double T_DOUBLE +SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_STDIO +PerlIO * T_INOUT +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT +bool T_BOOL + +############################################################################# +INPUT +T_SV + $var = $arg +T_SVREF + if (SvROK($arg)) + $var = (SV*)SvRV($arg); + else + 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_ \"%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_ \"%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_ \"%s: %s is not a code reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_SYSRET + $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) +T_IV + $var = ($type)SvIV($arg) +T_INT + $var = (int)SvIV($arg) +T_ENUM + $var = ($type)SvIV($arg) +T_BOOL + $var = (bool)SvTRUE($arg) +T_U_INT + $var = (unsigned int)SvUV($arg) +T_SHORT + $var = (short)SvIV($arg) +T_U_SHORT + $var = (unsigned short)SvUV($arg) +T_LONG + $var = (long)SvIV($arg) +T_U_LONG + $var = (unsigned long)SvUV($arg) +T_CHAR + $var = (char)*SvPV_nolen($arg) +T_U_CHAR + $var = (unsigned char)SvUV($arg) +T_FLOAT + $var = (float)SvNV($arg) +T_NV + $var = ($type)SvNV($arg) +T_DOUBLE + $var = (double)SvNV($arg) +T_PV + $var = ($type)SvPV_nolen($arg) +T_PTR + $var = INT2PTR($type,SvIV($arg)) +T_PTRREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + 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_ \"%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_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTROBJ + if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + 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)); + ${type}_desc = (\U${type}_DESC\E*) tmp; + $var = ${type}_desc->ptr; + } + else + 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_ \"%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_ \"%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 + $var = ($type)SvPV_nolen($arg) +T_PACKED + $var = XS_unpack_$ntype($arg) +T_PACKEDARRAY + $var = XS_unpack_$ntype($arg) +T_CALLBACK + $var = make_perl_cb_$type($arg) +T_ARRAY + U32 ix_$var = $argoff; + $var = $ntype(items -= $argoff); + while (items--) { + DO_ARRAY_ELEM; + ix_$var++; + } + /* this is the number of elements in the array */ + ix_$var -= $argoff +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) +############################################################################# +OUTPUT +T_SV + $arg = $var; +T_SVREF + $arg = newRV((SV*)$var); +T_AVREF + $arg = newRV((SV*)$var); +T_HVREF + $arg = newRV((SV*)$var); +T_CVREF + $arg = newRV((SV*)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); +T_INT + sv_setiv($arg, (IV)$var); +T_SYSRET + if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +T_ENUM + sv_setiv($arg, (IV)$var); +T_BOOL + $arg = boolSV($var); +T_U_INT + sv_setuv($arg, (UV)$var); +T_SHORT + sv_setiv($arg, (IV)$var); +T_U_SHORT + sv_setuv($arg, (UV)$var); +T_LONG + sv_setiv($arg, (IV)$var); +T_U_LONG + sv_setuv($arg, (UV)$var); +T_CHAR + sv_setpvn($arg, (char *)&$var, 1); +T_U_CHAR + sv_setuv($arg, (UV)$var); +T_FLOAT + sv_setnv($arg, (double)$var); +T_NV + sv_setnv($arg, (NV)$var); +T_DOUBLE + sv_setnv($arg, (double)$var); +T_PV + sv_setpv((SV*)$arg, $var); +T_PTR + sv_setiv($arg, PTR2IV($var)); +T_PTRREF + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTRDESC + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +T_REFREF + NOT_IMPLEMENTED +T_REFOBJ + NOT IMPLEMENTED +T_OPAQUE + sv_setpvn($arg, (char *)&$var, sizeof($var)); +T_OPAQUEPTR + sv_setpvn($arg, (char *)$var, sizeof(*$var)); +T_PACKED + XS_pack_$ntype($arg, $var); +T_PACKEDARRAY + XS_pack_$ntype($arg, $var, count_$ntype); +T_DATAUNIT + sv_setpvn($arg, $var.chp(), $var.size()); +T_CALLBACK + sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +T_ARRAY + { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_IN + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_INOUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_OUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/xsubpp b/Master/tlpkg/tlperl/lib/ExtUtils/xsubpp new file mode 100644 index 00000000000..e4e5b774d82 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/ExtUtils/xsubpp @@ -0,0 +1,156 @@ +#!./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<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs + +=head1 DESCRIPTION + +This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. + +I<xsubpp> will compile XS code into C code by embedding the constructs +necessary to let C functions manipulate Perl values and creates the glue +necessary to let Perl access those functions. The compiler uses typemaps to +determine how to map C function parameters and variables to Perl values. + +The compiler will search for typemap files called I<typemap>. It will use +the following search path to find default typemaps, with the rightmost +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 +any makefiles generated by MakeMaker. + +=over 5 + +=item B<-hiertype> + +Retains '::' in type names so that C++ hierarchical types can be mapped. + +=item B<-except> + +Adds exception handling stubs to the C code. + +=item B<-typemap typemap> + +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. + +=item B<-prototypes> + +By default I<xsubpp> will not automatically generate prototype code for +all xsubs. This flag will enable prototypes. + +=item B<-noversioncheck> + +Disables the run time test that determines if the object file (derived +from the C<.xs> file) and the C<.pm> files have the same version +number. + +=item B<-nolinenumbers> + +Prevents the inclusion of `#line' directives in the output. + +=item B<-nooptimize> + +Disables certain optimizations. The only optimization that is currently +affected is the use of I<target>s by the output C code (see L<perlguts>). +This may significantly slow down the generated code, but this is the way +B<xsubpp> of 5.005 and earlier operated. + +=item B<-noinout> + +Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. + +=item B<-noargtypes> + +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 + +No environment variables are used. + +=head1 AUTHOR + +Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module +by Ken Williams. + +=head1 MODIFICATION HISTORY + +See the file F<Changes>. + +=head1 SEE ALSO + +perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS + +=cut + |