X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/760ac839baf413929cd31cc32ffd6dba6b781a81..cdf8b154184019da333b6320795257b487053e0a:/utils/h2xs.PL diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 4ef790e..0a065ec 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -12,10 +13,10 @@ use File::Basename qw(&basename &dirname); # 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. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -25,111 +26,207 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; + +use warnings; + =head1 NAME h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B [B<-AOPXcf>] [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 -I builds a Perl extension from any C header file. The extension will -include functions which can be used to retrieve the value of any #define -statement which was in the C header. +I builds a Perl extension from C header files. The extension +will include functions which can be used to retrieve the value of any +#define statement which was in the C header files. The I will be used for the name of the extension. If -module_name is not supplied then the name of the header file will be used, -with the first character capitalized. +module_name is not supplied then the name of the first header file +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. =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. + +=item B<-C>, B<--omit-changes> -Omit all autoload facilities. This is the same as B<-c> but also removes the -S> statement from the .pm file. +Omits creation of the F file, and adds a HISTORY section to +the POD template. + +=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>. -=item B<-O> +=item B<-M>, B<--func-mask>=I + +selects functions/macros to process. + +=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. -=item B<-c> +=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. + +=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 +value of the element if called without additional arguments; and will set +the element to the supplied value (and return the new value) if called with +an additional argument. Embedded structures and unions are returned as a +pointer rather than the complete structure, to facilitate chained calls. + +These methods all apply to the Ptr type for the structure; additionally +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<-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. + +=item B<-c>, B<--omit-constant> Omit C from the .xs file and corresponding specialised C from the .pm file. -=item B<-f> +=item B<-d>, B<--debugging> + +Turn on debugging messages. + +=item B<-f>, B<--force> Allows an extension to be created for a header even if that header is -not found in /usr/include. +not found in standard include directories. -=item B<-h> +=item B<-h>, B<-?>, B<--help> Print the usage, help and version for this h2xs and exit. -=item B<-n> I +=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>, 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>, B<--name>=I Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> -=item B<-p> I +=item B<-o>, B<--opaque-re>=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 mechansim. +Use "opaque" data type for the C types matched by the regular +expression, even if these types are C-equivalent to types +from typemaps. Should not be used without B<-x>. -=item B<-s> I +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. -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>. +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<-v> I +=item B<-p>, B<--remove-prefix>=I -Specify a version number for this extension. This version number is added -to the templates. The default is 0.01. +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<-X> +=item B<-s>, B<--const-subs>=I -Omit the XS portion. Used to generate templates for a module which is not -XS-based. +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> + +When B<--compat-version> (B<-b>) is present the generated tests will use +C rather then C which is the default for versions before +5.7.2 . C will be added to PREREQ_PM in the generated +C. + +=item B<--use-old-tests> -=item B<-x> +Will force the generation of test code that uses the older C module. + +=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. + +=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 emited 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. -=item B<-F> - -Additional flags to specify to C preprocessor when scanning header for -function declarations. Should not be used without B<-x>. +Note that some types of arguments/return-values for functions may +result in XSUB-declarations/typemap-entries which need +hand-editing. Such may be objects which cannot be converted from/to a +pointer (like C), pointers to functions, or arrays. See +also the section on L>. =back @@ -171,16 +268,84 @@ function declarations. Should not be used without B<-x>. h2xs -n DCE::rgynbase -p sec_rgy_ \ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase - # Make XS with defines in perl.h, and function declarations + # 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. - h2xs -xn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" \ - ../perl5_003_01/perl.h + # 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. - perl H:\get\perl\perl5_003_01.try\utils\h2xs -xn perl1 \ - ../perl5_003_01/perl.h,proto.h + h2xs -xAn perl2 perl.h,proto.h + + # Same but select only functions which match /^av_/ + h2xs -M '^av_' -xAn perl2 perl.h,proto.h + + # Same but treat SV* etc as "opaque" types + h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h + +=head2 Extension based on F<.h> and F<.c> files + +Suppose that you have some C files implementing some functionality, +and the corresponding header files. How to create an extension which +makes this functionality accessable 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">. + +=over + +=item Find the directory name + +Start with a dummy run of h2xs: + + h2xs -Afn Ext::Ension + +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. + +=item Copy C files + +Copy your header files and C files to this directory F. + +=item Create the extension + +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 @@ -198,114 +363,388 @@ L, L, L, and L. The usual warnings if it cannot read or write the files involved. +=head1 LIMITATIONS of B<-x> + +F would not distinguish whether an argument to a C function +which is of the form, say, C, is an input, output, or +input/output parameter. In particular, argument declarations of the +form + + int + foo(n) + int *n + +should be better rewritten as + + int + foo(n) + int &n + +if C is an input parameter. + +Additionally, F has no facilities to intuit that a function + + int + foo(addr,l) + char *addr + int l + +takes a pair of address and length of data at this address, so it is better +to rewrite this function as + + int + foo(sv) + SV *addr + PREINIT: + STRLEN len; + char *s; + CODE: + s = SvPV(sv,len); + RETVAL = foo(s, len); + OUTPUT: + RETVAL + +or alternately + + static int + my_foo(SV *sv) + { + STRLEN len; + char *s = SvPV(sv,len); + + return foo(s, len); + } + + MODULE = foo PACKAGE = foo PREFIX = my_ + + int + foo(sv) + SV *sv + +See L and L for additional details. + =cut -my( $H2XS_VERSION ) = ' $Revision: 1.16 $ ' =~ /\$Revision:\s+([^\s]+)/; -my $TEMPLATE_VERSION = '0.01'; +use strict; -use Getopt::Std; -sub usage{ - warn "@_\n" if @_; - die "h2xs [-AOPXcfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] +my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/; +my $TEMPLATE_VERSION = '0.01'; +my @ARGS = @ARGV; +my $compat_version = $]; + +use Getopt::Long; +use Config; +use Text::Wrap; +$Text::Wrap::huge = 'overflow'; +$Text::Wrap::columns = 80; +use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload); + +sub usage { + warn "@_\n" if @_; + die < \$opt_A, + '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, + 'force|f' => \$opt_f, + '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=s' => \$opt_x, + 'use-new-tests' => \$new_test, + 'use-old-tests' => \$old_test + ); + +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 =~ /^\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) = split(/\./,$opt_b,3); + $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub); +} + if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } + +# -A implies -c. $opt_c = 1 if $opt_A; -%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; -$path_h = shift; -$extralibs = "@ARGV"; +# -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 = ''; + +my @path_h; + +while (my $arg = shift) { + if ($arg =~ /^-l/i) { + $extralibs = "$arg @ARGV"; + last; + } + push(@path_h, $arg); +} usage "Must supply header file or module name\n" - unless ($path_h or $opt_n); + unless (@path_h or $opt_n); + +my $fmask; +my $tmask; +$fmask = qr{$opt_M} if defined $opt_M; +$tmask = qr{$opt_o} if defined $opt_o; +my $tmask_all = $tmask && $opt_o eq '.'; + +if ($opt_x) { + eval {require C::Scan; 1} + or die <= 0.70 + or die <curdir(), $Config{usrinc}, + (split ' ', $Config{locincpth}), '/usr/include'); + } + foreach my $path_h (@path_h) { + $name ||= $path_h; + $module ||= do { + $name =~ s/\.h$//; + if ( $name !~ /::/ ) { + $name =~ s#^.*/##; + $name = "\u$name"; + } + $name; + }; -if( $path_h ){ - $name = $path_h; if( $path_h =~ s#::#/#g && $opt_n ){ warn "Nesting of headerfile ignored with -n\n"; } $path_h .= ".h" unless $path_h =~ /\.h$/; - $fullpath = $path_h; + my $fullpath = $path_h; $path_h =~ s/,.*$// if $opt_x; - if ($^O eq 'VMS') { # Consider overrides of default location - if ($path_h !~ m![:>\[]!) { - my($hadsys) = ($path_h =~ s!^sys/!!i); - if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; } - elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; } - elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' . - ($hadsys ? '[vms]' : '[000000]') . $path_h; } - elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; } - else { $path_h = "Sys\$Library:$path_h"; } - } + $fullpath{$path_h} = $fullpath; + + # Minor trickery: we can't chdir() before we processed the headers + # (so know the name of the extension), but the header may be in the + # extension directory... + my $tmp_path_h = $path_h; + my $rel_path_h = $path_h; + my @dirs = @paths; + if (not -f $path_h) { + my $found; + for my $dir (@paths) { + $found++, last + if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + } + if ($found) { + $rel_path_h = $path_h; + } 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; + } } - elsif ($^O eq 'os2') { - $path_h = "/usr/include/$path_h" unless $path_h =~ m#^([a-z]:)?[./]#i; - } - else { $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#; } - die "Can't find $path_h\n" if ( ! $opt_f && ! -f $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 not (currently) processed. - open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; - while () { - if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) { - print "Matched $_ ($1)\n"; - $_ = $1; + + if (!$opt_c) { + 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, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; + defines: + while () { + 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*(?=[^" \t])(.*)/) { + my $def = $1; + my $rest = $2; + $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments + $rest =~ s/^\s+//; + $rest =~ s/\s+$//; + # Cannot do: (-1) and ((LHANDLE)3) are OK: + #print("Skip non-wordy $def => $rest\n"), + # next defines if $rest =~ /[^\w\$]/; + if ($rest =~ /"/) { + print("Skip stringy $def => $rest\n") if $opt_d; + next defines; + } + print "Matched $_ ($def)\n" if $opt_d; + $seen_define{$def} = $rest; + $_ = $def; next if /^_.*_h_*$/i; # special case, but for what? if (defined $opt_p) { - if (!/^$opt_p(\d)/) { - ++$prefix{$_} if s/^$opt_p//; - } - else { - warn "can't remove $opt_p prefix from '$_'!\n"; - } + if (!/^$opt_p(\d)/) { + ++$prefix{$_} if s/^$opt_p//; + } + else { + warn "can't remove $opt_p prefix from '$_'!\n"; + } } - $const_names{$_}++; - } + $prefixless{$def} = $_; + if (!$fmask or /$fmask/) { + print "... Passes mask of -M.\n" if $opt_d and $fmask; + $const_names{$_}++; + } + } + } + close(CH); + } } - close(CH); - @const_names = sort keys %const_names; } -$module = $opt_n || do { - $name =~ s/\.h$//; - if( $name !~ /::/ ){ - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; -}; -(chdir 'ext', $ext = 'ext/') if -d 'ext'; +my ($ext, $nested, @modparts, $modfname, $modpname); + +$ext = chdir 'ext' ? 'ext/' : ''; if( $module =~ /::/ ){ $nested = 1; @@ -322,45 +761,171 @@ else { if ($opt_O) { warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; -} else { +} +else { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } if( $nested ){ - $modpath = ""; + my $modpath = ""; foreach (@modparts){ - mkdir("$modpath$_", 0777); + -d "$modpath$_" || mkdir("$modpath$_", 0777); $modpath .= "$_/"; } } -mkdir($modpname, 0777); +-d "$modpname" || mkdir($modpname, 0777); chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; +my %types_seen; +my %std_types; +my $fdecls = []; +my $fdecls_parsed = []; +my $typedef_rex; +my %typedefs_pre; +my %known_fnames; +my %structs; + +my @fnames; +my @fnames_no_prefix; +my %vdecl_hash; +my @vdecls; + if( ! $opt_X ){ # use XS, unless it was disabled 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; + my @good_td; + my $addflags = $opt_F || ''; + + foreach my $filename (@path_h) { + my $c; + my $filter; + + if ($fullpath{$filename} =~ /,/) { + $filename = $`; + $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' => \@styles; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; + push(@$fdecls, @{$c->get('fdecls')}); + + push @td, @{$c->get('typedefs_maybe')}; + if ($opt_a) { + my $structs = $c->get('typedef_structs'); + @structs{keys %$structs} = values %$structs; + } + + if ($opt_m) { + %vdecl_hash = %{ $c->get('vdecl_hash') }; + @vdecls = sort keys %vdecl_hash; + for (local $_ = 0; $_ < @vdecls; ++$_) { + my $var = $vdecls[$_]; + my($type, $post) = @{ $vdecl_hash{$var} }; + if (defined $post) { + warn "Can't handle variable '$type $var $post', skipping.\n"; + splice @vdecls, $_, 1; + redo; + } + $type = normalize_type($type); + $vdecl_hash{$var} = $type; + } + } + + unless ($tmask_all) { + warn "Scanning $filename for typedefs...\n"; + my $td = $c->get('typedef_hash'); + # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; + my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; + push @good_td, @f_good_td; + @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; + } + } + { local $" = '|'; + $typedef_rex = qr(\b(?[$i][1] =~ /$fmask/; # [1] is NAME + push @good, $i; + print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" + if $opt_d; + } + $fdecls = [@$fdecls[@good]]; + $fdecls_parsed = [@$fdecls_parsed[@good]]; + } + @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME + # Sort declarations: + { + my %h = map( ($_->[1], $_), @$fdecls_parsed); + $fdecls_parsed = [ @h{@fnames} ]; + } + @fnames_no_prefix = @fnames; + @fnames_no_prefix + = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; + # Remove macros which expand to typedefs + print "Typedefs are @td.\n" if $opt_d; + my %td = map {($_, $_)} @td; + # Add some other possible but meaningless values for macros + for my $k (qw(char double float int long short unsigned signed void)) { + $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); + } + # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; + my $n = 0; + my %bad_macs; + while (keys %td > $n) { + $n = keys %td; + my ($k, $v); + while (($k, $v) = each %seen_define) { + # print("found '$k'=>'$v'\n"), + $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; + } + } + # Now %bad_macs contains names of bad macros + for my $k (keys %bad_macs) { + delete $const_names{$prefixless{$k}}; + print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; + } + } } +my @const_names = sort keys %const_names; + open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; $" = "\n\t"; warn "Writing $ext$modpname/$modfname.pm\n"; +if ( $compat_version < 5.006 ) { print PM <<"END"; package $module; +use $compat_version; use strict; END +} +else { +print PM <<"END"; +package $module; -if( $opt_X || $opt_c || $opt_A ){ - # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD - print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT); +use 5.006; +use strict; +use warnings; END } -else{ + +unless( $opt_X || $opt_c || $opt_A ){ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); END } @@ -373,81 +938,65 @@ print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled require DynaLoader; END -# require autoloader if XS is disabled. -# if XS is enabled, require autoloader unless autoloading is disabled. -if( $opt_X || (! $opt_A) ){ - print PM <<"END"; -require AutoLoader; -END -} - -if( $opt_X || ($opt_c && ! $opt_A) ){ - # we won't have our own AUTOLOAD(), so we'll inherit it. - if( ! $opt_X ) { # use DynaLoader, unless XS was disabled - print PM <<"END"; -\@ISA = qw(Exporter AutoLoader DynaLoader); -END +# Are we using AutoLoader or not? +unless ($opt_A) { # no autoloader whatsoever. + unless ($opt_c) { # we're doing the AUTOLOAD + print PM "use AutoLoader;\n"; } - else{ - print PM <<"END"; - -\@ISA = qw(Exporter AutoLoader); -END + else { + print PM "use AutoLoader qw(AUTOLOAD);\n" } } -else{ - # 1) we have our own AUTOLOAD(), so don't need to inherit it. - # or - # 2) we don't want autoloading mentioned. - if( ! $opt_X ){ # use DynaLoader, unless XS was disabled - print PM <<"END"; - -\@ISA = qw(Exporter DynaLoader); -END - } - else{ - print PM <<"END"; -\@ISA = qw(Exporter); -END - } +if ( $compat_version < 5.006 ) { + if ( $opt_X || $opt_c || $opt_A ) { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);'; + } else { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);'; + } } -print PM<<"END"; +# Determine @ISA. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. +$myISA .= ' DynaLoader' unless $opt_X; # no XS +$myISA .= ');'; +$myISA =~ s/^our // if $compat_version < 5.006; + +print PM "\n$myISA\n\n"; + +my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); + +my $tmp=<<"END"; # 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. -\@EXPORT = qw( + +# This allows declaration use $module ':all'; +# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( + @exported_names +) ] ); + +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); + +our \@EXPORT = qw( @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END -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; - (\$constname = \$AUTOLOAD) =~ s/.*:://; - my \$val = constant(\$constname, \@_ ? \$_[0] : 0); - if (\$! != 0) { - if (\$! =~ /Invalid/) { - \$AutoLoader::AUTOLOAD = \$AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined $module macro \$constname"; - } - } - eval "sub \$AUTOLOAD { \$val }"; - goto &\$AUTOLOAD; +$tmp =~ s/^our //mg if $compat_version < 5.006; +print PM $tmp; + +if (@vdecls) { + printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; } -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"; @@ -455,6 +1004,17 @@ bootstrap $module \$VERSION; END } +# tying the variables can happen only after bootstrap +if (@vdecls) { + printf PM <))[0,6]; + $author =~ s/,.*$//; # in case of sub fields + my $domain = $Config{'mydomain'}; + $domain =~ s/^\.//; + $email = "$user\@$domain"; + }; + +$author ||= "A. U. Thor"; +$email ||= 'a.u.thor@a.galaxy.far.far.away'; -$pod = <<"END" unless $opt_P; -## Below is the stub of documentation for your module. You better edit it! +my $revhist = ''; +$revhist = < should be removed. +# +#EOD + $exp_doc .= <${email}E # -#=head1 SEE ALSO +#=head1 COPYRIGHT AND LICENSE +# +#Copyright ${\(1900 + (localtime) [5])} by $author # -#perl(1). +#This library is free software; you can redistribute it and/or modify +#it under the same terms as Perl itself. # #=cut END @@ -516,91 +1173,74 @@ if( ! $opt_X ){ # print XS, unless it is disabled warn "Writing $ext$modpname/$modfname.xs\n"; print XS <<"END"; -#ifdef __cplusplus -extern "C" { -#endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#ifdef __cplusplus -} -#endif END -if( $path_h ){ +if( @path_h ){ + foreach my $path_h (@path_h_ini) { my($h) = $path_h; $h =~ s#^/usr/include/##; if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } -print XS <<"END"; -#include <$h> - -END -} - -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(s) -char *s; -{ - croak("$module::%s not implemented on this architecture", s); - return -1; + print XS qq{#include <$h>\n}; + } + print XS "\n"; } -static double -constant(name, arg) -char *name; -int arg; -{ - errno = 0; - switch (*name) { -END +my %pointer_typedefs; +my %struct_typedefs; -my(@AZ, @az, @under); - -foreach(@const_names){ - @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; - @az = 'a' .. 'z' if !@az && /^[a-z]/; - @under = '_' if !@under && /^_/; +sub td_is_pointer { + my $type = shift; + my $out = $pointer_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /\*$/); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_pointer($type); + } + return ($pointer_typedefs{$otype} = $out); } -foreach $letter (@AZ, @az, @under) { +sub td_is_struct { + my $type = shift; + my $out = $struct_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_struct($type); + } + return ($struct_typedefs{$otype} = $out); +} - last if $letter eq 'a' && !@const_names; +my $types = {}; +# Important. Passing an undef scalar doesn't cause the +# autovivified hashref to appear back out in this scope. - print XS " case '$letter':\n"; - my($name); - while (substr($const_names[0],0,1) eq $letter) { - $name = shift(@const_names); - $macro = $prefix{$name} ? "$opt_p$name" : $name; - next if $const_xsub{$macro}; - print XS <<"END"; - if (strEQ(name, "$name")) -#ifdef $macro - return $macro; -#else - goto not_there; -#endif -END - } - print XS <<"END"; - break; -END +if( ! $opt_c ) { + print XS constant_types(), "\n"; + foreach (C_constant ($module, undef, $opt_t, $types, undef, undef, + @const_names)) { + print XS $_, "\n"; + } } -print XS <<"END"; - } - errno = EINVAL; - return 0; -not_there: - errno = ENOENT; - return 0; -} +print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; -END -} +my $prefix = defined $opt_p ? "PREFIX = $opt_p" : ''; -$prefix = "PREFIX = $opt_p" if defined $opt_p; # Now switch from C to XS by issuing the first MODULE declaration: print XS <<"END"; @@ -615,160 +1255,659 @@ $_() CODE: #ifdef $_ - RETVAL = $_; + RETVAL = $_; #else - croak("Your vendor has not defined the $module macro $_"); + croak("Your vendor has not defined the $module macro $_"); #endif OUTPUT: - RETVAL + RETVAL END } # If a constant() function was written then output a corresponding # XS declaration: -print XS <<"END" unless $opt_c; - -double -constant(name,arg) - char * name - int arg +# XXX IVs +print XS XS_constant ($module, $types) unless $opt_c; -END +my %seen_decl; +my %typemap; sub print_decl { my $fh = shift; my $decl = shift; my ($type, $name, $args) = @$decl; + return if $seen_decl{$name}++; # Need to do the same for docs as well? + my @argnames = map {$_->[1]} @$args; - my @argtypes = map { normalize_type( $_->[0] ) } @$args; + my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; + if ($opt_k) { + s/^\s*const\b\s*// for @argtypes; + } + my @argarrays = map { $_->[4] || '' } @$args; my $numargs = @$args; if ($numargs and $argtypes[-1] eq '...') { $numargs--; $argnames[-1] = '...'; } local $" = ', '; - $type = normalize_type($type); - + $type = normalize_type($type, 1); + print $fh <<"EOP"; $type $name(@argnames) EOP - for $arg (0 .. $numargs - 1) { + for my $arg (0 .. $numargs - 1) { print $fh <<"EOP"; - $argtypes[$arg] $argnames[$arg] + $argtypes[$arg] $argnames[$arg]$argarrays[$arg] EOP } } -my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; +sub print_tievar_subs { + my($fh, $name, $type) = @_; + 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 { + my $type = normalize_type($item->[0]); + my $ttype = $structs{$type} ? normalize_type("$type *") : $type; + print $fh <<"EOF"; +$ttype +$item->[2](THIS, __value = NO_INIT) + $ptrname THIS + $type __value + PROTOTYPE: \$;\$ + CODE: + if (items > 1) + THIS->$item->[-1] = __value; + RETVAL = @{[ + $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" + ]}; + OUTPUT: + RETVAL + +EOF + } + } +} + +sub accessor_docs { + my($name, $struct) = @_; + return unless defined $struct && $name !~ /\s|_ANON/; + $name = normalize_type($name); + my $ptrname = $name . 'Ptr'; + my @items = @$struct; + my @list; + while (@items) { + my $item = shift @items; + if ($item->[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 exersizes 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. + my @tm = qw(../../../typemap ../../typemap ../typemap); + my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; + unshift @tm, $stdtypemap; + my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; + + # Start with useful default values + $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 + unless -T $typemap ; + open(TYPEMAP, $typemap) + or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; + my $mode = 'Typemap'; + while () { + next if /^\s*\#/; + if (/^INPUT\s*$/) { $mode = 'Input'; next; } + elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } + elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } + elsif ($mode eq 'Typemap') { + next if /^\s*($|\#)/ ; + my ($type, $image); + if ( ($type, $image) = + /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o + # This may reference undefined functions: + and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { + $typemap{normalize_type($type)} = $image; + } + } + } + close(TYPEMAP) or die "Cannot close $typemap: $!"; + } + %std_types = %types_seen; + %types_seen = (); +} + -sub normalize_type { +sub normalize_type { # Second arg: do not strip const's before \* my $type = shift; - $type =~ s/$ignore_mods//go; - $type =~ s/\s+/ /g; + my $do_keep_deep_const = shift; + # If $do_keep_deep_const this is heuristical only + my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); + 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; + } + else { + $type =~ s/$ignore_mods//go; + } + $type =~ s/([^\s\w])/ $1 /g; $type =~ s/\s+$//; $type =~ s/^\s+//; - $type =~ s/\b\*/ */g; - $type =~ s/\*\b/* /g; - $type =~ s/\*\s+(?=\*)/*/g; + $type =~ s/\s+/ /g; + $type =~ s/\* (?=\*)/*/g; + $type =~ s/\. \. \./.../g; + $type =~ s/ ,/,/g; + $types_seen{$type}++ + unless $type eq '...' or $type eq 'void' or $std_types{$type}; $type; } +my $need_opaque; + +sub assign_typemap_entry { + my $type = shift; + my $otype = $type; + my $entry; + if ($tmask and $type =~ /$tmask/) { + print "Type $type matches -o mask\n" if $opt_d; + $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + } + elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type $type; + 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; + $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; + return $entry; +} + +for (@vdecls) { + print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); +} + if ($opt_x) { - require C::Scan; # Run-time directive - require Config; # Run-time directive - my $c; - my $filter; - my $filename = $path_h; - my $addflags = $opt_F || ''; - if ($fullpath =~ /,/) { - $filename = $`; - $filter = $'; + for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + if ($opt_a) { + while (my($name, $struct) = each %structs) { + print_accessors(\*XS, $name, $struct); + } } - $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, - 'add_cppflags' => $addflags; - $c->set('includeDirs' => [$Config::Config{shrpdir}]); - - my $fdec = $c->get('parsed_fdecls'); - - for $decl (@$fdec) { print_decl(\*XS, $decl) } } close XS; + +if (%types_seen) { + my $type; + warn "Writing $ext$modpname/typemap\n"; + open TM, ">typemap" or die "Cannot open typemap file for write: $!"; + + for $type (sort keys %types_seen) { + my $entry = assign_typemap_entry $type; + print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" + } + + print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry +############################################################################# +INPUT +T_OPAQUE_STRUCT + if (sv_derived_from($arg, \"${ntype}\")) { + STRLEN len; + char *s = SvPV((SV*)SvRV($arg), len); + + if (len != sizeof($var)) + croak(\"Size %d of packed data != expected %d\", + len, sizeof($var)); + $var = *($type *)s; + } + else + croak(\"$var is not of type ${ntype}\") +############################################################################# +OUTPUT +T_OPAQUE_STRUCT + sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); +EOP + + close TM or die "Cannot close typemap file for write: $!"; +} + } # if( ! $opt_X ) warn "Writing $ext$modpname/Makefile.PL\n"; open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; -print PL <<'END'; +my $prereq_pm; + +if ( $compat_version < 5.00702 and $new_test ) +{ + $prereq_pm = q%'Test::More' => 0%; +} +else +{ + $prereq_pm = ''; +} + +print PL < '$module', + 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION + 'PREREQ_PM' => {$prereq_pm}, # e.g., Module::Name => 1.1 + (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => '$modfname.pm', # 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' +$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 -print PL "WriteMakefile(\n"; -print PL " 'NAME' => '$module',\n"; -print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; -if( ! $opt_X ){ # print C stuff, unless XS is disabled - print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; - print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; - print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; } print PL ");\n"; 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 doesnt 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.00702 and $new_test ) +{ + $rm_prereq = 'Test::More'; +} +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. + +Copyright (C) $thisyear $author + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +_RMEND_ +close(RM) || die "Can't close $ext$modpname/README: $!\n"; + +my $testdir = "t"; +my $testfile = "$testdir/1.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 1.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'; -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.007 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_ + + if (@const_names) { + my $const_names = join " ", @const_names; + print EX <<'_END_'; + +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_ -print EX <<'_END_'; -$loaded = 1; -print "ok 1\n"; + } +} +else +{ + print EX <<_END_; +use Test::More tests => $tests; +BEGIN { use_ok('$module') }; -######################### End of black magic. +_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): + if (@const_names) { + my $const_names = join " ", @const_names; + print EX <<'_END_'; +my $fail = 0; +foreach my $constname (qw( _END_ -close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; -warn "Writing $ext$modpname/Changes\n"; -open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; -print EX "Revision history for Perl extension $module.\n\n"; -print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; -print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; -close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; + 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"; + $" = ' '; + open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; + @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; + print EX <MANIFEST') or die "Can't create MANIFEST: $!"; -@files = <*>; +my @files = grep { -f } (<*>, ); if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); } } if (!@files) { @files = map {chomp && $_} `ls`; } -print MANI join("\n",@files); +if ($^O eq 'VMS') { + foreach (@files) { + # Clip trailing '.' for portability -- non-VMS OSs don't expect it + s%\.$%%; + # Fix up for case-sensitive file systems + s/$modfname/$modfname/i && next; + $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; + $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; + } +} +print MANI join("\n",@files), "\n"; close MANI; !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir;