File manager - Edit - /home/c14075/dragmet-ural.ru/www/ExtUtils.tar
Back
Constant.pm 0000644 00000035312 15140257564 0006710 0 ustar 00 package ExtUtils::Constant; use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); $VERSION = '0.25'; =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 = 0; /* avoid uninit var warning */\n"; } else { $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; } if ($params->{NV}) { $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n"; } else { $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; } if ($params->{PV}) { $xs .= " const char *pv = NULL; /* avoid uninit var warning */\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, 2); 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}; # Do this before creating (empty) files, in case it fails: require ExtUtils::Constant::ProxySubs if $ARGS{PROXYSUBS}; 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}) { $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 typemap 0000644 00000026063 15140257564 0006166 0 ustar 00 # 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 # These are the backwards-compatibility AV*/HV* typemaps that # do not decrement refcounts. Locally override with # "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED", # "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED", # to get the fixed versions. SVREF T_SVREF CV * T_CVREF AV * T_AVREF HV * T_HVREF 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 STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv)){ $var = SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_SVREF_REFCOUNT_FIXED STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv)){ $var = SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_AVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ $var = (AV*)SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_AVREF_REFCOUNT_FIXED STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ $var = (AV*)SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_HVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ $var = (HV*)SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not a HASH reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_HVREF_REFCOUNT_FIXED STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ $var = (HV*)SvRV(xsub_tmp_sv); } else{ Perl_croak_nocontext(\"%s: %s is not a HASH reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_CVREF STMT_START { HV *st; GV *gvp; SV * const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0); if (!$var) { Perl_croak_nocontext(\"%s: %s is not a CODE reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_CVREF_REFCOUNT_FIXED STMT_START { HV *st; GV *gvp; SV * const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0); if (!$var) { Perl_croak_nocontext(\"%s: %s is not a CODE reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END 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_nocontext(\"%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_nocontext(\"%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_nocontext(\"%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_nocontext(\"%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_nocontext(\"%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_nocontext(\"%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_nocontext(\"%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_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_SVREF_REFCOUNT_FIXED $arg = newRV_noinc((SV*)$var); T_AVREF $arg = newRV((SV*)$var); T_AVREF_REFCOUNT_FIXED $arg = newRV_noinc((SV*)$var); T_HVREF $arg = newRV((SV*)$var); T_HVREF_REFCOUNT_FIXED $arg = newRV_noinc((SV*)$var); T_CVREF $arg = newRV((SV*)$var); T_CVREF_REFCOUNT_FIXED $arg = newRV_noinc((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 ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($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_ARRAY { U32 ix_$var; SSize_t extend_size = /* The weird way this is written is because g++ is dumb * enough to warn "comparison is always false" on something * like: * * sizeof(a) > sizeof(b) && a > B_t_MAX * * (where the LH condition is false) */ (size_$var > (sizeof(size_$var) > sizeof(SSize_t) ? SSize_t_MAX : size_$var)) ? -1 : (SSize_t)size_$var; EXTEND(SP, extend_size); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } } T_STDIO { GV *gv = (GV *)sv_newmortal(); PerlIO *fp = PerlIO_importFILE($var,0); gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) { SV *rv = newRV_inc((SV*)gv); rv = sv_bless(rv, GvSTASH(gv)); ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} }${"$var" ne "RETVAL" ? \" else sv_setsv($arg, &PL_sv_undef);\n" : \""} } T_IN { GV *gv = (GV *)sv_newmortal(); gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) { SV *rv = newRV_inc((SV*)gv); rv = sv_bless(rv, GvSTASH(gv)); ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} }${"$var" ne "RETVAL" ? \" else sv_setsv($arg, &PL_sv_undef);\n" : \""} } T_INOUT { GV *gv = (GV *)sv_newmortal(); gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) { SV *rv = newRV_inc((SV*)gv); rv = sv_bless(rv, GvSTASH(gv)); ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} }${"$var" ne "RETVAL" ? \" else sv_setsv($arg, &PL_sv_undef);\n" : \""} } T_OUT { GV *gv = (GV *)sv_newmortal(); gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) { SV *rv = newRV_inc((SV*)gv); rv = sv_bless(rv, GvSTASH(gv)); ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} }${"$var" ne "RETVAL" ? \" else sv_setsv($arg, &PL_sv_undef);\n" : \""} } Command.pm 0000644 00000017165 15140257564 0006503 0 ustar 00 package ExtUtils::Command; use 5.00503; use strict; 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 = '7.44'; $VERSION =~ tr/_//d; 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__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; 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(); require File::Path; File::Path::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); require Carp; Carp::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; if (@src > 1 && ! -d $dst) { require Carp; Carp::croak("Too many arguments"); } require File::Copy; my $nok = 0; foreach my $src (@src) { $nok ||= !File::Copy::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; if (@src > 1 && ! -d $dst) { require Carp; Carp::croak("Too many arguments"); } require File::Copy; my $nok = 0; foreach my $src (@src) { $nok ||= !File::Copy::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) { require File::Spec; 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(); require File::Path; 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 }; binmode ORIG; binmode TEMP; 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 ParseXS.pm 0000644 00000202463 15140257564 0006447 0 ustar 00 package ExtUtils::ParseXS; use strict; use 5.006001; use Cwd; use Config; use Exporter 'import'; use File::Basename; use File::Spec; use Symbol; our $VERSION; BEGIN { $VERSION = '3.40'; require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION); } $VERSION = eval $VERSION if $VERSION =~ /_/; use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); our @EXPORT_OK = qw( process_file report_error_count ); ############################## # A number of "constants" 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; # "impossible" keyword (multiple newline) my $END = "!End!\n\n"; # Match an XS Keyword my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:"; sub new { return bless {} => shift; } our $Singleton = __PACKAGE__->new; sub process_file { my $self; # Allow for $package->process_file(%hash), $obj->process_file, and process_file() if (@_ % 2) { my $invocant = shift; $self = ref($invocant) ? $invocant : $invocant->new; } else { $self = $Singleton; } my %options = @_; $self->{ProtoUsed} = exists $options{prototypes}; # Set defaults. my %args = ( argtypes => 1, csuffix => '.c', except => 0, hiertype => 0, inout => 1, linenumbers => 1, optimize => 1, output => \*STDOUT, prototypes => 0, typemap => [], versioncheck => 1, FH => Symbol::gensym(), %options, ); $args{except} = $args{except} ? ' TRY' : ''; # 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 = ExtUtils::XSSymSet->new(28); } @{ $self->{XSStack} } = ({type => 'none'}); $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; $self->{Overload} = 0; # bool $self->{errors} = 0; # count $self->{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 $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; $self->{WantPrototypes} = $args{prototypes}; $self->{WantVersionChk} = $args{versioncheck}; $self->{WantLineNumbers} = $args{linenumbers}; $self->{IncludedFiles} = {}; die "Missing required parameter 'filename'" unless $args{filename}; $self->{filepathname} = $args{filename}; ($self->{dir}, $self->{filename}) = (dirname($args{filename}), basename($args{filename})); $self->{filepathname} =~ s/\\/\\\\/g; $self->{IncludedFiles}->{$args{filename}}++; # 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 and restore. my $orig_cwd = cwd(); my $orig_fh = select(); chdir($self->{dir}); my $pwd = cwd(); my $csuffix = $args{csuffix}; if ($self->{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}; } $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); # Move more settings from parameters to object foreach my $datum ( qw| argtypes except inout optimize | ) { $self->{$datum} = $args{$datum}; } $self->{strip_c_func_prefix} = $args{s}; # Identify the version of xsubpp used print <<EOM; /* * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead. * * ANY CHANGES MADE HERE WILL BE LOST! * */ EOM print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n") if $self->{WantLineNumbers}; # Open the input file (using $self->{filename} which # is a basename'd $args{filename} due to chdir above) open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; FIRSTMODULE: while (readline($self->{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 \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) if $self->{WantLineNumbers}; next FIRSTMODULE; } } while (readline($self->{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 $self->{filename}, line $podstartline\n") unless $self->{lastline}; } last if ($self->{Package}, $self->{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 $self->{WantLineNumbers}; standard_XS_defs(); print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; $self->{lastline} = $_; $self->{lastline_no} = $.; my $BootCode_ref = []; my $XSS_work_idx = 0; my $cpp_next_tmp = 'XSubPPtmpAAAA'; PARAGRAPH: while ($self->fetch_para()) { my $outlist_ref = []; # Print initial preprocessor statements and blank lines while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { my $ln = shift(@{ $self->{line} }); print $ln, "\n"; next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; my $statement = $+; ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); } next PARAGRAPH unless @{ $self->{line} }; if ($XSS_work_idx && !$self->{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(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; } $self->death( "Code is not inside a function" ." (maybe last function was ended by a blank line " ." followed by a statement on column one?)") if $self->{line}->[0] =~ /^\s/; # initialize info arrays foreach my $member (qw(args_match var_types defaults arg_list argtype_seen in_out lengthof)) { $self->{$member} = {}; } $self->{proto_arg} = []; $self->{processing_arg_with_types} = 0; # bool $self->{proto_in_this_xsub} = 0; # counter & bool $self->{scope_in_this_xsub} = 0; # counter & bool $self->{interface} = 0; # bool $self->{interface_macro} = 'XSINTERFACE_FUNC'; $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; $self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) $self->{ScopeThisXSUB} = 0; # bool my $xsreturn = 0; $_ = shift(@{ $self->{line} }); while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { my $method = $kwd . "_handler"; $self->$method($_); next PARAGRAPH unless @{ $self->{line} }; $_ = shift(@{ $self->{line} }); } if ($self->check_keyword("BOOT")) { check_conditional_preprocessor_statements($self); push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" . escape_file_for_line_directive($self->{filepathname}) . "\"") if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; push (@{ $BootCode_ref }, @{ $self->{line} }, ""); next PARAGRAPH; } # extract return type, function name and arguments ($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_); my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; # Allow one-line ANSI-like declaration unshift @{ $self->{line} }, $2 if $self->{argtypes} and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; # a function definition needs at least 2 lines $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH unless @{ $self->{line} }; my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; my $static = 1 if $self->{ret_type} =~ s/^static\s+//; my $func_header = shift(@{ $self->{line} }); $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; my ($class, $orig_args); ($class, $self->{func_name}, $orig_args) = ($1, $2, $3); $class = "$4 $class" if $4; ($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; my $clean_func_name; ($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//; $self->{Full_func_name} = "$self->{Packid}_$clean_func_name"; if ($Is_VMS) { $self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} ); } # Check for duplicate function definition for my $tmp (@{ $self->{XSStack} }) { next unless defined $tmp->{functions}{ $self->{Full_func_name} }; Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); last; } $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; delete $self->{XsubAliases}; delete $self->{XsubAliasValues}; %{ $self->{Interfaces} } = (); @{ $self->{Attributes} } = (); $self->{DoSetMagic} = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations my @args; my (@fake_INPUT_pre); # For length(s) generated variables my (@fake_INPUT); my $only_C_inlist_ref = {}; # Not in the signature of Perl function if ($self->{argtypes} and $orig_args =~ /\S/) { my $args = "$orig_args ,"; use re 'eval'; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); no re 'eval'; for ( @args ) { s/^\s+//; s/\s+$//; my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); my ($pre, $len_name) = ($arg =~ /(.*?) \s* \b ( \w+ | length\( \s*\w+\s* \) ) \s* $ /x); next unless defined($pre) && length($pre); my $out_type = ''; my $inout_var; if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { my $type = $1; $out_type = $type if $type ne 'IN'; $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; } my $islength; if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { $len_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"; $self->{argtype_seen}->{$len_name}++; $_ = "$len_name$default"; # Assigns to @args } $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; $self->{in_out}->{$len_name} = $out_type if $out_type; } } else { no re 'eval'; @args = split(/\s*,\s*/, $orig_args); Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); } } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { my $out_type = $1; next if $out_type eq 'IN'; $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; if ($out_type =~ /OUTLIST$/) { push @{ $outlist_ref }, undef; } $self->{in_out}->{$_} = $out_type; } } } if (defined($class)) { my $arg0 = ((defined($static) or $self->{func_name} eq 'new') ? "CLASS" : "THIS"); unshift(@args, $arg0); } my $extra_args = 0; my @args_num = (); my $num_args = 0; my $report_args = ''; my $ellipsis; 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_ref->{$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; $self->{defaults}->{$args[$i]} = $2; $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } $self->{proto_arg}->[$i+1] = '$' unless $only_C_inlist_ref->{$args[$i]}; } my $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; $report_args =~ s/^,\s+//; $self->{func_args} = assign_func_args($self, \@args, $class); @{ $self->{args_match} }{@args} = @args_num; my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) # to set explicit return values. my $EXPLICIT_RETURN = ($CODE && ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $self->{ALIAS} = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); $xsreturn = 1 if $EXPLICIT_RETURN; $externC = $externC ? qq[extern "C"] : ""; # print function header print Q(<<"EOF"); #$externC #XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Full_func_name}) #[[ # dVAR; dXSARGS; EOF print Q(<<"EOF") if $self->{ALIAS}; # dXSI32; EOF print Q(<<"EOF") if $INTERFACE; # dXSFUNCTION($self->{ret_type}); EOF $self->{cond} = set_cond($ellipsis, $min_args, $num_args); print Q(<<"EOF") if $self->{except}; # char errbuf[1024]; # *errbuf = '\\0'; EOF if($self->{cond}) { print Q(<<"EOF"); # if ($self->{cond}) # croak_xs_usage(cv, "$report_args"); EOF } else { # cv and items likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -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. $self->{condnum} = 0; $self->{cond} = ''; # last CASE: conditional push(@{ $self->{line} }, "$END:"); push(@{ $self->{line_no} }, $self->{line_no}->[-1]); $_ = ''; check_conditional_preprocessor_statements(); while (@{ $self->{line} }) { $self->CASE_handler($_) if $self->check_keyword("CASE"); print Q(<<"EOF"); # $self->{except} [[ EOF # do initialization of input variables $self->{thisdone} = 0; $self->{retvaldone} = 0; $self->{deferred} = ""; %{ $self->{arg_list} } = (); $self->{gotRETVAL} = 0; $self->INPUT_handler($_); $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ENTER; # [[ EOF if (!$self->{thisdone} && defined($class)) { if (defined($static) or $self->{func_name} eq 'new') { print "\tchar *"; $self->{var_types}->{"CLASS"} = "char *"; $self->generate_init( { type => "char *", num => 1, var => "CLASS", printed_name => undef, } ); } else { print "\t" . map_type($self, "$class *"); $self->{var_types}->{"THIS"} = "$class *"; $self->generate_init( { type => "$class *", num => 1, var => "THIS", printed_name => undef, } ); } } # These are set if OUTPUT is found and/or CODE using RETVAL $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; my ($wantRETVAL); # do code if (/^\s*NOT_IMPLEMENTED_YET/) { print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; $_ = ''; } else { if ($self->{ret_type} ne "void") { print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" if !$self->{retvaldone}; $self->{args_match}->{"RETVAL"} = 0; $self->{var_types}->{"RETVAL"} = $self->{ret_type}; my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); print "\tdXSTARG;\n" if $self->{optimize} and $outputmap and $outputmap->targetable; } if (@fake_INPUT or @fake_INPUT_pre) { unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; $_ = ""; $self->{processing_arg_with_types} = 1; $self->INPUT_handler($_); } print $self->{deferred}; $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); if ($self->check_keyword("PPCODE")) { $self->print_section(); $self->death("PPCODE must be last thing") if @{ $self->{line} }; print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; print "\tPUTBACK;\n\treturn;\n"; } elsif ($self->check_keyword("CODE")) { my $consumed_code = $self->print_section(); if ($consumed_code =~ /\bRETVAL\b/) { $self->{have_CODE_with_RETVAL} = 1; } } elsif (defined($class) and $self->{func_name} eq "DESTROY") { print "\n\t"; print "delete THIS;\n"; } else { print "\n\t"; if ($self->{ret_type} ne "void") { print "RETVAL = "; $wantRETVAL = 1; } if (defined($static)) { if ($self->{func_name} eq 'new') { $self->{func_name} = "$class"; } else { print "${class}::"; } } elsif (defined($class)) { if ($self->{func_name} eq 'new') { $self->{func_name} .= " $class"; } else { print "THIS->"; } } my $strip = $self->{strip_c_func_prefix}; $self->{func_name} =~ s/^\Q$strip// if defined $strip; $self->{func_name} = 'XSFUNCTION' if $self->{interface}; print "$self->{func_name}($self->{func_args});\n"; } } # do output variables $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; undef %{ $self->{outargs} }; $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); # A CODE section with RETVAL, but no OUTPUT? FAIL! if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); } $self->generate_output( { type => $self->{var_types}->{$_}, num => $self->{args_match}->{$_}, var => $_, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; my $prepush_done; # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; my $var = 'RETVAL'; my $type = $self->{ret_type}; if ($trgt) { my $what = $self->eval_output_typemap_code( qq("$trgt->{what}"), {var => $var, type => $self->{ret_type}} ); if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; $prepush_done = 1; } else { my $tsize = $trgt->{what_size}; $tsize = '' unless defined $tsize; $tsize = $self->eval_output_typemap_code( qq("$tsize"), {var => $var, type => $self->{ret_type}} ); print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; $prepush_done = 1; } } else { # RETVAL almost never needs SvSETMAGIC() $self->generate_output( { type => $self->{ret_type}, num => 0, var => 'RETVAL', do_setmagic => 0, do_push => undef, } ); } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; my $c = @{ $outlist_ref }; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; $self->generate_output( { type => $self->{var_types}->{$_}, num => $num++, var => $_, do_setmagic => 0, do_push => 1, } ) for @{ $outlist_ref }; # do cleanup $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ]] EOF print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; # LEAVE; EOF # print function trailer print Q(<<"EOF"); # ]] EOF print Q(<<"EOF") if $self->{except}; # BEGHANDLERS # CATCHALL # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); # ENDHANDLERS EOF if ($self->check_keyword("CASE")) { $self->blurt("Error: No 'CASE:' at top of function") unless $self->{condnum}; $_ = "CASE: $_"; # Restore CASE: label next; } last if $_ eq "$END:"; $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); } print Q(<<"EOF") if $self->{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 $self->{proto} = ""; unless($self->{ProtoThisXSUB}) { $self->{newXS} = "newXS_deffile"; $self->{file} = ""; } else { # Build the prototype string for the xsub $self->{newXS} = "newXSproto_portable"; $self->{file} = ", file"; if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype } elsif ($self->{ProtoThisXSUB} eq 1) { my $s = ';'; if ($min_args < $num_args) { $s = ''; $self->{proto_arg}->[$min_args] .= ";"; } push @{ $self->{proto_arg} }, "$s\@" if $ellipsis; $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); } else { # User has specified a prototype $self->{proto} = $self->{ProtoThisXSUB}; } $self->{proto} = qq{, "$self->{proto}"}; } if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { $self->{XsubAliases}->{ $self->{pname} } = 0 unless defined $self->{XsubAliases}->{ $self->{pname} }; foreach my $xname (sort keys %{ $self->{XsubAliases} }) { my $value = $self->{XsubAliases}{$xname}; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # XSANY.any_i32 = $value; EOF } } elsif (@{ $self->{Attributes} }) { push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); EOF } elsif ($self->{interface}) { foreach my $yname (sort keys %{ $self->{Interfaces} }) { my $value = $self->{Interfaces}{$yname}; $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # $self->{interface_macro_set}(cv,$value); EOF } } elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro push(@{ $self->{InitFileCode} }, " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } else { push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop if ($self->{Overload}) { # make it findable with fetchmethod print Q(<<"EOF"); #XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Packid}_nil) #{ # dXSARGS; # PERL_UNUSED_VAR(items); # XSRETURN_EMPTY; #} # EOF unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); /* Making a sub named "$self->{Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("$self->{Package}") to return true. */ (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); MAKE_FETCHMETHOD_WORK } # print initialization routine print Q(<<"EOF"); ##ifdef __cplusplus #extern "C" ##endif EOF print Q(<<"EOF"); #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ #XS_EXTERNAL(boot_$self->{Module_cname}) #[[ ##if PERL_VERSION_LE(5, 21, 5) # dVAR; dXSARGS; ##else # dVAR; ${\($self->{WantVersionChk} ? 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} ##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 $self->{Full_func_name} there are no xsubs in this .xs #so 'file' is unused print Q(<<"EOF") if $self->{Full_func_name}; ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # char* file = __FILE__; ##else # const char* file = __FILE__; ##endif # # PERL_UNUSED_VAR(file); EOF print Q("#\n"); print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ EOF if( $self->{WantVersionChk}){ print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) # XS_VERSION_BOOTCHECK; ## ifdef XS_APIVERSION_BOOTCHECK # XS_APIVERSION_BOOTCHECK; ## endif ##endif EOF } else { print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) # XS_APIVERSION_BOOTCHECK; ##endif EOF } print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # { # CV * cv; # EOF print Q(<<"EOF") if ($self->{Overload}); # /* register the overloading (type 'A') magic */ ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # PL_amagic_generation++; ##endif # /* 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( "$self->{Package}::()", TRUE ), # $self->{Fallback} # ); EOF print @{ $self->{InitFileCode} }; print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # } EOF if (@{ $BootCode_ref }) { print "\n /* Initialisation Section */\n\n"; @{ $self->{line} } = @{ $BootCode_ref }; $self->print_section(); print "\n /* End of Initialisation Section */\n\n"; } print Q(<<'EOF'); ##if PERL_VERSION_LE(5, 21, 5) ## if PERL_VERSION_GE(5, 9, 0) # if (PL_unitcheckav) # call_list(PL_scopestack_ix, PL_unitcheckav); ## endif # XSRETURN_YES; ##else # Perl_xs_boot_epilog(aTHX_ ax); ##endif #]] # EOF warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") unless $self->{ProtoUsed}; chdir($orig_cwd); select($orig_fh); untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; close $self->{FH}; return 1; } sub report_error_count { if (@_) { return $_[0]->{errors}||0; } else { return $Singleton->{errors}||0; } } # Input: ($self, $_, @{ $self->{line} }) == unparsed input. # Output: ($_, @{ $self->{line} }) == (rest of line, following lines). # Return: the matched keyword if found, otherwise 0 sub check_keyword { my $self = shift; $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } sub print_section { my $self = shift; # the "do" is required for right semantics do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; my $consumed_code = ''; print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", escape_file_for_line_directive($self->{filepathname}), "\"\n") if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { print "$_\n"; $consumed_code .= "$_\n"; } print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; return $consumed_code; } sub merge_section { my $self = shift; my $in = ''; while (!/\S/ && @{ $self->{line} }) { $_ = shift(@{ $self->{line} }); } for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { $in .= "$_\n"; } chomp $in; return $in; } sub process_keyword { my($self, $pattern) = @_; while (my $kwd = $self->check_keyword($pattern)) { my $method = $kwd . "_handler"; $self->$method($_); } } sub CASE_handler { my $self = shift; $_ = shift; $self->blurt("Error: 'CASE:' after unconditional 'CASE:'") if $self->{condnum} && $self->{cond} eq ''; $self->{cond} = $_; trim_whitespace($self->{cond}); print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); $_ = ''; } sub INPUT_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { last if /^\s*NOT_IMPLEMENTED_YET/; next unless /\S/; # skip blank lines trim_whitespace($_); my $ln = $_; # 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"; $self->{lengthof}->{$2} = undef; $self->{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; # *sigh* It's valid to supply explicit input typemaps in the argument list... my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; s/\s+/ /g; my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or $self->blurt("Error: invalid argument declaration '$ln'"), next; # Check for duplicate definitions $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next if $self->{arg_list}->{$var_name}++ or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; $self->{thisdone} |= $var_name eq "THIS"; $self->{retvaldone} |= $var_name eq "RETVAL"; $self->{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. my $printed_name; if ($var_type =~ / \( \s* \* \s* \) /x) { # Function pointers are not yet supported with output_init()! print "\t" . map_type($self, $var_type, $var_name); $printed_name = 1; } else { print "\t" . map_type($self, $var_type, undef); $printed_name = 0; } $self->{var_num} = $self->{args_match}->{$var_name}; if ($self->{var_num}) { my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); $self->report_typemap_failure($self->{typemap}, $var_type, "death") if not $typemap and not $is_overridden_typemap; $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; } $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($printed_name) { print ";\n"; } else { print "\t$var_name;\n"; } } elsif ($var_init =~ /\S/) { $self->output_init( { type => $var_type, num => $self->{var_num}, var => $var_name, init => $var_init, printed_name => $printed_name, } ); } elsif ($self->{var_num}) { $self->generate_init( { type => $var_type, num => $self->{var_num}, var => $var_name, printed_name => $printed_name, } ); } else { print ";\n"; } } } sub OUTPUT_handler { my $self = shift; $self->{have_OUTPUT} = 1; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); next; } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next if $self->{outargs}->{$outarg}++; if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { # deal with RETVAL last $self->{RETVAL_code} = $outcode; $self->{gotRETVAL} = 1; next; } $self->blurt("Error: OUTPUT $outarg not an argument"), next unless defined($self->{args_match}->{$outarg}); $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $self->{var_types}->{$outarg}; $self->{var_num} = $self->{args_match}->{$outarg}; if ($outcode) { print "\t$outcode\n"; print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; } else { $self->generate_output( { type => $self->{var_types}->{$outarg}, num => $self->{var_num}, var => $outarg, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ); } delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; } } sub C_ARGS_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); $self->{func_args} = $in; } sub INTERFACE_MACRO_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); if ($in =~ /\s/) { # two ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; } else { $self->{interface_macro} = $in; $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later } $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub INTERFACE_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); foreach (split /[\s,]+/, $in) { my $iface_name = $_; $iface_name =~ s/^$self->{Prefix}//; $self->{Interfaces}->{$iface_name} = $_; } print Q(<<"EOF"); # XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); EOF $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub CLEANUP_handler { my $self = shift; $self->print_section(); } sub PREINIT_handler { my $self = shift; $self->print_section(); } sub POSTCALL_handler { my $self = shift; $self->print_section(); } sub INIT_handler { my $self = shift; $self->print_section(); } sub get_aliases { my $self = shift; my ($line) = @_; my ($orig) = $line; # Parse alias definitions # format is # alias = value alias = value ... while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { my ($alias, $value) = ($1, $2); my $orig_alias = $alias; # check for optional package definition in the alias $alias = $self->{Packprefix} . $alias if $alias !~ /::/; # check for duplicate alias name & duplicate value Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") if defined $self->{XsubAliases}->{$alias}; Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") if $self->{XsubAliasValues}->{$value}; $self->{XsubAliases}->{$alias} = $value; $self->{XsubAliasValues}->{$value} = $orig_alias; } blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") if $line; } sub ATTRS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); push @{ $self->{Attributes} }, $_; } } sub ALIAS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); $self->get_aliases($_) if $_; } } sub OVERLOAD_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$self->{Package}\::(".$1; push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } } sub FALLBACK_handler { my ($self, $setting) = @_; # the rest of the current line should contain either TRUE, # FALSE or UNDEF trim_whitespace($setting); $setting = uc($setting); 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 $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; $self->{Fallback} = $map{$setting}; } sub REQUIRE_handler { # the rest of the current line should contain a version number my ($self, $ver) = @_; trim_whitespace($ver); $self->death("Error: REQUIRE expects a version number") unless $ver; # check that the version number is of the form n.n $self->death("Error: REQUIRE: expected a number, got '$ver'") unless $ver =~ /^\d+(\.\d*)?/; $self->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 my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; } sub PROTOTYPE_handler { my $self = shift; $_ = shift; my $specified; $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") if $self->{proto_in_this_xsub}++; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; $specified = 1; trim_whitespace($_); if ($_ eq 'DISABLE') { $self->{ProtoThisXSUB} = 0; } elsif ($_ eq 'ENABLE') { $self->{ProtoThisXSUB} = 1; } else { # remove any whitespace s/\s+//g; $self->death("Error: Invalid prototype '$_'") unless valid_proto_string($_); $self->{ProtoThisXSUB} = C_string($_); } } # If no prototype specified, then assume empty prototype "" $self->{ProtoThisXSUB} = 2 unless $specified; $self->{ProtoUsed} = 1; } sub SCOPE_handler { # Rest of line should be either ENABLE or DISABLE my ($self, $setting) = @_; $self->death("Error: Only 1 SCOPE declaration allowed per xsub") if $self->{scope_in_this_xsub}++; trim_whitespace($setting); $self->death("Error: SCOPE: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)\b/i; $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); } sub PROTOTYPES_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: PROTOTYPES: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; $self->{ProtoUsed} = 1; } sub EXPORT_XSUB_SYMBOLS_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; print Q(<<"EOF"); ##undef XS_EUPXS ##if defined(PERL_EUPXS_ALWAYS_EXPORT) ## define XS_EUPXS(name) XS_EXTERNAL(name) ##elif defined(PERL_EUPXS_NEVER_EXPORT) ## define XS_EUPXS(name) XS_INTERNAL(name) ##else ## define XS_EUPXS(name) $xs_impl(name) ##endif EOF } sub PushXSStack { my $self = shift; my %args = @_; # Save the current file context. push(@{ $self->{XSStack} }, { type => 'file', LastLine => $self->{lastline}, LastLineNo => $self->{lastline_no}, Line => $self->{line}, LineNo => $self->{line_no}, Filename => $self->{filename}, Filepathname => $self->{filepathname}, Handle => $self->{FH}, IsPipe => scalar($self->{filename} =~ /\|\s*$/), %args, }); } sub INCLUDE_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid filename trim_whitespace($_); $self->death("INCLUDE: filename missing") unless $_; $self->death("INCLUDE: output pipe is illegal") if /^\s*\|/; # simple minded recursion detector $self->death("INCLUDE loop detected") if $self->{IncludedFiles}->{$_}; ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; if (/\|\s*$/ && /^\s*perl\s/) { Warn( $self, "The INCLUDE directive with a command is discouraged." . " Use INCLUDE_COMMAND instead! In particular using 'perl'" . " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . " up the correct perl. The INCLUDE_COMMAND directive allows" . " the use of \$^X as the currently running perl, see" . " 'perldoc perlxs' for details."); } $self->PushXSStack(); $self->{FH} = Symbol::gensym(); # open the new file open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); print Q(<<"EOF"); # #/* INCLUDE: Including '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = ( $^O =~ /^mswin/i ) ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? : File::Spec->catfile($self->{dir}, $self->{filename}); # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub QuoteArgs { my $cmd = shift; my @args = split /\s+/, $cmd; $cmd = shift @args; for (@args) { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; } return join (' ', ($cmd, @args)); } # code copied from CPAN::HandleConfig::safe_quote # - that has doc saying leave if start/finish with same quote, but no code # given text, will conditionally quote it to protect from shell { my ($quote, $use_quote) = $^O eq 'MSWin32' ? (q{"}, q{"}) : (q{"'}, q{'}); sub _safe_quote { my ($self, $command) = @_; # Set up quote/default quote if (defined($command) and $command =~ /\s/ and $command !~ /[$quote]/) { return qq{$use_quote$command$use_quote} } return $command; } } sub INCLUDE_COMMAND_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid command trim_whitespace($_); $_ = QuoteArgs($_) if $^O eq 'VMS'; $self->death("INCLUDE_COMMAND: command missing") unless $_; $self->death("INCLUDE_COMMAND: pipes are illegal") if /^\s*\|/ or /\|\s*$/; $self->PushXSStack( IsPipe => 1 ); $self->{FH} = Symbol::gensym(); # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be # the same perl interpreter as we're currently running my $X = $self->_safe_quote($^X); # quotes if has spaces s/^\s*\$\^X/$X/; # open the new file open ($self->{FH}, "-|", $_) or $self->death( $self, "Cannot run command '$_' to include its output: $!"); print Q(<<"EOF"); # #/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = $self->{filename}; #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub PopFile { my $self = shift; return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; my $data = pop @{ $self->{XSStack} }; my $ThisFile = $self->{filename}; my $isPipe = $data->{IsPipe}; --$self->{IncludedFiles}->{$self->{filename}} unless $isPipe; close $self->{FH}; $self->{FH} = $data->{Handle}; # $filename is the leafname, which for some reason is used for diagnostic # messages, whereas $filepathname is the full pathname, and is used for # #line directives. $self->{filename} = $data->{Filename}; $self->{filepathname} = $data->{Filepathname}; $self->{lastline} = $data->{LastLine}; $self->{lastline_no} = $data->{LastLineNo}; @{ $self->{line} } = @{ $data->{Line} }; @{ $self->{line_no} } = @{ $data->{LineNo} }; if ($isPipe and $? ) { --$self->{lastline_no}; print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; exit 1; } print Q(<<"EOF"); # #/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ # EOF return 1; } sub Q { my($text) = @_; $text =~ s/^#//gm; $text =~ s/\[\[/{/g; $text =~ s/\]\]/}/g; $text; } # Process "MODULE = Foo ..." lines and update global state accordingly sub _process_module_xs_line { my ($self, $module, $pkg, $prefix) = @_; ($self->{Module_cname} = $module) =~ s/\W/_/g; $self->{Package} = defined($pkg) ? $pkg : ''; $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); ($self->{Packid} = $self->{Package}) =~ tr/:/_/; $self->{Packprefix} = $self->{Package}; $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; $self->{lastline} = ""; } # Skip any embedded POD sections sub _maybe_skip_pod { my ($self) = @_; while ($self->{lastline} =~ /^=/) { while ($self->{lastline} = readline($self->{FH})) { last if ($self->{lastline} =~ /^=cut\s*$/); } $self->death("Error: Unterminated pod") unless defined $self->{lastline}; $self->{lastline} = readline($self->{FH}); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } } # This chunk of code strips out (and parses) embedded TYPEMAP blocks # which support a HEREdoc-alike block syntax. sub _maybe_parse_typemap_block { my ($self) = @_; # This is special cased from the usual paragraph-handler logic # due to the HEREdoc-ish syntax. if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) { my $end_marker = quotemeta(defined($1) ? $2 : $3); # Scan until we find $end_marker alone on a line. my @tmaplines; while (1) { $self->{lastline} = readline($self->{FH}); $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; last if $self->{lastline} =~ /^$end_marker\s*$/; push @tmaplines, $self->{lastline}; } my $tmap = ExtUtils::Typemaps->new( string => join("", @tmaplines), lineno_offset => 1 + ($self->current_line_number() || 0), fake_filename => $self->{filename}, ); $self->{typemap}->merge(typemap => $tmap, replace => 1); $self->{lastline} = ""; } } # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). sub fetch_para { my $self = shift; # parse paragraph $self->death("Error: Unterminated '#if/#ifdef/#ifndef'") if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; @{ $self->{line} } = (); @{ $self->{line_no} } = (); return $self->PopFile() if not defined $self->{lastline}; # EOF if ($self->{lastline} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { $self->_process_module_xs_line($1, $2, $3); } for (;;) { $self->_maybe_skip_pod; $self->_maybe_parse_typemap_block; if ($self->{lastline} !~ /^\s*#/ # not a CPP directive # 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) || $self->{lastline} =~ /^\#[ \t]* (?: (?:if|ifn?def|elif|else|endif| define|undef|pragma|error| warning|line\s+\d+|ident) \b | (?:include(?:_next)?|import) \s* ["<] .* [>"] ) /x ) { last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; push(@{ $self->{line} }, $self->{lastline}); push(@{ $self->{line_no} }, $self->{lastline_no}); } # Read next line and continuation lines last unless defined($self->{lastline} = readline($self->{FH})); $self->{lastline_no} = $.; my $tmp_line; $self->{lastline} .= $tmp_line while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } # Nuke trailing "line" entries until there's one that's not empty pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq ""; return 1; } sub output_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $init, $printed_name) = @{$argsref}{qw(type num var init printed_name)}; # local assign for efficiently passing in to eval_input_typemap_code local $argsref->{arg} = $num ? "ST(" . ($num-1) . ")" : "/* not a parameter */"; if ( $init =~ /^=/ ) { if ($printed_name) { $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); } else { $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); } } else { if ( $init =~ s/^\+// && $num ) { $self->generate_init( { type => $type, num => $num, var => $var, printed_name => $printed_name, } ); } elsif ($printed_name) { print ";\n"; $init =~ s/^;//; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); $init =~ s/^;//; } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); } } sub generate_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $printed_name) = @{$argsref}{qw(type num var printed_name)}; my $argoff = $num - 1; my $arg = "ST($argoff)"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); if (not $typemaps->get_typemap(ctype => $type)) { $self->report_typemap_failure($typemaps, $type); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $typem = $typemaps->get_typemap(ctype => $type); my $xstype = $typem->xstype; #this is an optimization from perl 5.0 alpha 6, class check is skipped #T_REF_IV_REF is missing since it has no untyped analog at the moment $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ if $self->{func_name} =~ /DESTROY$/; if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { print "\t$var" unless $printed_name; print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; die "default value not supported with length(NAME) supplied" if defined $self->{defaults}->{$var}; return; } $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; my $inputmap = $typemaps->get_inputmap(xstype => $xstype); if (not defined $inputmap) { $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); return; } my $expr = $inputmap->cleaned_code; # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); if (not $subinputmap) { $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $subinputmap->cleaned_code; $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 $self->{ScopeThisXSUB} = 1; } my $eval_vars = { var => $var, printed_name => $printed_name, type => $type, ntype => $ntype, subtype => $subtype, num => $num, arg => $arg, argoff => $argoff, }; if (defined($self->{defaults}->{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } if ($self->{defaults}->{$var} eq 'NO_INIT') { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } else { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } } elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); } else { die "panic: do not know how to handle this branch for function pointers" if $printed_name; $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); } } sub generate_output { my $self = shift; my $argsref = shift; my ($type, $num, $var, $do_setmagic, $do_push) = @{$argsref}{qw(type num var do_setmagic do_push)}; my $arg = "ST(" . ($num - ($num != 0)) . ")"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); local $argsref->{type} = $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 { my $typemap = $typemaps->get_typemap(ctype => $type); if (not $typemap) { $self->report_typemap_failure($typemaps, $type); return; } my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); if (not $outputmap) { $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; my $expr = $outputmap->cleaned_code; if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); if (not $suboutputmap) { $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $suboutputmap->cleaned_code; $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/; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { my $orig_arg = $arg; my $indent; my $use_RETVALSV = 1; my $do_mortal = 0; my $do_copy_tmp = 1; my $pre_expr; local $eval_vars->{arg} = $arg = 'RETVALSV'; my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); if ($expr =~ /^\t\Q$arg\E = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. $do_mortal = 1; } # If RETVAL is immortal, don't mortalize it. This code is not perfect: # It won't detect a func or expression that only returns immortals, for # example, this RE must be tried before next elsif. elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV $use_RETVALSV = 0; } elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { # We expect that $arg has refcnt >=1, so we need # to mortalize it! $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block $do_mortal = 1; } else { # Just hope that the entry would safely write it # over an already mortalized value. By # coincidence, something like $arg = &PL_sv_undef # works too, but should be caught above. $pre_expr = "RETVALSV = sv_newmortal();\n"; # new mortals don't have set magic $do_setmagic = 0; } if($use_RETVALSV) { print "\t{\n\t SV * RETVALSV;\n"; $indent = "\t "; } else { $indent = "\t"; } print $indent.$pre_expr if $pre_expr; if($use_RETVALSV) { #take control of 1 layer of indent, may or may not indent more $evalexpr =~ s/^(\t| )/$indent/gm; #"\t \t" doesn't draw right in some IDEs #break down all \t into spaces $evalexpr =~ s/\t/ /g; #rebuild back into \t'es, \t==8 spaces, indent==4 spaces $evalexpr =~ s/ /\t/g; } else { if($do_mortal || $do_setmagic) { #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code } else { #if no extra boilerplate (no mortal, no set magic) is needed #after $evalexport, get rid of RETVALSV's visual cluter and change $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) } } #stop " RETVAL = RETVAL;" for SVPtr type print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" if $do_mortal || $do_setmagic || $do_copy_tmp; print "\t}\n" if $use_RETVALSV; } elsif ($do_push) { print "\tPUSHs(sv_newmortal());\n"; local $eval_vars->{arg} = "ST($num)"; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } elsif ($arg =~ /^ST\(\d+\)$/) { $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } # Just delegates to a clean package. # Shim to evaluate Perl code in the right variable context # for typemap code (having things such as $ALIAS set up). sub eval_output_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); } sub eval_input_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); } 1; # vim: ts=2 sw=2 et: MM_Win95.pm 0000644 00000002377 15140257564 0006430 0 ustar 00 package ExtUtils::MM_Win95; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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. =over 4 =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 https://metacpan.org/release/ExtUtils-MakeMaker. =cut 1; MM_Darwin.pm 0000644 00000001642 15140257564 0006733 0 ustar 00 package ExtUtils::MM_Darwin; use strict; BEGIN { require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Unix ); } our $VERSION = '7.44'; $VERSION =~ tr/_//d; =head1 NAME ExtUtils::MM_Darwin - special behaviors for OS X =head1 SYNOPSIS For internal MakeMaker use only =head1 DESCRIPTION See L<ExtUtils::MM_Unix> or L<ExtUtils::MM_Any> for documentation on the methods overridden here. =head2 Overridden 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; xsubpp 0000644 00000011717 15140257564 0006030 0 ustar 00 #!perl use 5.006; BEGIN { pop @INC if $INC[-1] eq '.' } use strict; eval { require ExtUtils::ParseXS; 1; } or do { my $err = $@ || 'Zombie error'; my $v = $ExtUtils::ParseXS::VERSION; $v = '<undef>' if not defined $v; die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err"; }; use Getopt::Long; my %args = (); my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|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|strip=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; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file(%args); exit( $pxs->report_error_count() ? 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> or by L<Module::Build> or other Perl module build tools. 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. =item B<-s=...> or B<-strip=...> I<This option is obscure and discouraged.> If specified, the given string will be stripped off from the beginning of the C function name in the generated XS functions (if it starts with that prefix). This only applies to XSUBs without C<CODE> or C<PPCODE> blocks. For example, the XS: void foo_bar(int i); when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar> function in Perl, but really call C<bar(i)> in C. Most of the time, this is the opposite of what you want and failure modes are somewhat obscure, so please avoid this option where possible. =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 MM_DOS.pm 0000644 00000002033 15140257564 0006127 0 ustar 00 package ExtUtils::MM_DOS; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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; } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =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; MM_MacOS.pm 0000644 00000001567 15140257564 0006457 0 ustar 00 package ExtUtils::MM_MacOS; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; sub new { die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'; } =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. Anyone interested in resurrecting this file should pull the old version from the MakeMaker CVS repository and contact makemaker@perl.org. =cut 1; MM_BeOS.pm 0000644 00000002030 15140257564 0006267 0 ustar 00 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 L<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 = '7.44'; $VERSION =~ tr/_//d; =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_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; $self->{EXPORT_LIST} ||= ''; } =back =cut 1; __END__ Constant/Utils.pm 0000644 00000006702 15140257564 0010011 0 ustar 00 package ExtUtils::Constant::Utils; use strict; use vars qw($VERSION @EXPORT_OK @ISA); use Carp; @ISA = 'Exporter'; @EXPORT_OK = qw(C_stringify perl_stringify); $VERSION = '0.04'; use constant is_perl55 => ($] < 5.005_50); use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); use constant is_sane_perl => $] > 5.007; =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 more so 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; unless (is_perl55) { # This will elicit a warning on 5.005_03 about [: :] being reserved unless # I cheat my $cheat = '([[:^print:]])'; if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. s/$cheat/sprintf "\\%03o", ord $1/ge; } else { s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; } 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 (is_perl55) { # This will elicit a warning on 5.005_03 about [: :] being reserved unless # I cheat my $cheat = '([[:^print:]])'; if (is_sane_perl) { if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. s/$cheat/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; } 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 Constant/Base.pm 0000644 00000101052 15140257564 0007555 0 ustar 00 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.06'; 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_ifndef { my ($self, $macro) = @_; if (ref $macro) { # Can't invert these stylishly, so "bodge it" return "$macro->[0]#else\n"; } if (defined $macro && $macro ne "" && $macro ne "1") { return $macro ? "#ifndef $macro\n" : "#if 1\n"; } croak "Can't generate an ifndef for unconditional code"; } 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 do 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 # original 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 Constant/XS.pm 0000644 00000014321 15140257564 0007237 0 ustar 00 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; Constant/ProxySubs.pm 0000644 00000046436 15140257564 0010677 0 ustar 00 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.09'; @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, $push) = @_; 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(); if ($push) { return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); while ($iterator->name) { he = $subname($athx $hash, $iterator->name, $iterator->namelen, %s); av_push(push, newSVhek(HeKEY_hek(he))); ++$iterator; } EOBOOT } else { 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, $default_type, $package) = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)}; my $xs_subname = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant'; my $options = $ARGS->{PROXYSUBS}; $options = {} unless ref $options; my $push = $options->{push}; my $explosives = $options->{croak_on_read}; my $croak_on_error = $options->{croak_on_error}; my $autoload = $options->{autoload}; { my $exclusive = 0; ++$exclusive if $explosives; ++$exclusive if $croak_on_error; ++$exclusive if $autoload; # Until someone patches this (with test cases): carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together") if $exclusive > 1; } # Strictly it requires Perl_caller_cx carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later") if $croak_on_error && $^V < v5.13.5; # Strictly this is actually 5.8.9, but it's not well tested there my $can_do_pcs = $] >= 5.009; # Until someone patches this (with test cases) carp ("PROXYSUBS option 'push' requires v5.10 or later") if $push && !$can_do_pcs; # Until someone patches this (with test cases) carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together") if $explosives && $push; # 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) . '::'; $push = C_stringify($package . '::' . $push) if $push; my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; print $c_fh $self->header(); if ($autoload || $croak_on_error) { print $c_fh <<'EOC'; /* This allows slightly more efficient code on !USE_ITHREADS: */ #ifdef USE_ITHREADS # define COP_FILE(c) CopFILE(c) # define COP_FILE_F "s" #else # define COP_FILE(c) CopFILESV(c) # define COP_FILE_F SVf #endif EOC } my $return_type = $push ? 'HE *' : 'void'; print $c_fh <<"EOADD"; static $return_type ${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"; HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL, 0); SV *sv; if (!he) { croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", name); } sv = HeVAL(he); 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 " return he;\n" if $push; 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); croak("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: { #if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT) dTHX; #endif HV *symbol_table = get_hv("$symbol_table", GV_ADD); EOBOOT if ($push) { print $xs_fh <<"EOC"; AV *push = get_av(\"$push\", GV_ADD); HE *he; EOC } 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 $lc_type = $type ? lc($type) : 'notfound'; my $struct_type = $lc_type . '_s'; my $array_name = 'values_for_' . $lc_type; $iterator{$type} = 'value_for_' . $lc_type; # Give the notfound struct file scope. The others are scoped within the # BOOT block my $struct_fh = $type ? $xs_fh : $c_fh; print $c_fh "struct $struct_type $struct;\n"; print $struct_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; } if ($item->{invert_macro}) { print $struct_fh $self->macro_to_ifndef($macro); print $struct_fh " /* This is the default value: */\n" if $type; } else { print $struct_fh $ifdef; } print $struct_fh " { ", join (', ', "\"$name\"", $namelen, &$type_to_value($value)), " },\n", $self->macro_to_endif($macro); } # Terminate the list with a NULL print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; print $xs_fh <<"EOBOOT" if $type; const struct $struct_type *$iterator{$type} = $array_name; EOBOOT } delete $found->{''}; 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, $push); } print $xs_fh <<"EOBOOT"; if (C_ARRAY_LENGTH(values_for_notfound) > 1) { #ifndef SYMBIAN HV *const ${c_subname}_missing = get_missing_hash(aTHX); #endif const struct notfound_s *value_for_notfound = values_for_notfound; do { 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. */ HE *he = (HE*) hv_common_key_len(symbol_table, value_for_notfound->name, value_for_notfound->namelen, HV_FETCH_LVALUE, NULL, 0); SV *sv; #ifndef SYMBIAN HEK *hek; #endif if (!he) { croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", value_for_notfound->name); } sv = HeVAL(he); 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 hek = HeKEY_hek(he); if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE, &PL_sv_yes, HEK_HASH(hek))) croak("Couldn't add key '%s' to missing_hash", value_for_notfound->name); #endif DONT print $xs_fh " av_push(push, newSVhek(hek));\n" if $push; print $xs_fh <<"EOBOOT"; } while ((++value_for_notfound)->name); } 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); } if ($] >= 5.009) { print $xs_fh <<EOBOOT; /* As we've been creating subroutines, we better invalidate any cached methods */ mro_method_changed_in(symbol_table); } EOBOOT } else { print $xs_fh <<EOBOOT; /* As we've been creating subroutines, we better invalidate any cached methods */ ++PL_sub_generation; } EOBOOT } return if !defined $xs_subname; if ($croak_on_error || $autoload) { print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA'; void $xs_subname(sv) INPUT: SV * sv; PREINIT: const PERL_CONTEXT *cx = caller_cx(0, NULL); /* cx is NULL if we've been called from the top level. PL_curcop isn't ideal, but it's much cheaper than other ways of not going SEGV. */ const COP *cop = cx ? cx->blk_oldcop : PL_curcop; EOC void AUTOLOAD() PROTOTYPE: DISABLE PREINIT: SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); const COP *cop = PL_curcop; EOA print $xs_fh <<"EOC"; PPCODE: #ifndef SYMBIAN /* It's not obvious how to calculate this at C pre-processor time. However, any compiler optimiser worth its salt should be able to remove the dead code, and hopefully the now-obviously-unused static function too. */ HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) ? get_missing_hash(aTHX) : NULL; if ((C_ARRAY_LENGTH(values_for_notfound) > 1) ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf ", used at %" COP_FILE_F " line %" UVuf "\\n", sv, COP_FILE(cop), (UV)CopLINE(cop)); } else #endif { sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro at %" COP_FILE_F " line %" UVuf "\\n", sv, COP_FILE(cop), (UV)CopLINE(cop)); } croak_sv(sv_2mortal(sv)); EOC } else { 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) INPUT: SV * sv; PPCODE: #ifndef SYMBIAN /* It's not obvious how to calculate this at C pre-processor time. However, any compiler optimiser worth its salt should be able to remove the dead code, and hopefully the now-obviously-unused static function too. */ HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) ? get_missing_hash(aTHX) : NULL; if ((C_ARRAY_LENGTH(values_for_notfound) > 1) ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf ", used", sv); } else #endif { sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro", sv); } PUSHs(sv_2mortal(sv)); DONT } } 1; Manifest.pm 0000644 00000055657 15140257564 0006703 0 ustar 00 package ExtUtils::Manifest; # git description: 1.71-18-g17b7919 require Exporter; use Config; use File::Basename; use File::Copy 'copy'; use File::Find; use File::Spec 0.8; use Carp; use strict; use warnings; our $VERSION = '1.72'; our @ISA = ('Exporter'); our @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck manifind maniread manicopy maniadd maniskip ); our $Is_MacOS = $^O eq 'MacOS'; our $Is_VMS = $^O eq 'VMS'; our $Is_VMS_mode = 0; our $Is_VMS_lc = 0; our $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); } our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; our $Quiet = 0; our $MANIFEST = 'MANIFEST'; our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); =head1 NAME ExtUtils::Manifest - Utilities to write and check a MANIFEST file =head1 VERSION version 1.72 =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 ... =head1 FUNCTIONS ExtUtils::Manifest exports no functions by default. The following are exported on request: =head2 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: $!"; binmode M, ':raw'; 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; if ( $Is_VMS ) { $filename =~ s/\.$//; # trim trailing dot $filename = VMS::Filespec::unixify($filename); # unescape spaces, etc. if( $Is_VMS_lc ) { $filename = lc($filename); $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i; } } return $filename; } =head2 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 $_; $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, follow_fast => 1}, $Is_MacOS ? ":" : "."); return $found; } =head2 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(); } =head2 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(); } =head2 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()]; } =head2 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; } =head2 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; } if( $Is_VMS_lc ) { $file = lc($file); $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i; } } $read->{$file} = $comment; } close M; $read; } =head2 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; } binmode M, ':raw'; 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; } =head2 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; } =head2 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: $!"; binmode MANIFEST, ':raw'; 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; } # Make sure this MANIFEST is consistently written with native # newlines and has a terminal newline. sub _fix_manifest { my $manifest_file = shift; open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; local $/; my @manifest = split /(\015\012|\012|\015)/, <MANIFEST>, -1; close MANIFEST; my $must_rewrite = ""; if ($manifest[-1] eq ""){ # sane case: last line had a terminal newline pop @manifest; for (my $i=1; $i<=$#manifest; $i+=2) { unless ($manifest[$i] eq "\n") { $must_rewrite = "not a newline at pos $i"; last; } } } else { $must_rewrite = "last line without newline"; } if ( $must_rewrite ) { 1 while unlink $MANIFEST; # avoid multiple versions on VMS open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!"; binmode MANIFEST, ':raw'; for (my $i=0; $i<=$#manifest; $i+=2) { print MANIFEST "$manifest[$i]\n"; } close MANIFEST or die "could not write $MANIFEST: $!"; } } # UNIMPLEMENTED sub _normalize { return; } =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> Currently maintained by the Perl Toolchain Gang. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1996- by Andreas Koenig. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut 1; CBuilder.pm 0000644 00000021263 15140257564 0006610 0 ustar 00 package ExtUtils::CBuilder; use File::Spec (); use File::Path (); use File::Basename (); use Perl::OSType qw/os_type/; use warnings; use strict; our $VERSION = '0.280234'; # VERSION our @ISA; # 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__; my $ostype = os_type(); if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) { $load->(__PACKAGE__ . "::Platform::$^O"); } elsif ( $ostype && grep {-e File::Spec->catfile($_, @package, 'Platform', $ostype) . '.pm'} @INC) { $load->(__PACKAGE__ . "::Platform::$ostype"); } else { $load->(__PACKAGE__ . "::Base"); } } 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 SUPPORT ExtUtils::CBuilder is maintained as part of the Perl 5 core. Please submit any bug reports via the F<perlbug> tool included with Perl 5. Bug reports will be included in the Perl 5 ticket system at L<https://rt.perl.org>. The Perl 5 source code is available at L<https://perl5.git.perl.org/perl.git> and ExtUtils-CBuilder may be found in the F<dist/ExtUtils-CBuilder> directory of the repository. =head1 AUTHOR Ken Williams, kwilliams@cpan.org Additional contributions by The Perl 5 Porters. =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 MM_VMS.pm 0000644 00000205251 15140257564 0006156 0 ustar 00 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 = '7.44'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); 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 L<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 L<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 "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 "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 "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 0; # false and not empty } =item _fixin_replace_shebang (override) Helper routine for L<< MM->fixin()|ExtUtils::MM_Unix/fixin >>, overridden because there's no such thing as an actual shebang line that will be interpreted by the shell, so we just prepend $Config{startperl} and preserve the shebang line argument for any switches it may contain. =cut sub _fixin_replace_shebang { my ( $self, $file, $line ) = @_; my ( undef, $arg ) = split ' ', $line, 2; return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n"; } =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) The list of macro definitions to be passed through must be specified using the /MACRO qualifier and must not add another /DEFINE qualifier. We prepend our own comma here to the contents of $(PASTHRU_DEFINE) because it is often empty and a comma always present in CCFLAGS would generate a missing qualifier value error. =cut sub pasthru { my($self) = shift; my $pasthru = $self->SUPER::pasthru; $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|; $pasthru =~ s|\n\z|)\n|m; $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig; return $pasthru; } =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 separator 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_tools (override) Provide VMS-specific forms of various utility commands. Sets DEV_NULL to nothing because I don't know how to do it on VMS. 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_tools { 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->{UMASK_NULL} = '! '; $self->SUPER::init_tools; # Use the default shell $self->{SHELL} ||= 'Posix'; # 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} = ''; return; } =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_ARCHLIBDEP PERL_INC PERL_SRC ], (map { 'INSTALL'.$_ } $self->installvars), (map { 'DESTINSTALL'.$_ } $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 / ) { next unless defined $self->{$macro}; $self->{$macro} = $self->fixpath($self->{$macro},0); } for my $macro (qw/ OBJECT LDFROM / ) { next unless defined $self->{$macro}; # Must expand macros before splitting on unescaped whitespace. $self->{$macro} = $self->eliminate_macros($self->{$macro}); if ($self->{$macro} =~ /(?<!\^)\s/) { $self->{$macro} =~ s/(\\)?\n+\s+/ /g; $self->{$macro} = $self->wraplist( map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro} ); } else { $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 "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; # PASTHRU_DEFINE will have its own comma $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')'; } } $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 /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) .cpp$(OBJ_EXT) : $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) .cxx$(OBJ_EXT) : $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) '; } =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_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c '; } =item xs_o (override) Use MM[SK] macros, and VMS command line for C compiler. =cut sub xs_o { my ($self) = @_; return '' unless $self->needs_linking(); my $frag = ' .xs$(OBJ_EXT) : $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) '; if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my $version = $self->parse_version("$ext.pm"); my $ccflags = $self->{CCFLAGS}; $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/; $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/; $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC'); $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE'); $frag .= _sprintf562 <<'EOF', $ext, $ccflags; %1$s$(OBJ_EXT) : %1$s.xs $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c $(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) EOF } } $frag; } =item _xsbuild_replace_macro (override) There is no simple replacement possible since a qualifier and all its subqualifiers must be considered together, so we use our own utility routine for the replacement. =cut sub _xsbuild_replace_macro { my ($self, undef, $xstype, $ext, $varname) = @_; my $value = $self->_xsbuild_value($xstype, $ext, $varname); return unless defined $value; $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname); } =item _xsbuild_value (override) Convert the extension spec to Unix format, as that's what will match what's in the XSBUILD data structure. =cut sub _xsbuild_value { my ($self, $xstype, $ext, $varname) = @_; $ext = unixify($ext); return $self->SUPER::_xsbuild_value($xstype, $ext, $varname); } sub _vms_replace_qualifier { my ($self, $flags, $newflag, $macro) = @_; my $qual_type; my $type_suffix; my $quote_subquals = 0; my @subquals_new = split /\s+/, $newflag; if ($macro eq 'DEFINE') { $qual_type = 'Def'; $type_suffix = 'ine'; map { $_ =~ s/^-D// } @subquals_new; $quote_subquals = 1; } elsif ($macro eq 'INC') { $qual_type = 'Inc'; $type_suffix = 'lude'; map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new; } my @subquals = (); while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) { my $term = $1; $term =~ s/\"//g; $term =~ s:^\((.+)\)$:$1:; push @subquals, split /,/, $term; } for my $new (@subquals_new) { my ($sq_new, $sqval_new) = split /=/, $new; my $replaced_old = 0; for my $old (@subquals) { my ($sq, $sqval) = split /=/, $old; if ($sq_new eq $sq) { $old = $sq_new; $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new); $replaced_old = 1; last; } } push @subquals, $new unless $replaced_old; } if (@subquals) { $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig; # add quotes if requested but not for unexpanded macros map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals; $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')'; } return $flags; } sub xs_dlsyms_ext { '.opt'; } =item dlsyms (override) Create VMS linker options files specifying universal symbols for this extension's shareable image(s), and listing other shareable images or libraries to which it should be linked. =cut sub dlsyms { my ($self, %attribs) = @_; return '' unless $self->needs_linking; $self->xs_dlsyms_iterator; } sub xs_make_dlsyms { my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; my @m; my $instloc; if ($self->{XSMULTI}) { my ($v, $d, $f) = File::Spec->splitpath($target); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f); push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'dynamic'}; push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'static'}; push @m, "\n", sprintf <<'EOF', $instloc, $target; %s : %s $(CP) $(MMS$SOURCE) $(MMS$TARGET) EOF } else { push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'dynamic'}; push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'static'}; push @m, "\n", sprintf <<'EOF', $target; $(INST_ARCHAUTODIR)$(BASEEXT).opt : %s $(CP) $(MMS$SOURCE) $(MMS$TARGET) EOF } push @m, "\n$target : $dep\n\t", q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name, q!', 'DLBASE' => '!,$dlbase, q!', 'DL_FUNCS' => !,neatvalue($funcs), q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars); push @m, $extra if defined $extra; push @m, qq!);"\n\t!; # Can't use dlbase as it's been through mod2fname. my $olb_base = basename($target, '.opt'); if ($self->{XSMULTI}) { # We've been passed everything but the kitchen sink -- and the location of the # static library we're using to build the dynamic library -- so concoct that # location from what we do have. my $olb_dir = $self->catdir(dirname($instloc), $olb_base); push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!; push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base); push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"; } else { push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/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_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/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 xs_obj_opt Override to fixup -o flags. =cut sub xs_obj_opt { my ($self, $output_file) = @_; "/OBJECT=$output_file"; } =item dynamic_lib (override) Use VMS Link command. =cut sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s EOF } sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my $shr = $Config{'dbgprefix'} . 'PerlShr'; $exportlist =~ s/.def$/.opt/; # it's a linker options file # 1 2 3 4 5 _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}"; %1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option EOF } =item xs_make_static_lib (override) Use VMS commands to manipulate object library. =cut sub xs_make_static_lib { my ($self, $object, $to, $todir) = @_; my @objects; if ($self->{XSMULTI}) { # The extension name should be the main object file name minus file type. my $lib = $object; $lib =~ s/\$\(OBJ_EXT\)\z//; my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT'); $object = $override if defined $override; @objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object; } else { push @objects, $object; } my @m; for my $obj (@objects) { push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir); } push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects)); # 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}) { for my $obj (@objects) { push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\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 static_lib_pure_cmd (override) Use VMS commands to manipulate object library. =cut sub static_lib_pure_cmd { my ($self, $from) = @_; sprintf <<'MAKE_FRAG', $from; If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) Library/Object/Replace $(MMS$TARGET) %s MAKE_FRAG } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =item extra_clean_files Clean up some OS specific files. Plus the temp file used to shorten a lot of commands. And the name mangler database. =cut sub extra_clean_files { return qw( *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso .MM_Tmp cxx_repository ); } =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) install_vendor :: all 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" # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: ]; push @m, q[ $(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 ] unless $self->{NO_PACKLIST}; push @m, q[ $(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 :: ]; push @m, q[ $(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 ] unless $self->{NO_PACKLIST}; push @m, q[ $(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 :: ]; push @m, q[ $(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 ] unless $self->{NO_PACKLIST}; push @m, q[ $(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 ]; push @m, q[ # Ditto doc_perl_install :: $(NOECHO) $(NOOP) # And again doc_site_install :: $(NOECHO) $(NOOP) doc_vendor_install :: $(NOECHO) $(NOOP) ] if $self->{NO_PERLLOCAL}; push @m, q[ # 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 ] unless $self->{NO_PERLLOCAL}; 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[ uninstall_from_sitedirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ uninstall_from_vendordirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ ]; join('',@m); } =item perldepend (override) Use VMS-style syntax for files; it's cheaper to just do it directly here than to have the L<MM_Unix|ExtUtils::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); if ($self->{OBJECT}) { # Need to add an object file dependency on the perl headers. # this is very important for XS modules in perl.git development. push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC) } 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),sort 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) || $a cmp $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 "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 "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) Ensure 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 ) { warn " 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 ) { warn " no new prefix.\n" if $Verbose >= 2; } else { warn " prefixify $var => $path\n" if $Verbose >= 2; warn " from $sprefix to $rprefix\n" if $Verbose >= 2; my($path_vol, $path_dirs) = $self->splitpath( $path ); if( $path_vol eq $Config{vms_prefix}.':' ) { warn " $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) = @_; warn " cannot prefix, using default.\n" if $Verbose >= 2; if( !$default ) { warn "No default!\n" if $Verbose >= 1; return; } if( !$rprefix ) { warn "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+$}{}; my @cmds = split /\n/, $cmd; $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; $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, it's faster. =cut sub echo { my($self, $text, $file, $opts) = @_; # Compatibility with old options if( !ref $opts ) { my $append = $opts; $opts = { append => $append || 0 }; } my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write'; $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; my $ql_opts = { allow_variables => $opts->{allow_variables} }; my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) } split /\n/, $text; push @cmds, '$(NOECHO) Close MMECHOFILE'; return @cmds; } =item quote_literal =cut sub quote_literal { my($self, $text, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # I believe this is all we should need. $text =~ s{"}{""}g; $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return qq{"$text"}; } =item escape_dollarsigns Quote, don't escape. =cut sub escape_dollarsigns { my($self, $text) = @_; # Quote dollar signs which are not starting a variable $text =~ s{\$ (?!\() }{"\$"}gx; return $text; } =item escape_all_dollarsigns Quote, don't escape. =cut sub escape_all_dollarsigns { my($self, $text) = @_; # Quote dollar signs $text =~ s{\$}{"\$\"}gx; return $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_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; } =item catdir (override) =item catfile (override) Eliminate the macros in the output to the MMS/MMK file. (L<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 L<File::Spec::VMS> is deprecated. =cut sub eliminate_macros { my($self,$path) = @_; return '' unless $path; $self = {} unless ref $self; 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 = $self->{$macro}; # Don't unixify if there is unescaped whitespace $macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/); $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 L<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 =~ 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'); } =item is_make_type (override) None of the make types being checked for is viable on VMS, plus our $self->{MAKE} is an unexpanded (and unexpandable) macro whose value is known only to the make utility itself. =cut sub is_make_type { my($self, $type) = @_; return 0; } =item make_type (override) Returns a suitable string describing the type of makefile being written. =cut sub make_type { "$Config{make}-style"; } =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; MM_QNX.pm 0000644 00000001575 15140257564 0006162 0 ustar 00 package ExtUtils::MM_QNX; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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; MakeMaker.pm 0000644 00000326151 15140257564 0006760 0 ustar 00 # $Id$ package ExtUtils::MakeMaker; use strict; BEGIN {require 5.006;} require Exporter; use ExtUtils::MakeMaker::Config; use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm use Carp; use File::Path; my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') } if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii'; 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 %macro_fsentity; # whether a macro is a filesystem name our %macro_dep; # whether a macro is a dependency our $VERSION = '7.44'; $VERSION =~ tr/_//d; # 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 $Verbose &prompt &os_unsupported); our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists &WriteEmptyMakefile &open_for_writing &write_file_via_tmp &_sprintf562); # 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'; our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our 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. # 5.6.2 can't do sprintf "%1$s" - this can only do %s sub _sprintf562 { my ($format, @args) = @_; for (my $i = 1; $i <= @args; $i++) { $format =~ s#%$i\$s#$args[$i-1]#g; } $format; } sub WriteMakefile { croak "WriteMakefile: Need even number of args" if @_ % 2; require ExtUtils::MY; my %att = @_; _convert_compat_attrs(\%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 = ( AUTHOR => 'ARRAY', 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', OBJECT => ['ARRAY', ''], PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', BUILD_REQUIRES => 'HASH', CONFIGURE_REQUIRES => 'HASH', TEST_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', XSBUILD => '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 _convert_compat_attrs { #result of running several times should be same my($att) = @_; if (exists $att->{AUTHOR}) { if ($att->{AUTHOR}) { if (!ref($att->{AUTHOR})) { my $t = $att->{AUTHOR}; $att->{AUTHOR} = [$t]; } } else { $att->{AUTHOR} = []; } } } sub _verify_att { my($att) = @_; foreach my $key (sort keys %$att) { my $val = $att->{$key}; 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) = @_; 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 ) { $ans =~ s{\015?\012$}{}; } else { # user hit ctrl-D print "\n"; } } return (!defined $ans || $ans eq '') ? $def : $ans; } sub os_unsupported { die "OS unsupported\n"; } 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("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 @dep_macros = qw/ PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP /; my @fs_macros = qw/ FULLPERL XSUBPPDIR 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 MAKE LIBPERL_A LIB PERL_SRC PERL_INC PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT /; 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 FULLPERLRUN FULLPERLRUNINST FUNCLIST H IMPORTS INC INCLUDE_EXT LDFROM LIBS LICENSE LINKTYPE 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 NO_MYMETA NO_PACKLIST NO_PERLLOCAL NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE PERM_DIR PERM_RW PERM_RWX MAGICXS PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ PUREPERL_ONLY SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit MAN1EXT MAN3EXT MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED /; push @attrib_help, @fs_macros; @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros); @macro_dep{@dep_macros} = (1) x @dep_macros; # 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_bs dynamic 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 _has_cpan_meta_requirements { return eval { require CPAN::Meta::Requirements; CPAN::Meta::Requirements->VERSION(2.130); require B; # CMR requires this, for core we have to too. }; } sub new { my($class,$self) = @_; my($key); _convert_compat_attrs($self) if defined $self && $self; # Store the original args passed to WriteMakefile() foreach my $k (keys %$self) { $self->{ARGS}{$k} = $self->{$k}; } $self = {} unless defined $self; # 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"; # Cleanup all the module requirement bits my %key2cmr; for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { $self->{$key} ||= {}; if (_has_cpan_meta_requirements) { my $cmr = CPAN::Meta::Requirements->from_string_hash( $self->{$key}, { bad_version_hook => sub { #no warnings 'numeric'; # module doesn't use warnings my $fallback; if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf "%f", $_[0]; } else { ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback"; } version->new($fallback); }, }, ); $self->{$key} = $cmr->as_string_hash; $key2cmr{$key} = $cmr; } else { for my $module (sort keys %{ $self->{$key} }) { my $version = $self->{$key}->{$module}; my $fallback = 0; if (!defined($version) or !length($version)) { carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)"; } elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) { next; } else { if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf "%f", $version; } else { ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)"; } } $self->{$key}->{$module} = $fallback; } } } if ("@ARGV" =~ /\bPREREQ_PRINT\b/) { $self->_PREREQ_PRINT; } # PRINT_PREREQ is RedHatism. if ("@ARGV" =~ /\bPRINT_PREREQ\b/) { $self->_PRINT_PREREQ; } print "MakeMaker (v$VERSION)\n" if $Verbose; if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){ check_manifest(); } check_hints($self); if ( defined $self->{MIN_PERL_VERSION} && $self->{MIN_PERL_VERSION} !~ /^v?[\d_\.]+$/ ) { require version; my $normal = eval { local $SIG{__WARN__} = sub { # simulate "use warnings FATAL => 'all'" for vintage perls die @_; }; version->new( $self->{MIN_PERL_VERSION} ) }; $self->{MIN_PERL_VERSION} = $normal if defined $normal && !$@; } # Translate X.Y.Z to X.00Y00Z if( defined $self->{MIN_PERL_VERSION} ) { $self->{MIN_PERL_VERSION} =~ s{ ^v? (\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) { die <<'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 %prereq2version; my $cmr; if (_has_cpan_meta_requirements) { $cmr = CPAN::Meta::Requirements->new; for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key}; } foreach my $prereq ($cmr->required_modules) { $prereq2version{$prereq} = $cmr->requirements_for_module($prereq); } } else { for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { next unless my $module2version = $self->{$key}; $prereq2version{$_} = $module2version->{$_} for keys %$module2version; } } foreach my $prereq (sort keys %prereq2version) { my $required_version = $prereq2version{$prereq}; my $pr_version = 0; my $installed_file; if ( $prereq eq 'perl' ) { if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/ || $required_version !~ /^v?[\d_\.]+$/ ) { require version; my $normal = eval { version->new( $required_version ) }; $required_version = $normal if defined $normal; } $installed_file = $prereq; $pr_version = $]; } else { $installed_file = MM->_installed_file_for_module($prereq); $pr_version = MM->parse_version($installed_file) if $installed_file; $pr_version = 0 if $pr_version eq 'undef'; if ( !eval { version->new( $pr_version ); 1 } ) { #no warnings 'numeric'; # module doesn't use warnings my $fallback; if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf '%f', $pr_version; } else { ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback"; } $pr_version = $fallback; } } # 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} or $UNDER_CORE; $unsatisfied{$prereq} = 'not installed'; } elsif ( $cmr ? !$cmr->accepts_module($prereq, $pr_version) : $required_version > $pr_version ) { warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n", $prereq, $required_version, ($pr_version || 'unknown version') unless $self->{PREREQ_FATAL} or $UNDER_CORE; $unsatisfied{$prereq} = $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}}}; _convert_compat_attrs(\%configure_att); $self = { %$self, %configure_att }; } else { croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\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}; if ($Is_VMS && $key =~ /PERL$/) { # 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); } else { my $value = $self->{$key}; # not going to test in FS so only stripping start $value =~ s/"// if $key =~ /PERL$/ and $self->is_make_type('dmake'); $value =~ s/^"// if $key =~ /PERL$/; $value = $self->catdir("..", $value) unless $self->file_name_is_absolute($value); $value = qq{"$value} if $key =~ /PERL$/; $self->{$key} = $value; } } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE AR FULL_AR CC CCFLAGS OPTIMIZE LD LDDLFLAGS LDFLAGS PERL_ARCHLIB DESTDIR)) { 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, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV); } # RT#91540 PREREQ_FATAL not recognized on command line 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 } $self->{NAME} ||= $self->guess_name; warn "Warning: NAME must be a package name\n" unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!; ($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_tools(); $self->init_others(); $self->init_platform(); $self->init_PERM(); my @args = @ARGV; @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; my($argv) = neatvalue(\@args); $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 { croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; my %att = @_; $att{DIR} = [] unless $att{DIR}; # don't recurse by default 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 : manifypods : subdirs : dynamic : static : clean : install : makemakerdflt : test : test_dynamic : test_static : 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; 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} || {} }, %{ $att->{TEST_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; } # _shellwords and _parseline borrowed from Text::ParseWords sub _shellwords { my (@lines) = @_; my @allwords; foreach my $line (@lines) { $line =~ s/^\s+//; my @words = _parse_line('\s+', 0, $line); pop @words if (@words and !defined $words[-1]); return() unless (@words || !length($line)); push(@allwords, @words); } return(@allwords); } sub _parse_line { my($delimiter, $keep, $line) = @_; my($word, @pieces); no warnings 'uninitialized'; # we will be testing undef strings while (length($line)) { # This pattern is optimised to be stack conservative on older perls. # Do not refactor without being careful and testing it on very long strings. # See Perl bug #42980 for an example of a stack busting input. $line =~ s/^ (?: # double quoted string (") # $quote ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted | # --OR-- # singe quoted string (') # $quote ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted | # --OR-- # unquoted string ( # $unquoted (?:\\.|[^\\"'])*? ) # followed by ( # $delim \Z(?!\n) # EOL | # --OR-- (?-x:$delimiter) # delimiter | # --OR-- (?!^)(?=["']) # a quote ) )//xs or return; # extended layout my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6); return() unless( defined($quote) || length($unquoted) || length($delim)); if ($keep) { $quoted = "$quote$quoted$quote"; } else { $unquoted =~ s/\\(.)/$1/sg; if (defined $quote) { $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); #$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); } } $word .= substr($line, 0, 0); # leave results tainted $word .= defined $quote ? $quoted : $unquoted; if (length($delim)) { push(@pieces, $word); push(@pieces, $delim) if ($keep eq 'delimiters'); undef $word; } if (!length($line)) { push(@pieces, $word); } } return(@pieces); } sub check_manifest { print "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 "Warning: the following files are missing in your kit:\n"; print "\t", join "\n\t", @missed; print "\n"; print "Please inform the author.\n"; } else { print "Looks good\n"; } } sub parse_args{ my($self, @args) = @_; @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; 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 "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; } else { print "$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 "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 "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 " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; print "'$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 "Processing hints file $hint_file\n" if $Verbose; # 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 = $@ || $!; warn $error; } } sub mv_all_methods { my($from,$to) = @_; local $SIG{__WARN__} = sub { # can't use 'no warnings redefined', 5.6 only warn @_ unless $_[0] =~ /^Subroutine .* redefined/ }; foreach my $method (@Overridable) { 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(@_); }; } } } sub skipcheck { my($self) = shift; my($section) = @_; return 'skipped' if $section eq 'metafile' && $UNDER_CORE; if ($section eq 'dynamic') { print "Warning (non-fatal): Target 'dynamic' depends on targets ", "in skipped section 'dynamic_bs'\n" if $self->{SKIPHASH}{dynamic_bs} && $Verbose; print "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 "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 "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 ''; } # returns filehandle, dies on fail. :raw so no :crlf sub open_for_writing { my ($file) = @_; open my $fh ,">", $file or die "Unable to open $file: $!"; my @layers = ':raw'; push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE; binmode $fh, join ' ', @layers; $fh; } sub flush { my $self = shift; my $finalname = $self->{MAKEFILE}; printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT}; print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT}; unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); write_file_via_tmp($finalname, $self->{RESULT}); # Write MYMETA.yml to communicate metadata up to the CPAN clients print "Writing MYMETA.yml and MYMETA.json\n" if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta ); # save memory if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) { my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE); delete $self->{$_} for grep !$keep{$_}, keys %$self; } system("$Config::Config{eunicefix} $finalname") if $Config::Config{eunicefix} ne ":"; return; } sub write_file_via_tmp { my ($finalname, $contents) = @_; my $fh = open_for_writing("MakeMaker.tmp"); die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents; for my $chunk (@$contents) { my $to_write = $chunk; utf8::encode $to_write if !$CAN_DECODE && "$]" > 5.008; print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!"; } close $fh or die "Can't write to MakeMaker.tmp: $!"; _rename("MakeMaker.tmp", $finalname) or warn "rename MakeMaker.tmp => $finalname: $!"; chmod 0644, $finalname if !$Is_VMS; return; } # This is a rename for OS's where the target must be unlinked first. sub _rename { my($src, $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); for my $key (sort keys %$v) { last unless defined $key; # cautious programming in case (undef,undef) is true push @m,"$key=>".neatvalue($v->{$key}); } return "{ ".join(', ',@m)." }"; } sub _find_magic_vstring { my $value = shift; return $value if $UNDER_CORE; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } 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"; } } # added here as selfdocument is not overridable push @m, <<'EOF'; # here so even if top_targets is overridden, these will still be defined # gmake will silently still work if any are .PHONY-ed but nmake won't EOF push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n", # config is so manifypods won't puke if no subdirs grep !$self->{SKIPHASH}{$_}, qw(static dynamic config); join "\n", @m; } 1; __END__ =head1 NAME ExtUtils::MakeMaker - Create a module Makefile =head1 SYNOPSIS use ExtUtils::MakeMaker; WriteMakefile( NAME => "Foo::Bar", VERSION_FROM => "lib/Foo/Bar.pm", ); =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. As there are various Make programs with incompatible syntax, which use operating system shells, again with incompatible syntax, it is important for users of this module to know which flavour of Make a Makefile has been written for so they'll use the correct one and won't have to face the possibly bewildering errors resulting from using the wrong one. On POSIX systems, that program will likely be GNU Make; on Microsoft Windows, it will be either Microsoft NMake, DMake or GNU Make. See the section on the L</"MAKE"> parameter for details. ExtUtils::MakeMaker (EUMM) 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(). All inputs to WriteMakefile are Unicode characters, not just octets. EUMM seeks to handle all of these correctly. It is currently still not possible to portably use Unicode characters in module names, because this requires Perl to handle Unicode filenames, which is not yet the case on Windows. See L<ExtUtils::MakeMaker::FAQ> for details of the design and usage. =head2 How To Write A Makefile.PL See L<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 executes 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. You can also organize your tests within subdirectories in the F<t/> directory. To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you had tests in: t/foo t/foo/bar You could tell make to run tests in both of those directories with the following directives: test => {TESTS => 't/*/*.t t/*/*/*.t'} test => {TESTS => 't/foo/*.t t/foo/bar/*.t'} The first will run all test files in all first-level subdirectories and all subdirectories they contain. The second will run tests in only the F<t/foo> and F<t/foo/bar>. 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 If you want to run particular test files, set the C<TEST_FILES> variable. It is possible to use globbing with this mechanism. make test TEST_FILES='t/foobar.t t/dagobah*.t' Windows users who are using C<nmake> should note that due to a bug in C<nmake>, when specifying C<TEST_FILES> you must use back-slashes instead of forward-slashes. nmake test TEST_FILES='t\foobar.t t\dagobah*.t' =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 by 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 F<Makefile.aperl> (may be system dependent). If you want to force the creation of a new perl, it is recommended that you delete this F<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 by 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 mentioning 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. Attributes that became available with later versions of MakeMaker are indicated. In order to maintain portability of attributes with older versions of MakeMaker you may want to use L<App::EUMM::Upgrade> with your C<Makefile.PL>. =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 Array of strings containing name (and email address) of package author(s). Is used in CPAN Meta files (META.yml or META.json) and 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 Available in version 6.55_03 and above. 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> and the C<build> of the C<prereqs> field of your F<META.json>. Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. 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. The default value is taken from $Config{ccflags}. When overriding CCFLAGS, make sure to include the $Config{ccflags} settings to avoid binary incompatibilities. =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 Available in version 6.52 and above. 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> and the C<configure> of the C<prereqs> field of your F<META.json>. Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. 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 below 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 DLEXT Specifies the extension of the module's loadable object. For example: DLEXT => 'unusual_ext', # Default value is $Config{so} NOTE: When using this option to alter the extension of a module's loadable object, it is also necessary that the module's pm file specifies the same change: local $DynaLoader::dl_dlext = 'unusual_ext'; =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 Available in version 6.30_02 and above. 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. Note that if you do not set this, the value of INSTALLVENDORLIB will be used, which is probably not what you want. =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 Available in version 6.30_02 and above. 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 Available in version 6.31 and above. The licensing terms of your distribution. Generally it's "perl_5" for the same license as Perl itself. See L<CPAN::Meta::Spec> 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 MAGICXS Available in version 6.8305 and above. When this is set to C<1>, C<OBJECT> will be automagically derived from C<O_FILES>. =item MAKE Available in version 6.30_01 and above. 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 precedence. Currently the only significant values are 'dmake' and 'nmake' for Windows users, instructing MakeMaker to generate a Makefile in the flavour of DMake ("Dennis Vadura's Make") or Microsoft NMake respectively. Defaults to $Config{make}, which may go looking for a Make program in your environment. How are you supposed to know what flavour of Make a Makefile has been generated for if you didn't specify a value explicitly? Search the generated Makefile for the definition of the MAKE variable, which is used to recursively invoke the Make utility. That will tell you what Make you're supposed to invoke the Makefile with. =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 Available in version 6.46 and above. A hashref of items to add to the CPAN Meta file (F<META.yml> or F<META.json>). They differ in how they behave if they have the same key as the default metadata. META_ADD will override the default value with its 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. Where prereqs are concerned, if META_MERGE is used, prerequisites are merged with their counterpart C<WriteMakefile()> argument (PREREQ_PM is merged into {prereqs}{runtime}{requires}, BUILD_REQUIRES into C<{prereqs}{build}{requires}>, CONFIGURE_REQUIRES into C<{prereqs}{configure}{requires}>, and TEST_REQUIRES into C<{prereqs}{test}{requires})>. When prereqs are specified with META_ADD, the only prerequisites added to the file come from the metadata, not C<WriteMakefile()> arguments. Note that these configuration options are only used for generating F<META.yml> and F<META.json> -- they are NOT used for F<MYMETA.yml> and F<MYMETA.json>. Therefore data in these fields should NOT be used for dynamic (user-side) configuration. By default CPAN Meta specification C<1.4> is used. In order to use CPAN Meta specification C<2.0>, indicate with C<meta-spec> the version you want to use. META_MERGE => { "meta-spec" => { version => 2 }, resources => { repository => { type => 'git', url => 'git://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker.git', web => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker', }, }, }, =item MIN_PERL_VERSION Available in version 6.48 and above. The minimum required version of Perl for this distribution. Either the 5.006001 or the 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 The package representing the distribution. For example, C<Test::More> or C<ExtUtils::MakeMaker>. It will be used to derive information about the distribution such as the L</DISTNAME>, installation locations within the Perl library and where XS files will be looked for by default (see L</XS>). C<NAME> I<must> be a valid Perl package name and it I<must> have an associated C<.pm> file. For example, C<Foo::Bar> is a valid C<NAME> and there must exist F<Foo/Bar.pm>. Any XS code should be in F<Bar.xs> unless stated otherwise. Your distribution B<must> have a C<NAME>. =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 it's 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 and META.json module meta-data files during 'make distdir'. Defaults to false. =item NO_MYMETA Available in version 6.57_02 and above. When true, suppresses the generation of MYMETA.yml and MYMETA.json module meta-data files during 'perl Makefile.PL'. Defaults to false. =item NO_PACKLIST Available in version 6.7501 and above. When true, suppresses the writing of C<packlist> files for installs. Defaults to false. =item NO_PERLLOCAL Available in version 6.7501 and above. When true, suppresses the appending of installations to C<perllocal>. 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 or an array containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" or ["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. If it contains spaces or other shell metacharacters, it needs to be quoted in a way that protects them, since this value is intended to be inserted in a shell command line in the Makefile. E.g.: # Perl executable lives in "C:/Program Files/Perl/bin" # Normally you don't need to set this yourself! $ perl Makefile.PL PERL='"C:/Program Files/Perl/bin/perl.exe" -w' =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.> Neglecting to set this flag in I<any one> of the 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 Available in version 6.51_01 and above. 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. This basename is actually a build target, and there is an intention, but not a requirement, that the *.PL file make the file passed to to 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'} PL_FILES => {'foo.PL' => 'foo.c'} 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 If an output file depends on extra input files beside the script itself, a hash ref can be used in version 7.36 and above: PL_FILES => { 'foo.PL' => { 'foo.out' => 'foo.in', 'bar.out' => [qw(bar1.in bar2.in)], } In this case the extra input files will be passed to the program after the target file: perl foo.PL foo.out foo.in perl foo.PL bar.out bar1.in bar2.in PL files are normally run B<after> pm_to_blib and include INST_LIB and INST_ARCH in their 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 it's somewhat DWIM). The argument passed to the .PL is set up as a target to build in the Makefile. In other sections such as C<postamble> you can specify a dependency on the filename/argument that the .PL is supposed (or will have, now that that is is a dependency) to generate. Note the file to be generated will still be generated and the .PL will still run even without an explicit dependency created by you, since the C<all> target still depends on running all eligible to run.PL files. =item PM Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIB)/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. You could use: PM_FILTER => 'perl -ne "print unless /^\\#/"', to remove all the leading comments on the fly during the build. In order to be as portable as possible, please consider using a Perl one-liner rather than Unix (or other) utilities, as above. The # is escaped for the Makefile, since what is going to be generated will then be: PM_FILTER = perl -ne "print unless /^\#/" Without the \ before the #, we'd have the start of a Makefile comment, and the macro would be incorrectly defined. You will almost certainly be better off using the C<PL_FILES> system, instead. See above, or the L<ExtUtils::MakeMaker::FAQ> entry. =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 PPM_UNINSTALL_EXEC Available in version 6.8502 and above. Name of the executable used to run C<PPM_UNINSTALL_SCRIPT> below. (e.g. perl) =item PPM_UNINSTALL_SCRIPT Available in version 6.8502 and above. Name of the script that gets executed by the Perl Package Manager before the removal 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 affected 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. For dependencies that are required in order to run C<Makefile.PL>, see C<CONFIGURE_REQUIRES>. Module installation tools have ways of resolving unmet dependencies but to do that they need a F<Makefile>. Using C<PREREQ_FATAL> breaks this. That's bad. Assuming you have good test coverage, your tests should fail with missing dependencies informing the user more strongly that something is wrong. You can write a F<t/00compile.t> test which will simply check that your code compiles and stop "make test" prematurely if it doesn't. See L<Test::More/BAIL_OUT> for more details. =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. The versions given may be a Perl v-string (see L<version>) or a range (see L<CPAN::Meta::Requirements>). This will go into the C<requires> field of your F<META.yml> and the C<runtime> of the C<prereqs> field of your F<META.json>. 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 hashref. =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 Available in version 6.18 and above. 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 TEST_REQUIRES Available in version 6.64 and above. A hash of modules that are needed to test your module but not run or build it. This will go into the C<build_requires> field of your F<META.yml> and the C<test> of the C<prereqs> field of your F<META.json>. The format is the same as PREREQ_PM. =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'; (Putting C<my> or C<local> on the preceding line will work o.k.) "Version strings" are incompatible and 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); 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 XSBUILD Available in version 7.12 and above. Hashref with options controlling the operation of C<XSMULTI>: { xs => { all => { # options applying to all .xs files for this distribution }, 'lib/Class/Name/File' => { # specifically for this file DEFINE => '-Dfunktastic', # defines for only this file INC => "-I$funkyliblocation", # include flags for only this file # OBJECT => 'lib/Class/Name/File$(OBJ_EXT)', # default LDFROM => "lib/Class/Name/File\$(OBJ_EXT) $otherfile\$(OBJ_EXT)", # what's linked }, }, } Note C<xs> is the file-extension. More possibilities may arise in the future. Note that object names are specified without their XS extension. C<LDFROM> defaults to the same as C<OBJECT>. C<OBJECT> defaults to, for C<XSMULTI>, just the XS filename with the extension replaced with the compiler-specific object-file extension. The distinction between C<OBJECT> and C<LDFROM>: C<OBJECT> is the make target, so make will try to build it. However, C<LDFROM> is what will actually be linked together to make the shared object or static library (SO/SL), so if you override it, make sure it includes what you want to make the final SO/SL, almost certainly including the XS basename with C<$(OBJ_EXT)> appended. =item XSMULTI Available in version 7.12 and above. When this is set to C<1>, multiple XS files may be placed under F<lib/> next to their corresponding C<*.pm> files (this is essential for compiling with the correct C<VERSION> values). This feature should be considered experimental, and details of it may change. This feature was inspired by, and small portions of code copied from, L<ExtUtils::MakeMaker::BigHelper>. Hopefully this feature will render that module mainly obsolete. =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 C<-protoypes>, C<-noprototypes> or the empty string. The empty string is equivalent to the xsubpp default, 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 L<MY::postamble()|ExtUtils::MM_Any/postamble (o)> if you have one. =item realclean {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} =item test Specify the targets for testing. {TESTS => 't/*.t'} C<RECURSIVE_TEST_FILES> can be used to include all directories recursively under C<t> that contain C<.t> files. It will be ignored if you provide your own C<TESTS> attribute, defaults to false. {RECURSIVE_TEST_FILES=>1} This is supported since 6.76 =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 L<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 L<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 L<ExtUtils::Manifest/fullcheck> for details) =item make skipcheck reports which files are skipped due to the entries in the C<MANIFEST.SKIP> file (See L<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 veryclean does a realclean first and then removes backup files such as C<*~>, C<*.bak>, C<*.old> and C<*.orig> =item make manifest rewrites the MANIFEST file, adding all remaining files found (See L<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 META.yml and META.json 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 (META and MYMETA) 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>. Over the years, it has become standard to keep this information in one or more CPAN Meta files distributed with each distribution. The original format of CPAN Meta files was L<YAML> and the corresponding file was called F<META.yml>. In 2010, version 2 of the L<CPAN::Meta::Spec> was released, which mandates JSON format for the metadata in order to overcome certain compatibility issues between YAML serializers and to avoid breaking older clients unable to handle a new version of the spec. The L<CPAN::Meta> library is now standard for accessing old and new-style Meta files. If L<CPAN::Meta> is installed, MakeMaker will automatically generate F<META.json> and F<META.yml> files for you and add them 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. At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agreed to use the CPAN Meta format to communicate post-configuration requirements between toolchain components. These files, F<MYMETA.json> and F<MYMETA.yml>, are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta> is installed). Clients like L<CPAN> or L<CPANPLUS> will read these files to see what prerequisites must be fulfilled before building or testing the distribution. If you wish to shut this feature off, set the C<NO_MYMETA> 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. =item os_unsupported os_unsupported(); os_unsupported if $^O eq 'MSWin32'; The C<os_unsupported()> function provides a way to correctly exit your C<Makefile.PL> before calling C<WriteMakefile>. It is essentially a C<die> with the message "OS unsupported". This is supported since 7.26 =back =head2 Supported versions of Perl Please note that while this module works on Perl 5.6, it is no longer being routinely tested on 5.6 - the earliest Perl version being routinely tested, and expressly supported, is 5.8.1. However, patches to repair any breakage on 5.6 are still being accepted. =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 as the shell would, and the result is processed before any actual command line arguments are processed. PERL_MM_OPT='CCFLAGS="-Wl,-rpath -Wl,/foo/bar/lib" LIBS="-lwibble -lwobble"' =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 may be easier to extend to suit your needs. L<Module::Build::Tiny> is a minimal pure-Perl alternative to MakeMaker that follows the Build.PL protocol of Module::Build but without its complexity and cruft, implementing only the installation of the module and leaving authoring to L<mbtiny> or other authoring tools. L<Module::Install> is a (now discouraged) 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. L<CPAN::Meta> and L<CPAN::Meta::Spec> explain CPAN Meta files in detail. L<File::ShareDir::Install> makes it easy to install static, sometimes also referred to as 'shared' files. L<File::ShareDir> helps accessing the shared files after installation. L<Test::File::ShareDir> helps when writing tests to use the shared files both before and after installation. L<Dist::Zilla> is an authoring tool which allows great customization and extensibility of the author experience, relying on the existing install tools like ExtUtils::MakeMaker only for installation. L<Dist::Milla> is a Dist::Zilla bundle that greatly simplifies common usage. L<Minilla> is a minimal authoring tool that does the same things as Dist::Milla without the overhead of Dist::Zilla. =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<https://metacpan.org/release/ExtUtils-MakeMaker>. Repository available at L<https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker>. =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 MM_Unix.pm 0000644 00000336076 15140257564 0006446 0 ustar 00 package ExtUtils::MM_Unix; require 5.006; use strict; use Carp; use ExtUtils::MakeMaker::Config; use File::Basename qw(basename dirname); our %Config_Override; use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); # If we make $VERSION an our variable parse_version() breaks use vars qw($VERSION); $VERSION = '7.44'; $VERSION =~ tr/_//d; 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) ) ); $Is{Android} = $^O =~ /android/; if ( $^O eq 'darwin' && $^X eq '/usr/bin/perl' ) { my @osvers = split /\./, $Config{osvers}; $Is{ApplCor} = ( $osvers[0] >= 18 ); } } 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 require ExtUtils::MM_Unix; =head1 DESCRIPTION The methods provided by this package are designed to be used in conjunction with L<ExtUtils::MakeMaker>. When MakeMaker writes a Makefile, it creates one or more objects that inherit their methods from a package L<MM|ExtUtils::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 L<MM_Any|ExtUtils::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 $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 ( $Is{ApplCor} ) { $flags =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/; } 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 }; } my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : ''; push @m, sprintf <<'EOF', $command, $flags, $m_o; .c.s : %s -S %s $*.c %s EOF my @exts = qw(c cpp cxx cc); push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; my $dbgout = $self->dbgoutflag; for my $ext (@exts) { push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags " .($dbgout?"$dbgout ":'') ."\$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n"; } return join "", @m; } =item xs_obj_opt Takes the object file as an argument, and returns the portion of compile command-line that will output to the specified object file. =cut sub xs_obj_opt { my ($self, $output_file) = @_; "-o $output_file"; } =item dbgoutflag Returns a CC flag that tells the CC to emit a separate debugging symbol file when compiling an object file. =cut sub dbgoutflag { ''; } =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)}; # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89) # flags to the %Config, and the modules in the core should be built # with the warning flags, but NOT the -std=c89 flags (the latter # would break using any system header files that are strict C99). my @ccextraflags = qw(ccwarnflags); if ($ENV{PERL_CORE}) { for my $x (@ccextraflags) { if (exists $Config{$x}) { $cflags{$x} = $Config{$x}; } } } 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 "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 " $1 = $2\n" if $Verbose; } else { print "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 '; } for my $x (@ccextraflags) { next unless exists $cflags{$x}; $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x}; } 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)'; } 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) Sets SHELL if needed, then defines a couple of constants in the Makefile that are imported from %Config. =cut sub const_config { # --- Constants Sections --- my($self) = shift; my @m = $self->specify_shell(); # Usually returns empty string push @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}; 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 MAN1SECTION MAN3SECTION INSTALLDIRS INSTALL_BASE DESTDIR PREFIX PERLPREFIX SITEPREFIX VENDORPREFIX ), (map { ("INSTALL".$_, "DESTINSTALL".$_) } $self->installvars), qw( PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP LIBPERL_A MYEXTLIB FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP 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; $self->{$macro} = $self->quote_dep($self->{$macro}) if $ExtUtils::MakeMaker::macro_dep{$macro}; 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(sort @{$self->{C}})." O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})." H_FILES = ".$self->wraplist(sort @{$self->{H}})." MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})." MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})." "; push @m, q{ SDKROOT := $(shell xcrun --show-sdk-path) PERL_SYSROOT = $(SDKROOT) } if $Is{ApplCor} && $self->{'PERL_INC'} =~ m!^/System/Library/Perl/!; push @m, q{ # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_SYSROOT)$(PERL_INCDEP)$(DFSEP)config.h } if $Is{ApplCor}; push @m, q{ # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h } if -e $self->catfile( $self->{PERL_INC}, 'config.h' ) && !$Is{ApplCor}; 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_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP} PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER} }; push @m, " TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n"; join('',@m); } =item depend (o) Same as macro for the depend attribute. =cut sub depend { my($self,%attribs) = @_; my(@m,$key,$val); for my $key (sort keys %attribs){ my $val = $attribs{$key}; next unless defined $key and defined $val; 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 = ''; if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) { $attribs{SUFFIX} = '.' . $attribs{SUFFIX}; } 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 sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]); @all = sort keys %{ maniread() }; print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all}) == 0 or die $!; print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all}) == 0 or die $!; EOF } =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 $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)' $(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) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip' $(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 $(NOECHO) $(ECHO) 'Created $(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) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar' $(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 "\nBOOTSTRAP =\n" unless $self->has_link_code(); my @exts; if ($self->{XSMULTI}) { @exts = $self->_xs_list_basenames; } else { @exts = '$(BASEEXT)'; } return join "\n", "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n", map { $self->_xs_make_bs($_) } @exts; } sub _xs_make_bs { my ($self, $basename) = @_; my ($v, $d, $f) = File::Spec->splitpath($basename); my @d = File::Spec->splitdir($d); shift @d if $self->{XSMULTI} and $d[0] eq 'lib'; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)'; my $instfile = $self->catfile($instdir, "$f.bs"); my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target # 1 2 3 return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists; # 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. %1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP) $(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))" $(NOECHO) $(PERLRUN) \ "-MExtUtils::Mkbootstrap" \ -e "Mkbootstrap('%1$s','$(BSLOADLIBS)');" $(NOECHO) $(TOUCH) "%1$s.bs" $(CHMOD) $(PERM_RW) "%1$s.bs" %2$s : %1$s.bs %3$s $(NOECHO) $(RM_RF) %2$s - $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW) 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 @m = $self->xs_dynamic_lib_macros(\%attribs); my @libs; my $dlsyms_ext = eval { $self->xs_dlsyms_ext }; if ($self->{XSMULTI}) { my @exts = $self->_xs_list_basenames; for my $ext (@exts) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; pop @d if $d[$#d] eq ''; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); # Dynamic library names may need special handling. eval { require DynaLoader }; if (defined &DynaLoader::mod2fname) { $f = &DynaLoader::mod2fname([@d, $f]); } my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)"); my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT'); $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile; my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM'); $ldfrom = $objfile unless defined $ldfrom; my $exportlist = "$ext.def"; my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist); push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef; push @libs, \@libchunk; } } else { my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)); push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef; @libs = (\@libchunk); } push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs; return join("\n",@m); } =item xs_dynamic_lib_macros Defines the macros for the C<dynamic_lib> section. =cut sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; my $armaybe = $self->_xs_armaybe($attribs); my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too? my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : ''; sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). ARMAYBE = %s OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s INST_DYNAMIC_FIX = %s EOF } sub _xs_armaybe { my ($self, $attribs) = @_; my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":"; $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':'); $armaybe; } =item xs_make_dynamic_lib Defines the recipes for the C<dynamic_lib> section. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_; $exportlist = '' if $exportlist ne '$(EXPORT_LIST)'; my $armaybe = $self->_xs_armaybe($attribs); my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || ''); my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms); 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) \$\@\n"); my $libs = '$(LDLOADLIBS)'; if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $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'; } elsif ( $Is{Android} ) { # The Android linker will not recognize symbols from # libperl unless the module explicitly depends on it. $libs .= ' "-L$(PERL_INC)" -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, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist; %s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \ $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \ $(INST_DYNAMIC_FIX) $(CHMOD) $(PERM_RWX) $@ MAKE 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){ my ($abs, $use_dir); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo $use_dir = 1; } else { # foo/bar $abs = $self->catfile($Curdir, $name); } foreach my $dir ($use_dir ? @$dirs : 1){ next unless defined $dir; # $self->{PERL_SRC} may be undefined $abs = $self->catfile($dir, $name) if $use_dir; print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); print "Executing $abs\n" if ($trace >= 2); my $val; my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"}; # 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 "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 ) = @_; 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 shebang file. my $shb = $self->_fixin_replace_shebang( $file, $line ); next unless defined $shb; 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); } sub _fixin_replace_shebang { my ( $self, $file, $line ) = @_; # Now figure out the interpreter name. my ( $origcmd, $arg ) = split ' ', $line, 2; (my $cmd = $origcmd) =~ s!^.*/!!; # Now look (in reverse) for interpreter in absolute PATH (unless perl). my $interpreter; if ( defined $ENV{PERL_MM_SHEBANG} && $ENV{PERL_MM_SHEBANG} eq "relocatable" ) { $interpreter = "/usr/bin/env perl"; } elsif ( $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) { my $maybefile = $self->catfile($dir,$cmd); if ( $self->maybe_command($maybefile) ) { warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; $interpreter = $maybefile; } } # If the shebang is absolute and exists in PATH, but was not # the first one found, leave it alone if it's actually the # same file as first one. This avoids packages built on # merged-/usr systems with /usr/bin before /bin in the path # breaking when installed on systems without merged /usr if ($origcmd ne $interpreter and $self->file_name_is_absolute($origcmd)) { my $origdir = dirname($origcmd); if ($self->maybe_command($origcmd) && grep { $_ eq $origdir } @absdirs) { my ($odev, $oino) = stat $origcmd; my ($idev, $iino) = stat $interpreter; if ($odev == $idev && $oino == $iino) { warn "$origcmd is the same as $interpreter, leaving alone" if $Verbose; $interpreter = $origcmd; } } } } # Figure out how to invoke interpreter on this machine. my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; my ($shb) = ""; if ($interpreter) { print "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"; } } else { warn "Can't find $cmd in PATH, $file unchanged" if $Verbose; return; } return $shb } =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, %o, %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; my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/; @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS}; if ( defined $self->{XS} and !defined $self->{C} ) { my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}}; my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}}; %c = map { $_ => 1 } @c_files; %o = map { $_ => 1 } @o_files; } foreach my $name ($self->lsdir($Curdir)){ next if $name =~ /\#/; next if $name =~ $distprefix && -d $name; $name = lc($name) if $Is{VMS}; 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}}; %o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files); $self->{O_FILES} = [sort keys %o]; } =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(); } } # logic similar to picking man${num}ext in perl's Configure script foreach my $num (1,3) { my $installdirs = uc $self->{INSTALLDIRS}; $installdirs = '' if $installdirs eq 'PERL'; my @mandirs = File::Spec->splitdir( $self->_expand_macros( $self->{ "INSTALL${installdirs}MAN${num}DIR" } ) ); my $mandir = pop @mandirs; my $section = $num; foreach ($num, "${num}p", "${num}pm", qw< l n o C L >, "L$num") { if ( $mandir =~ /^(?:man|cat)$_$/ ) { $section = $_; last; } } $self->{"MAN${num}SECTION"} = $section; } } 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) or ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod ) { 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; if ($self->{XSMULTI} and $inst =~ /\.xs\z/) { my($base); ($base = $path) =~ s/\.xs\z//; $self->{XS}{$path} = "$base.c"; push @{$self->{C}}, "$base.c"; push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}"; } else { $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. # We require DynaLoader to make sure that mod2fname is loaded eval { require DynaLoader }; 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"); $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 <<EOP; ... Detected uninstalled Perl. Trying to continue. EOP } } } } if ($Is{Android}) { # Android fun times! # ../../perl -I../../lib -MFile::Glob -e1 works # ../../../perl -I../../../lib -MFile::Glob -e1 fails to find # the .so for File::Glob. # This always affects core perl, but may also affect an installed # perl built with -Duserelocatableinc. $self->{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB}); $self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB}); } $self->{PERL_INCDEP} = $self->{PERL_INC}; $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB}; # 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 "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 "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_tools Initializes tools to use their common (and faster) Unix commands. =cut sub init_tools { 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->{TEST_S} ||= "test -s"; $self->{CP} ||= "cp"; $self->{MV} ||= "mv"; $self->{CHMOD} ||= "chmod"; $self->{FALSE} ||= 'false'; $self->{TRUE} ||= 'true'; $self->{LD} ||= 'ld'; return $self->SUPER::init_tools(@_); # After SUPER::init_tools so $Config{shell} has a # chance to get set. $self->{SHELL} ||= '/bin/sh'; return; } =item init_linker Unix has no need of special linker flags. =cut sub init_linker { my($self) = shift; $self->{PERL_ARCHIVE} ||= ''; $self->{PERL_ARCHIVEDEP} ||= ''; $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 "Directory $self->{$Arch} not found\n" if $Verbose; $self->{$Arch} = $self->{$Lib}; } print "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$Config{version}", 'perl5', 'perl'); # miniperl has priority over all but the canonical 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 ); my $perl = $self->{PERL}; $perl =~ s/^"//; my $has_mcr = $perl =~ s/^MCR\s*//; my $perlflags = ''; my $stripped_perl; while ($perl) { ($stripped_perl = $perl) =~ s/"$//; last if -x $stripped_perl; last unless $perl =~ s/(\s+\S+)$//; $perlflags = $1.$perlflags; } $self->{PERL} = $stripped_perl; $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS}; # 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) unless ($self->{FULLPERL}) { ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i; $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags; } # Can't have an image name with quotes, and findperl will have # already escaped spaces. $self->{FULLPERL} =~ tr/"//d if $Is{VMS}; # `dmake` can fail for image (aka, executable) names which start with double-quotes # * push quote inward by at least one character (or the drive prefix, if present) # * including any initial directory separator preserves the `file_name_is_absolute` property $self->{FULLPERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake'); # Little hack to get around VMS's find_perl putting "MCR" in front # sometimes. $self->{ABSPERL} = $self->{PERL}; $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; } $self->{PERL} = qq{"$self->{PERL}"}.$perlflags; # Can't have an image name with quotes, and findperl will have # already escaped spaces. $self->{PERL} =~ tr/"//d if $Is{VMS}; # `dmake` can fail for image (aka, executable) names which start with double-quotes # * push quote inward by at least one character (or the drive prefix, if present) # * including any initial directory separator preserves the `file_name_is_absolute` property $self->{PERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake'); # 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}; # Make sure perl can find itself before it's installed. my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE} ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ? q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"} : undef; my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB} ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"' : 'RUN)'.$perlflags.' "-I$(INST_LIB)"'; # How do we run perl? foreach my $perl (qw(PERL FULLPERL ABSPERL)) { my $run = $perl.'RUN'; $self->{$run} = qq{\$($perl)}; $self->{$run} .= $lib_paths if $lib_paths; $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths; } 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'); if ($self->{XSMULTI}) { my @exts = $self->_xs_list_basenames; my (@statics, @dynamics, @boots); for my $ext (@exts) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if defined $d[0] and $d[0] eq 'lib'; pop @d if $d[$#d] eq ''; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); my $instfile = $self->catfile($instdir, $f); push @statics, "$instfile\$(LIB_EXT)"; # Dynamic library names may need special handling. my $dynfile = $instfile; eval { require DynaLoader }; if (defined &DynaLoader::mod2fname) { $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f])); } push @dynamics, "$dynfile.\$(DLEXT)"; push @boots, "$instfile.bs"; } $self->{INST_STATIC} = join ' ', @statics; $self->{INST_DYNAMIC} = join ' ', @dynamics; $self->{INST_BOOT} = join ' ', @boots; } } 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) umask 022; $(MOD_INSTALL) \ }; push @m, 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) umask 02; $(MOD_INSTALL) \ }; push @m, q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \ } unless $self->{NO_PACKLIST}; push @m, 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) umask 022; $(MOD_INSTALL) \ }; push @m, q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \ "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)" }; push @m, q{ doc_perl_install :: all $(NOECHO) $(NOOP) doc_site_install :: all $(NOECHO) $(NOOP) doc_vendor_install :: all $(NOECHO) $(NOOP) } if $self->{NO_PERLLOCAL}; push @m, q{ doc_perl_install :: all doc_site_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLSITEARCH)/perllocal.pod" -$(NOECHO) umask 02; $(MKPATH) "$(DESTINSTALLSITEARCH)" -$(NOECHO) umask 02; $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "}.$self->catfile('$(DESTINSTALLSITEARCH)','perllocal.pod').q{" doc_vendor_install :: all } unless $self->{NO_PERLLOCAL}; push @m, q{ uninstall :: uninstall_from_$(INSTALLDIRS)dirs $(NOECHO) $(NOOP) uninstall_from_perldirs :: uninstall_from_sitedirs :: $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" uninstall_from_vendordirs :: }; 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 = sort @{$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 = sort 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. my @froms = sort keys %fromto; for my $from (@froms) { # 1 2 push @m, _sprintf562 <<'MAKE', $from, $fromto{$from}; %2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(NOECHO) $(RM_F) %2$s $(CP) %1$s %2$s $(FIXIN) %2$s -$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s MAKE } join "", @m; } =item linkext (o) Defines the linkext target which in turn defines the LINKTYPE. =cut # LINKTYPE => static or dynamic or '' sub linkext { my($self, %attribs) = @_; my $linktype = $attribs{LINKTYPE}; $linktype = $self->{LINKTYPE} unless defined $linktype; if (defined $linktype and $linktype eq '') { warn "Warning: LINKTYPE set to '', no longer necessary\n"; } $linktype = '$(LINKTYPE)' unless defined $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 { # $self my(undef, $dir, $regex) = @_; opendir(my $dh, defined($dir) ? $dir : ".") or return; my @ls = readdir $dh; closedir $dh; @ls = grep(/$regex/, @ls) if defined $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; foreach my $key (sort keys %attribs) { my $val = $attribs{$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)}; s/^(.*)/"-I$1"/ for @{$perlinc || []}; my(@m); push @m, " # --- MakeMaker makeaperl section --- MAP_TARGET = $target FULLPERL = $self->{FULLPERL} MAP_PERLINC = @{$perlinc || []} "; return join '', @m if $self->{PARENT}; my($dir) = join ":", @{$self->{DIR}}; unless ($self->{MAKEAPERL}) { push @m, q{ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ $(MAKE_APERL_FILE) : static $(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){ my $arg = $_; # avoid lvalue aliasing if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) { $arg = $1 . $self->quote_literal($2); } push @m, " \\\n\t\t$arg"; } push @m, "\n"; return join '', @m; } my $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... my $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 $staticlib21 = $self->_find_static_libs($searchdirs); # We trust that what has been handed in as argument, will be buildable $static = [] unless $static; @$staticlib21{@{$static}} = (1) x @{$static}; $extra = [] unless $extra && ref $extra eq 'ARRAY'; for (sort keys %$staticlib21) { 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 my @map_static = reverse sort keys %$staticlib21; push @m, " MAP_LINKCMD = $linkcmd MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), " MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), " MAP_PRELIBS = $Config{perllibs} $Config{cryptlib} "; my $lperl; 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}/../.."; $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 <<EOF unless -f $lperl || defined($self->{PERL_SRC}); Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning EOF } # SUNOS ld does not take the full path to a shared library my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl'; my $libperl_dep = $self->quote_dep($libperl); push @m, " MAP_LIBPERL = $libperl MAP_LIBPERLDEP = $libperl_dep 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"; } my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)'; # 1 2 3 4 push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename; $(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all $(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS) $(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call" $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)" $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean" %1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c EOF push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n"; my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : ''; push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader; %1$s/perlmain.c: %2$s $(NOECHO) $(ECHO) Writing $@ $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \ -e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t $(MV) $@t $@ EOF 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; } # utility method sub _find_static_libs { my ($self, $searchdirs) = @_; # don't use File::Spec here because on Win32 F::F still uses "/" my $installed_version = join('/', 'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" ); my %staticlib21; require File::Find; File::Find::find(sub { if ($File::Find::name =~ m{/auto/share\z}) { # in a subdir of auto/share, prune because e.g. # Alien::pkgconfig uses File::ShareDir to put .a files # there. do not want $File::Find::prune = 1; return; } return unless m/\Q$self->{LIB_EXT}\E$/; return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation # 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 # include duplicates # Once the patch to minimod.PL is in the distribution, I can # drop it return if $File::Find::name =~ m:\Q$installed_version\E\z:; return if !$self->xs_static_lib_is_xs($_); use Cwd 'cwd'; $staticlib21{cwd() . "/" . $_}++; }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) ); return \%staticlib21; } =item xs_static_lib_is_xs (o) Called by a utility method of makeaperl. Checks whether a given file is an XS library by seeing whether it defines any symbols starting with C<boot_> (with an optional leading underscore - needed on MacOS). =cut sub xs_static_lib_is_xs { my ($self, $libfile) = @_; my $devnull = File::Spec->devnull; return `nm $libfile 2>$devnull` =~ /\b_?boot_/; } =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; my $cross = ''; if (defined $::Cross::platform) { # Inherited from win32/buildext.pl $cross = "-MCross=$::Cross::platform "; } $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $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) %sMakefile.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': $!"; binmode $fh; my $inpod = 0; my $pod_encoding; my $package = $self->{DISTNAME}; $package =~ s/-/::/g; while (<$fh>) { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if !$inpod; s#\r*\n\z##; # handle CRLF input if ( /^=encoding\s*(.*)$/i ) { $pod_encoding = $1; } if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) { $result = $2; next; } next unless $result; if ( $result && ( /^\s*$/ || /^\=/ ) ) { last; } $result = join ' ', $result, $_; } close $fh; if ( $pod_encoding and !( "$]" < 5.008 or !$Config{useperlio} ) ) { # Have to wrap in an eval{} for when running under PERL_CORE # Encode isn't available during build phase and parsing # ABSTRACT isn't important there eval { require Encode; $result = Encode::decode($pod_encoding, $result); } } 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|elsif)/; if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) { local $^W = 0; $result = $1; } elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* (?<![<>=!])\=[^=]}x ) { $result = $self->get_version($parsefile, $1, $2); } else { next; } last if defined $result; } close $fh; if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) { require version; my $normal = eval { version->new( $result ) }; $result = $normal if defined $normal; } $result = "undef" unless defined $result; return $result; } sub get_version { my ($self, $parsefile, $sigil, $name) = @_; my $line = $_; # from the while() loop in parse_version { package ExtUtils::MakeMaker::_version; undef *version; # in case of unexpected version() sub eval { require version; version::->import; }; no strict; local *{$name}; local $^W = 0; $line = $1 if $line =~ m{^(.+)}s; eval($line); ## no critic return ${$name}; } } =item pasthru (o) Defines the string that is passed to recursive make calls in subdirectories. The variables like C<PASTHRU_DEFINE> are used in each level, and passed downwards on the command-line with e.g. the value of that level's DEFINE. Example: # Level 0 has DEFINE = -Dfunky # This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE) # $(PASTHRU_DEFINE)" # Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE) # So will level 1's, so when level 1 compiles, it will get right values # And so ad infinitum =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 LD PREFIX INSTALL_BASE) ) { next unless defined $self->{$key}; push @pasthru, "$key=\"\$($key)\""; } foreach my $key (qw(DEFINE INC)) { # default to the make var my $val = qq{\$($key)}; # expand within perl if given since need to use quote_literal # since INC might include space-protecting ""! chomp($val = $self->{$key}) if defined $self->{$key}; $val .= " \$(PASTHRU_$key)"; my $quoted = $self->quote_literal($val); push @pasthru, qq{PASTHRU_$key=$quoted}; } 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_INCDEP)/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; if ($self->{OBJECT}) { # Need to add an object file dependency on the perl headers. # this is very important for XS modules in perl.git development. push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h } push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; return 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, map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}}); $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds; $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n}; return $r; } # 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 = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']}); $author =~ s/</</g; $author =~ s/>/>/g; my $ppd_file = "$self->{DISTNAME}.ppd"; my @ppd_chunks = qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n); push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author; <ABSTRACT>%s</ABSTRACT> <AUTHOR>%s</AUTHOR> PPD_HTML push @ppd_chunks, " <IMPLEMENTATION>\n"; if ( $self->{MIN_PERL_VERSION} ) { my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION}); push @ppd_chunks, 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}; my %attrs = ( NAME => $name ); $attrs{VERSION} = $version if $version; my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs; push @ppd_chunks, 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}"; } push @ppd_chunks, sprintf <<'PPD_OUT', $archname; <ARCHITECTURE NAME="%s" /> PPD_OUT if ($self->{PPM_INSTALL_SCRIPT}) { if ($self->{PPM_INSTALL_EXEC}) { push @ppd_chunks, sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n}, $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT}; } else { push @ppd_chunks, sprintf qq{ <INSTALL>%s</INSTALL>\n}, $self->{PPM_INSTALL_SCRIPT}; } } if ($self->{PPM_UNINSTALL_SCRIPT}) { if ($self->{PPM_UNINSTALL_EXEC}) { push @ppd_chunks, sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n}, $self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT}; } else { push @ppd_chunks, sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n}, $self->{PPM_UNINSTALL_SCRIPT}; } } my ($bin_location) = $self->{BINARY_LOCATION} || ''; $bin_location =~ s/\\/\\\\/g; push @ppd_chunks, sprintf <<'PPD_XML', $bin_location; <CODEBASE HREF="%s" /> </IMPLEMENTATION> </SOFTPKG> PPD_XML my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file); 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|/$|; warn " prefixify $var => $path\n" if $Verbose >= 2; warn " from $sprefix to $rprefix\n" if $Verbose >= 2; if( $self->{ARGS}{PREFIX} && $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) { warn " cannot prefix, using default.\n" if $Verbose >= 2; warn " 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 $targets = $pl_files->{$plfile}; my $list = ref($targets) eq 'HASH' ? [ sort keys %$targets ] : ref($targets) eq 'ARRAY' ? $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'; } my $extra_inputs = ''; if( ref($targets) eq 'HASH' ) { my $inputs = ref($targets->{$target}) ? $targets->{$target} : [$targets->{$target}]; for my $input (@$inputs) { if( $Is{VMS} ) { $input = vmsify($self->eliminate_macros($input)); } $extra_inputs .= ' '.$input; } } $m .= <<MAKE_FRAG; pure_all :: $target \$(NOECHO) \$(NOOP) $target :: $plfile $pm_dep $extra_inputs \$($perlrun) $plfile $target $extra_inputs MAKE_FRAG } } return $m; } =item specify_shell Specify SHELL if needed - not done on Unix. =cut sub specify_shell { return ''; } =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 Quotes macro literal value suitable for being used on a command line so that when expanded by make, will be received by command as given to this method: my $quoted = $mm->quote_literal(q{it isn't}); # returns: # 'it isn'\''t' print MAKEFILE "target:\n\techo $quoted\n"; # when run "make target", will output: # it isn't =cut sub quote_literal { my($self, $text, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # Quote single quotes $text =~ s{'}{'\\''}g; $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return "'$text'"; } =item escape_newlines =cut sub escape_newlines { my($self, $text) = @_; $text =~ s{\n}{\\\n}g; return $text; } =item max_exec_len Using L<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) '; } sub static_lib { my($self) = @_; return '' unless $self->has_link_code; my(@m); my @libs; if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)"); my $objfile = "$ext\$(OBJ_EXT)"; push @libs, [ $objfile, $instfile, $instdir ]; } } else { @libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]); } push @m, map { $self->xs_make_static_lib(@$_); } @libs; join "\n", @m; } =item xs_make_static_lib Defines the recipes for the C<static_lib> section. =cut sub xs_make_static_lib { my ($self, $from, $to, $todir) = @_; my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir; push @m, "\t\$(RM_F) \"\$\@\"\n"; push @m, $self->static_lib_fixtures; push @m, $self->static_lib_pure_cmd($from); push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; push @m, $self->static_lib_closures($todir); join '', @m; } =item static_lib_closures Records C<$(EXTRALIBS)> in F<extralibs.ld> and F<$(PERL_SRC)/ext.libs>. =cut sub static_lib_closures { my ($self, $todir) = @_; my @m = sprintf <<'MAKE_FRAG', $todir; $(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld MAKE_FRAG # Old mechanism - still available: push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs MAKE_FRAG @m; } =item static_lib_fixtures Handles copying C<$(MYEXTLIB)> as starter for final static library that then gets added to. =cut sub static_lib_fixtures { my ($self) = @_; # If this extension has its own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. return unless $self->{MYEXTLIB}; "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n"; } =item static_lib_pure_cmd Defines how to run the archive utility. =cut sub static_lib_pure_cmd { my ($self, $from) = @_; 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'; } sprintf <<'MAKE_FRAG', $ar, $from; $(%s) $(AR_STATIC_ARGS) "$@" %s $(RANLIB) "$@" MAKE_FRAG } =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, <<'EOF'; # The default clean, realclean and test targets in this Makefile # have automatically been given entries for each subdir. EOF } else { push(@m, "\n# none") } join('',@m); } =item test (o) Defines the test targets. =cut sub test { my($self, %attribs) = @_; my $tests = $attribs{TESTS} || ''; if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) { $tests = $self->find_tests_recursive; } elsif (!$tests && -d 't') { $tests = $self->find_tests; } # have to do this because nmake is broken $tests =~ s!/!\\!g if $self->is_make_type('nmake'); # note: 'test.pl' name is also hardcoded in init_dirscan() my @m; my $default_testtype = $Config{usedl} ? 'dynamic' : 'static'; push @m, <<EOF; TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) \$(NOECHO) \$(NOOP) test :: \$(TEST_TYPE) \$(NOECHO) \$(NOOP) # Occasionally we may face this degenerate target: test_ : test_$default_testtype \$(NOECHO) \$(NOOP) EOF for my $linktype (qw(dynamic static)) { my $directdeps = join ' ', grep !$self->{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped push @m, "subdirs-test_$linktype :: $directdeps\n"; foreach my $dir (@{ $self->{DIR} }) { my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)"); push @m, "\t\$(NOECHO) $test\n"; } push @m, "\n"; if ($tests or -f "test.pl") { for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) { my ($db, $switch) = @$testspec; my ($command, $deps); # if testdb, build all but don't test all $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype"; if ($linktype eq 'static' and $self->needs_linking) { my $target = File::Spec->rel2abs('$(MAP_TARGET)'); $command = qq{"$target" \$(MAP_PERLINC)}; $deps .= ' $(MAP_TARGET)'; } else { $command = '$(FULLPERLRUN)' . $switch; } push @m, "test${db}_$linktype :: $deps\n"; if ($db eq 'db') { push @m, $self->test_via_script($command, '$(TEST_FILE)') } else { push @m, $self->test_via_script($command, '$(TEST_FILE)') if -f "test.pl"; push @m, $self->test_via_harness($command, '$(TEST_FILES)') if $tests; } push @m, "\n"; } } else { push @m, _sprintf562 <<'EOF', $linktype; testdb_%1$s test_%1$s :: subdirs-test_%1$s $(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.' EOF } } 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}; my $foundxsubpp = 0; foreach my $dir (@xsubpp_dirs) { $xsdir = $self->catdir($dir, 'ExtUtils'); if( -r $self->catfile($xsdir, "xsubpp") ) { $foundxsubpp = 1; last; } } die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp; my $tmdir = $self->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 { $typemap = vmsify($typemap) if $Is{VMS}; push(@tmdeps, $typemap); } } } push(@tmdeps, "typemap") if -f "typemap"; # absolutised because with deep-located typemaps, eg "lib/XS/typemap", # if xsubpp is called from top level with # $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs" # it says: # Can't find lib/XS/type map in (fulldir)/lib/XS # because ExtUtils::ParseXS::process_file chdir's to .xs file's # location. This is the only way to get all specified typemaps used, # wherever located. my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps; $_ = $self->quote_dep($_) for @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}; my $xsdirdep = $self->quote_dep($xsdir); # -dep for use when dependency not command return qq{ XSUBPPDIR = $xsdir XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp" XSUBPPRUN = \$(PERLRUN) \$(XSUBPP) XSPROTOARG = $self->{XSPROTOARG} XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)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, sprintf <<'EOF'; pure_all :: config pm_to_blib subdirs linkext $(NOECHO) $(NOOP) $(NOECHO) $(NOOP) subdirs :: $(MYEXTLIB) $(NOECHO) $(NOOP) config :: $(FIRST_MAKEFILE) blibdirs $(NOECHO) $(NOOP) EOF 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 = gmtime($ENV{SOURCE_DATE_EPOCH} || time); 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 was originally only intended for broken make implementations, but is now necessary for per-XS file under C<XSMULTI>, since each XS file might have an individual C<$(VERSION)>. =cut sub xs_o { my ($self) = @_; return '' unless $self->needs_linking(); my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; my $dbgout = $self->dbgoutflag; $dbgout = $dbgout ? "$dbgout " : ''; my $frag = ''; # dmake makes noise about ambiguous rule $frag .= sprintf <<'EOF', $dbgout, $m_o unless $self->is_make_type('dmake'); .xs$(OBJ_EXT) : $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.c $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) %s$*.c %s EOF if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my $pmfile = "$ext.pm"; croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile; my $version = $self->parse_version($pmfile); my $cccmd = $self->{CONST_CCCMD}; $cccmd =~ s/^\s*CCCMD\s*=\s*//; $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/; $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/; $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC'); my $define = '$(DEFINE)'; $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE'); # 1 2 3 4 5 $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define, $dbgout; %1$s$(OBJ_EXT): %1$s.xs $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.c %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s %5$s$*.c %3$s EOF } } $frag =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/sg if $Is{ApplCor}; $frag; } # param gets modified sub _xsbuild_replace_macro { my ($self, undef, $xstype, $ext, $varname) = @_; my $value = $self->_xsbuild_value($xstype, $ext, $varname); return unless defined $value; $_[1] =~ s/\$\($varname\)/$value/; } sub _xsbuild_value { my ($self, $xstype, $ext, $varname) = @_; return $self->{XSBUILD}{$xstype}{$ext}{$varname} if $self->{XSBUILD}{$xstype}{$ext}{$varname}; return $self->{XSBUILD}{$xstype}{all}{$varname} if $self->{XSBUILD}{$xstype}{all}{$varname}; (); } 1; =back =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut __END__ ParseXS/Eval.pm 0000644 00000004506 15140257564 0007334 0 ustar 00 package ExtUtils::ParseXS::Eval; use strict; use warnings; our $VERSION = '3.40'; =head1 NAME ExtUtils::ParseXS::Eval - Clean package to evaluate code in =head1 SYNOPSIS use ExtUtils::ParseXS::Eval; my $rv = ExtUtils::ParseXS::Eval::eval_typemap_code( $parsexs_obj, "some Perl code" ); =head1 SUBROUTINES =head2 $pxs->eval_output_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $ALIAS $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $arg =cut sub eval_output_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $ntype, $subtype, $arg) = @{$_other}{qw(var type ntype subtype arg)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head2 $pxs->eval_input_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $ALIAS $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $num $init $printed_name $arg $argoff =cut sub eval_input_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) = @{$_other}{qw(var type num init printed_name arg ntype argoff subtype)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head1 TODO Eventually, with better documentation and possible some cleanup, this could be part of C<ExtUtils::Typemaps>. =cut 1; # vim: ts=2 sw=2 et: ParseXS/CountLines.pm 0000644 00000001713 15140257564 0010525 0 ustar 00 package ExtUtils::ParseXS::CountLines; use strict; our $VERSION = '3.40'; our $SECTION_END_MARKER; sub TIEHANDLE { my ($class, $cfile, $fh) = @_; $cfile =~ s/\\/\\\\/g; $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 necessary for references to be released. } sub end_marker { return $SECTION_END_MARKER; } 1; ParseXS/Constants.pm 0000644 00000002170 15140257564 0010414 0 ustar 00 package ExtUtils::ParseXS::Constants; use strict; use warnings; use Symbol; our $VERSION = '3.40'; =head1 NAME ExtUtils::ParseXS::Constants - Initialization values for some globals =head1 SYNOPSIS use ExtUtils::ParseXS::Constants (); $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp; =head1 DESCRIPTION Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its supporting packages has been moved into this package so that those values can be defined exactly once and then re-used in any package. Nothing is exported. Use fully qualified variable names. =cut # FIXME: THESE ARE NOT CONSTANTS! our @InitFileCode; # Note that to reduce maintenance, $PrototypeRegexp is used # by ExtUtils::Typemaps, too! our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]"; our @XSKeywords = qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK EXPORT_XSUB_SYMBOLS ); our $XSKeywordsAlternation = join('|', @XSKeywords); 1; ParseXS/Utilities.pm 0000644 00000041423 15140257564 0010417 0 ustar 00 package ExtUtils::ParseXS::Utilities; use strict; use warnings; use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); our $VERSION = '3.40'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 NAME ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS =head1 SYNOPSIS use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 SUBROUTINES The following functions are not considered to be part of the public interface. They are documented here for the benefit of future maintainers of this module. =head2 C<standard_typemap_locations()> =over 4 =item * Purpose Provide a list of filepaths where F<typemap> files may be found. The filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority. The highest priority is to look in the current directory. 'typemap' The second and third highest priorities are to look in the parent of the current directory and a directory called F<lib/ExtUtils> underneath the parent directory. '../typemap', '../lib/ExtUtils/typemap', The fourth through ninth highest priorities are to look in the corresponding grandparent, great-grandparent and great-great-grandparent directories. '../../typemap', '../../lib/ExtUtils/typemap', '../../../typemap', '../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../../lib/ExtUtils/typemap', The tenth and subsequent priorities are to look in directories named F<ExtUtils> which are subdirectories of directories found in C<@INC> -- I<provided> a file named F<typemap> actually exists in such a directory. Example: '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', However, these filepaths appear in the list returned by C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest. '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', '../../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../lib/ExtUtils/typemap', '../../../typemap', '../../lib/ExtUtils/typemap', '../../typemap', '../lib/ExtUtils/typemap', '../typemap', 'typemap' =item * Arguments my @stl = standard_typemap_locations( \@INC ); Reference to C<@INC>. =item * Return Value Array holding list of directories to be searched for F<typemap> files. =back =cut SCOPE: { my @tm_template; sub standard_typemap_locations { my $include_ref = shift; if (not @tm_template) { @tm_template = 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_template, File::Spec->catfile($dir, 'typemap'); unshift @tm_template, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); } } my @tm = @tm_template; foreach my $dir (@{ $include_ref}) { my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); unshift @tm, $file if -e $file; } return @tm; } } # end SCOPE =head2 C<trim_whitespace()> =over 4 =item * Purpose Perform an in-place trimming of leading and trailing whitespace from the first argument provided to the function. =item * Argument trim_whitespace($arg); =item * Return Value None. Remember: this is an I<in-place> modification of the argument. =back =cut sub trim_whitespace { $_[0] =~ s/^\s+|\s+$//go; } =head2 C<C_string()> =over 4 =item * Purpose Escape backslashes (C<\>) in prototype strings. =item * Arguments $ProtoThisXSUB = C_string($_); String needing escaping. =item * Return Value Properly escaped string. =back =cut sub C_string { my($string) = @_; $string =~ s[\\][\\\\]g; $string; } =head2 C<valid_proto_string()> =over 4 =item * Purpose Validate prototype string. =item * Arguments String needing checking. =item * Return Value Upon success, returns the same string passed as argument. Upon failure, returns C<0>. =back =cut sub valid_proto_string { my ($string) = @_; if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) { return $string; } return 0; } =head2 C<process_typemaps()> =over 4 =item * Purpose Process all typemap files. =item * Arguments my $typemaps_object = process_typemaps( $args{typemap}, $pwd ); List of two elements: C<typemap> element from C<%args>; current working directory. =item * Return Value Upon success, returns an L<ExtUtils::Typemaps> object. =back =cut sub process_typemaps { my ($tmap, $pwd) = @_; my @tm = ref $tmap ? @{$tmap} : ($tmap); foreach my $typemap (@tm) { die "Can't find $typemap in $pwd\n" unless -r $typemap; } push @tm, standard_typemap_locations( \@INC ); require ExtUtils::Typemaps; my $typemap = ExtUtils::Typemaps->new; foreach my $typemap_loc (@tm) { next unless -f $typemap_loc; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next unless -T $typemap_loc; $typemap->merge(file => $typemap_loc, replace => 1); } return $typemap; } =head2 C<map_type()> =over 4 =item * Purpose Performs a mapping at several places inside C<PARAGRAPH> loop. =item * Arguments $type = map_type($self, $type, $varname); List of three arguments. =item * Return Value String holding augmented version of second argument. =back =cut sub map_type { my ($self, $type, $varname) = @_; # C++ has :: in types too so skip this $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; if ($varname) { if ($type =~ / \( \s* \* (?= \s* \) ) /xg) { (substr $type, pos $type, 0) = " $varname "; } else { $type .= "\t$varname"; } } return $type; } =head2 C<standard_XS_defs()> =over 4 =item * Purpose Writes to the C<.c> output file certain preprocessor directives and function headers needed in all such files. =item * Arguments None. =item * Return Value Returns true. =back =cut sub standard_XS_defs { print <<"EOF"; #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef dVAR # define dVAR dNOOP #endif /* This stuff is not part of the API! You have been warned. */ #ifndef PERL_VERSION_DECIMAL # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #endif #ifndef PERL_DECIMAL_VERSION # define PERL_DECIMAL_VERSION \\ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #endif #ifndef PERL_VERSION_GE # define PERL_VERSION_GE(r,v,s) \\ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #endif #ifndef PERL_VERSION_LE # define PERL_VERSION_LE(r,v,s) \\ (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) #endif /* XS_INTERNAL is the explicit static-linkage variant of the default * XS macro. * * XS_EXTERNAL is the same as XS_INTERNAL except it does not include * "STATIC", ie. it exports XSUB symbols. You probably don't want that * for anything but the BOOT XSUB. * * See XSUB.h in core! */ /* TODO: This might be compatible further back than 5.10.0. */ #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) # undef XS_EXTERNAL # undef XS_INTERNAL # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # if defined(__SYMBIAN32__) # define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) # define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) # endif # ifndef XS_EXTERNAL # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) # define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) # else # ifdef __cplusplus # define XS_EXTERNAL(name) extern "C" XSPROTO(name) # define XS_INTERNAL(name) static XSPROTO(name) # else # define XS_EXTERNAL(name) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # endif # endif #endif /* perl >= 5.10.0 && perl <= 5.15.1 */ /* The XS_EXTERNAL macro is used for functions that must not be static * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL * macro defined, the best we can do is assume XS is the same. * Dito for XS_INTERNAL. */ #ifndef XS_EXTERNAL # define XS_EXTERNAL(name) XS(name) #endif #ifndef XS_INTERNAL # define XS_INTERNAL(name) XS(name) #endif /* Now, finally, after all this mess, we want an ExtUtils::ParseXS * internal macro that we're free to redefine for varying linkage due * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! */ #undef XS_EUPXS #if defined(PERL_EUPXS_ALWAYS_EXPORT) # define XS_EUPXS(name) XS_EXTERNAL(name) #else /* default to internal */ # define XS_EUPXS(name) XS_INTERNAL(name) #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(const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(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_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak_nocontext("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define croak_xs_usage S_croak_xs_usage #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) */ #if PERL_VERSION_LE(5, 21, 5) # define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file) #else # define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) #endif EOF return 1; } =head2 C<assign_func_args()> =over 4 =item * Purpose Perform assignment to the C<func_args> attribute. =item * Arguments $string = assign_func_args($self, $argsref, $class); List of three elements. Second is an array reference; third is a string. =item * Return Value String. =back =cut sub assign_func_args { my ($self, $argsref, $class) = @_; my @func_args = @{$argsref}; shift @func_args if defined($class); for my $arg (@func_args) { $arg =~ s/^/&/ if $self->{in_out}->{$arg}; } return join(", ", @func_args); } =head2 C<analyze_preprocessor_statements()> =over 4 =item * Purpose Within each function inside each Xsub, print to the F<.c> output file certain preprocessor statements. =item * Arguments ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); List of four elements. =item * Return Value Modifed values of three of the arguments passed to the function. In particular, the C<XSStack> and C<InitFileCode> attributes are modified. =back =cut sub analyze_preprocessor_statements { my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_; if ($statement eq 'if') { $XSS_work_idx = @{ $self->{XSStack} }; push(@{ $self->{XSStack} }, {type => 'if'}); } else { $self->death("Error: '$statement' with no matching 'if'") if $self->{XSStack}->[-1]{type} ne 'if'; if ($self->{XSStack}->[-1]{varname}) { push(@{ $self->{InitFileCode} }, "#endif\n"); push(@{ $BootCode_ref }, "#endif"); } my(@fns) = keys %{$self->{XSStack}->[-1]{functions}}; if ($statement ne 'endif') { # Hide the functions defined in other #if branches, and reset. @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns; @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {}); } else { my($tmp) = pop(@{ $self->{XSStack} }); 0 while (--$XSS_work_idx && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if'); # Keep all new defined functions push(@fns, keys %{$tmp->{other_functions}}); @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; } } return ($self, $XSS_work_idx, $BootCode_ref); } =head2 C<set_cond()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub set_cond { my ($ellipsis, $min_args, $num_args) = @_; my $cond; 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); } return $cond; } =head2 C<current_line_number()> =over 4 =item * Purpose Figures out the current line number in the XS file. =item * Arguments C<$self> =item * Return Value The current line number. =back =cut sub current_line_number { my $self = shift; my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1]; return $line_number; } =head2 C<Warn()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub Warn { my $self = shift; my $warn_line_number = $self->current_line_number(); print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; } =head2 C<blurt()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub blurt { my $self = shift; $self->Warn(@_); $self->{errors}++ } =head2 C<death()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub death { my $self = shift; $self->Warn(@_); exit 1; } =head2 C<check_conditional_preprocessor_statements()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub check_conditional_preprocessor_statements { my ($self) = @_; my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} }); if (@cpp) { my $cpplevel; for my $cpp (@cpp) { if ($cpp =~ /^\#\s*if/) { $cpplevel++; } elsif (!$cpplevel) { $self->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 $self->{XSStack}->[-1]{type} eq 'if'; return; } elsif ($cpp =~ /^\#\s*endif/) { $cpplevel--; } } $self->Warn("Warning: #if without #endif in this function") if $cpplevel; } } =head2 C<escape_file_for_line_directive()> =over 4 =item * Purpose Escapes a given code source name (typically a file name but can also be a command that was read from) so that double-quotes and backslashes are escaped. =item * Arguments A string. =item * Return Value A string with escapes for double-quotes and backslashes. =back =cut sub escape_file_for_line_directive { my $string = shift; $string =~ s/\\/\\\\/g; $string =~ s/"/\\"/g; return $string; } =head2 C<report_typemap_failure> =over 4 =item * Purpose Do error reporting for missing typemaps. =item * Arguments The C<ExtUtils::ParseXS> object. An C<ExtUtils::Typemaps> object. The string that represents the C type that was not found in the typemap. Optionally, the string C<death> or C<blurt> to choose whether the error is immediately fatal or not. Default: C<blurt> =item * Return Value Returns nothing. Depending on the arguments, this may call C<death> or C<blurt>, the former of which is fatal. =back =cut sub report_typemap_failure { my ($self, $tm, $ctype, $error_method) = @_; $error_method ||= 'blurt'; my @avail_ctypes = $tm->list_mapped_ctypes; my $err = "Could not find a typemap for C type '$ctype'.\n" . "The following C types are mapped by the current typemap:\n'" . join("', '", @avail_ctypes) . "'\n"; $self->$error_method($err); return(); } 1; # vim: ts=2 sw=2 et: MM_OS2.pm 0000644 00000006217 15140257564 0006115 0 ustar 00 package ExtUtils::MM_OS2; use strict; use ExtUtils::MakeMaker qw(neatvalue); use File::Spec; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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) = @_; 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"; foreach my $name (sort keys %{$self->{IMPORTS}}) { my $exp = $self->{IMPORTS}->{$name}; 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: $!, \$?=$?"; } return '' if $self->{SKIPHASH}{'dynamic'}; $self->xs_dlsyms_iterator(\%attribs); } sub xs_dlsyms_ext { '.def'; } sub xs_dlsyms_extra { join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS); } sub static_lib_pure_cmd { my($self) = @_; my $old = $self->SUPER::static_lib_pure_cmd; return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; $old . <<'EOC'; $(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/* $(RANLIB) "$@" EOC } 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_ARCHIVEDEP} ||= ''; $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'); } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =back =cut 1; Mkbootstrap.pm 0000644 00000006344 15140257564 0007427 0 ustar 00 package ExtUtils::Mkbootstrap; # There's just too much Dynaloader incest here to turn on strict vars. use strict 'refs'; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 " 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 || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){ open my $bs, ">", "$baseext.bs" or die "Unable to open $baseext.bs: $!"; print "Writing $baseext.bs\n"; print " 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"; if (@all) { 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 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 Liblist/Kid.pm 0000644 00000061550 15140257564 0007233 0 ustar 00 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; use warnings; our $VERSION = '7.44_01'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::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|android/ and $Config{perllibs} ) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll/libperl.so 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"; my $Config_dlext = $Config{dlext}; # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl require Text::ParseWords; my ( @searchpath ); # from "-L/path" entries in $potential_libs my ( @libpath ) = Text::ParseWords::quotewords( '\s+', 0, $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; if ( $^O eq 'darwin' or $^O eq 'next' ) { # 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on $potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g; $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g; } # Debian-specific: don't use LD_RUN_PATH for standard dirs $ld_run_path_seen{$_}++ for @libpath; foreach my $thislib ( Text::ParseWords::quotewords( '\s+', 0, $potential_libs) ) { my ( $custom_name ) = ''; # Handle possible linker path arguments. if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # 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 =~ m!^-Wl,-[Rr]! ) ) { if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) { $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 ); $thislib = qq{"$thislib"} if $thislib =~ / /; # protect spaces if there push( @extralibs, "$ptype$thislib" ); push( @ldloadlibs, "$rtype$thislib" ); next; } if ( $thislib =~ m!^-Wl,! ) { push( @extralibs, $thislib ); push( @ldloadlibs, $thislib ); next; } # Handle possible library arguments. if ( $thislib =~ s/^-l(:)?// ) { # Handle -l:foo.so, which means that the library will # actually be called foo.so, not libfoo.so. This # is used in Android by ExtUtils::Depends to allow one XS # module to link to another. $custom_name = $1 || ''; } else { 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]+")) || (@fullname = $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) { # 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 ( defined( $Config_dlext ) && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) ) { } elsif ( $^O eq 'darwin' && require DynaLoader && defined &DynaLoader::dl_load_file && DynaLoader::dl_load_file( $fullname = "$thispth/lib$thislib.$so", 0 ) ) { } elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) { } elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) { } elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) { } 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.) } elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) { } 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... # "Sounds like we should always assume it's a dynamic library on AIX." my $is_dyna = $^O eq 'aix' ? 1 : ( $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$custom_name$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$custom_name$thislib" ) unless ( $in_perl and $^O eq 'sunos' ); } else { push( @ldloadlibs, "-l$custom_name$thislib" ); } } last; # found one here so don't bother looking further } warn "Warning (mostly 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; # TODO: make this use MM_Win32.pm's compiler detection my %libs_seen; my @extralibs; my $cc = $Config{cc} || ''; my $VC = $cc =~ /\bcl\b/i; my $GC = $cc =~ /\bgcc\b/i; my $libext = _win32_lib_extensions(); my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs my @libpath = _win32_default_search_paths( $VC, $GC ); my $pwd = cwd(); # from Cwd.pm my $search = 1; # compute @extralibs from $potential_libs my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose ); for ( @lib_search_list ) { my $thislib = $_; # see if entry is a flag if ( /^:\w+$/ ) { $search = 0 if lc eq ':nosearch'; $search = 1 if lc eq ':search'; _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(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, $_ ); next; } # handle possible linker path arguments if ( s/^-L// and not -d ) { _debug( "$thislib ignored, directory does not exist\n", $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; } my @paths = ( @searchpath, @libpath ); my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC ); if ( !$fullname ) { warn "Warning (mostly harmless): No library found for $thislib\n"; next; } _debug( "'$thislib' found as '$fullname'\n", $verbose ); push( @extralibs, $fullname ); $libs_seen{$fullname} = 1 if $path; # why is this a special case? } my @libs = sort keys %libs_seen; return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs; # make sure paths with spaces are properly quoted @extralibs = map { qq["$_"] } @extralibs; @libs = map { qq["$_"] } @libs; my $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; _debug( "Result: $lib\n", $verbose ); wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib; } sub _win32_make_lib_search_list { my ( $potential_libs, $verbose ) = @_; # If Config.pm defines a set of default libs, we always # tack them on to the user-supplied list, unless the user # specified :nodefault my $libs = $Config{'perllibs'}; $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i; _debug( "Potential libraries are '$potential_libs':\n", $verbose ); $potential_libs =~ s,\\,/,g; # normalize to forward slashes my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs ); return @list; } sub _win32_default_search_paths { my ( $VC, $GC ) = @_; my $libpth = $Config{'libpth'} || ''; $libpth =~ s,\\,/,g; # normalize to forward slashes my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth ); push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB}; push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH}; return @libpath; } sub _win32_search_file { my ( $thislib, $libext, $paths, $verbose, $GC ) = @_; my @file_list = _win32_build_file_list( $thislib, $GC, $libext ); for my $lib_file ( @file_list ) { for my $path ( @{$paths} ) { my $fullname = $lib_file; $fullname = "$path\\$fullname" if $path; return ( $fullname, $path ) if -f $fullname; _debug( "'$thislib' not found as '$fullname'\n", $verbose ); } } return; } sub _win32_build_file_list { my ( $lib, $GC, $extensions ) = @_; my @pre_fixed = _win32_build_prefixed_list( $lib, $GC ); return map _win32_attach_extensions( $_, $extensions ), @pre_fixed; } sub _win32_build_prefixed_list { my ( $lib, $GC ) = @_; return $lib if $lib !~ s/^-l//; return $lib if $lib =~ /^lib/ and !$GC; ( my $no_prefix = $lib ) =~ s/^lib//i; $lib = "lib$lib" if $no_prefix eq $lib; return ( $lib, $no_prefix ) if $GC; return ( $no_prefix, $lib ); } sub _win32_attach_extensions { my ( $lib, $extensions ) = @_; return map _win32_try_attach_extension( $lib, $_ ), @{$extensions}; } sub _win32_try_attach_extension { my ( $lib, $extension ) = @_; return $lib if $lib =~ /\Q$extension\E$/i; return "$lib$extension"; } sub _win32_lib_extensions { my @extensions; push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'}; push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions; push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions; return \@extensions; } sub _debug { my ( $message, $verbose ) = @_; return if !$verbose; warn $message; return; } 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' ); 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 = VMS::Filespec::vmspath( $dir ); } 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 "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; $type = 'OBJ'; } else { warn "Warning (mostly 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 "Warning (mostly 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 ) { 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 "Warning (mostly 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; $ldlib =~ s/^\s+|\s+$//g; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib; } 1; CBuilder/Base.pm 0000644 00000025043 15140257564 0007462 0 ustar 00 package ExtUtils::CBuilder::Base; use strict; use warnings; use File::Spec; use File::Basename; use Cwd (); use Config; use Text::ParseWords; use IPC::Cmd qw(can_run); use File::Temp qw(tempfile); our $VERSION = '0.280234'; # VERSION # More details about C/C++ compilers: # http://developers.sun.com/sunstudio/documentation/product/compiler.jsp # http://gcc.gnu.org/ # http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp # http://msdn.microsoft.com/en-us/vstudio/default.aspx my %cc2cxx = ( # first line order is important to support wrappers like in pkgsrc cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers gcc => [ 'g++' ], # GNU Compiler Collection xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety cl => [ 'cl' ], # Microsoft Visual Studio ); 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 defined $ENV{CC}; $self->{config}{ccflags} = join(" ", $self->{config}{ccflags}, $ENV{CFLAGS}) if defined $ENV{CFLAGS}; $self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX}; $self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS}; $self->{config}{ld} = $ENV{LD} if defined $ENV{LD}; $self->{config}{ldflags} = join(" ", $self->{config}{ldflags}, $ENV{LDFLAGS}) if defined $ENV{LDFLAGS}; unless ( exists $self->{config}{cxx} ) { my ($ccbase, $ccpath, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); ## If the path is just "cc", fileparse returns $ccpath as "./" $ccpath = "" if $self->{config}{cc} =~ /^\Q$ccbase$ccsfx\E$/; foreach my $cxx (@{$cc2cxx{$ccbase}}) { my $cxx1 = File::Spec->catfile( $ccpath, $cxx . $ccsfx); if( can_run( $cxx1 ) ) { $self->{config}{cxx} = $cxx1; last; } my $cxx2 = $cxx . $ccsfx; if( can_run( $cxx2 ) ) { $self->{config}{cxx} = $cxx2; last; } if( can_run( $cxx ) ) { $self->{config}{cxx} = $cxx; last; } } unless ( exists $self->{config}{cxx} ) { $self->{config}{cxx} = $self->{config}{cc}; my $cflags = $self->{config}{ccflags}; $self->{config}{cxxflags} = '-x c++'; $self->{config}{cxxflags} .= " $cflags" if defined $cflags; } } 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); # XXX how about using IPC::Cmd::can_run here? 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 get_config { return %{ $_[0]->{config} }; } 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{$_}", sort keys %args; } sub compile { my ($self, %args) = @_; die "Missing 'source' argument to compile()" unless defined $args{source}; my $cf = $self->{config}; # For convenience my $object_file = $args{object_file} ? $args{object_file} : $self->object_file($args{source}); my $include_dirs_ref = (exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY") ? [ $args{include_dirs} ] : $args{include_dirs}; my @include_dirs = $self->arg_include_dirs( @{ $include_dirs_ref || [] }, $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($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags}); 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($object_file), ); my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc}); $self->do_system(@cc, @flags, $args{source}) or die "error building $object_file from '$args{source}'"; return $object_file; } sub have_compiler { my ($self, $is_cplusplus) = @_; my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc"; my $suffix = $is_cplusplus ? ".cc" : ".c"; return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag}; my $result; my $attempts = 3; # tmpdir has issues for some people so fall back to current dir # don't clobber existing files (rare, but possible) my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix ); binmode $FH; if ( $is_cplusplus ) { print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; } else { print $FH "int boot_compilet() { return 1; }\n"; } close $FH; 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; } return $self->{$have_compiler_flag} = $result; } sub have_cplusplus { push @_, 1; goto &have_compiler; } sub lib_file { my ($self, $dl_file, %args) = @_; $dl_file =~ s/\.[^.]+$//; $dl_file =~ tr/"//d; if (defined $args{module_name} and length $args{module_name}) { # Need to create with the same name as DynaLoader will load with. require DynaLoader; if (defined &DynaLoader::mod2fname) { my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]); my ($dev, $lib_dir, undef) = File::Spec->splitpath($dl_file); $dl_file = File::Spec->catpath($dev, $lib_dir, $lib); } } $dl_file .= ".$self->{config}{dlext}"; return $dl_file; } 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) = @_; my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args); require ExtUtils::Mksymlists; # dl. abbrev for dynamic library ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } ); # Mksymlists will create one of these files return grep -e, map "$dl_file_out.$_", qw(ext def opt); } sub _prepare_mksymlists_args { my $args = shift; ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file}; my %mksymlists_args = ( 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'), ); return ($args->{dl_file}, \%mksymlists_args); } 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], %args); 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); # Text::ParseWords replaces all 'escaped' characters with themselves, which completely # breaks paths under windows. As such, we forcibly replace backwards slashes with forward # slashes on windows. $string =~ s@\\@/@g if $^O eq 'MSWin32'; 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; # vim: ts=2 sw=2 et: CBuilder/Platform/Windows.pm 0000644 00000021401 15140257564 0012020 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows; use strict; use warnings; use File::Basename; use File::Spec; use ExtUtils::CBuilder::Base; use IO::File; our $VERSION = '0.280234'; # VERSION our @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{$_}"}, sort keys %args; } sub compile { my ($self, %args) = @_; my $cf = $self->{config}; die "Missing 'source' argument to compile()" unless defined $args{source}; $args{include_dirs} = [ $args{include_dirs} ] if exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY"; 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 => $args{object_file} || 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/lib/CORE} 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} ||= $spec{output} . '.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( %args, 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 CBuilder/Platform/VMS.pm 0000644 00000024060 15140257564 0011037 0 ustar 00 package ExtUtils::CBuilder::Platform::VMS; use warnings; use strict; use ExtUtils::CBuilder::Base; our $VERSION = '0.280234'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Base); use File::Spec::Functions qw(catfile catdir); use Config; # 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{$_}" : '') . "\"", sort 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) . ')'); } # We override the compile method because we consume the includes and defines # parts of ccflags in the process of compiling but don't save those parts # anywhere, so $self->{config}{ccflags} needs to be reset for each compile # operation. sub compile { my ($self, %args) = @_; $self->{config}{ccflags} = $Config{ccflags}; $self->{config}{ccflags} = $ENV{CFLAGS} if defined $ENV{CFLAGS}; return $self->SUPER::compile(%args); } 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"); } # 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'); 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) { 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; CBuilder/Platform/aix.pm 0000644 00000001161 15140257564 0011150 0 ustar 00 package ExtUtils::CBuilder::Platform::aix; use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; our $VERSION = '0.280234'; # VERSION our @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; CBuilder/Platform/darwin.pm 0000644 00000001010 15140257564 0011644 0 ustar 00 package ExtUtils::CBuilder::Platform::darwin; use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; our $VERSION = '0.280234'; # VERSION our @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; CBuilder/Platform/cygwin.pm 0000644 00000001644 15140257564 0011675 0 ustar 00 package ExtUtils::CBuilder::Platform::cygwin; use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; our $VERSION = '0.280234'; # VERSION our @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; CBuilder/Platform/os2.pm 0000644 00000004553 15140257564 0011102 0 ustar 00 package ExtUtils::CBuilder::Platform::os2; use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; our $VERSION = '0.280234'; # VERSION our @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})) { # 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 $exp_dir = ($near_obj =~ m,(.*)[/\\],s ? "$1/" : '' ); $args{dl_file} = $1 if $near_obj =~ m,(.*)\.,s; # put ExportList near OBJ # 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; CBuilder/Platform/android.pm 0000644 00000002300 15140257564 0012003 0 ustar 00 package ExtUtils::CBuilder::Platform::android; use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; use Config; our $VERSION = '0.280234'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # The Android linker will not recognize symbols from # libperl unless the module explicitly depends on it. sub link { my ($self, %args) = @_; if ($self->{config}{useshrplib} eq 'true') { $args{extra_linker_flags} = [ $self->split_like_shell($args{extra_linker_flags}), '-L' . $self->perl_inc(), '-lperl', $self->split_like_shell($Config{perllibs}), ]; } # Several modules on CPAN rather rightfully expect being # able to pass $so_file to DynaLoader::dl_load_file and # have it Just Work. However, $so_file will more likely # than not be a relative path, and unless the module # author subclasses MakeMaker/Module::Build to modify # LD_LIBRARY_PATH, which would be insane, Android's linker # won't find the .so # So we make this all work by returning an absolute path. my($so_file, @so_tmps) = $self->SUPER::link(%args); $so_file = File::Spec->rel2abs($so_file); return wantarray ? ($so_file, @so_tmps) : $so_file; } 1; CBuilder/Platform/Windows/MSVC.pm 0000644 00000006260 15140257564 0012576 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::MSVC; our $VERSION = '0.280234'; # VERSION use warnings; use strict; 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}; my $manifest = $spec{manifest}; $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', $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; CBuilder/Platform/Windows/BCC.pm 0000644 00000006657 15140257564 0012427 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::BCC; our $VERSION = '0.280234'; # VERSION use strict; use warnings; 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 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{startup} && @{$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; CBuilder/Platform/Windows/GCC.pm 0000644 00000010244 15140257564 0012417 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::GCC; our $VERSION = '0.280234'; # VERSION use warnings; use strict; 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; CBuilder/Platform/Unix.pm 0000644 00000002026 15140257564 0011313 0 ustar 00 package ExtUtils::CBuilder::Platform::Unix; use warnings; use strict; use ExtUtils::CBuilder::Base; our $VERSION = '0.280234'; # VERSION our @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; CBuilder/Platform/dec_osf.pm 0000644 00000000654 15140257564 0011777 0 ustar 00 package ExtUtils::CBuilder::Platform::dec_osf; use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; our $VERSION = '0.280234'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); 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; ParseXS.pod 0000644 00000010466 15140257564 0006615 0 ustar 00 =head1 NAME ExtUtils::ParseXS - converts Perl XS code into C code =head1 SYNOPSIS use ExtUtils::ParseXS; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file( filename => 'foo.xs' ); $pxs->process_file( filename => 'foo.xs', output => 'bar.c', 'C++' => 1, typemap => 'path/to/typemap', hiertype => 1, except => 1, versioncheck => 1, linenumbers => 1, optimize => 1, prototypes => 1, ); # Legacy non-OO interface using a singleton: use ExtUtils::ParseXS qw(process_file); process_file( filename => 'foo.xs' ); =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()> and/or C<report_error_count()> may be exported upon request. Using the functional interface is discouraged. =head1 METHODS =over 4 =item $pxs->new() Returns a new, empty XS parser/compiler object. =item $pxs->process_file() This method processes an XS file and sends output to a C file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. 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++ hierarchical 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<Maintainer note:> I have no clue what this does. Strips function prefixes? =back =item $pxs->report_error_count() This method returns the number of [a certain kind of] errors encountered during processing of the XS file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. =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> =item * James Keenan, <jkeenan@cpan.org> =item * Steffen Mueller, <smueller@cpan.org> =back =head1 COPYRIGHT Copyright 2002-2014 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 C<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 MM_UWIN.pm 0000644 00000001724 15140257564 0006272 0 ustar 00 package ExtUtils::MM_UWIN; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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; MM.pm 0000644 00000004134 15140257564 0005426 0 ustar 00 package ExtUtils::MM; use strict; use ExtUtils::MakeMaker::Config; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<ExtUtils::MakeMaker> which automatically chooses the appropriate OS specific subclass for you (ie. L<ExtUtils::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; } MM_Any.pm 0000644 00000241726 15140257564 0006247 0 ustar 00 package ExtUtils::MM_Any; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; use Carp; use File::Spec; use File::Basename; BEGIN { our @ISA = qw(File::Spec); } # We need $Verbose use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); 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 $Updir = __PACKAGE__->updir; my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec'; my $METASPEC_V = 2; =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> L<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 can_run use ExtUtils::MM; my $runnable = MM->can_run($Config{make}); If called in a scalar context it will return the full path to the binary you asked for if it was found, or C<undef> if it was not. If called in a list context, it will return a list of the full paths to instances of the binary where found in C<PATH>, or an empty list if it was not found. Copied from L<IPC::Cmd|IPC::Cmd/"$path = can_run( PROGRAM );">, but modified into a method (and removed C<$INSTANCES> capability). =cut sub can_run { my ($self, $command) = @_; # a lot of VMS executables have a symbol defined # check those first if ( $^O eq 'VMS' ) { require VMS::DCLsym; my $syms = VMS::DCLsym->new; return $command if scalar $syms->getsym( uc $command ); } my @possibles; if( File::Spec->file_name_is_absolute($command) ) { return $self->maybe_command($command); } else { for my $dir ( File::Spec->path, File::Spec->curdir ) { next if ! $dir || ! -d $dir; my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command); push @possibles, $abs if $abs = $self->maybe_command($abs); } } return @possibles if wantarray; return shift @possibles; } =head3 can_redirect_error $useredirect = MM->can_redirect_error; True if on an OS where qx operator (or backticks) can redirect C<STDERR> onto C<STDOUT>. =cut sub can_redirect_error { my $self = shift; $self->os_flavor_is('Unix') or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x')) or $self->os_flavor_is('OS/2') } =head3 is_make_type my $is_dmake = $self->is_make_type('dmake'); Returns true if C<< $self->make >> is the given type; possibilities are: gmake GNU make dmake nmake bsdmake BSD pmake-derived =cut my %maketype2true; # undocumented - so t/cd.t can still do its thing sub _clear_maketype_cache { %maketype2true = () } sub is_make_type { my($self, $type) = @_; return $maketype2true{$type} if defined $maketype2true{$type}; (undef, undef, my $make_basename) = $self->splitpath($self->make); return $maketype2true{$type} = 1 if $make_basename =~ /\b$type\b/i; # executable's filename return $maketype2true{$type} = 0 if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake # now have to run with "-v" and guess my $redirect = $self->can_redirect_error ? '2>&1' : ''; my $make = $self->make || $self->{MAKE}; my $minus_v = `"$make" -v $redirect`; return $maketype2true{$type} = 1 if $type eq 'gmake' and $minus_v =~ /GNU make/i; return $maketype2true{$type} = 1 if $type eq 'bsdmake' and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im; $maketype2true{$type} = 0; # it wasn't whatever you asked } =head3 can_dep_space my $can_dep_space = $self->can_dep_space; Returns true if C<make> can handle (probably by quoting) dependencies that contain a space. Currently known true for GNU make, false for BSD pmake derivative. =cut my $cached_dep_space; sub can_dep_space { my $self = shift; return $cached_dep_space if defined $cached_dep_space; return $cached_dep_space = 1 if $self->is_make_type('gmake'); return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32 return $cached_dep_space = 0 if $self->is_make_type('bsdmake'); return $cached_dep_space = 0; # assume no } =head3 quote_dep $text = $mm->quote_dep($text); Method that protects Makefile single-value constants (mainly filenames), so that make will still treat them as single values even if they inconveniently have spaces in. If the make program being used cannot achieve such protection and the given text would need it, throws an exception. =cut sub quote_dep { my ($self, $arg) = @_; die <<EOF if $arg =~ / / and not $self->can_dep_space; Tried to use make dependency with space for make that can't: '$arg' EOF $arg =~ s/( )/\\$1/g; # how GNU make does it return $arg; } =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 make_type Returns a suitable string describing the type of makefile being written. =cut # override if this isn't suitable! sub make_type { return 'Unix-style'; } =head3 stashmeta my @recipelines = $MM->stashmeta($text, $file); Generates a set of C<@recipelines> which will result in the literal C<$text> ending up in literal C<$file> when the recipe is executed. Call it once, with all the text you want in C<$file>. Make macros will not be expanded, so the locations will be fixed at configure-time, not at build-time. =cut sub stashmeta { my($self, $text, $file) = @_; $self->echo($text, $file, { allow_variables => 0, append => 0 }); } =head3 echo my @commands = $MM->echo($text); my @commands = $MM->echo($text, $file); my @commands = $MM->echo($text, $file, \%opts); Generates a set of @commands which print the $text to a $file. If $file is not given, output goes to STDOUT. If $opts{append} is true the $file will be appended to rather than overwritten. Default is to overwrite. If $opts{allow_variables} is true, make variables of the form C<$(...)> will not be escaped. Other C<$> will. Default is to escape all C<$>. Example of use: my $make = join '', map "\t$_\n", $MM->echo($text, $file); =cut sub echo { my($self, $text, $file, $opts) = @_; # Compatibility with old options if( !ref $opts ) { my $append = $opts; $opts = { append => $append || 0 }; } $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; my $ql_opts = { allow_variables => $opts->{allow_variables} }; my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) } split /\n/, $text; if( $file ) { my $redirect = $opts->{append} ? '>>' : '>'; $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'; Dollar signs in the $perl_code will be protected from make using the C<quote_literal> method, unless they are recognised as being a make variable, C<$(varname)>, in which case they will be left for make to expand. 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); my $safe_text = $MM->quote_literal($text, \%options); 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. If $options{allow_variables} is true it will leave C<'$(FOO)'> make variables untouched. If false they will be escaped like any other C<$>. Defaults to true. =head3 escape_dollarsigns my $escaped_text = $MM->escape_dollarsigns($text); Escapes stray C<$> so they are not interpreted as make variables. It lets by C<$(...)>. =cut sub escape_dollarsigns { my($self, $text) = @_; # Escape dollar signs which are not starting a variable $text =~ s{\$ (?!\() }{\$\$}gx; return $text; } =head3 escape_all_dollarsigns my $escaped_text = $MM->escape_all_dollarsigns($text); Escapes all C<$> so they are not interpreted as make variables. =cut sub escape_all_dollarsigns { my($self, $text) = @_; # Escape dollar signs $text =~ s{\$}{\$\$}gx; return $text; } =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 _xs_list_basenames { my ($self) = @_; map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} }; } sub blibdirs_target { my $self = shift; my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib autodir archautodir bin script man1dir man3dir ); if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); } } 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 = sort values %{$self->{XS}}; # .c files from *.xs files push @files, map { my $file = $_; map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base); } $self->_xs_list_basenames; 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) # ); 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) MYMETA.json MYMETA.yml 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 if ($^O eq 'vos') { push(@files, qw[perl*.kp]); } else { 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 = sort keys %f; } { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort 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'; $(NOECHO) $(RM_F) $(MAKEFILE_OLD) - $(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); exit 0 unless 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 separate 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 4; %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 scratch directory, 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 xs_dlsyms_arg Returns command-line arg(s) to linker for file listing dlsyms to export. Defaults to returning empty string, can be overridden by e.g. AIX. =cut sub xs_dlsyms_arg { return ''; } =head3 xs_dlsyms_ext Returns file-extension for C<xs_make_dlsyms> method's output file, including any "." character. =cut sub xs_dlsyms_ext { die "Pure virtual method"; } =head3 xs_dlsyms_extra Returns any extra text to be prepended to the C<$extra> argument of C<xs_make_dlsyms>. =cut sub xs_dlsyms_extra { ''; } =head3 xs_dlsyms_iterator Iterates over necessary shared objects, calling C<xs_make_dlsyms> method for each with appropriate arguments. =cut sub xs_dlsyms_iterator { my ($self, $attribs) = @_; if ($self->{XSMULTI}) { my @m; for my $ext ($self->_xs_list_basenames) { my @parts = File::Spec->splitdir($ext); shift @parts if $parts[0] eq 'lib'; my $name = join '::', @parts; push @m, $self->xs_make_dlsyms( $attribs, $ext . $self->xs_dlsyms_ext, "$ext.xs", $name, $parts[-1], {}, [], {}, [], $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext), ); } return join "\n", @m; } else { return $self->xs_make_dlsyms( $attribs, $self->{BASEEXT} . $self->xs_dlsyms_ext, 'Makefile.PL', $self->{NAME}, $self->{DLBASE}, $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {}, $attribs->{FUNCLIST} || $self->{FUNCLIST} || [], $attribs->{IMPORTS} || $self->{IMPORTS} || {}, $attribs->{DL_VARS} || $self->{DL_VARS} || [], $self->xs_dlsyms_extra, ); } } =head3 xs_make_dlsyms $self->xs_make_dlsyms( \%attribs, # hashref from %attribs in caller "$self->{BASEEXT}.def", # output file for Makefile target 'Makefile.PL', # dependency $self->{NAME}, # shared object's "name" $self->{DLBASE}, # last ::-separated part of name $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params $attribs{FUNCLIST} || $self->{FUNCLIST} || [], $attribs{IMPORTS} || $self->{IMPORTS} || {}, $attribs{DL_VARS} || $self->{DL_VARS} || [], # optional extra param that will be added as param to Mksymlists ); Utility method that returns Makefile snippet to call C<Mksymlists>. =cut sub xs_make_dlsyms { my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; my @m = ( "\n$target: $dep\n", q! $(PERLRUN) -MExtUtils::Mksymlists \\ -e "Mksymlists('NAME'=>\"!, $name, q!\", 'DLBASE' => '!,$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) ); push @m, $extra if defined $extra; push @m, qq!);"\n!; join '', @m; } =head3 dynamic (o) Defines the dynamic target. =cut sub dynamic { # --- Dynamic Loading Sections --- my($self) = shift; ' dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC) $(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 (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) { $dependencies .= " \\\n\t$name"; } my $manify = <<END; manifypods : pure_all config $dependencies END my @man_cmds; foreach my $num (qw(1 3)) { my $pods = $self->{"MAN${num}PODS"}; my $p2m = sprintf <<'CMD', "\$(MAN${num}EXT)", "$]" > 5.008 ? " -u" : ""; $(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s CMD push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods); } $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds; $manify .= join '', map { "$_\n" } @man_cmds; return $manify; } { my $has_cpan_meta; sub _has_cpan_meta { return $has_cpan_meta if defined $has_cpan_meta; return $has_cpan_meta = !!eval { require CPAN::Meta; CPAN::Meta->VERSION(2.112150); 1; }; } } =head3 metafile_target my $target = $mm->metafile_target; Generate the metafile target. Writes the file META.yml (YAML encoded meta-data) and META.json (JSON 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} or ! _has_cpan_meta(); metafile : $(NOECHO) $(NOOP) MAKE_FRAG my $metadata = $self->metafile_data( $self->{META_ADD} || {}, $self->{META_MERGE} || {}, ); my $meta = $self->_fix_metadata_before_conversion( $metadata ); my @write_metayml = $self->stashmeta( $meta->as_string({version => "1.4"}), 'META_new.yml' ); my @write_metajson = $self->stashmeta( $meta->as_string({version => "2.0"}), 'META_new.json' ); my $metayml = join("\n\t", @write_metayml); my $metajson = join("\n\t", @write_metajson); return sprintf <<'MAKE_FRAG', $metayml, $metajson; metafile : create_distdir $(NOECHO) $(ECHO) Generating META.yml %s -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml $(NOECHO) $(ECHO) Generating META.json %s -$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json MAKE_FRAG } =begin private =head3 _fix_metadata_before_conversion $mm->_fix_metadata_before_conversion( \%metadata ); Fixes errors in the metadata before it's handed off to L<CPAN::Meta> for conversion. This hopefully results in something that can be used further on, no guarantee is made though. =end private =cut sub _fix_metadata_before_conversion { my ( $self, $metadata ) = @_; # we should never be called unless this already passed but # prefer to be defensive in case somebody else calls this return unless _has_cpan_meta; my $bad_version = $metadata->{version} && !CPAN::Meta::Validator->new->version( 'version', $metadata->{version} ); # just delete all invalid versions if( $bad_version ) { warn "Can't parse version '$metadata->{version}'\n"; $metadata->{version} = ''; } my $validator2 = CPAN::Meta::Validator->new( $metadata ); my @errors; push @errors, $validator2->errors if !$validator2->is_valid; my $validator14 = CPAN::Meta::Validator->new( { %$metadata, 'meta-spec' => { version => 1.4 }, } ); push @errors, $validator14->errors if !$validator14->is_valid; # fix non-camelcase custom resource keys (only other trick we know) for my $error ( @errors ) { my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ ); next if !$key; # first try to remove all non-alphabetic chars ( my $new_key = $key ) =~ s/[^_a-zA-Z]//g; # if that doesn't work, uppercase first one $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key ); # copy to new key if that worked $metadata->{resources}{$new_key} = $metadata->{resources}{$key} if $validator14->custom_1( $new_key ); # and delete old one in any case delete $metadata->{resources}{$key}; } # paper over validation issues, but still complain, necessary because # there's no guarantee that the above will fix ALL errors my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) }; warn $@ if $@ and $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/; # use the original metadata straight if the conversion failed # or if it can't be stringified. if( !$meta || !eval { $meta->as_string( { version => $METASPEC_V } ) } || !eval { $meta->as_string } ) { $meta = bless $metadata, 'CPAN::Meta'; } my $now_license = $meta->as_struct({ version => 2 })->{license}; if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and @{$now_license} == 1 and $now_license->[0] eq 'unknown' ) { warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n"; } $meta; } =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_hashref = $mm->metafile_data(\%meta_add, \%meta_merge); Returns the data which MakeMaker turns into the META.yml file and the META.json file. It is always in version 2.0 of the format. 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) = @_; $meta_add ||= {}; $meta_merge ||= {}; my $version = _normalize_version($self->{VERSION}); my $release_status = ($version =~ /_/) ? 'unstable' : 'stable'; my %meta = ( # required abstract => $self->{ABSTRACT} || 'unknown', author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'], dynamic_config => 1, generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", license => [ $self->{LICENSE} || 'unknown' ], 'meta-spec' => { url => $METASPEC_URL, version => $METASPEC_V, }, name => $self->{DISTNAME}, release_status => $release_status, version => $version, # optional no_index => { directory => [qw(t inc)] }, ); $self->_add_requirements_to_meta(\%meta); if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) { return \%meta; } # needs to be based on the original version my $v1_add = _metaspec_version($meta_add) !~ /^2/; my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge; for my $frag ($meta_add, $meta_merge) { my $def_v = $frag == $meta_add ? $merge_v : $add_v; $frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment; } # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that # will override all prereqs, which is more than the user asked for; # instead, we'll go inside the prereqs and override all those while( my($key, $val) = each %$meta_add ) { if ($v1_add and $key eq 'prereqs') { $meta{$key}{$_} = $val->{$_} for keys %$val; } elsif ($key ne 'meta-spec') { $meta{$key} = $val; } } while( my($key, $val) = each %$meta_merge ) { next if $key eq 'meta-spec'; $self->_hash_merge(\%meta, $key, $val); } return \%meta; } =begin private =cut sub _add_requirements_to_meta { my ( $self, $meta ) = @_; # Check the original args so we can tell between the user setting it # to an empty hash and it just being initialized. $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES} ? $self->{CONFIGURE_REQUIRES} : { 'ExtUtils::MakeMaker' => 0, }; $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES} ? $self->{BUILD_REQUIRES} : { 'ExtUtils::MakeMaker' => 0, }; $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES} if $self->{ARGS}{TEST_REQUIRES}; $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM} if $self->{ARGS}{PREREQ_PM}; $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) if $self->{MIN_PERL_VERSION}; } # spec version of given fragment - if not given, assume 1.4 sub _metaspec_version { my ( $meta ) = @_; return $meta->{'meta-spec'}->{version} if defined $meta->{'meta-spec'} and defined $meta->{'meta-spec'}->{version}; return '1.4'; } sub _add_requirements_to_meta_v1_4 { my ( $self, $meta ) = @_; # Check the original args so we can tell between the user setting it # to an empty hash and it just being initialized. if( $self->{ARGS}{CONFIGURE_REQUIRES} ) { $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES}; } else { $meta->{configure_requires} = { 'ExtUtils::MakeMaker' => 0, }; } if( $self->{ARGS}{BUILD_REQUIRES} ) { $meta->{build_requires} = $self->{BUILD_REQUIRES}; } else { $meta->{build_requires} = { 'ExtUtils::MakeMaker' => 0, }; } if( $self->{ARGS}{TEST_REQUIRES} ) { $meta->{build_requires} = { %{ $meta->{build_requires} }, %{ $self->{TEST_REQUIRES} }, }; } $meta->{requires} = $self->{PREREQ_PM} if defined $self->{PREREQ_PM}; $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) if $self->{MIN_PERL_VERSION}; } # Adapted from Module::Build::Base sub _normalize_version { my ($version) = @_; $version = 0 unless defined $version; if ( ref $version eq 'version' ) { # version objects $version = $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots # normalize string tuples without "v": "1.2.3" -> "v1.2.3" $version = "v$version"; } else { # leave alone } return $version; } =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 and META.json to the MANIFEST in the distdir. =cut sub distmeta_target { my $self = shift; my @add_meta = ( $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']), exit unless -e q{META.yml}; eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) } or die "Could not add META.yml to MANIFEST: ${'@'}" CODE $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']) exit unless -f q{META.json}; eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) } or die "Could not add META.json to MANIFEST: ${'@'}" CODE ); my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta; return sprintf <<'MAKE', @add_meta_to_distdir; distmeta : create_distdir metafile $(NOECHO) %s $(NOECHO) %s MAKE } =head3 mymeta my $mymeta = $mm->mymeta; Generate MYMETA information as a hash either from an existing CPAN Meta file (META.json or META.yml) or from internal data. =cut sub mymeta { my $self = shift; my $file = shift || ''; # for testing my $mymeta = $self->_mymeta_from_meta($file); my $v2 = 1; unless ( $mymeta ) { $mymeta = $self->metafile_data( $self->{META_ADD} || {}, $self->{META_MERGE} || {}, ); $v2 = 0; } # Overwrite the non-configure dependency hashes $self->_add_requirements_to_meta($mymeta); $mymeta->{dynamic_config} = 0; return $mymeta; } sub _mymeta_from_meta { my $self = shift; my $metafile = shift || ''; # for testing return unless _has_cpan_meta(); my $meta; for my $file ( $metafile, "META.json", "META.yml" ) { next unless -e $file; eval { $meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } ); }; last if $meta; } return unless $meta; # META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory. # There was a good chance the author accidentally uploaded a stale META.yml if they # rolled their own tarball rather than using "make dist". if ($meta->{generated_by} && $meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { my $eummv = do { local $^W = 0; $1+0; }; if ($eummv < 6.2501) { return; } } return $meta; } =head3 write_mymeta $self->write_mymeta( $mymeta ); Write MYMETA information to MYMETA.json and MYMETA.yml. =cut sub write_mymeta { my $self = shift; my $mymeta = shift; return unless _has_cpan_meta(); my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta ); $meta_obj->save( 'MYMETA.json', { version => "2.0" } ); $meta_obj->save( 'MYMETA.yml', { version => "1.4" } ); return 1; } =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 = sort keys %f; } { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort 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 :: 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; my @m = <<'EOF'; # so clean is forced to complete before realclean_subdirs runs realclean_subdirs : clean EOF return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}}; foreach my $dir (@{$self->{DIR}}) { foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) { my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile); chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s'; CODE push @m, "\t- $subrclean\n"; } } return join '', @m; } =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 die "Could not add SIGNATURE to MANIFEST: ${'@'}" 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 : distmeta $(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 pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static 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"; } if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) { warn "WARNING: ABSTRACT contains control character(s),". " they will be removed\n"; $self->{ABSTRACT} =~ s![[:cntrl:]]+!!g; return; } } =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}) { $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}.')'; warn "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); warn " $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} ||= ($thing =~ /^man.dir$/ and not $Config{lc $key}) ? 'none' : $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"); } } if (defined $self->{VERSION}) { if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) { require version; my $normal = eval { version->new( $self->{VERSION} ) }; $self->{VERSION} = $normal if defined $normal; } $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 bottom line 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_tools $MM->init_tools(); Initializes the simple macro definitions used by tools_other() and places them in the $MM object. These use conservative cross platform versions and should be overridden with platform specific versions for performance. Defines at least these macros. Macro Description NOOP Do nothing NOECHO Tell make not to display the command itself 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 TEST_S Test the size of a file CP Copy a file CP_NONEMPTY Copy a file if it is not empty 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_tools { my $self = shift; $self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; 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->{TEST_S} ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]); $self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]); $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->{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->{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} ||= ''; return; } =head3 init_others $MM->init_others(); Initializes the macro definitions having to do with compiling and linking 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 L<ExtUtils::MakeMaker>. =cut sub init_others { my $self = shift; $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} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT}; $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) { $self->{OBJECT} = join(" ", @{$self->{O_FILES}}); $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; } # 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 CP_NONEMPTY } ) { 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 separator 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 separator between directories. Some operating systems use different separators 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 module. (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 separator 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" "-MTest::Harness" }. qq{"-e" "undef *Test::Harness::Switches; 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); return 1 if $pthinks =~ /perl-base/; # https://bugs.debian.org/962138 $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 <<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 L<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 find_tests_recursive my $tests = $mm->find_tests_recursive; Returns a string suitable for feeding to the shell to return all tests in t/ but recursively. Equivalent to my $tests = $mm->find_tests_recursive_in('t'); =cut sub find_tests_recursive { my $self = shift; return $self->find_tests_recursive_in('t'); } =head3 find_tests_recursive_in my $tests = $mm->find_tests_recursive_in($dir); Returns a string suitable for feeding to the shell to return all tests in $dir recursively. =cut sub find_tests_recursive_in { my($self, $dir) = @_; return '' unless -d $dir; require File::Find; my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] ); my %depths; my $wanted = sub { return unless m!\.t$!; my ($volume,$directories,$file) = File::Spec->splitpath( $File::Find::name ); my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories ); $depth -= $base_depth; $depths{ $depth } = 1; }; File::Find::find( $wanted, $dir ); return join ' ', map { $dir . '/*' x $_ . '.t' } sort { $a <=> $b } keys %depths; } =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 and base-level F<README.pod> from installation. =cut sub libscan { my($self,$path) = @_; if ($path =~ m<^README\.pod$>i) { warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n"; return ''; } 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 ''; } =head3 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 { ""; } =head3 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 { ""; } =head3 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 { ""; } =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 include 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 _perl_header_files my $perl_header_files= $self->_perl_header_files; returns a sorted list of header files as found in PERL_SRC or $archlibexp/CORE. Used by perldepend() in MM_Unix and MM_VMS via _perl_header_files_fragment() =end private =cut sub _perl_header_files { my $self = shift; my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE'); opendir my $dh, $header_dir or die "Failed to opendir '$header_dir' to find header files: $!"; # we need to use a temporary here as the sort in scalar context would have undefined results. my @perl_headers= sort grep { /\.h\z/ } readdir($dh); closedir $dh; return @perl_headers; } =begin private =head3 _perl_header_files_fragment ($o, $separator) my $perl_header_files_fragment= $self->_perl_header_files_fragment("/"); return a Makefile fragment which holds the list of perl header files which XS code depends on $(PERL_INC), and sets up the dependency for the $(OBJECT) file. The $separator argument defaults to "". MM_VMS will set it to "" and MM_UNIX to "/" in perldepend(). This reason child subclasses need to control this is that in VMS the $(PERL_INC) directory will already have delimiters in it, but in UNIX $(PERL_INC) will need a slash between it an the filename. Hypothetically win32 could use "\\" (but it doesn't need to). =end private =cut sub _perl_header_files_fragment { my ($self, $separator)= @_; $separator ||= ""; return join("\\\n", "PERL_HDRS = ", map { sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ ) } $self->_perl_header_files() ) . "\n\n" . "\$(OBJECT) : \$(PERL_HDRS)\n"; } =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; Command/MM.pm 0000644 00000017030 15140257564 0007003 0 ustar 00 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 test_s cp_nonempty); our $VERSION = '7.44'; $VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; sub mtime { no warnings 'redefine'; local $@; *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat) ? sub { (Time::HiRes::stat($_[0]))[9] } : sub { ( stat($_[0]))[9] } ; goto &mtime; } =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 0; } } 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', 'utf8|u' ); delete $options{utf8} unless $Pod::Man::VERSION >= 2.17; # 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}; my $count = scalar @ARGV / 2; my $plural = $count == 1 ? 'document' : 'documents'; print "Manifying $count pod $plural\n"; do {{ # so 'next' works my ($pod, $man) = splice(@ARGV, 0, 2); next if ((-e $man) && (mtime($man) > mtime($pod)) && (mtime($man) > mtime("Makefile"))); 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 separated 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; my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time); $pod = sprintf <<'POD', scalar($time), $type, $name, $name; =head2 %s: C<%s> L<%s|%s> =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 } =item B<test_s> perl "-MExtUtils::Command::MM" -e test_s <file> Tests if a file exists and is not empty (size > 0). I<Exits> with 0 if it does, 1 if it does not. =cut sub test_s { exit(-s $ARGV[0] ? 0 : 1); } =item B<cp_nonempty> perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm> Tests if the source file exists and is not empty (size > 0). If it is not empty it copies it to the given destination with the given permissions. =back =cut sub cp_nonempty { my @args = @ARGV; return 0 unless -s $args[0]; require ExtUtils::Command; { local @ARGV = @args[0,1]; ExtUtils::Command::cp(@ARGV); } { local @ARGV = @args[2,1]; ExtUtils::Command::chmod(@ARGV); } } 1; Liblist.pm 0000644 00000022427 15140257564 0006524 0 ustar 00 package ExtUtils::Liblist; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 my $dir_fh, $_[0]; my @out = grep /$rex/, readdir $dir_fh; closedir $dir_fh; 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 Typemaps.pm 0000644 00000064415 15140257564 0006727 0 ustar 00 package ExtUtils::Typemaps; use 5.006001; use strict; use warnings; our $VERSION = '3.38'; require ExtUtils::ParseXS; require ExtUtils::ParseXS::Constants; require ExtUtils::Typemaps::InputMap; require ExtUtils::Typemaps::OutputMap; require ExtUtils::Typemaps::Type; =head1 NAME ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files =head1 SYNOPSIS # read/create file my $typemap = ExtUtils::Typemaps->new(file => 'typemap'); # alternatively create an in-memory typemap # $typemap = ExtUtils::Typemaps->new(); # alternatively create an in-memory typemap by parsing a string # $typemap = ExtUtils::Typemaps->new(string => $sometypemap); # add a mapping $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV'); $typemap->add_inputmap( xstype => 'T_NV', code => '$var = ($type)SvNV($arg);' ); $typemap->add_outputmap( xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);' ); $typemap->add_string(string => $typemapstring); # will be parsed and merged # remove a mapping (same for remove_typemap and remove_outputmap...) $typemap->remove_inputmap(xstype => 'SomeType'); # save a typemap to a file $typemap->write(file => 'anotherfile.map'); # merge the other typemap into this one $typemap->merge(typemap => $another_typemap); =head1 DESCRIPTION This module can read, modify, create and write Perl XS typemap files. If you don't know what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals. The module is not entirely round-trip safe: For example it currently simply strips all comments. The order of entries in the maps is, however, preserved. We check for duplicate entries in the typemap, but do not check for missing C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden in a different typemap. =head1 METHODS =cut =head2 new Returns a new typemap object. Takes an optional C<file> parameter. If set, the given file will be read. If the file doesn't exist, an empty typemap is returned. Alternatively, if the C<string> parameter is given, the supplied string will be parsed instead of a file. =cut sub new { my $class = shift; my %args = @_; if (defined $args{file} and defined $args{string}) { die("Cannot handle both 'file' and 'string' arguments to constructor"); } my $self = bless { file => undef, %args, typemap_section => [], typemap_lookup => {}, input_section => [], input_lookup => {}, output_section => [], output_lookup => {}, } => $class; $self->_init(); return $self; } sub _init { my $self = shift; if (defined $self->{string}) { $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); delete $self->{string}; } elsif (defined $self->{file} and -e $self->{file}) { open my $fh, '<', $self->{file} or die "Cannot open typemap file '" . $self->{file} . "' for reading: $!"; local $/ = undef; my $string = <$fh>; $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); } } =head2 file Get/set the file that the typemap is written to when the C<write> method is called. =cut sub file { $_[0]->{file} = $_[1] if @_ > 1; $_[0]->{file} } =head2 add_typemap Add a C<TYPEMAP> entry to the typemap. Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>) and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>). Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be added to the typemap. In that case, only the C<replace> or C<skip> named parameters may be used after the object. Example: $map->add_typemap($type_obj, replace => 1); =cut sub add_typemap { my $self = shift; my $type; my %args; if ((@_ % 2) == 1) { my $orig = shift; $type = $orig->new(); %args = @_; } else { %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; $type = ExtUtils::Typemaps::Type->new( xstype => $xstype, 'prototype' => $args{'prototype'}, ctype => $ctype, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_typemap(ctype => $type->ctype); } elsif ($args{skip}) { return() if exists $self->{typemap_lookup}{$type->ctype}; } else { $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype); } # store push @{$self->{typemap_section}}, $type; # remember type for lookup, too. $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}}; return 1; } =head2 add_inputmap Add an C<INPUT> entry to the typemap. Required named arguments: The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>) and the C<code> to associate with it for input. Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be added to the typemap. In that case, only the C<replace> or C<skip> named parameters may be used after the object. Example: $map->add_inputmap($type_obj, replace => 1); =cut sub add_inputmap { my $self = shift; my $input; my %args; if ((@_ % 2) == 1) { my $orig = shift; $input = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $input = ExtUtils::Typemaps::InputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_inputmap(xstype => $input->xstype); } elsif ($args{skip}) { return() if exists $self->{input_lookup}{$input->xstype}; } else { $self->validate(inputmap_xstype => $input->xstype); } # store push @{$self->{input_section}}, $input; # remember type for lookup, too. $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}}; return 1; } =head2 add_outputmap Add an C<OUTPUT> entry to the typemap. Works exactly the same as C<add_inputmap>. =cut sub add_outputmap { my $self = shift; my $output; my %args; if ((@_ % 2) == 1) { my $orig = shift; $output = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $output = ExtUtils::Typemaps::OutputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_outputmap(xstype => $output->xstype); } elsif ($args{skip}) { return() if exists $self->{output_lookup}{$output->xstype}; } else { $self->validate(outputmap_xstype => $output->xstype); } # store push @{$self->{output_section}}, $output; # remember type for lookup, too. $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}}; return 1; } =head2 add_string Parses a string as a typemap and merge it into the typemap object. Required named argument: C<string> to specify the string to parse. =cut sub add_string { my $self = shift; my %args = @_; die("Need 'string' argument") if not defined $args{string}; # no, this is not elegant. my $other = ExtUtils::Typemaps->new(string => $args{string}); $self->merge(typemap => $other); } =head2 remove_typemap Removes a C<TYPEMAP> entry from the typemap. Required named argument: C<ctype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object. =cut sub remove_typemap { my $self = shift; my $ctype; if (@_ > 1) { my %args = @_; $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); } else { $ctype = $_[0]->tidy_ctype; } return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup}); } =head2 remove_inputmap Removes an C<INPUT> entry from the typemap. Required named argument: C<xstype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object. =cut sub remove_inputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup}); } =head2 remove_inputmap Removes an C<OUTPUT> entry from the typemap. Required named argument: C<xstype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object. =cut sub remove_outputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup}); } sub _remove { my $self = shift; my $rm = shift; my $array = shift; my $lookup = shift; # Just fetch the index of the item from the lookup table my $index = $lookup->{$rm}; return() if not defined $index; # Nuke the item from storage splice(@$array, $index, 1); # Decrement the storage position of all items thereafter foreach my $key (keys %$lookup) { if ($lookup->{$key} > $index) { $lookup->{$key}--; } } return(); } =head2 get_typemap Fetches an entry of the TYPEMAP section of the typemap. Mandatory named arguments: The C<ctype> of the entry. Returns the C<ExtUtils::Typemaps::Type> object for the entry if found. =cut sub get_typemap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); my $index = $self->{typemap_lookup}{$ctype}; return() if not defined $index; return $self->{typemap_section}[$index]; } =head2 get_inputmap Fetches an entry of the INPUT section of the typemap. Mandatory named arguments: The C<xstype> of the entry or the C<ctype> of the typemap that can be used to find the C<xstype>. To wit, the following pieces of code are equivalent: my $type = $typemap->get_typemap(ctype => $ctype) my $input_map = $typemap->get_inputmap(xstype => $type->xstype); my $input_map = $typemap->get_inputmap(ctype => $ctype); Returns the C<ExtUtils::Typemaps::InputMap> object for the entry if found. =cut sub get_inputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{input_lookup}{$xstype}; return() if not defined $index; return $self->{input_section}[$index]; } =head2 get_outputmap Fetches an entry of the OUTPUT section of the typemap. Mandatory named arguments: The C<xstype> of the entry or the C<ctype> of the typemap that can be used to resolve the C<xstype>. (See above for an example.) Returns the C<ExtUtils::Typemaps::InputMap> object for the entry if found. =cut sub get_outputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{output_lookup}{$xstype}; return() if not defined $index; return $self->{output_section}[$index]; } =head2 write Write the typemap to a file. Optionally takes a C<file> argument. If given, the typemap will be written to the specified file. If not, the typemap is written to the currently stored file name (see L</file> above, this defaults to the file it was read from if any). =cut sub write { my $self = shift; my %args = @_; my $file = defined $args{file} ? $args{file} : $self->file(); die("write() needs a file argument (or set the file name of the typemap using the 'file' method)") if not defined $file; open my $fh, '>', $file or die "Cannot open typemap file '$file' for writing: $!"; print $fh $self->as_string(); close $fh; } =head2 as_string Generates and returns the string form of the typemap. =cut sub as_string { my $self = shift; my $typemap = $self->{typemap_section}; my @code; push @code, "TYPEMAP\n"; foreach my $entry (@$typemap) { # type kind proto # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o push @code, $entry->ctype . "\t" . $entry->xstype . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n"; } my $input = $self->{input_section}; if (@$input) { push @code, "\nINPUT\n"; foreach my $entry (@$input) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } my $output = $self->{output_section}; if (@$output) { push @code, "\nOUTPUT\n"; foreach my $entry (@$output) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } return join '', @code; } =head2 as_embedded_typemap Generates and returns the string form of the typemap with the appropriate prefix around it for verbatim inclusion into an XS file as an embedded typemap. This will return a string like TYPEMAP: <<END_OF_TYPEMAP ... typemap here (see as_string) ... END_OF_TYPEMAP The method takes care not to use a HERE-doc end marker that appears in the typemap string itself. =cut sub as_embedded_typemap { my $self = shift; my $string = $self->as_string; my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END); my $icand = 0; my $cand_suffix = ""; while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) { $icand++; if ($icand == @ident_cand) { $icand = 0; ++$cand_suffix; } } my $marker = "$ident_cand[$icand]$cand_suffix"; return "TYPEMAP: <<$marker;\n$string\n$marker\n"; } =head2 merge Merges a given typemap into the object. Note that a failed merge operation leaves the object in an inconsistent state so clone it if necessary. Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj> or C<file =E<gt> $path_to_typemap_file> but not both. Optional arguments: C<replace =E<gt> 1> to force replacement of existing typemap entries without warning or C<skip =E<gt> 1> to skip entries that exist already in the typemap. =cut sub merge { my $self = shift; my %args = @_; if (exists $args{typemap} and exists $args{file}) { die("Need {file} OR {typemap} argument. Not both!"); } elsif (not exists $args{typemap} and not exists $args{file}) { die("Need {file} or {typemap} argument!"); } my @params; push @params, 'replace' => $args{replace} if exists $args{replace}; push @params, 'skip' => $args{skip} if exists $args{skip}; my $typemap = $args{typemap}; if (not defined $typemap) { $typemap = ref($self)->new(file => $args{file}, @params); } # FIXME breaking encapsulation. Add accessor code. foreach my $entry (@{$typemap->{typemap_section}}) { $self->add_typemap( $entry, @params ); } foreach my $entry (@{$typemap->{input_section}}) { $self->add_inputmap( $entry, @params ); } foreach my $entry (@{$typemap->{output_section}}) { $self->add_outputmap( $entry, @params ); } return 1; } =head2 is_empty Returns a bool indicating whether this typemap is entirely empty. =cut sub is_empty { my $self = shift; return @{ $self->{typemap_section} } == 0 && @{ $self->{input_section} } == 0 && @{ $self->{output_section} } == 0; } =head2 list_mapped_ctypes Returns a list of the C types that are mappable by this typemap object. =cut sub list_mapped_ctypes { my $self = shift; return sort keys %{ $self->{typemap_lookup} }; } =head2 _get_typemap_hash Returns a hash mapping the C types to the XS types: { 'char **' => 'T_PACKEDARRAY', 'bool_t' => 'T_IV', 'AV *' => 'T_AVREF', 'InputStream' => 'T_IN', 'double' => 'T_DOUBLE', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_typemap_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; } return \%rv; } =head2 _get_inputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding INPUT code: { 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) ', 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) ', 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_inputmap_hash { my $self = shift; my $lookup = $self->{input_lookup}; my $storage = $self->{input_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_outputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding OUTPUT code: { 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); ', 'T_OUT' => ' { GV *gv = (GV *)sv_newmortal(); gv_init_pvn(gv, gv_stashpvs("$Package",1), "__ANONIO__",10,0); 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; } ', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_outputmap_hash { my $self = shift; my $lookup = $self->{output_lookup}; my $storage = $self->{output_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_prototype_hash Returns a hash mapping the C types of the typemap to their corresponding prototypes. { 'char **' => '$', 'bool_t' => '$', 'AV *' => '$', 'InputStream' => '$', 'double' => '$', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_prototype_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; } return \%rv; } # make sure that the provided types wouldn't collide with what's # in the object already. sub validate { my $self = shift; my %args = @_; if ( exists $args{ctype} and exists $self->{typemap_lookup}{tidy_type($args{ctype})} ) { die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); } if ( exists $args{inputmap_xstype} and exists $self->{input_lookup}{$args{inputmap_xstype}} ) { die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); } if ( exists $args{outputmap_xstype} and exists $self->{output_lookup}{$args{outputmap_xstype}} ) { die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); } return 1; } =head2 clone Creates and returns a clone of a full typemaps object. Takes named parameters: If C<shallow> is true, the clone will share the actual individual type/input/outputmap objects, but not share their storage. Use with caution. Without C<shallow>, the clone will be fully independent. =cut sub clone { my $proto = shift; my %args = @_; my $self; if ($args{shallow}) { $self = bless( { %$proto, typemap_section => [@{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [@{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [@{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } else { $self = bless( { %$proto, typemap_section => [map $_->new, @{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [map $_->new, @{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [map $_->new, @{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } return $self; } =head2 tidy_type Function to (heuristically) canonicalize a C type. Works to some degree with C++ types. $halfway_canonical_type = tidy_type($ctype); Moved from C<ExtUtils::ParseXS>. =cut sub tidy_type { local $_ = shift; # for templated C++ types, do some bit of flawed canonicalization # wrt. templates at least if (/[<>]/) { s/\s*([<>])\s*/$1/g; s/>>/> >/g; } # rationalise any '*' by joining them into bunches and removing whitespace s#\s*(\*+)\s*#$1#g; s#(\*+)# $1 #g ; # trim leading & trailing whitespace s/^\s+//; s/\s+$//; # change multiple whitespace into a single space s/\s+/ /g; $_; } sub _parse { my $self = shift; my $stringref = shift; my $lineno_offset = shift; $lineno_offset = 0 if not defined $lineno_offset; my $filename = shift; $filename = '<string>' if not defined $filename; my $replace = $self->{replace}; my $skip = $self->{skip}; die "Can only replace OR skip" if $replace and $skip; my @add_params; push @add_params, replace => 1 if $replace; push @add_params, skip => 1 if $skip; # TODO comments should round-trip, currently ignoring # TODO order of sections, multiple sections of same type # Heavily influenced by ExtUtils::ParseXS my $section = 'typemap'; my $lineno = $lineno_offset; my $junk = ""; my $current = \$junk; my @input_expr; my @output_expr; while ($$stringref =~ /^(.*)$/gcm) { local $_ = $1; ++$lineno; chomp; next if /^\s*#/; if (/^INPUT\s*$/) { $section = 'input'; $current = \$junk; next; } elsif (/^OUTPUT\s*$/) { $section = 'output'; $current = \$junk; next; } elsif (/^TYPEMAP\s*$/) { $section = 'typemap'; $current = \$junk; next; } if ($section eq 'typemap') { my $line = $_; s/^\s+//; s/\s+$//; next if $_ eq '' or /^#/; my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; # prototype defaults to '$' $proto = '$' unless $proto; warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") unless _valid_proto_string($proto); $self->add_typemap( ExtUtils::Typemaps::Type->new( xstype => $kind, proto => $proto, ctype => $type ), @add_params ); } elsif (/^\s/) { s/\s+$//; $$current .= $$current eq '' ? $_ : "\n".$_; } elsif ($_ eq '') { next; } elsif ($section eq 'input') { s/\s+$//; push @input_expr, {xstype => $_, code => ''}; $current = \$input_expr[-1]{code}; } else { # output section s/\s+$//; push @output_expr, {xstype => $_, code => ''}; $current = \$output_expr[-1]{code}; } } # end while lines foreach my $inexpr (@input_expr) { $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); } foreach my $outexpr (@output_expr) { $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); } return 1; } # taken from ExtUtils::ParseXS sub _valid_proto_string { my $string = shift; if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { return $string; } return 0 ; } # taken from ExtUtils::ParseXS (C_string) sub _escape_backslashes { my $string = shift; $string =~ s[\\][\\\\]g; $string; } =head1 CAVEATS Inherits some evil code from C<ExtUtils::ParseXS>. =head1 SEE ALSO The parser is heavily inspired from the one in L<ExtUtils::ParseXS>. For details on typemaps: L<perlxstut>, L<perlxs>. =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012, 2013 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Miniperl.pm 0000644 00000016773 15140257564 0006710 0 ustar 00 #!./perl -w package ExtUtils::Miniperl; use strict; require Exporter; use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body); our @ISA = qw(Exporter); our @EXPORT = qw(writemain); our $VERSION = '1.09'; # blead will run this with miniperl, hence we can't use autodie or File::Temp my $temp; END { return if !defined $temp || !-e $temp; unlink $temp or warn "Can't unlink '$temp': $!"; } sub writemain{ my ($fh, $real); if (ref $_[0] eq 'SCALAR') { $real = ${+shift}; $temp = $real; $temp =~ s/(?:.c)?\z/.new/; open $fh, '>', $temp or die "Can't open '$temp' for writing: $!"; } elsif (ref $_[0]) { $fh = shift; } else { $fh = \*STDOUT; } my(@exts) = @_; printf $fh <<'EOF!HEAD', xsi_header(); /* miniperlmain.c or perlmain.c - a generated file * * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003, * 2004, 2005, 2006, 2007, 2016 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. The typical * difference being that the latter includes Dynaloader. * * 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. * * The content of the body of this generated file is mostly contained * in Miniperl.pm - edit that file if you want to change anything. * miniperlmain.c is generated by running regen/miniperlmain.pl, while * perlmain.c is built automatically by Makefile (so the former is * included in the tarball while the latter isn't). */ #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 #define PERL_IN_MINIPERLMAIN_C /* work round bug in MakeMaker which doesn't currently (2019) supply this * flag when making a statically linked perl */ #define PERL_CORE 1 %s static void xs_init (pTHX); static PerlInterpreter *my_perl; #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 { int exitstatus, i; #ifdef PERL_GLOBAL_STRUCT struct perl_vars *my_vars = init_global_struct(); # ifdef PERL_GLOBAL_STRUCT_PRIVATE int veto; my_plvarsp = my_vars; # endif #endif /* PERL_GLOBAL_STRUCT */ #ifndef NO_ENV_ARRAY_IN_MAIN PERL_UNUSED_ARG(env); #endif #ifndef PERL_USE_SAFE_PUTENV PL_use_safe_putenv = FALSE; #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 PERL_SYS_FPU_INIT; 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; if (!perl_parse(my_perl, xs_init, argc, argv, (char **)NULL)) perl_run(my_perl); #ifndef PERL_MICRO /* Unregister our signal handler before destroying my_perl */ for (i = 1; 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); } } #endif 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 PERL_SYS_TERM(); #ifdef PERL_GLOBAL_STRUCT # ifdef PERL_GLOBAL_STRUCT_PRIVATE veto = my_plvarsp->Gveto_cleanup; # endif free_global_struct(my_vars); # ifdef PERL_GLOBAL_STRUCT_PRIVATE if (!veto) my_plvarsp = NULL; /* Remember, functions registered with atexit() can run after this point, and may access "global" variables, and hence end up calling Perl_GetVarsPrivate() */ #endif #endif /* PERL_GLOBAL_STRUCT */ exit(exitstatus); } /* Register any extra external extensions */ EOF!HEAD print $fh xsi_protos(@exts), <<'EOT', xsi_body(@exts), "}\n"; static void xs_init(pTHX) { EOT if ($real) { close $fh or die "Can't close '$temp': $!"; rename $temp, $real or die "Can't rename '$temp' to '$real': $!"; } } 1; __END__ =head1 NAME ExtUtils::Miniperl - write the C code for miniperlmain.c and perlmain.c =head1 SYNOPSIS use ExtUtils::Miniperl; writemain(@directories); # or writemain($fh, @directories); # or writemain(\$filename, @directories); =head1 DESCRIPTION C<writemain()> takes an argument list of zero or more directories containing archive libraries that relate to perl modules and should be linked into a new perl binary. It writes a corresponding F<miniperlmain.c> or F<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. If the first argument to C<writemain()> is a reference to a scalar it is used as the filename to open for output. Any other reference is used as the filehandle to write to. Otherwise output defaults to C<STDOUT>. The typical usage is from within perl's own Makefile (to build F<perlmain.c>) or from F<regen/miniperlmain.pl> (to build miniperlmain.c). So under normal circumstances you won't have to deal with this module directly. =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut # ex: set ts=8 sts=4 sw=4 et: Install.pm 0000644 00000120003 15140257564 0006515 0 ustar 00 package ExtUtils::Install; use strict; use Config qw(%Config); use Cwd qw(cwd); use Exporter (); use File::Basename qw(dirname); use File::Copy; use File::Path; use File::Spec; our @ISA = ('Exporter'); our @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); our $MUST_REBOOT; =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 2.14 =cut our $VERSION = '2.14'; # <-- do not 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 occurred. 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 occurred and anything depending on this module cannot proceed until a reboot has occurred. If this value is defined but false then such an operation has ocurred, but should not impact later operations. =over =begin _private =item _chmod($$;$) Wrapper to chmod() for debugging and error trapping. =item _warnonce(@) Warns about something only once. =item _choke(@) Dies with a special message. =back =end _private =cut BEGIN { *Is_VMS = $^O eq 'VMS' ? sub(){1} : sub(){0}; *Is_Win32 = $^O eq 'MSWin32' ? sub(){1} : sub(){0}; *Is_cygwin = $^O eq 'cygwin' ? sub(){1} : sub(){0}; *CanMoveAtBoot = ($^O eq 'MSWin32' || $^O eq 'cygwin') ? sub(){1} : sub(){0}; } my $Inc_uninstall_warn_handler; # install relative to here my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET}; $INSTALL_QUIET = 1 if (!exists $ENV{PERL_INSTALL_QUIET} and defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/); my $Curdir = File::Spec->curdir; 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",@_; require Carp; Carp::croak($msg); } sub _croak { require Carp; Carp::croak(@_); } sub _confess { require Carp; Carp::confess(@_); } sub _compare { require File::Compare; File::Compare::compare(@_); } 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 occurred 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 { my $Has_Win32API_File; sub _move_file_at_boot { #XXX OS-SPECIFIC my ( $file, $target, $moan )= @_; _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'"; # *note* CanMoveAtBoot is only incidentally the same condition as below # this needs not hold true in the future. $Has_Win32API_File = (Is_Win32 || Is_cygwin) ? (eval {require Win32API::File; 1} || 0) : 0 unless defined $Has_Win32API_File; if ( ! $Has_Win32API_File ) { my @msg=( "Cannot schedule $descr at reboot.", "Try installing Win32API::File to allow operations on locked files", "to be scheduled during reboot. Or try to perform the operation by", "hand yourself. (You may need to close other perl processes first)" ); if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } return 0; } my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() unless ref $target; _chmod( 0666, $file ); _chmod( 0666, $target ) unless ref $target; if (Win32API::File::MoveFileEx( $file, $target, $opts )) { $MUST_REBOOT ||= ref $target ? 0 : 1; return 1; } else { my @msg=( "MoveFileEx $descr at reboot failed: $^E", "You may try to perform the operation by hand yourself. ", "(You may need to close other perl processes first).", ); if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } } return 0; } } =begin _private =item _unlink_or_rename( $file, $tryhard, $installing ) OS-Specific, Win32/Cygwin Tries to get a file out of the way by unlinking it or renaming it. On some OS'es (Win32 based) DLL files can end up locked such that they can be renamed but not deleted. Likewise sometimes a file can be locked such that it cant even be renamed or changed except at reboot. To handle these cases this routine finds a tempfile name that it can either rename the file out of the way or use as a proxy for the install so that the rename can happen later (at reboot). $file : the file to remove. $tryhard : should advanced tricks be used for deletion $installing : we are not merely deleting but we want to overwrite When $tryhard is not true if the unlink fails its fatal. When $tryhard is true then the file is attempted to be renamed. The renamed file is then scheduled for deletion. If the rename fails then $installing governs what happens. If it is false the failure is fatal. If it is true then an attempt is made to schedule installation at boot using a temporary file to hold the new file. If this fails then a fatal error is thrown, if it succeeds it returns the temporary file name (which will be a derivative of the original in the same directory) so that the caller can use it to install under. In all other cases of success returns $file. On failure throws a fatal error. =end _private =cut sub _unlink_or_rename { #XXX OS-SPECIFIC my ( $file, $tryhard, $installing )= @_; # this chmod was originally unconditional. However, its not needed on # POSIXy systems since permission to unlink a file is specified by the # directory rather than the file; and in fact it screwed up hard- and # symlinked files. Keep it for other platforms in case its still # needed there. if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) { _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 successful. 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 proceed."); } } =pod =back =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 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) { $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,$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,$verbose,$dry_run)=@_; if ( $verbose && $verbose > 1 && ! -d $dir) { $show= 1; printf "mkpath(%s,%d)\n", $dir, $show; } if (!$dry_run) { if ( ! eval { File::Path::mkpath($dir,$show); 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 diagnostics 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 _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 =back =end _private =over =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 regardless 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 do not 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 _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); require ExtUtils::Packlist; 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; require File::Find; my $blib_lib = File::Spec->catdir('blib', 'lib'); my $blib_arch = File::Spec->catdir('blib', 'arch'); # File::Find seems to always be Unixy except on MacPerl :( my $current_directory = $^O eq 'MacOS' ? $Curdir : '.'; 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}); 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::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 doesn't get horribly confused. _chdir($save_cwd); }, $current_directory ); _chdir($cwd); } foreach my $targetdir (sort keys %check_dirs) { _mkpath( $targetdir, 0, $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, $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, $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 occurred. 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; require File::Find; File::Find::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 _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 require ExtUtils::Packlist; 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 occurring 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); 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. If an $autosplit_dir is provided, all .pm files will be autosplit into it. 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). By default verbose output is generated, setting the PERL_INSTALL_QUIET environment variable will silence this output. =cut sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; _mkpath($autodir,0) if defined $autodir; while(my($from, $to) = each %$fromto) { if( -f $to && -s $from == -s $to && -M $to < -M $from ) { print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; 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" unless $INSTALL_QUIET; next; } if (-f $to){ # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { _mkpath(dirname($to),0); } if ($need_filtering) { run_filter($pm_filter, $from, $to); print "$pm_filter <$from >$to\n"; } else { _copy( $from, $to ); print "cp $from $to\n" unless $INSTALL_QUIET; } my($mode,$atime,$mtime) = (stat $from)[2,8,9]; utime($atime,$mtime+Is_VMS,$to); _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); next unless $from =~ /\.pm$/; _autosplit($to,$autodir) if defined $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 require AutoSplit; my $retval = AutoSplit::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' . ( ExtUtils::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; MakeMaker/Tutorial.pod 0000644 00000012563 15140257564 0010730 0 ustar 00 package ExtUtils::MakeMaker::Tutorial; our $VERSION = '7.44'; $VERSION =~ tr/_//d; =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. It's 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 the .pm and .pod files you wish to have installed go. They are laid 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. Typically, the F<t/> test directory is flat, with all test files located directly within it. However, you can nest tests within subdirectories, for example: t/foo/subdir_test.t To do this, you need to inform C<WriteMakeFile()> in your I<Makefile.PL> file in the following fashion: test => {TESTS => 't/*.t t/*/*.t'} That will run all tests in F<t/>, as well as all tests in all subdirectories that reside under F<t/>. You can nest as deeply as makes sense for your project. Simply add another entry in the test location string. For example, to test: t/foo/bar/subdir_test.t You would use the following C<test> directive: test => {TESTS => 't/*.t t/*/*/*.t'} Note that in the above example, tests in the first subdirectory will not be run. To run all tests in the intermediary subdirectory preceding the one the test files are in, you need to explicitly note it: test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'} You don't need to specify wildcards if you only want to test within specific subdirectories. The following example will only run tests in F<t/foo>: test => {TESTS => 't/foo/*.t'} 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::Starter>, L<Minilla::Tutorial>, L<Dist::Milla::Tutorial>, L<Dist::Zilla::Starter> =cut 1; MakeMaker/Locale.pm 0000644 00000032026 15140257564 0010152 0 ustar 00 package ExtUtils::MakeMaker::Locale; use strict; our $VERSION = "7.44"; $VERSION =~ tr/_//d; use base 'Exporter'; our @EXPORT_OK = qw( decode_argv env $ENCODING_LOCALE $ENCODING_LOCALE_FS $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT ); use Encode (); use Encode::Alias (); our $ENCODING_LOCALE; our $ENCODING_LOCALE_FS; our $ENCODING_CONSOLE_IN; our $ENCODING_CONSOLE_OUT; sub DEBUG () { 0 } sub _init { if ($^O eq "MSWin32") { unless ($ENCODING_LOCALE) { # Try to obtain what the Windows ANSI code page is eval { unless (defined &GetConsoleCP) { require Win32; # manually "import" it since Win32->import refuses *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; } unless (defined &GetConsoleCP) { require Win32::API; Win32::API->Import('kernel32', 'int GetConsoleCP()'); } if (defined &GetConsoleCP) { my $cp = GetConsoleCP(); $ENCODING_LOCALE = "cp$cp" if $cp; } }; } unless ($ENCODING_CONSOLE_IN) { # only test one since set together unless (defined &GetInputCP) { eval { require Win32; eval { local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP() Win32::GetConsoleCP(); }; # manually "import" it since Win32->import refuses *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP; }; unless (defined &GetInputCP) { eval { # try Win32::Console module for codepage to use require Win32::Console; *GetInputCP = sub { &Win32::Console::InputCP } if defined &Win32::Console::InputCP; *GetOutputCP = sub { &Win32::Console::OutputCP } if defined &Win32::Console::OutputCP; }; } unless (defined &GetInputCP) { # final fallback *GetInputCP = *GetOutputCP = sub { # another fallback that could work is: # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP ((qx(chcp) || '') =~ /^Active code page: (\d+)/) ? $1 : (); }; } } my $cp = GetInputCP(); $ENCODING_CONSOLE_IN = "cp$cp" if $cp; $cp = GetOutputCP(); $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; } } unless ($ENCODING_LOCALE) { eval { require I18N::Langinfo; $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); # Workaround of Encode < v2.25. The "646" encoding alias was # introduced in Encode-2.25, but we don't want to require that version # quite yet. Should avoid the CPAN testers failure reported from # openbsd-4.7/perl-5.10.0 combo. $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; # https://rt.cpan.org/Ticket/Display.html?id=66373 $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; }; $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; } # Workaround of Encode < v2.71 for "cp65000" and "cp65001" # The "cp65000" and "cp65001" aliases were added in [Encode v2.71](https://github.com/dankogai/p5-encode/commit/7874bd95aa10967a3b5dbae333d16bcd703ac6c6) # via commit <https://github.com/dankogai/p5-encode/commit/84b9c1101d5251d37e226f80d1c6781718779047>. # This will avoid test failures for Win32 machines using the UTF-7 or UTF-8 code pages. $ENCODING_LOCALE = 'UTF-7' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65000"; $ENCODING_LOCALE = 'utf-8-strict' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65001"; if ($^O eq "darwin") { $ENCODING_LOCALE_FS ||= "UTF-8"; } # final fallback $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; unless (Encode::find_encoding($ENCODING_LOCALE)) { my $foundit; if (lc($ENCODING_LOCALE) eq "gb18030") { eval { require Encode::HanExtra; }; if ($@) { die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; } $foundit++ if Encode::find_encoding($ENCODING_LOCALE); } die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" unless $foundit; } # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; } _init(); Encode::Alias::define_alias(sub { no strict 'refs'; no warnings 'once'; return ${"ENCODING_" . uc(shift)}; }, "locale"); sub _flush_aliases { no strict 'refs'; for my $a (sort keys %Encode::Alias::Alias) { if (defined ${"ENCODING_" . uc($a)}) { delete $Encode::Alias::Alias{$a}; warn "Flushed alias cache for $a" if DEBUG; } } } sub reinit { $ENCODING_LOCALE = shift; $ENCODING_LOCALE_FS = shift; $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; _init(); _flush_aliases(); } sub decode_argv { die if defined wantarray; for (@ARGV) { $_ = Encode::decode(locale => $_, @_); } } sub env { my $k = Encode::encode(locale => shift); my $old = $ENV{$k}; if (@_) { my $v = shift; if (defined $v) { $ENV{$k} = Encode::encode(locale => $v); } else { delete $ENV{$k}; } } return Encode::decode(locale => $old) if defined wantarray; } 1; __END__ =head1 NAME ExtUtils::MakeMaker::Locale - bundled Encode::Locale =head1 SYNOPSIS use Encode::Locale; use Encode; $string = decode(locale => $bytes); $bytes = encode(locale => $string); if (-t) { binmode(STDIN, ":encoding(console_in)"); binmode(STDOUT, ":encoding(console_out)"); binmode(STDERR, ":encoding(console_out)"); } # Processing file names passed in as arguments my $uni_filename = decode(locale => $ARGV[0]); open(my $fh, "<", encode(locale_fs => $uni_filename)) || die "Can't open '$uni_filename': $!"; binmode($fh, ":encoding(locale)"); ... =head1 DESCRIPTION In many applications it's wise to let Perl use Unicode for the strings it processes. Most of the interfaces Perl has to the outside world are still byte based. Programs therefore need to decode byte strings that enter the program from the outside and encode them again on the way out. The POSIX locale system is used to specify both the language conventions requested by the user and the preferred character set to consume and output. The C<Encode::Locale> module looks up the charset and encoding (called a CODESET in the locale jargon) and arranges for the L<Encode> module to know this encoding under the name "locale". It means bytes obtained from the environment can be converted to Unicode strings by calling C<< Encode::encode(locale => $bytes) >> and converted back again with C<< Encode::decode(locale => $string) >>. Where file systems interfaces pass file names in and out of the program we also need care. The trend is for operating systems to use a fixed file encoding that don't actually depend on the locale; and this module determines the most appropriate encoding for file names. The L<Encode> module will know this encoding under the name "locale_fs". For traditional Unix systems this will be an alias to the same encoding as "locale". For programs running in a terminal window (called a "Console" on some systems) the "locale" encoding is usually a good choice for what to expect as input and output. Some systems allows us to query the encoding set for the terminal and C<Encode::Locale> will do that if available and make these encodings known under the C<Encode> aliases "console_in" and "console_out". For systems where we can't determine the terminal encoding these will be aliased as the same encoding as "locale". The advice is to use "console_in" for input known to come from the terminal and "console_out" for output to the terminal. In addition to arranging for various Encode aliases the following functions and variables are provided: =over =item decode_argv( ) =item decode_argv( Encode::FB_CROAK ) This will decode the command line arguments to perl (the C<@ARGV> array) in-place. The function will by default replace characters that can't be decoded by "\x{FFFD}", the Unicode replacement character. Any argument provided is passed as CHECK to underlying Encode::decode() call. Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the command line arguments can be decoded. See L<Encode/"Handling Malformed Data"> for details on other options for CHECK. =item env( $uni_key ) =item env( $uni_key => $uni_value ) Interface to get/set environment variables. Returns the current value as a Unicode string. The $uni_key and $uni_value arguments are expected to be Unicode strings as well. Passing C<undef> as $uni_value deletes the environment variable named $uni_key. The returned value will have the characters that can't be decoded replaced by "\x{FFFD}", the Unicode replacement character. There is no interface to request alternative CHECK behavior as for decode_argv(). If you need that you need to call encode/decode yourself. For example: my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK); my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK); =item reinit( ) =item reinit( $encoding ) Reinitialize the encodings from the locale. You want to call this function if you changed anything in the environment that might influence the locale. This function will croak if the determined encoding isn't recognized by the Encode module. With argument force $ENCODING_... variables to set to the given value. =item $ENCODING_LOCALE The encoding name determined to be suitable for the current locale. L<Encode> know this encoding as "locale". =item $ENCODING_LOCALE_FS The encoding name determined to be suitable for file system interfaces involving file names. L<Encode> know this encoding as "locale_fs". =item $ENCODING_CONSOLE_IN =item $ENCODING_CONSOLE_OUT The encodings to be used for reading and writing output to the a console. L<Encode> know these encodings as "console_in" and "console_out". =back =head1 NOTES This table summarizes the mapping of the encodings set up by the C<Encode::Locale> module: Encode | | | Alias | Windows | Mac OS X | POSIX ------------+---------+--------------+------------ locale | ANSI | nl_langinfo | nl_langinfo locale_fs | ANSI | UTF-8 | nl_langinfo console_in | OEM | nl_langinfo | nl_langinfo console_out | OEM | nl_langinfo | nl_langinfo =head2 Windows Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16 strings) and a byte based API based a character set called ANSI. The regular Perl interfaces to the OS currently only uses the ANSI APIs. Unfortunately ANSI is not a single character set. The encoding that corresponds to ANSI varies between different editions of Windows. For many western editions of Windows ANSI corresponds to CP-1252 which is a character set similar to ISO-8859-1. Conceptually the ANSI character set is a similar concept to the POSIX locale CODESET so this module figures out what the ANSI code page is and make this available as $ENCODING_LOCALE and the "locale" Encoding alias. Windows systems also operate with another byte based character set. It's called the OEM code page. This is the encoding that the Console takes as input and output. It's common for the OEM code page to differ from the ANSI code page. =head2 Mac OS X On Mac OS X the file system encoding is always UTF-8 while the locale can otherwise be set up as normal for POSIX systems. File names on Mac OS X will at the OS-level be converted to NFD-form. A file created by passing a NFC-filename will come in NFD-form from readdir(). See L<Unicode::Normalize> for details of NFD/NFC. Actually, Apple does not follow the Unicode NFD standard since not all character ranges are decomposed. The claim is that this avoids problems with round trip conversions from old Mac text encodings. See L<Encode::UTF8Mac> for details. =head2 POSIX (Linux and other Unixes) File systems might vary in what encoding is to be used for filenames. Since this module has no way to actually figure out what the is correct it goes with the best guess which is to assume filenames are encoding according to the current locale. Users are advised to always specify UTF-8 as the locale charset. =head1 SEE ALSO L<I18N::Langinfo>, L<Encode>, L<Term::Encoding> =head1 AUTHOR Copyright 2010 Gisle Aas <gisle@aas.no>. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MakeMaker/Config.pm 0000644 00000001114 15140257564 0010152 0 ustar 00 package ExtUtils::MakeMaker::Config; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 MakeMaker/version.pm 0000644 00000004505 15140257564 0010441 0 ustar 00 #--------------------------------------------------------------------------# # This is a modified copy of version.pm 0.9909, bundled exclusively for # use by ExtUtils::Makemaker and its dependencies to bootstrap when # version.pm is not available. It should not be used by ordinary modules. # # When loaded, it will try to load version.pm. If that fails, it will load # ExtUtils::MakeMaker::version::vpp and alias various *version functions # to functions in that module. It will also override UNIVERSAL::VERSION. #--------------------------------------------------------------------------# package ExtUtils::MakeMaker::version; use 5.006001; use strict; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); $VERSION = '7.44'; $VERSION =~ tr/_//d; $CLASS = 'version'; { local $SIG{'__DIE__'}; eval "use version"; if ( $@ ) { # don't have any version.pm installed eval "use ExtUtils::MakeMaker::version::vpp"; die "$@" if ( $@ ); local $^W; delete $INC{'version.pm'}; $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'}; push @version::ISA, "ExtUtils::MakeMaker::version::vpp"; $version::VERSION = $VERSION; *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv; *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare; *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; *version::new = \&ExtUtils::MakeMaker::version::vpp::new; if ("$]" >= 5.009000) { no strict 'refs'; *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp; *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse; } require ExtUtils::MakeMaker::version::regex; *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; } elsif ( ! version->can('is_qv') ) { *version::is_qv = sub { exists $_[0]->{qv} }; } } 1; MakeMaker/FAQ.pod 0000644 00000047512 15140257564 0007536 0 ustar 00 package ExtUtils::MakeMaker::FAQ; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 1; __END__ =head1 NAME ExtUtils::MakeMaker::FAQ - Frequently Asked Questions About MakeMaker =head1 DESCRIPTION FAQs, tricks and tips for L<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. Ways of handling this with a B<lot> less manual effort on your part are L<perlbrew> and L<local::lib>. Otherwise, you can 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. We highly recommend the install_base method, its the simplest and most closely approximates the expected behavior of an installation prefix. 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 This works most like other language's behavior when you specify a prefix. We recommend this method. 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 We highly discourage this method. It should only be used if you know what you're doing and specifically need the PREFIX behavior. The PREFIX algorithm is complicated and focused on matching the system installation. =item How do I keep from installing man pages? Recent versions of MakeMaker will only install man pages on Unix-like operating systems by default. To generate manpages on non-Unix operating systems, make the "manifypods" target. 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 use L<blib> to point Perl at the built but uninstalled module: perl -Mblib script.pl perl -Mblib -e '...' 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. Again, L<local::lib> may assist you here. =item How can I organize tests into subdirectories and have them run? Let's take the following test directory structure: t/foo/sometest.t t/bar/othertest.t t/bar/baz/anothertest.t Now, inside of the C<WriteMakeFile()> function in your F<Makefile.PL>, specify where your tests are located with the C<test> directive: test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'} The first entry in the string will run all tests in the top-level F<t/> directory. The second will run all test files located in any subdirectory under F<t/>. The third, runs all test files within any subdirectory within any other subdirectory located under F<t/>. Note that you do not have to use wildcards. You can specify explicitly which subdirectories to run tests in: test => {TESTS => 't/*.t t/foo/*.t t/bar/baz/*.t'} =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. =item Generating *.pm files with substitutions eg of $VERSION If you want to configure your module files for local conditions, or to automatically insert a version number, you can use EUMM's C<PL_FILES> capability, where it will automatically run each F<*.PL> it finds to generate its basename. For instance: # Makefile.PL: require 'common.pl'; my $version = get_version(); my @pms = qw(Foo.pm); WriteMakefile( NAME => 'Foo', VERSION => $version, PM => { map { ($_ => "\$(INST_LIB)/$_") } @pms }, clean => { FILES => join ' ', @pms }, ); # common.pl: sub get_version { '0.04' } sub process { my $v = get_version(); s/__VERSION__/$v/g; } 1; # Foo.pm.PL: require 'common.pl'; $_ = join '', <DATA>; process(); my $file = shift; open my $fh, '>', $file or die "$file: $!"; print $fh $_; __DATA__ package Foo; our $VERSION = '__VERSION__'; 1; You may notice that C<PL_FILES> is not specified above, since the default of mapping each .PL file to its basename works well. If the generated module were architecture-specific, you could replace C<$(INST_LIB)> above with C<$(INST_ARCHLIB)>, although if you locate modules under F<lib>, that would involve ensuring any C<lib/> in front of the module location were removed. =back =head2 Common errors and problems =over 4 =item "No rule to make target `/usr/lib/perl5/CORE/config.h', needed by `Makefile'" Just what it says, you're missing that file. MakeMaker uses it to determine if perl has been rebuilt since the Makefile was made. It's a bit of a bug that it halts installation. Some operating systems don't ship the CORE directory with their base perl install. To solve the problem, you likely need to install a perl development package such as perl-devel (CentOS, Fedora and other Redhat systems) or perl (Ubuntu and other Debian systems). =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 was long the official heir apparent to MakeMaker. The rate of both its development and adoption has slowed in recent years, though, and it is unclear what the future holds for it. That said, Module::Build set the stage for I<something> to become the heir to MakeMaker. MakeMaker's maintainers have long said that it is a dead end and should be kept functioning, while being cautious about extending with new features. =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. Probably the easiest way to do this is using F<perl-reversion> in L<Perl::Version>: perl-reversion -bump If your version control system supports revision numbers (git doesn't easily), the simplest way to do it automatically is to use its 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$) it's 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 different $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 surprised 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 tar should I use on Windows? We recommend ptar from Archive::Tar not older than 1.66 with '-C' option. =item Which zip should I use on Windows for '[ndg]make zipdist'? We recommend InfoZIP: L<http://www.info-zip.org/Zip.html> =back =head2 XS =over 4 =item How do 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. There are three ways: C<XSMULTI>, separate directories, and bootstrapping one XS from another. =over 8 =item XSMULTI Structure your modules so they are all located under F<lib>, such that C<Foo::Bar> is in F<lib/Foo/Bar.pm> and F<lib/Foo/Bar.xs>, etc. Have your top-level C<WriteMakefile> set the variable C<XSMULTI> to a true value. Er, that's it. =item Separate directories Put each XS files into separate directories, each with their own F<Makefile.PL>. Make sure each of those F<Makefile.PL>s has the correct C<CFLAGS>, C<INC>, C<LIBS> etc. You will need to make sure the top-level F<Makefile.PL> refers to each of these using C<DIR>. =item Bootstrapping 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. An alternative way to achieve this can be seen in L<Gtk2::CodeGen> and L<Glib::CodeGen>. =back =back =head1 DESIGN =head2 MakeMaker object hierarchy (simplified) What most people need to know (superclasses on top.) ExtUtils::MM_Any | ExtUtils::MM_Unix | ExtUtils::MM_{Current OS} | ExtUtils::MakeMaker | MY The object actually used is of the class L<MY|ExtUtils::MY> which allows you to override bits of MakeMaker inside your Makefile.PL by declaring MY::foo() methods. =head2 MakeMaker object hierarchy (real) Here's how it really works: ExtUtils::MM_Any | ExtUtils::MM_Unix | ExtUtils::Liblist::Kid ExtUtils::MM_{Current OS} (if necessary) | | ExtUtils::Liblist ExtUtils::MakeMaker | | | | | | |----------------------- ExtUtils::MM | | ExtUtils::MY MM (created by ExtUtils::MM) | | MY (created by ExtUtils::MY) | . | (mixin) | . | PACK### (created each call to ExtUtils::MakeMaker->new) NOTE: Yes, this is a mess. See L<http://archive.develooper.com/makemaker@perl.org/msg00134.html> for some history. NOTE: When L<ExtUtils::MM> is loaded it chooses a superclass for MM from amongst the ExtUtils::MM_* modules based on the current operating system. NOTE: ExtUtils::MM_{Current OS} represents one of the ExtUtils::MM_* modules except L<ExtUtils::MM_Any> chosen based on your operating system. NOTE: The main object used by MakeMaker is a PACK### object, *not* L<ExtUtils::MakeMaker>. It is, effectively, a subclass of L<MY|ExtUtils::MY>, L<ExtUtils::MakeMaker>, L<ExtUtils::Liblist> and ExtUtils::MM_{Current OS} NOTE: The methods in L<MY|ExtUtils::MY> are simply copied into PACK### rather than MY being a superclass of PACK###. I don't remember the rationale. NOTE: L<ExtUtils::Liblist> should be removed from the inheritance hiearchy and simply be called as functions. NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head2 The MM_* hierarchy MM_Win95 MM_NW5 \ / MM_BeOS MM_Cygwin MM_OS2 MM_VMS MM_Win32 MM_DOS MM_UWIN \ | | | / / / ------------------------------------------------ | | MM_Unix | | | MM_Any NOTE: Each direct L<MM_Unix|ExtUtils::MM_Unix> subclass is also an L<MM_Any|ExtUtils::MM_Any> subclass. This is a temporary hack because MM_Unix overrides some MM_Any methods with Unix specific code. It allows the non-Unix modules to see the original MM_Any implementations. NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head1 PATCHING If you have a question you'd like to see added to the FAQ (whether or not you have the answer) please either: =over 2 =item * make a pull request on the MakeMaker github repository =item * raise a issue on the MakeMaker github repository =item * file an RT ticket =item * email makemaker@perl.org =back =head1 AUTHOR The denizens of makemaker@perl.org. =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut MM_NW5.pm 0000644 00000012532 15140257564 0006120 0 ustar 00 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 L<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 = '7.44'; $VERSION =~ tr/_//d; require ExtUtils::MM_Win32; our @ISA = qw(ExtUtils::MM_Win32); use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562); $ENV{EMXSHELL} = 'sh'; # to run `commands` my $BORLAND = $Config{'cc'} =~ /\bbcc/i; my $GCC = $Config{'cc'} =~ /\bgcc/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 static_lib_pure_cmd Defines how to run the archive utility =cut sub static_lib_pure_cmd { my ($self, $src) = @_; $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src : ($GCC ? '-ru $@ ' . $src : '-type library -o $@ ' . $src)); } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =item dynamic_lib Override of utility methods for OS-specific work. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my @m; # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc if ($to =~ /^\$/) { if ($self->{NLM_SHORT_NAME}) { # deal with shortnames my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)}; push @m, "$to: $newto\n\n"; $to = $newto; } } else { my ($v, $d, $f) = File::Spec->splitpath($to); # relies on $f having a literal "." in it, unlike for $(OBJ_EXT) if ($f =~ /[^\.]{9}\./) { # 9+ chars before '.', need to shorten $f = substr $f, 0, 8; } my $newto = File::Spec->catpath($v, $d, $f); push @m, "$to: $newto\n\n"; $to = $newto; } # bits below should be in dlsyms, not here # 1 2 3 4 push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist; # Create xdc data for an MT safe NLM in case of mpk build %1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s $(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s MAKE_FRAG if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { (my $xdc = $exportlist) =~ s#def\z#xdc#; $xdc = '$(BASEEXT).xdc'; push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist; $(MPKTOOL) $(XDCFLAGS) %s $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s MAKE_FRAG } # Reconstruct the X.Y.Z version. my $version = join '.', map { sprintf "%d", $_ } "$]" =~ /(\d)\.(\d{3})(\d{2})/; push @m, sprintf <<'EOF', $from, $version, $to, $exportlist; $(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s $(CHMOD) 755 $@ EOF join '', @m; } 1; __END__ =back =cut Packlist.pm 0000644 00000020565 15140257564 0006675 0 ustar 00 package ExtUtils::Packlist; use 5.00503; use strict; use Carp qw(); use Config; use vars qw($VERSION $Relocations); $VERSION = '2.14'; $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; local $^W; 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 =back =end _undocumented =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 MANIFEST.SKIP 0000644 00000002121 15140257564 0006447 0 ustar 00 # 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 \b_eumm/ # 7.05_05 and above # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # and Module::Build::Tiny generated files \b_build_params$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ \..*\.sw.?$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid prove files \B\.prove$ # Avoid MYMETA files ^MYMETA\. # Temp files for new META ^META_new\.(?:json|yml) # Avoid travis-ci.org file ^\.travis\.yml # Avoid AppVeyor file ^\.?appveyor.yml MM_VOS.pm 0000644 00000001354 15140257564 0006156 0 ustar 00 package ExtUtils::MM_VOS; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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; Mksymlists.pm 0000644 00000025367 15140257564 0007307 0 ustar 00 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 = '7.44'; $VERSION =~ tr/_//d; 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 (sort 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}}; _print_imports($def, $data); close $def; } sub _print_imports { my ($def, $data)= @_; my $imports= $data->{IMPORTS} or return; if ( keys %$imports ) { print $def "IMPORTS\n"; foreach my $name (sort keys %$imports) { print $def " $name=$imports->{$name}\n"; } } } 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'} !~ /\bgcc/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 Borland C and Visual C # 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 #bcc dropped in 5.16, so dont create useless extra symbols for export table unless("$]" >= 5.016) { if ($Config::Config{'cc'} =~ /^bcc/i) { push @syms, "_$_", "$_ = _$_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } else { push @syms, "$_", "_$_ = $_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } } else { push @syms, "$_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } print $def join("\n ",@syms, "\n") if @syms; _print_imports($def, $data); 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. MY.pm 0000644 00000001244 15140257564 0005441 0 ustar 00 package ExtUtils::MY; use strict; require ExtUtils::MM; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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 L<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 MM_Win32.pm 0000644 00000034510 15140257564 0006411 0 ustar 00 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 L<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 _sprintf562); require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); our $VERSION = '7.44'; $VERSION =~ tr/_//d; $ENV{EMXSHELL} = 'sh'; # to run `commands` my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config ); sub _identify_compiler_environment { my ( $config ) = @_; my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0; my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0; my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C return ( $BORLAND, $GCC, $MSVC ); } =head2 Overridden methods =over 4 =item B<dlsyms> =cut sub dlsyms { my($self,%attribs) = @_; return '' if $self->{SKIPHASH}{'dynamic'}; $self->xs_dlsyms_iterator(\%attribs); } =item xs_dlsyms_ext On Win32, is C<.def>. =cut sub xs_dlsyms_ext { '.def'; } =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, except for "gmake" where it is /. =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') ? '\\\\' : $self->is_make_type('gmake') ? '/' : '\\'; } =item init_tools Override some of the slower, portable commands with Windows specific ones. =cut sub init_tools { my ($self) = @_; $self->{NOOP} ||= 'rem'; $self->{DEV_NULL} ||= '> NUL'; $self->{FIXIN} ||= $self->{PERL_CORE} ? "\$(PERLRUN) -I$self->{PERL_SRC}\\cpan\\ExtUtils-PL2Bat\\lib $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : 'pl2bat.bat'; $self->SUPER::init_tools; # Setting SHELL from $Config{sh} can break dmake. Its ok without it. delete $self->{SHELL}; return; } =item init_others Override the default link and compile tools. 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 = shift; $self->{LD} ||= 'link'; $self->{AR} ||= 'lib'; $self->SUPER::init_others; $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; } =item init_platform Add MM_Win32_VERSION. =item platform_constants =cut sub init_platform { my($self) = shift; $self->{MM_Win32_VERSION} = $VERSION; return; } 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 specify_shell Set SHELL to $ENV{COMSPEC} only if make is type 'gmake'. =cut sub specify_shell { my $self = shift; return '' unless $self->is_make_type('gmake'); "\nSHELL = $ENV{COMSPEC}\n"; } =item constants Add MAXLINELENGTH for dmake before all the constants are output. =cut sub constants { my $self = shift; my $make_text = $self->SUPER::constants; return $make_text unless $self->is_make_type('dmake'); # dmake won't read any single "line" (even those with escaped newlines) # larger than a certain size which can be as small as 8k. PM_TO_BLIB # on large modules like DateTime::TimeZone can create lines over 32k. # So we'll crank it up to a <ironic>WHOPPING</ironic> 64k. # # This has to come here before all the constants and not in # platform_constants which is after constants. my $size = $self->{MAXLINELENGTH} || 800000; my $prefix = qq{ # Get dmake to read long commands like PM_TO_BLIB MAXLINELENGTH = $size }; return $prefix . $make_text; } =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_pure_cmd Defines how to run the archive utility =cut sub static_lib_pure_cmd { my ($self, $from) = @_; $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from : ($GCC ? '-ru $@ ' . $from : '-out:$@ ' . $from)); } =item dynamic_lib Methods are overridden here: not dynamic_lib itself, but the utility ones that do the OS-specific work. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist; if ($GCC) { # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer # uses dlltool - relies on post 2002 MinGW # 1 2 push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom; $(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base EOF } elsif ($BORLAND) { my $ldargs = $self->is_make_type('dmake') ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),} : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),}; my $subbed; if ($exportlist eq '$(EXPORT_LIST)') { $subbed = $self->is_make_type('dmake') ? q{$(EXPORT_LIST:s,/,\,)} : q{$(subst /,\,$(EXPORT_LIST))}; } else { # in XSMULTI, exportlist is per-XS, so have to sub in perl not make ($subbed = $exportlist) =~ s#/#\\#g; } push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed; $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES) EOF } else { # VC push @m, sprintf <<'EOF', $ldfrom, $exportlist; $(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s EOF # 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, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; join '', @m; } sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s EOF } =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_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$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; } sub can_dep_space { my $self = shift; 1; # with Win32::GetShortPathName } =item quote_dep =cut sub quote_dep { my ($self, $arg) = @_; if ($arg =~ / / and not $self->is_make_type('gmake')) { require Win32; $arg = Win32::GetShortPathName($arg); die <<EOF if not defined $arg or $arg =~ / /; Tried to use make dependency with space for non-GNU make: '$arg' Fallback to short pathname failed. EOF return $arg; } return $self->SUPER::quote_dep($arg); } =item xs_obj_opt Override to fixup -o flags for MSVC. =cut sub xs_obj_opt { my ($self, $output_file) = @_; ($MSVC ? "/Fo" : "-o ") . $output_file; } =item pasthru All we send is -nologo to nmake to prevent it from printing its damned banner. =cut sub pasthru { my($self) = shift; my $old = $self->SUPER::pasthru; return $old unless $self->is_make_type('nmake'); $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /; $old; } =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, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP # Apply the Microsoft C/C++ parsing rules $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\" $text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\" $text =~ s{(?<!\\)"}{\\"}g; # " -> \" $text = qq{"$text"} if $text =~ /[ \t#]/; # hash because gmake 4.2.1 # Apply the Command Prompt parsing rules (cmd.exe) my @text = split /("[^"]*")/, $text; # We should also escape parentheses, but it breaks one-liners containing # $(MACRO)s in makefiles. s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text; $text = join('', @text); # dmake expands {{ to { and }} to }. if( $self->is_make_type('dmake') ) { $text =~ s/{/{{/g; $text =~ s/}/}}/g; } $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return $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 dbgoutflag Returns a CC flag that tells the CC to emit a separate debugging symbol file when compiling an object file. =cut sub dbgoutflag { $MSVC ? '-Fd$(*).pdb' : ''; } =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} }; } =item make_type Returns a suitable string describing the type of makefile being written. =cut sub make_type { my ($self) = @_; my $make = $self->make; $make = +( File::Spec->splitpath( $make ) )[-1]; $make =~ s!\.exe$!!i; if ( $make =~ m![^A-Z0-9]!i ) { ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make; } return "$make-style"; } 1; __END__ =back MM_Cygwin.pm 0000644 00000007611 15140257564 0006751 0 ustar 00 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 = '7.44'; $VERSION =~ tr/_//d; =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 L<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/(dll\.)?a$/dll.a/; } $self->{PERL_ARCHIVE} = $libperl; } else { $self->{PERL_ARCHIVE} = '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a"); } $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; $self->{EXPORT_LIST} ||= ''; } =item maybe_command Determine whether a file is native to Cygwin by checking whether it resides inside the Cygwin installation (using Windows paths). If so, use L<ExtUtils::MM_Unix> to determine if it may be a command. Otherwise use the tests from L<ExtUtils::MM_Win32>. =cut sub maybe_command { my ($self, $file) = @_; my $cygpath = Cygwin::posix_to_win_path('/', 1); my $filepath = Cygwin::posix_to_win_path($file, 1); return (substr($filepath,0,length($cygpath)) eq $cygpath) ? $self->SUPER::maybe_command($file) # Unix : ExtUtils::MM_Win32->maybe_command($file); # Win32 } =item dynamic_lib Use the default to produce the *.dll's. But for new archdir dll's use the same rebase address if the old exists. =cut sub dynamic_lib { my($self, %attribs) = @_; my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs); return '' unless $s; return $s unless %{$self->{XS}}; # do an ephemeral rebase so the new DLL fits to the current rebase map $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); $s; } =item install Rebase dll's with the global rebase database after installation. =cut sub install { my($self, %attribs) = @_; my $s = ExtUtils::MM_Unix::install($self, %attribs); return '' unless $s; return $s unless %{$self->{XS}}; my $INSTALLDIRS = $self->{INSTALLDIRS}; my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")}; my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/"; my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}"; $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); $s; } =back =cut 1; Installed.pm 0000644 00000034033 15140257564 0007035 0 ustar 00 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 = '2.14'; $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 { $_ ne '.' || ! $args{skip_cwd} } 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( skip_cwd => 1 ); 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<skip_cwd> is true, the current directory C<.> will be stripped from C<@INC> before searching for .packlists. This keeps ExtUtils::Installed from finding modules installed in other perls that happen to be located below the current directory. 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 F</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 Embed.pm 0000644 00000031104 15140257564 0006126 0 ustar 00 package ExtUtils::Embed; require Exporter; use Config; require File::Spec; our ( @Extensions, $opt_o, $opt_s ); use strict; # This is not a dual-life module, so no need for development version numbers our $VERSION = '1.35'; our @ISA = qw(Exporter); our @EXPORT = qw(&xsinit &ldopts &ccopts &ccflags &ccdlflags &perl_inc &xsi_header &xsi_protos &xsi_body); our $Verbose = 0; our $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 { require Getopt::Std; Getopt::Std::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 { open $fh, '>', $file or die "Can't open '$file': $!"; } push(@mods, static_ext()) if defined $std; @mods = grep(!$seen{$_}++, @mods); print $fh &xsi_header(); print $fh "\nEXTERN_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" #include "XSUB.h" EOF } sub xsi_protos { my @exts = @_; my %seen; my $retval = ''; foreach my $cname (canon('__', @exts)) { my $ccode = "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n"; $retval .= $ccode unless $seen{$ccode}++; } return $retval; } sub xsi_body { my @exts = @_; my %seen; my $retval; $retval .= " static const char file[] = __FILE__;\n" if @exts; $retval .= <<'EOT'; dXSUB_SYS; PERL_UNUSED_CONTEXT; EOT $retval .= "\n" if @exts; foreach my $pname (canon('/', @exts)) { next if $seen{$pname}++; (my $mname = $pname) =~ s!/!::!g; (my $cname = $pname) =~ s!/!__!g; my $fname; if ($pname eq 'DynaLoader'){ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! # boot_DynaLoader is called directly in DynaLoader.pm $retval .= " /* DynaLoader is a special case */\n"; $fname = "${mname}::boot_DynaLoader"; } else { $fname = "${mname}::bootstrap"; } $retval .= " newXS(\"$fname\", boot_${cname}, file);\n" } return $retval; } sub static_ext { @Extensions = ('DynaLoader', sort $Config{static_ext} =~ /(\S+)/g) unless @Extensions; @Extensions; } sub _escape { my $arg = shift; return $$arg if $^O eq 'VMS'; # parens legal in qualifier lists $$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|dist|cpan)/(?:auto/)?!!; s!/\w+\.\w+$!!; } if ($as ne '/') { s!/!$as!g foreach @ext; } @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 C<ExtUtils::Embed> provides utility functions for embedding a Perl interpreter and extensions in your C/C++ applications. Typically, an application F<Makefile> will invoke C<ExtUtils::Embed> functions while building your application. Note that on Debian systems the B<libperl-dev> package is required for compiling applications which embed an interpreter. =head1 @EXPORT C<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 C<xs_init> function that glues the perl C<Socket::bootstrap> function to the C C<boot_Socket> function and writes it to a file named F<xsinit.c>. Note that L<DynaLoader> is a special case where it must call C<boot_DynaLoader> directly. perl -MExtUtils::Embed -e xsinit This will generate code for linking with C<DynaLoader> and each static extension found in C<$Config{static_ext}>. The code is written to the default file name F<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 C<DBI> and C<DBD::Oracle>. If you have a working C<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 C<@INC>. Library archives are expected to be found as F</some/path/auto/ModuleName/ModuleName.a> For example, when looking for F<Socket.a> relative to a search path, we should find F<auto/Socket/Socket.a> When looking for C<DBD::Oracle> relative to a search path, we should find F<auto/DBD/Oracle/Oracle.a> Keep in mind that you can always supply F</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 C<libperl> and extensions found in C<$Config{static_ext}>. This includes libraries found in C<$Config{libs}> and the first ModuleName.a library for each extension that is found by searching C<@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 F<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 C<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 C<perl_inc()>, C<ccflags()> and C<ccdlflags()> into one. =item xsi_header() This function simply returns a string defining the same C<EXTERN_C> macro as F<perlmain.c> along with #including F<perl.h> and F<EXTERN.h>. =item xsi_protos(@modules) This function returns a string of C<boot_$ModuleName> prototypes for each @modules. =item xsi_body(@modules) This function returns a string of calls to C<newXS()> that glue the module I<bootstrap> function to I<boot_ModuleName> for each @modules. C<xsinit()> uses the xsi_* functions to generate most of its code. =back =head1 EXAMPLES For examples on how to use C<ExtUtils::Embed> for building C/C++ applications with embedded perl, see L<perlembed>. =head1 SEE ALSO L<perlembed> =head1 AUTHOR Doug MacEachern E<lt>C<dougm@osf.org>E<gt> Based on ideas from Tim Bunce E<lt>C<Tim.Bunce@ig.co.uk>E<gt> and F<minimod.pl> by Andreas Koenig E<lt>C<k@anna.in-berlin.de>E<gt> and Tim Bunce. =cut testlib.pm 0000644 00000001617 15140257564 0006566 0 ustar 00 package ExtUtils::testlib; use strict; use warnings; our $VERSION = '7.44'; $VERSION =~ tr/_//d; 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. Typemaps/InputMap.pm 0000644 00000003642 15140257564 0010457 0 ustar 00 package ExtUtils::Typemaps::InputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.38'; =head1 NAME ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $input = $typemap->get_input_map('T_NV'); my $code = $input->code(); $input->code("..."); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. =head1 METHODS =cut =head2 new Requires C<xstype> and C<code> parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the INPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the INPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; $code =~ s/(?:;+\s*|;*\s+)\z//s; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Typemaps/Type.pm 0000644 00000004045 15140257564 0007641 0 ustar 00 package ExtUtils::Typemaps::Type; use 5.006001; use strict; use warnings; require ExtUtils::Typemaps; our $VERSION = '3.38'; =head1 NAME ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $type = $typemap->get_type_map('char*'); my $input = $typemap->get_input_map($type->xstype); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. Object associates C<ctype> with C<xstype>, which is the index into the in- and output mapping tables. =head1 METHODS =cut =head2 new Requires C<xstype> and C<ctype> parameters. Optionally takes C<prototype> parameter. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{ctype}) { die("Need xstype and ctype parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {proto => ''}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{ctype} = $args{ctype} if defined $args{ctype}; $self->{tidy_ctype} = ExtUtils::Typemaps::tidy_type($self->{ctype}); $self->{proto} = $args{'prototype'} if defined $args{'prototype'}; return $self; } =head2 proto Returns or sets the prototype. =cut sub proto { $_[0]->{proto} = $_[1] if @_ > 1; return $_[0]->{proto}; } =head2 xstype Returns the name of the XS type that this C type is associated to. =cut sub xstype { return $_[0]->{xstype}; } =head2 ctype Returns the name of the C type as it was set on construction. =cut sub ctype { return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype}; } =head2 tidy_ctype Returns the canonicalized name of the C type. =cut sub tidy_ctype { return $_[0]->{tidy_ctype}; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Typemaps/OutputMap.pm 0000644 00000010514 15140257564 0010654 0 ustar 00 package ExtUtils::Typemaps::OutputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.38'; =head1 NAME ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $output = $typemap->get_output_map('T_NV'); my $code = $output->code(); $output->code("..."); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. =head1 METHODS =cut =head2 new Requires C<xstype> and C<code> parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the OUTPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the OUTPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head2 targetable This is an obscure but effective optimization that used to live in C<ExtUtils::ParseXS> directly. Not implementing it should never result in incorrect use of typemaps, just less efficient code. In a nutshell, this will check whether the output code involves calling C<sv_setiv>, C<sv_setuv>, C<sv_setnv>, C<sv_setpv> or C<sv_setpvn> to set the special C<$arg> placeholder to a new value B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is eligible for using the C<TARG>-related macros to optimize this. Thus the name of the method: C<targetable>. If this optimization is applicable, C<ExtUtils::ParseXS> will emit a C<dXSTARG;> definition at the start of the generated XSUB code, and type (see below) dependent code to set C<TARG> and push it on the stack at the end of the generated XSUB code. If the optimization can not be applied, this returns undef. If it can be applied, this method returns a hash reference containing the following information: type: Any of the characters i, u, n, p with_size: Bool indicating whether this is the sv_setpvn variant what: The code that actually evaluates to the output scalar what_size: If "with_size", this has the string length (as code, not constant, including leading comma) =cut sub targetable { my $self = shift; return $self->{targetable} if exists $self->{targetable}; our $bal; # ()-balanced $bal = qr[ (?: (?>[^()]+) | \( (??{ $bal }) \) )* ]x; my $bal_no_comma = qr[ (?: (?>[^(),]+) | \( (??{ $bal }) \) )+ ]x; # matches variations on (SV*) my $sv_cast = qr[ (?: \( \s* SV \s* \* \s* \) \s* )? ]x; my $size = qr[ # Third arg (to setpvn) , \s* (??{ $bal }) ]xo; my $code = $self->code; # 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 ($type, $with_size, $arg, $sarg) = ($code =~ m[^ \s+ sv_set([iunp])v(n)? # Type, is_setpvn \s* \( \s* $sv_cast \$arg \s* , \s* ( $bal_no_comma ) # Set from ( $size )? # Possible sizeof set-from \s* \) \s* ; \s* $ ]xo ); my $rv = undef; if ($type) { $rv = { type => $type, with_size => $with_size, what => $arg, what_size => $sarg, }; } $self->{targetable} = $rv; return $rv; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Typemaps/Cmd.pm 0000644 00000010045 15140257564 0007420 0 ustar 00 package ExtUtils::Typemaps::Cmd; use 5.006001; use strict; use warnings; our $VERSION = '3.38'; use ExtUtils::Typemaps; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(embeddable_typemap); our %EXPORT_TAGS = (all => \@EXPORT); sub embeddable_typemap { my @tms = @_; # Get typemap objects my @tm_objs = map [$_, _intuit_typemap_source($_)], @tms; # merge or short-circuit my $final_tm; if (@tm_objs == 1) { # just one, merge would be pointless $final_tm = shift(@tm_objs)->[1]; } else { # multiple, need merge $final_tm = ExtUtils::Typemaps->new; foreach my $other_tm (@tm_objs) { my ($tm_ident, $tm_obj) = @$other_tm; eval { $final_tm->merge(typemap => $tm_obj); 1 } or do { my $err = $@ || 'Zombie error'; die "Failed to merge typ"; } } } # stringify for embedding return $final_tm->as_embedded_typemap(); } sub _load_module { my $name = shift; return eval "require $name; 1"; } SCOPE: { my %sources = ( module => sub { my $ident = shift; my $tm; if (/::/) { # looks like FQ module name, try that first foreach my $module ($ident, "ExtUtils::Typemaps::$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } else { foreach my $module ("ExtUtils::Typemaps::$ident", "$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } return(); }, file => sub { my $ident = shift; return unless -e $ident and -r _; return ExtUtils::Typemaps->new(file => $ident); }, ); # Try to find typemap either from module or file sub _intuit_typemap_source { my $identifier = shift; my @locate_attempts; if ($identifier =~ /::/ || $identifier !~ /[^\w_]/) { @locate_attempts = qw(module file); } else { @locate_attempts = qw(file module); } foreach my $source (@locate_attempts) { my $tm = $sources{$source}->($identifier); return $tm if defined $tm; } die "Unable to find typemap for '$identifier': " . "Tried to load both as file or module and failed.\n"; } } # end SCOPE =head1 NAME ExtUtils::Typemaps::Cmd - Quick commands for handling typemaps =head1 SYNOPSIS From XS: INCLUDE_COMMAND: $^X -MExtUtils::Typemaps::Cmd \ -e "print embeddable_typemap(q{Excommunicated})" Loads C<ExtUtils::Typemaps::Excommunicated>, instantiates an object, and dumps it as an embeddable typemap for use directly in your XS file. =head1 DESCRIPTION This is a helper module for L<ExtUtils::Typemaps> for quick one-liners, specifically for inclusion of shared typemaps that live on CPAN into an XS file (see SYNOPSIS). For this reason, the following functions are exported by default: =head1 EXPORTED FUNCTIONS =head2 embeddable_typemap Given a list of identifiers, C<embeddable_typemap> tries to load typemaps from a file of the given name(s), or from a module that is an C<ExtUtils::Typemaps> subclass. Returns a string representation of the merged typemaps that can be included verbatim into XS. Example: print embeddable_typemap( "Excommunicated", "ExtUtils::Typemaps::Basic", "./typemap" ); This will try to load a module C<ExtUtils::Typemaps::Excommunicated> and use it as an C<ExtUtils::Typemaps> subclass. If that fails, it'll try loading C<Excommunicated> as a module, if that fails, it'll try to read a file called F<Excommunicated>. It'll work similarly for the second argument, but the third will be loaded as a file first. After loading all typemap files or modules, it will merge them in the specified order and dump the result as an embeddable typemap. =head1 SEE ALSO L<ExtUtils::Typemaps> L<perlxs> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; MM_AIX.pm 0000644 00000002712 15140257564 0006127 0 ustar 00 package ExtUtils::MM_AIX; use strict; our $VERSION = '7.44'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =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 L<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; join "\n", $self->xs_dlsyms_iterator(\%attribs); } =head3 xs_dlsyms_ext On AIX, is C<.exp>. =cut sub xs_dlsyms_ext { '.exp'; } sub xs_dlsyms_arg { my($self, $file) = @_; my $arg = qq{-bE:${file}}; $arg = '-Wl,'.$arg if $Config{lddlflags} =~ /-Wl,-bE:/; return $arg; } sub init_others { my $self = shift; $self->SUPER::init_others; # perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out # so right value can be added by xs_make_dynamic_lib to work for XSMULTI $self->{LDDLFLAGS} ||= $Config{lddlflags}; $self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#; return; } =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut 1;
| ver. 1.4 |
Github
|
.
| PHP 7.4.33 | Generation time: 0.27 |
proxy
|
phpinfo
|
Settings