X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/be573f631d93a503246e9a83f3e8e876f6c5fcfb..fbc70a9e6c5a8b48dcdf2aa4f1f639d7064649cf:/utils/h2xs.PL diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 8ebe8b3..634e891 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -13,9 +13,9 @@ use Cwd; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; +my $origdir = cwd; chdir dirname($0); -$file = basename($0, '.PL'); +my $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -35,15 +35,17 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; +use warnings; + =head1 NAME h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] +B [B ...] [headerfile ... [extra_libraries]] -B B<-h> +B B<-h>|B<-?>|B<--help> =head1 DESCRIPTION @@ -57,50 +59,59 @@ will be used, with the first character capitalized. If the extension might need extra libraries, they should be included here. The extension Makefile.PL will take care of checking whether -the libraries actually exist and how they should be loaded. -The extra libraries should be specified in the form -lm -lposix, etc, -just as on the cc command line. By default, the Makefile.PL will -search through the library path determined by Configure. That path -can be augmented by including arguments of the form B<-L/another/library/path> -in the extra-libraries argument. +the libraries actually exist and how they should be loaded. The extra +libraries should be specified in the form -lm -lposix, etc, just as on +the cc command line. By default, the Makefile.PL will search through +the library path determined by Configure. That path can be augmented +by including arguments of the form B<-L/another/library/path> in the +extra-libraries argument. + +In spite of its name, I may also be used to create a skeleton pure +Perl module. See the B<-X> option. =head1 OPTIONS =over 5 -=item B<-A> +=item B<-A>, B<--omit-autoload> -Omit all autoload facilities. This is the same as B<-c> but also removes the -S> statement from the .pm file. +Omit all autoload facilities. This is the same as B<-c> but also +removes the S> statement from the .pm file. -=item B<-C> +=item B<-B>, B<--beta-version> + +Use an alpha/beta style version number. Causes version number to +be "0.00_01" unless B<-v> is specified. + +=item B<-C>, B<--omit-changes> Omits creation of the F file, and adds a HISTORY section to the POD template. -=item B<-F> +=item B<-F>, B<--cpp-flags>=I Additional flags to specify to C preprocessor when scanning header for -function declarations. Should not be used without B<-x>. +function declarations. Writes these options in the generated F +too. -=item B<-M> I +=item B<-M>, B<--func-mask>=I selects functions/macros to process. -=item B<-O> +=item B<-O>, B<--overwrite-ok> Allows a pre-existing extension directory to be overwritten. -=item B<-P> +=item B<-P>, B<--omit-pod> -Omit the autogenerated stub POD section. +Omit the autogenerated stub POD section. -=item B<-X> +=item B<-X>, B<--omit-XS> -Omit the XS portion. Used to generate templates for a module which is not -XS-based. C<-c> and C<-f> are implicitly enabled. +Omit the XS portion. Used to generate a skeleton pure Perl module. +C<-c> and C<-f> are implicitly enabled. -=item B<-a> +=item B<-a>, B<--gen-accessors> Generate an accessor method for each element of structs and unions. The generated methods are named after the element name; will return the current @@ -114,39 +125,75 @@ two methods are constructed for the structure type itself, C<_to_ptr> which returns a Ptr type pointing to the same structure, and a C method to construct and return a new structure, initialised to zeroes. -=item B<-c> +=item B<-b>, B<--compat-version>=I + +Generates a .pm file which is backwards compatible with the specified +perl version. + +For versions < 5.6.0, the changes are. + - no use of 'our' (uses 'use vars' instead) + - no 'use warnings' + +Specifying a compatibility version higher than the version of perl you +are using to run h2xs will have no effect. If unspecified h2xs will default +to compatibility with the version of perl you are using to run h2xs. + +=item B<-c>, B<--omit-constant> Omit C from the .xs file and corresponding specialised C from the .pm file. -=item B<-d> +=item B<-d>, B<--debugging> Turn on debugging messages. -=item B<-f> +=item B<-e>, B<--omit-enums>=[I] + +If I is not given, skip all constants that are defined in +a C enumeration. Otherwise skip only those constants that are defined in an +enum whose name matches I. + +Since I is optional, make sure that this switch is followed +by at least one other switch if you omit I and have some +pending arguments such as header-file names. This is ok: + + h2xs -e -n Module::Foo foo.h + +This is not ok: + + h2xs -n Module::Foo -e foo.h + +In the latter, foo.h is taken as I. + +=item B<-f>, B<--force> Allows an extension to be created for a header even if that header is not found in standard include directories. -=item B<-h> +=item B<-g>, B<--global> + +Include code for safely storing static data in the .xs file. +Extensions that do no make use of static data can ignore this option. + +=item B<-h>, B<-?>, B<--help> Print the usage, help and version for this h2xs and exit. -=item B<-k> +=item B<-k>, B<--omit-const-func> For function arguments declared as C, omit the const attribute in the generated XS code. -=item B<-m> +=item B<-m>, B<--gen-tied-var> B: for each variable declared in the header file(s), declare a perl variable of the same name magically tied to the C variable. -=item B<-n> I +=item B<-n>, B<--name>=I Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> -=item B<-o> I +=item B<-o>, B<--opaque-re>=I Use "opaque" data type for the C types matched by the regular expression, even if these types are C-equivalent to types @@ -155,35 +202,80 @@ from typemaps. Should not be used without B<-x>. This may be useful since, say, types which are C-equivalent to integers may represent OS-related handles, and one may want to work with these handles in OO-way, as in C<$handle-Edo_something()>. -Use C<-o .> if you want to handle all the Ced types as opaque types. +Use C<-o .> if you want to handle all the Ced types as opaque +types. The type-to-match is whitewashed (except for commas, which have no whitespace before them, and multiple C<*> which have no whitespace between them). -=item B<-p> I +=item B<-p>, B<--remove-prefix>=I + +Specify a prefix which should be removed from the Perl function names, +e.g., S<-p sec_rgy_> This sets up the XS B keyword and removes +the prefix from functions that are autoloaded via the C +mechanism. + +=item B<-s>, B<--const-subs>=I + +Create a perl subroutine for the specified macros rather than autoload +with the constant() subroutine. These macros are assumed to have a +return type of B, e.g., +S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. + +=item B<-t>, B<--default-type>=I + +Specify the internal type that the constant() mechanism uses for macros. +The default is IV (signed integer). Currently all macros found during the +header scanning process will be assumed to have this type. Future versions +of C may gain the ability to make educated guesses. + +=item B<--use-new-tests> -Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> -This sets up the XS B keyword and removes the prefix from functions that are -autoloaded via the C mechanism. +When B<--compat-version> (B<-b>) is present the generated tests will use +C rather than C which is the default for versions before +5.6.2. C will be added to PREREQ_PM in the generated +C. -=item B<-s> I +=item B<--use-old-tests> -Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine. -These macros are assumed to have a return type of B, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. +Will force the generation of test code that uses the older C module. -=item B<-v> I +=item B<--skip-exporter> + +Do not use C and/or export any symbol. + +=item B<--skip-ppport> + +Do not use C: no portability to older version. + +=item B<--skip-autoloader> + +Do not use the module C; but keep the constant() function +and C for constants. + +=item B<--skip-strict> + +Do not use the pragma C. + +=item B<--skip-warnings> + +Do not use the pragma C. + +=item B<-v>, B<--version>=I Specify a version number for this extension. This version number is added -to the templates. The default is 0.01. +to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified. +The version specified should be numeric. -=item B<-x> +=item B<-x>, B<--autogen-xsubs> Automatically generate XSUBs basing on function declarations in the header file. The package C should be installed. If this option is specified, the name of the header file may look like -C. In this case NAME1 is used instead of the specified string, -but XSUBs are emitted only for the declarations included from file NAME2. +C. In this case NAME1 is used instead of the specified +string, but XSUBs are emitted only for the declarations included from +file NAME2. Note that some types of arguments/return-values for functions may result in XSUB-declarations/typemap-entries which need @@ -196,57 +288,133 @@ also the section on L>. =head1 EXAMPLES - # Default behavior, extension is Rusers - h2xs rpcsvc/rusers + # Default behavior, extension is Rusers + h2xs rpcsvc/rusers + + # Same, but extension is RUSERS + h2xs -n RUSERS rpcsvc/rusers + + # Extension is rpcsvc::rusers. Still finds + h2xs rpcsvc::rusers + + # Extension is ONC::RPC. Still finds + h2xs -n ONC::RPC rpcsvc/rusers + + # Without constant() or AUTOLOAD + h2xs -c rpcsvc/rusers + + # Creates templates for an extension named RPC + h2xs -cfn RPC + + # Extension is ONC::RPC. + h2xs -cfn ONC::RPC + + # Extension is a pure Perl module with no XS code. + h2xs -X My::Module + + # Extension is Lib::Foo which works at least with Perl5.005_03. + # Constants are created for all #defines and enums h2xs can find + # in foo.h. + h2xs -b 5.5.3 -n Lib::Foo foo.h + + # Extension is Lib::Foo which works at least with Perl5.005_03. + # Constants are created for all #defines but only for enums + # whose names do not start with 'bar_'. + h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h + + # Makefile.PL will look for library -lrpc in + # additional directory /opt/net/lib + h2xs rpcsvc/rusers -L/opt/net/lib -lrpc + + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase + + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + # subroutines are created for sec_rgy_wildcard_name and + # sec_rgy_wildcard_sid + h2xs -n DCE::rgynbase -p sec_rgy_ \ + -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase + + # Make XS without defines in perl.h, but with function declarations + # visible from perl.h. Name of the extension is perl1. + # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= + # Extra backslashes below because the string is passed to shell. + # Note that a directory with perl header files would + # be added automatically to include path. + h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h + + # Same with function declaration in proto.h as visible from perl.h. + h2xs -xAn perl2 perl.h,proto.h - # Same, but extension is RUSERS - h2xs -n RUSERS rpcsvc/rusers + # Same but select only functions which match /^av_/ + h2xs -M '^av_' -xAn perl2 perl.h,proto.h - # Extension is rpcsvc::rusers. Still finds - h2xs rpcsvc::rusers + # Same but treat SV* etc as "opaque" types + h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h - # Extension is ONC::RPC. Still finds - h2xs -n ONC::RPC rpcsvc/rusers +=head2 Extension based on F<.h> and F<.c> files - # Without constant() or AUTOLOAD - h2xs -c rpcsvc/rusers +Suppose that you have some C files implementing some functionality, +and the corresponding header files. How to create an extension which +makes this functionality accessible in Perl? The example below +assumes that the header files are F and +I, and you want the perl module be named as +C. If you need some preprocessor directives and/or +linking with external libraries, see the flags C<-F>, C<-L> and C<-l> +in L<"OPTIONS">. - # Creates templates for an extension named RPC - h2xs -cfn RPC +=over - # Extension is ONC::RPC. - h2xs -cfn ONC::RPC +=item Find the directory name - # Makefile.PL will look for library -lrpc in - # additional directory /opt/net/lib - h2xs rpcsvc/rusers -L/opt/net/lib -lrpc +Start with a dummy run of h2xs: - # Extension is DCE::rgynbase - # prefix "sec_rgy_" is dropped from perl function names - h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase + h2xs -Afn Ext::Ension - # Extension is DCE::rgynbase - # prefix "sec_rgy_" is dropped from perl function names - # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid - h2xs -n DCE::rgynbase -p sec_rgy_ \ - -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase +The only purpose of this step is to create the needed directories, and +let you know the names of these directories. From the output you can +see that the directory for the extension is F. - # Make XS without defines in perl.h, but with function declarations - # visible from perl.h. Name of the extension is perl1. - # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= - # Extra backslashes below because the string is passed to shell. - # Note that a directory with perl header files would - # be added automatically to include path. - h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h +=item Copy C files - # Same with function declaration in proto.h as visible from perl.h. - h2xs -xAn perl2 perl.h,proto.h +Copy your header files and C files to this directory F. - # Same but select only functions which match /^av_/ - h2xs -M '^av_' -xAn perl2 perl.h,proto.h +=item Create the extension - # Same but treat SV* etc as "opaque" types - h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h +Run h2xs, overwriting older autogenerated files: + + h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h + +h2xs looks for header files I changing to the extension +directory, so it will find your header files OK. + +=item Archive and test + +As usual, run + + cd Ext/Ension + perl Makefile.PL + make dist + make + make test + +=item Hints + +It is important to do C as early as possible. This way you +can easily merge(1) your changes to autogenerated files if you decide +to edit your C<.h> files and rerun h2xs. + +Do not forget to edit the documentation in the generated F<.pm> file. + +Consider the autogenerated files as skeletons only, you may invent +better interfaces than what h2xs could guess. + +Consider this section as a guideline only, some other options of h2xs +may better suit your needs. + +=back =head1 ENVIRONMENT @@ -326,71 +494,235 @@ See L and L for additional details. =cut +# ' # Grr use strict; -my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; my @ARGS = @ARGV; +my $compat_version = $]; -use Getopt::Std; - -sub usage{ - warn "@_\n" if @_; - die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] +use Getopt::Long; +use Config; +use Text::Wrap; +$Text::Wrap::huge = 'overflow'; +$Text::Wrap::columns = 80; +use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload); +use File::Compare; +use File::Path; + +sub usage { + warn "@_\n" if @_; + die <. + --skip-strict Do not use the pragma C. + --skip-warnings Do not use the pragma C. + -v, --version Specify a version number for this extension. + -x, --autogen-xsubs Autogenerate XSUBs using C::Scan. + --use-xsloader Use XSLoader in backward compatible modules (ignored + when used with -X). + extra_libraries are any libraries that might be needed for loading the extension, e.g. -lm would try to link in the math library. -"; +EOFUSAGE } - -getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || usage; -use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d - $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x); +my ($opt_A, + $opt_B, + $opt_C, + $opt_F, + $opt_M, + $opt_O, + $opt_P, + $opt_X, + $opt_a, + $opt_c, + $opt_d, + $opt_e, + $opt_f, + $opt_g, + $opt_h, + $opt_k, + $opt_m, + $opt_n, + $opt_o, + $opt_p, + $opt_s, + $opt_v, + $opt_x, + $opt_b, + $opt_t, + $new_test, + $old_test, + $skip_exporter, + $skip_ppport, + $skip_autoloader, + $skip_strict, + $skip_warnings, + $use_xsloader + ); + +Getopt::Long::Configure('bundling'); +Getopt::Long::Configure('pass_through'); + +my %options = ( + 'omit-autoload|A' => \$opt_A, + 'beta-version|B' => \$opt_B, + 'omit-changes|C' => \$opt_C, + 'cpp-flags|F=s' => \$opt_F, + 'func-mask|M=s' => \$opt_M, + 'overwrite_ok|O' => \$opt_O, + 'omit-pod|P' => \$opt_P, + 'omit-XS|X' => \$opt_X, + 'gen-accessors|a' => \$opt_a, + 'compat-version|b=s' => \$opt_b, + 'omit-constant|c' => \$opt_c, + 'debugging|d' => \$opt_d, + 'omit-enums|e:s' => \$opt_e, + 'force|f' => \$opt_f, + 'global|g' => \$opt_g, + 'help|h|?' => \$opt_h, + 'omit-const-func|k' => \$opt_k, + 'gen-tied-var|m' => \$opt_m, + 'name|n=s' => \$opt_n, + 'opaque-re|o=s' => \$opt_o, + 'remove-prefix|p=s' => \$opt_p, + 'const-subs|s=s' => \$opt_s, + 'default-type|t=s' => \$opt_t, + 'version|v=s' => \$opt_v, + 'autogen-xsubs|x' => \$opt_x, + 'use-new-tests' => \$new_test, + 'use-old-tests' => \$old_test, + 'skip-exporter' => \$skip_exporter, + 'skip-ppport' => \$skip_ppport, + 'skip-autoloader' => \$skip_autoloader, + 'skip-warnings' => \$skip_warnings, + 'skip-strict' => \$skip_strict, + 'use-xsloader' => \$use_xsloader, + ); + +GetOptions(%options) || usage; usage if $opt_h; +if( $opt_b ){ + usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); + $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ || + usage "You must provide the backwards compatibility version in X.Y.Z form. " + . "(i.e. 5.5.0)\n"; + my ($maj,$min,$sub) = ($1,$2,$3); + if ($maj < 5 || ($maj == 5 && $min < 6)) { + $compat_version = + $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) : + sprintf("%d.%03d", $maj,$min); + } else { + $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub); + } +} else { + my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/; + $sub ||= 0; + warn sprintf <<'EOF', $maj,$min,$sub; +Defaulting to backwards compatibility with perl %d.%d.%d +If you intend this module to be compatible with earlier perl versions, please +specify a minimum perl version with the -b option. + +EOF +} + +if( $opt_B ){ + $TEMPLATE_VERSION = '0.00_01'; +} + if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; + + # check if it is numeric + my $temp_version = $TEMPLATE_VERSION; + my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/; + my $notnum; + { + local $SIG{__WARN__} = sub { $notnum = 1 }; + use warnings 'numeric'; + $temp_version = 0+$temp_version; + } + + if ($notnum) { + my $module = $opt_n || 'Your::Module'; + warn <<"EOF"; +You have specified a non-numeric version. Unless you supply an +appropriate VERSION class method, users may not be able to specify a +minimum required version with C. + +EOF + } + else { + $opt_B = $beta_version; + } } # -A implies -c. -$opt_c = 1 if $opt_A; +$skip_autoloader = $opt_c = 1 if $opt_A; # -X implies -c and -f $opt_c = $opt_f = 1 if $opt_X; -my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; -my $extralibs; +$opt_t ||= 'IV'; + +my %const_xsub; +%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; + +my $extralibs = ''; + my @path_h; while (my $arg = shift) { if ($arg =~ /^-l/i) { - $extralibs = "$arg @ARGV"; - last; + $extralibs .= "$arg "; + next; } + last if $extralibs; push(@path_h, $arg); } @@ -430,18 +762,23 @@ EOD } } elsif ($opt_o or $opt_F) { - warn <catfile($dir, $tmp_path_h)); + $found++, last + if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + } + if ($found) { + $rel_path_h = $path_h; + $fullpath{$path_h} = $fullpath; + } else { + (my $epath = $module) =~ s,::,/,g; + $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; + $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); + $path_h = $tmp_path_h; # Used during -x + push @dirs, $epath; } } if (!$opt_c) { - die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); + die "Can't find $tmp_path_h in @dirs\n" + if ( ! $opt_f && ! -f "$rel_path_h" ); # Scan the header file (we should deal with nested header files) # Record the names of simple #define constants into const_names # Function prototypes are processed below. - open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; defines: while () { - if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { + if ($pre_sub_tri_graphs) { + # Preprocess all tri-graphs + # including things stuck in quoted string constants. + s/\?\?=/#/g; # | ??=| #| + s/\?\?\!/|/g; # | ??!| || + s/\?\?'/^/g; # | ??'| ^| + s/\?\?\(/[/g; # | ??(| [| + s/\?\?\)/]/g; # | ??)| ]| + s/\?\?\-/~/g; # | ??-| ~| + s/\?\?\//\\/g; # | ??/| \| + s/\?\?/}/g; # | ??>| }| + } + if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) { my $def = $1; my $rest = $2; $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments @@ -511,36 +888,56 @@ if( @path_h ){ } } } - close(CH); + if (defined $opt_e and !$opt_e) { + close(CH); + } + else { + # Work from miniperl too - on "normal" systems + my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0; + seek CH, 0, $SEEK_SET; + my $src = do { local $/; }; + close CH; + no warnings 'uninitialized'; + + # Remove C and C++ comments + $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs; + $src =~ s#//.*$##gm; + + while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) { + my ($enum_name, $enum_body) = ($1, $2); + # skip enums matching $opt_e + next if $opt_e && $enum_name =~ /$opt_e/; + my $val = 0; + for my $item (split /,/, $enum_body) { + next if $item =~ /\A\s*\Z/; + my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/; + $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val; + $seen_define{$key} = $val; + $const_names{$key} = { name => $key, macro => 1 }; + } + } # while (...) + } # if (!defined $opt_e or $opt_e) } } } +# Save current directory so that C::Scan can use it +my $cwd = File::Spec->rel2abs( File::Spec->curdir ); -my $module = $opt_n || do { - $name =~ s/\.h$//; - if( $name !~ /::/ ){ - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; -}; +# As Ilya suggested, use a name that contains - and then it can't clash with +# the names of any packages. A directory 'fallback' will clash with any +# new pragmata down the fallback:: tree, but that seems unlikely. +my $constscfname = 'const-c.inc'; +my $constsxsfname = 'const-xs.inc'; +my $fallbackdirname = 'fallback'; -my ($ext, $nested, @modparts, $modfname, $modpname); -(chdir 'ext', $ext = 'ext/') if -d 'ext'; - -if( $module =~ /::/ ){ - $nested = 1; - @modparts = split(/::/,$module); - $modfname = $modparts[-1]; - $modpname = join('/',@modparts); -} -else { - $nested = 0; - @modparts = (); - $modfname = $modpname = $module; -} +my $ext = chdir 'ext' ? 'ext/' : ''; +my @modparts = split(/::/,$module); +my $modpname = join('-', @modparts); +my $modfname = pop @modparts; +my $modpmdir = join '/', 'lib', @modparts; +my $modpmname = join '/', $modpmdir, $modfname.'.pm'; if ($opt_O) { warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; @@ -548,14 +945,7 @@ if ($opt_O) { else { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } -if( $nested ){ - my $modpath = ""; - foreach (@modparts){ - mkdir("$modpath$_", 0777); - $modpath .= "$_/"; - } -} -mkdir($modpname, 0777); +-d "$modpname" || mkpath([$modpname], 0, 0775); chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; my %types_seen; @@ -573,9 +963,14 @@ my %vdecl_hash; my @vdecls; if( ! $opt_X ){ # use XS, unless it was disabled + unless ($skip_ppport) { + require Devel::PPPort; + warn "Writing $ext$modpname/ppport.h\n"; + Devel::PPPort::WriteFile('ppport.h') + || die "Can't create $ext$modpname/ppport.h: $!\n"; + } open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; if ($opt_x) { - require Config; # Run-time directive warn "Scanning typemaps...\n"; get_typemap(); my @td; @@ -591,9 +986,12 @@ if( ! $opt_X ){ # use XS, unless it was disabled $filter = $'; } warn "Scanning $filename for functions...\n"; + my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X); $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, - 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)]; - $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + 'add_cppflags' => $addflags, 'c_styles' => \@styles; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]); + + $c->get('keywords')->{'__restrict'} = 1; push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; push(@$fdecls, @{$c->get('fdecls')}); @@ -652,7 +1050,8 @@ if( ! $opt_X ){ # use XS, unless it was disabled } @fnames_no_prefix = @fnames; @fnames_no_prefix - = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; + = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix + if defined $opt_p; # Remove macros which expand to typedefs print "Typedefs are @td.\n" if $opt_d; my %td = map {($_, $_)} @td; @@ -667,7 +1066,7 @@ if( ! $opt_X ){ # use XS, unless it was disabled $n = keys %td; my ($k, $v); while (($k, $v) = each %seen_define) { - # print("found '$k'=>'$v'\n"), + # print("found '$k'=>'$v'\n"), $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; } } @@ -678,21 +1077,33 @@ if( ! $opt_X ){ # use XS, unless it was disabled } } } -my @const_names = sort keys %const_names; +my (@const_specs, @const_names); + +for (sort(keys(%const_names))) { + my $v = $const_names{$_}; + + push(@const_specs, ref($v) ? $v : $_); + push(@const_names, $_); +} -open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; +-d $modpmdir || mkpath([$modpmdir], 0, 0775); +open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n"; $" = "\n\t"; -warn "Writing $ext$modpname/$modfname.pm\n"; +warn "Writing $ext$modpname/$modpmname\n"; print PM <<"END"; package $module; -use 5.006; +use $compat_version; +END + +print PM <<"END" unless $skip_strict; use strict; -use warnings; END +print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006; + unless( $opt_X || $opt_c || $opt_A ){ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and # will want Carp. @@ -701,18 +1112,19 @@ use Carp; END } -print PM <<'END'; +print PM <<'END' unless $skip_exporter; require Exporter; END -print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled +my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader); +print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled require DynaLoader; END # Are we using AutoLoader or not? -unless ($opt_A) { # no autoloader whatsoever. +unless ($skip_autoloader) { # no autoloader whatsoever. unless ($opt_c) { # we're doing the AUTOLOAD print PM "use AutoLoader;\n"; } @@ -721,15 +1133,27 @@ unless ($opt_A) { # no autoloader whatsoever. } } +if ( $compat_version < 5.006 ) { + my $vars = '$VERSION @ISA'; + $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter; + $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A; + $vars .= ' $XS_VERSION' if $opt_B && !$opt_X; + print PM "use vars qw($vars);"; +} + # Determine @ISA. -my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. -$myISA .= ' DynaLoader' unless $opt_X; # no XS -$myISA .= ');'; +my @modISA; +push @modISA, 'Exporter' unless $skip_exporter; +push @modISA, 'DynaLoader' if $use_Dyna; # no XS +my $myISA = "our \@ISA = qw(@modISA);"; +$myISA =~ s/^our // if $compat_version < 5.006; + print PM "\n$myISA\n\n"; my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); -print PM<<"END"; +my $tmp=''; +$tmp .= <<"END" unless $skip_exporter; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @@ -746,53 +1170,39 @@ our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); our \@EXPORT = qw( @const_names ); -our \$VERSION = '$TEMPLATE_VERSION'; END +$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n"; +if ($opt_B) { + $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X; + $tmp .= "\$VERSION = eval \$VERSION; # see L\n"; +} +$tmp .= "\n"; + +$tmp =~ s/^our //mg if $compat_version < 5.006; +print PM $tmp; + if (@vdecls) { printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; } -print PM <<"END" unless $opt_c or $opt_X; -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my \$constname; - our \$AUTOLOAD; - (\$constname = \$AUTOLOAD) =~ s/.*:://; - croak "&$module::constant not defined" if \$constname eq 'constant'; - my \$val = constant(\$constname, \@_ ? \$_[0] : 0); - if (\$! != 0) { - if (\$! =~ /Invalid/ || \$!{EINVAL}) { - \$AutoLoader::AUTOLOAD = \$AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined $module macro \$constname"; - } - } - { - no strict 'refs'; - # Fixed between 5.005_53 and 5.005_61 - if (\$] >= 5.00561) { - *\$AUTOLOAD = sub () { \$val }; - } - else { - *\$AUTOLOAD = sub { \$val }; - } - } - goto &\$AUTOLOAD; -} -END +print PM autoload ($module, $compat_version) unless $opt_c or $opt_X; if( ! $opt_X ){ # print bootstrap, unless XS is disabled - print PM <<"END"; + if ($use_Dyna) { + $tmp = <<"END"; bootstrap $module \$VERSION; END + } else { + $tmp = <<"END"; +require XSLoader; +XSLoader::load('$module', \$VERSION); +END + } + $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B; + print PM $tmp; } # tying the variables can happen only after bootstrap @@ -829,58 +1239,98 @@ print PM <<"END"; __END__ END -my $author = "A. U. Thor"; -my $email = 'a.u.thor@a.galaxy.far.far.away'; +my ($email,$author,$licence); -my $revhist = ''; -$revhist = <))[0,6]; + if (defined $username && defined $author) { + $author =~ s/,.*$//; # in case of sub fields + my $domain = $Config{'mydomain'}; + $domain =~ s/^\.//; + $email = "$username\@$domain"; + } + }; -=over 8 +$author =~ s/'/\\'/g if defined $author; +$author ||= "A. U. Thor"; +$email ||= 'a.u.thor@a.galaxy.far.far.away'; -=item $TEMPLATE_VERSION +$licence = sprintf << "DEFAULT", $^V; +Copyright (C) ${\(1900 + (localtime) [5])} by $author -Original version; created by h2xs $H2XS_VERSION with options - - @ARGS - -=back +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version %vd or, +at your option, any later version of Perl 5 you may have available. +DEFAULT +my $revhist = ''; +$revhist = < should be removed. +# $exp_doc .= < should be removed. +# +#EOD + $exp_doc .= <${email}E # -#=head1 SEE ALSO +#=head1 COPYRIGHT AND LICENSE # -#L. +$licence_hash # #=cut END @@ -925,6 +1387,12 @@ print XS <<"END"; #include "XSUB.h" END + +print XS <<"END" unless $skip_ppport; +#include "ppport.h" + +END + if( @path_h ){ foreach my $path_h (@path_h_ini) { my($h) = $path_h; @@ -935,6 +1403,21 @@ if( @path_h ){ print XS "\n"; } +print XS <<"END" if $opt_g; + +/* Global Data */ + +#define MY_CXT_KEY "${module}::_guts" XS_VERSION + +typedef struct { + /* Put Global Data in here */ + int dummy; /* you can access this elsewhere as MY_CXT.dummy */ +} my_cxt_t; + +START_MY_CXT + +END + my %pointer_typedefs; my %struct_typedefs; @@ -972,187 +1455,55 @@ sub td_is_struct { return ($struct_typedefs{$otype} = $out); } -# Some macros will bomb if you try to return them from a double-returning func. -# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen). -# Fortunately, we can detect both these cases... -sub protect_convert_to_double { - my $in = shift; - my $val; - return '' unless defined ($val = $seen_define{$in}); - return '(IV)' if $known_fnames{$val}; - # OUT_t of ((OUT_t)-1): - return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/; - td_is_pointer($2) ? '(IV)' : ''; -} - -# For each of the generated functions, length($pref) leading -# letters are already checked. Moreover, it is recommended that -# the generated functions uses switch on letter at offset at least -# $off + length($pref). -# -# The given list has length($pref) chars removed at front, it is -# guarantied that $off leading chars in the rest are the same for all -# elts of the list. -# -# Returns: how at which offset it was decided to make a switch, or -1 if none. - -sub write_const; - -sub write_const { - my ($fh, $pref, $off, $list) = (shift,shift,shift,shift); - my %leading; - my $offarg = length $pref; +print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; - if (@$list == 0) { # Can happen on the initial iteration only - print $fh <<"END"; -static double -constant(char *name, int len, int arg) -{ - errno = EINVAL; - return 0; -} -END - return -1; +if( ! $opt_c ) { + # We write the "sample" files used when this module is built by perl without + # ExtUtils::Constant. + # h2xs will later check that these are the same as those generated by the + # code embedded into Makefile.PL + unless (-d $fallbackdirname) { + mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n"; } - - if (@$list == 1) { # Can happen on the initial iteration only - my $protect = protect_convert_to_double("$pref$list->[0]"); - - print $fh <<"END"; -static double -constant(char *name, int len, int arg) -{ - errno = 0; - if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */ -#ifdef $pref$list->[0] - return $protect$pref$list->[0]; -#else - errno = ENOENT; - return 0; -#endif - } - errno = EINVAL; - return 0; + warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n"; + warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n"; + my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname); + my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname); + WriteConstants ( C_FILE => $cfallback, + XS_FILE => $xsfallback, + DEFAULT_TYPE => $opt_t, + NAME => $module, + NAMES => \@const_specs, + ); + print XS "#include \"$constscfname\"\n"; } -END - return -1; - } - - for my $n (@$list) { - my $c = substr $n, $off, 1; - $leading{$c} = [] unless exists $leading{$c}; - push @{$leading{$c}}, substr $n, $off + 1; - } - - if (keys(%leading) == 1) { - return 1 + write_const $fh, $pref, $off + 1, $list; - } - - my $leader = substr $list->[0], 0, $off; - foreach my $letter (keys %leading) { - write_const $fh, "$pref$leader$letter", 0, $leading{$letter} - if @{$leading{$letter}} > 1; - } - my $npref = "_$pref"; - $npref = '' if $pref eq ''; - print $fh <<"END"; -static double -constant$npref(char *name, int len, int arg) -{ -END +my $prefix = defined $opt_p ? "PREFIX = $opt_p" : ''; - print $fh <<"END" if $npref eq ''; - errno = 0; -END +# Now switch from C to XS by issuing the first MODULE declaration: +print XS <<"END"; - print $fh <<"END" if $off; - if ($offarg + $off >= len ) { - errno = EINVAL; - return 0; - } -END +MODULE = $module PACKAGE = $module $prefix - print $fh <<"END"; - switch (name[$offarg + $off]) { END - foreach my $letter (sort keys %leading) { - my $let = $letter; - $let = '\0' if $letter eq ''; - - print $fh < 1) { - # It makes sense to call a function - if ($off) { - print $fh <[0] =~ /_ANON/) { + if (defined $item->[2]) { + push @items, map [ + @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", + ], @{ $structs{$item->[0]} }; + } else { + push @items, @{ $structs{$item->[0]} }; + } + } else { + push @list, $item->[2]; + } + } + my $methods = (join '(...)>, C<', @list) . '(...)'; + + my $pod = <<"EOF"; +# +#=head2 Object and class methods for C<$name>/C<$ptrname> +# +#The principal Perl representation of a C object of type C<$name> is an +#object of class C<$ptrname> which is a reference to an integer +#representation of a C pointer. To create such an object, one may use +#a combination +# +# my \$buffer = $name->new(); +# my \$obj = \$buffer->_to_ptr(); +# +#This exercises the following two methods, and an additional class +#C<$name>, the internal representation of which is a reference to a +#packed string with the C structure. Keep in mind that \$buffer should +#better survive longer than \$obj. +# +#=over +# +#=item C<\$object_of_type_$name-E_to_ptr()> +# +#Converts an object of type C<$name> to an object of type C<$ptrname>. +# +#=item C<$name-Enew()> +# +#Creates an empty object of type C<$name>. The corresponding packed +#string is zeroed out. +# +#=item C<$methods> +# +#return the current value of the corresponding element if called +#without additional arguments. Set the element to the supplied value +#(and return the new value) if called with an additional argument. +# +#Applicable to objects of type C<$ptrname>. +# +#=back +# +EOF + $pod =~ s/^\#//gm; + return $pod; +} + # Should be called before any actual call to normalize_type(). sub get_typemap { # We do not want to read ./typemap by obvios reasons. @@ -1366,15 +1764,15 @@ sub get_typemap { my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; # Start with useful default values - $typemap{float} = 'T_DOUBLE'; + $typemap{float} = 'T_NV'; foreach my $typemap (@tm) { next unless -e $typemap ; # skip directories, binary files etc. warn " Scanning $typemap\n"; - warn("Warning: ignoring non-text typemap file '$typemap'\n"), next + warn("Warning: ignoring non-text typemap file '$typemap'\n"), next unless -T $typemap ; - open(TYPEMAP, $typemap) + open(TYPEMAP, $typemap) or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; my $mode = 'Typemap'; while () { @@ -1403,9 +1801,9 @@ sub get_typemap { sub normalize_type { # Second arg: do not strip const's before \* my $type = shift; my $do_keep_deep_const = shift; - # If $do_keep_deep_const this is heuristical only + # If $do_keep_deep_const this is heuristic only my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); - my $ignore_mods + my $ignore_mods = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! $type =~ s/$ignore_mods//go; @@ -1413,14 +1811,14 @@ sub normalize_type { # Second arg: do not strip const's before \* else { $type =~ s/$ignore_mods//go; } - $type =~ s/([^\s\w])/ \1 /g; + $type =~ s/([^\s\w])/ $1 /g; $type =~ s/\s+$//; $type =~ s/^\s+//; $type =~ s/\s+/ /g; $type =~ s/\* (?=\*)/*/g; $type =~ s/\. \. \./.../g; $type =~ s/ ,/,/g; - $types_seen{$type}++ + $types_seen{$type}++ unless $type eq '...' or $type eq 'void' or $std_types{$type}; $type; } @@ -1440,6 +1838,8 @@ sub assign_typemap_entry { print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; $entry = assign_typemap_entry($type); } + # XXX good do better if our UV happens to be long long + return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/; $entry ||= $typemap{$otype} || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); $typemap{$otype} = $entry; @@ -1501,55 +1901,297 @@ EOP warn "Writing $ext$modpname/Makefile.PL\n"; open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; -print PL < 0, %; +} +elsif ( $compat_version < 5.006002 ) +{ + $prereq_pm .= q%'Test' => 0, %; +} + +if ( $compat_version < 5.006 and !$opt_X and $use_xsloader) +{ + $prereq_pm .= q%'XSLoader' => 0, %; +} + +print PL <<"END"; +use $compat_version; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( - 'NAME' => '$module', - 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION - 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 + NAME => '$module', + VERSION_FROM => '$modpmname', # finds \$VERSION + PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1 + (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module + AUTHOR => '$author <$email>') : ()), END if (!$opt_X) { # print C stuff, unless XS is disabled $opt_F = '' unless defined $opt_F; + my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); + my $Ihelp = ($I ? '-I. ' : ''); + my $Icomment = ($I ? '' : < ['$extralibs'], # e.g., '-lm' - 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' + LIBS => ['$extralibs'], # e.g., '-lm' + DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING' +$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other' END -} + + my $C = grep {$_ ne "$modfname.c"} + (glob '*.c'), (glob '*.cc'), (glob '*.C'); + my $Cpre = ($C ? '' : '# '); + my $Ccomment = ($C ? '' : < '\$(O_FILES)', # link all the C files too +END +} # ' # Grr print PL ");\n"; +if (!$opt_c) { + my $generate_code = + WriteMakefileSnippet ( C_FILE => $constscfname, + XS_FILE => $constsxsfname, + DEFAULT_TYPE => $opt_t, + NAME => $module, + NAMES => \@const_specs, + ); + print PL <<"END"; +if (eval {require ExtUtils::Constant; 1}) { + # If you edit these definitions to change the constants used by this module, + # you will need to use the generated $constscfname and $constsxsfname + # files to replace their "fallback" counterparts before distributing your + # changes. +$generate_code +} +else { + use File::Copy; + use File::Spec; + foreach my \$file ('$constscfname', '$constsxsfname') { + my \$fallback = File::Spec->catfile('$fallbackdirname', \$file); + copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!"; + } +} +END + + eval $generate_code; + if ($@) { + warn <<"EOM"; +Attempting to test constant code in $ext$modpname/Makefile.PL: +$generate_code +__END__ +gave unexpected error $@ +Please report the circumstances of this bug in h2xs version $H2XS_VERSION +using the perlbug script. +EOM + } else { + my $fail; + + foreach my $file ($constscfname, $constsxsfname) { + my $fallback = File::Spec->catfile($fallbackdirname, $file); + if (compare($file, $fallback)) { + warn << "EOM"; +Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ. +EOM + $fail++; + } + } + if ($fail) { + warn fill ('','', <<"EOM") . "\n"; +It appears that the code in $ext$modpname/Makefile.PL does not autogenerate +the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname +correctly. + +Please report the circumstances of this bug in h2xs version $H2XS_VERSION +using the perlbug script. +EOM + } else { + unlink $constscfname, $constsxsfname; + } + } +} close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; -warn "Writing $ext$modpname/test.pl\n"; -open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n"; -print EX <<'_END_'; +# Create a simple README since this is a CPAN requirement +# and it doesn't hurt to have one +warn "Writing $ext$modpname/README\n"; +open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; +my $thisyear = (gmtime)[5] + 1900; +my $rmhead = "$modpname version $TEMPLATE_VERSION"; +my $rmheadeq = "=" x length($rmhead); + +my $rm_prereq; + +if ( $compat_version < 5.006002 and $new_test ) +{ + $rm_prereq = 'Test::More'; +} +elsif ( $compat_version < 5.006002 ) +{ + $rm_prereq = 'Test'; +} +else +{ + $rm_prereq = 'blah blah blah'; +} + +print RM <<_RMEND_; +$rmhead +$rmheadeq + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the +README file from a module distribution so that people browsing the +archive can use it get an idea of the modules uses. It is usually a +good idea to provide version information here so that people can +decide whether fixes for the module are worth downloading. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + $rm_prereq + +COPYRIGHT AND LICENCE + +Put the correct copyright and licence information here. + +$licence + +_RMEND_ +close(RM) || die "Can't close $ext$modpname/README: $!\n"; + +my $testdir = "t"; +my $testfile = "$testdir/$modpname.t"; +unless (-d "$testdir") { + mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n"; +} +warn "Writing $ext$modpname/$testfile\n"; +my $tests = @const_names ? 2 : 1; + +open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n"; + +print EX <<_END_; # Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' +# `make test'. After `make install' it should work as `perl $modpname.t' -######################### We start with some black magic to print on failure. +######################### -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) +# change 'tests => $tests' to 'tests => last_test_to_print'; + +use strict; +use warnings; -BEGIN { $| = 1; print "1..1\n"; } -END {print "not ok 1\n" unless $loaded;} _END_ -print EX <<_END_; + +my $test_mod = 'Test::More'; + +if ( $old_test or ($compat_version < 5.006002 and not $new_test )) +{ + my $test_mod = 'Test'; + + print EX <<_END_; +use Test; +BEGIN { plan tests => $tests }; use $module; +ok(1); # If we made it this far, we're ok. + _END_ -print EX <<'_END_'; -$loaded = 1; -print "ok 1\n"; -######################### End of black magic. + if (@const_names) { + my $const_names = join " ", @const_names; + print EX <<'_END_'; -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): +my $fail; +foreach my $constname (qw( +_END_ + + print EX wrap ("\t", "\t", $const_names); + print EX (")) {\n"); + + print EX <<_END_; + next if (eval "my \\\$a = \$constname; 1"); + if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { + print "# pass: \$\@"; + } else { + print "# fail: \$\@"; + \$fail = 1; + } +} +if (\$fail) { + print "not ok 2\\n"; +} else { + print "ok 2\\n"; +} _END_ -close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; + } +} +else +{ + print EX <<_END_; +use Test::More tests => $tests; +BEGIN { use_ok('$module') }; + +_END_ + + if (@const_names) { + my $const_names = join " ", @const_names; + print EX <<'_END_'; + +my $fail = 0; +foreach my $constname (qw( +_END_ + + print EX wrap ("\t", "\t", $const_names); + print EX (")) {\n"); + + print EX <<_END_; + next if (eval "my \\\$a = \$constname; 1"); + if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { + print "# pass: \$\@"; + } else { + print "# fail: \$\@"; + \$fail = 1; + } + +} + +ok( \$fail == 0 , 'Constants' ); +_END_ + } +} + +print EX <<_END_; +######################### + +# Insert your test code below, the $test_mod module is use()ed here so read +# its man page ( perldoc $test_mod ) for help writing this test script. + +_END_ + +close(EX) || die "Can't close $ext$modpname/$testfile: $!\n"; unless ($opt_C) { warn "Writing $ext$modpname/Changes\n"; @@ -1569,7 +2211,7 @@ EOP warn "Writing $ext$modpname/MANIFEST\n"; open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; -my @files = <*>; +my @files = grep { -f } (<*>, , <$fallbackdirname/*>, <$modpmdir/*>); if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); }