1N/A#!/usr/local/bin/perl
1N/A
1N/Ause Config;
1N/Ause File::Basename qw(&basename &dirname);
1N/Ause Cwd;
1N/A
1N/A# List explicitly here the variables you want Configure to
1N/A# generate. Metaconfig only looks for shell variables, so you
1N/A# have to mention them as if they were shell variables, not
1N/A# %Config entries. Thus you write
1N/A# $startperl
1N/A# to ensure Configure will look for $Config{startperl}.
1N/A
1N/A# This forces PL files to create target in same directory as PL file.
1N/A# This is so that make depend always knows where to find PL derivatives.
1N/Amy $origdir = cwd;
1N/Achdir dirname($0);
1N/Amy $file = basename($0, '.PL');
1N/A$file .= '.com' if $^O eq 'VMS';
1N/A
1N/Aopen OUT,">$file" or die "Can't create $file: $!";
1N/A
1N/Aprint "Extracting $file (with variable substitutions)\n";
1N/A
1N/A# In this section, perl variables will be expanded during extraction.
1N/A# You can use $Config{...} to use Configure variables.
1N/A
1N/Aprint OUT <<"!GROK!THIS!";
1N/A$Config{startperl}
1N/A eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
1N/A if \$running_under_some_shell;
1N/A!GROK!THIS!
1N/A
1N/A# In the following, perl variables are not expanded during extraction.
1N/A
1N/Aprint OUT <<'!NO!SUBS!';
1N/A
1N/Ause warnings;
1N/A
1N/A=head1 NAME
1N/A
1N/Ah2xs - convert .h C header files to Perl extensions
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/AB<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
1N/A
1N/AB<h2xs> B<-h>|B<-?>|B<--help>
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/AI<h2xs> builds a Perl extension from C header files. The extension
1N/Awill include functions which can be used to retrieve the value of any
1N/A#define statement which was in the C header files.
1N/A
1N/AThe I<module_name> will be used for the name of the extension. If
1N/Amodule_name is not supplied then the name of the first header file
1N/Awill be used, with the first character capitalized.
1N/A
1N/AIf the extension might need extra libraries, they should be included
1N/Ahere. The extension Makefile.PL will take care of checking whether
1N/Athe libraries actually exist and how they should be loaded. The extra
1N/Alibraries should be specified in the form -lm -lposix, etc, just as on
1N/Athe cc command line. By default, the Makefile.PL will search through
1N/Athe library path determined by Configure. That path can be augmented
1N/Aby including arguments of the form B<-L/another/library/path> in the
1N/Aextra-libraries argument.
1N/A
1N/A=head1 OPTIONS
1N/A
1N/A=over 5
1N/A
1N/A=item B<-A>, B<--omit-autoload>
1N/A
1N/AOmit all autoload facilities. This is the same as B<-c> but also
1N/Aremoves the S<C<use AutoLoader>> statement from the .pm file.
1N/A
1N/A=item B<-B>, B<--beta-version>
1N/A
1N/AUse an alpha/beta style version number. Causes version number to
1N/Abe "0.00_01" unless B<-v> is specified.
1N/A
1N/A=item B<-C>, B<--omit-changes>
1N/A
1N/AOmits creation of the F<Changes> file, and adds a HISTORY section to
1N/Athe POD template.
1N/A
1N/A=item B<-F>, B<--cpp-flags>=I<addflags>
1N/A
1N/AAdditional flags to specify to C preprocessor when scanning header for
1N/Afunction declarations. Writes these options in the generated F<Makefile.PL>
1N/Atoo.
1N/A
1N/A=item B<-M>, B<--func-mask>=I<regular expression>
1N/A
1N/Aselects functions/macros to process.
1N/A
1N/A=item B<-O>, B<--overwrite-ok>
1N/A
1N/AAllows a pre-existing extension directory to be overwritten.
1N/A
1N/A=item B<-P>, B<--omit-pod>
1N/A
1N/AOmit the autogenerated stub POD section.
1N/A
1N/A=item B<-X>, B<--omit-XS>
1N/A
1N/AOmit the XS portion. Used to generate templates for a module which is not
1N/AXS-based. C<-c> and C<-f> are implicitly enabled.
1N/A
1N/A=item B<-a>, B<--gen-accessors>
1N/A
1N/AGenerate an accessor method for each element of structs and unions. The
1N/Agenerated methods are named after the element name; will return the current
1N/Avalue of the element if called without additional arguments; and will set
1N/Athe element to the supplied value (and return the new value) if called with
1N/Aan additional argument. Embedded structures and unions are returned as a
1N/Apointer rather than the complete structure, to facilitate chained calls.
1N/A
1N/AThese methods all apply to the Ptr type for the structure; additionally
1N/Atwo methods are constructed for the structure type itself, C<_to_ptr>
1N/Awhich returns a Ptr type pointing to the same structure, and a C<new>
1N/Amethod to construct and return a new structure, initialised to zeroes.
1N/A
1N/A=item B<-b>, B<--compat-version>=I<version>
1N/A
1N/AGenerates a .pm file which is backwards compatible with the specified
1N/Aperl version.
1N/A
1N/AFor versions < 5.6.0, the changes are.
1N/A - no use of 'our' (uses 'use vars' instead)
1N/A - no 'use warnings'
1N/A
1N/ASpecifying a compatibility version higher than the version of perl you
1N/Aare using to run h2xs will have no effect. If unspecified h2xs will default
1N/Ato compatibility with the version of perl you are using to run h2xs.
1N/A
1N/A=item B<-c>, B<--omit-constant>
1N/A
1N/AOmit C<constant()> from the .xs file and corresponding specialised
1N/AC<AUTOLOAD> from the .pm file.
1N/A
1N/A=item B<-d>, B<--debugging>
1N/A
1N/ATurn on debugging messages.
1N/A
1N/A=item B<-e>, B<--omit-enums>=[I<regular expression>]
1N/A
1N/AIf I<regular expression> is not given, skip all constants that are defined in
1N/Aa C enumeration. Otherwise skip only those constants that are defined in an
1N/Aenum whose name matches I<regular expression>.
1N/A
1N/ASince I<regular expression> is optional, make sure that this switch is followed
1N/Aby at least one other switch if you omit I<regular expression> and have some
1N/Apending arguments such as header-file names. This is ok:
1N/A
1N/A h2xs -e -n Module::Foo foo.h
1N/A
1N/AThis is not ok:
1N/A
1N/A h2xs -n Module::Foo -e foo.h
1N/A
1N/AIn the latter, foo.h is taken as I<regular expression>.
1N/A
1N/A=item B<-f>, B<--force>
1N/A
1N/AAllows an extension to be created for a header even if that header is
1N/Anot found in standard include directories.
1N/A
1N/A=item B<-g>, B<--global>
1N/A
1N/AInclude code for safely storing static data in the .xs file.
1N/AExtensions that do no make use of static data can ignore this option.
1N/A
1N/A=item B<-h>, B<-?>, B<--help>
1N/A
1N/APrint the usage, help and version for this h2xs and exit.
1N/A
1N/A=item B<-k>, B<--omit-const-func>
1N/A
1N/AFor function arguments declared as C<const>, omit the const attribute in the
1N/Agenerated XS code.
1N/A
1N/A=item B<-m>, B<--gen-tied-var>
1N/A
1N/AB<Experimental>: for each variable declared in the header file(s), declare
1N/Aa perl variable of the same name magically tied to the C variable.
1N/A
1N/A=item B<-n>, B<--name>=I<module_name>
1N/A
1N/ASpecifies a name to be used for the extension, e.g., S<-n RPC::DCE>
1N/A
1N/A=item B<-o>, B<--opaque-re>=I<regular expression>
1N/A
1N/AUse "opaque" data type for the C types matched by the regular
1N/Aexpression, even if these types are C<typedef>-equivalent to types
1N/Afrom typemaps. Should not be used without B<-x>.
1N/A
1N/AThis may be useful since, say, types which are C<typedef>-equivalent
1N/Ato integers may represent OS-related handles, and one may want to work
1N/Awith these handles in OO-way, as in C<$handle-E<gt>do_something()>.
1N/AUse C<-o .> if you want to handle all the C<typedef>ed types as opaque
1N/Atypes.
1N/A
1N/AThe type-to-match is whitewashed (except for commas, which have no
1N/Awhitespace before them, and multiple C<*> which have no whitespace
1N/Abetween them).
1N/A
1N/A=item B<-p>, B<--remove-prefix>=I<prefix>
1N/A
1N/ASpecify a prefix which should be removed from the Perl function names,
1N/Ae.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
1N/Athe prefix from functions that are autoloaded via the C<constant()>
1N/Amechanism.
1N/A
1N/A=item B<-s>, B<--const-subs>=I<sub1,sub2>
1N/A
1N/ACreate a perl subroutine for the specified macros rather than autoload
1N/Awith the constant() subroutine. These macros are assumed to have a
1N/Areturn type of B<char *>, e.g.,
1N/AS<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
1N/A
1N/A=item B<-t>, B<--default-type>=I<type>
1N/A
1N/ASpecify the internal type that the constant() mechanism uses for macros.
1N/AThe default is IV (signed integer). Currently all macros found during the
1N/Aheader scanning process will be assumed to have this type. Future versions
1N/Aof C<h2xs> may gain the ability to make educated guesses.
1N/A
1N/A=item B<--use-new-tests>
1N/A
1N/AWhen B<--compat-version> (B<-b>) is present the generated tests will use
1N/AC<Test::More> rather than C<Test> which is the default for versions before
1N/A5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
1N/AC<Makefile.PL>.
1N/A
1N/A=item B<--use-old-tests>
1N/A
1N/AWill force the generation of test code that uses the older C<Test> module.
1N/A
1N/A=item B<--skip-exporter>
1N/A
1N/ADo not use C<Exporter> and/or export any symbol.
1N/A
1N/A=item B<--skip-ppport>
1N/A
1N/ADo not use C<Devel::PPPort>: no portability to older version.
1N/A
1N/A=item B<--skip-autoloader>
1N/A
1N/ADo not use the module C<AutoLoader>; but keep the constant() function
1N/Aand C<sub AUTOLOAD> for constants.
1N/A
1N/A=item B<--skip-strict>
1N/A
1N/ADo not use the pragma C<strict>.
1N/A
1N/A=item B<--skip-warnings>
1N/A
1N/ADo not use the pragma C<warnings>.
1N/A
1N/A=item B<-v>, B<--version>=I<version>
1N/A
1N/ASpecify a version number for this extension. This version number is added
1N/Ato the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
1N/AThe version specified should be numeric.
1N/A
1N/A=item B<-x>, B<--autogen-xsubs>
1N/A
1N/AAutomatically generate XSUBs basing on function declarations in the
1N/Aheader file. The package C<C::Scan> should be installed. If this
1N/Aoption is specified, the name of the header file may look like
1N/AC<NAME1,NAME2>. In this case NAME1 is used instead of the specified
1N/Astring, but XSUBs are emitted only for the declarations included from
1N/Afile NAME2.
1N/A
1N/ANote that some types of arguments/return-values for functions may
1N/Aresult in XSUB-declarations/typemap-entries which need
1N/Ahand-editing. Such may be objects which cannot be converted from/to a
1N/Apointer (like C<long long>), pointers to functions, or arrays. See
1N/Aalso the section on L<LIMITATIONS of B<-x>>.
1N/A
1N/A=back
1N/A
1N/A=head1 EXAMPLES
1N/A
1N/A
1N/A # Default behavior, extension is Rusers
1N/A h2xs rpcsvc/rusers
1N/A
1N/A # Same, but extension is RUSERS
1N/A h2xs -n RUSERS rpcsvc/rusers
1N/A
1N/A # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
1N/A h2xs rpcsvc::rusers
1N/A
1N/A # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
1N/A h2xs -n ONC::RPC rpcsvc/rusers
1N/A
1N/A # Without constant() or AUTOLOAD
1N/A h2xs -c rpcsvc/rusers
1N/A
1N/A # Creates templates for an extension named RPC
1N/A h2xs -cfn RPC
1N/A
1N/A # Extension is ONC::RPC.
1N/A h2xs -cfn ONC::RPC
1N/A
1N/A # Extension is Lib::Foo which works at least with Perl5.005_03.
1N/A # Constants are created for all #defines and enums h2xs can find
1N/A # in foo.h.
1N/A h2xs -b 5.5.3 -n Lib::Foo foo.h
1N/A
1N/A # Extension is Lib::Foo which works at least with Perl5.005_03.
1N/A # Constants are created for all #defines but only for enums
1N/A # whose names do not start with 'bar_'.
1N/A h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
1N/A
1N/A # Makefile.PL will look for library -lrpc in
1N/A # additional directory /opt/net/lib
1N/A h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
1N/A
1N/A # Extension is DCE::rgynbase
1N/A # prefix "sec_rgy_" is dropped from perl function names
1N/A h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
1N/A
1N/A # Extension is DCE::rgynbase
1N/A # prefix "sec_rgy_" is dropped from perl function names
1N/A # subroutines are created for sec_rgy_wildcard_name and
1N/A # sec_rgy_wildcard_sid
1N/A h2xs -n DCE::rgynbase -p sec_rgy_ \
1N/A -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
1N/A
1N/A # Make XS without defines in perl.h, but with function declarations
1N/A # visible from perl.h. Name of the extension is perl1.
1N/A # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
1N/A # Extra backslashes below because the string is passed to shell.
1N/A # Note that a directory with perl header files would
1N/A # be added automatically to include path.
1N/A h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
1N/A
1N/A # Same with function declaration in proto.h as visible from perl.h.
1N/A h2xs -xAn perl2 perl.h,proto.h
1N/A
1N/A # Same but select only functions which match /^av_/
1N/A h2xs -M '^av_' -xAn perl2 perl.h,proto.h
1N/A
1N/A # Same but treat SV* etc as "opaque" types
1N/A h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
1N/A
1N/A=head2 Extension based on F<.h> and F<.c> files
1N/A
1N/ASuppose that you have some C files implementing some functionality,
1N/Aand the corresponding header files. How to create an extension which
1N/Amakes this functionality accessable in Perl? The example below
1N/Aassumes that the header files are F<interface_simple.h> and
1N/AI<interface_hairy.h>, and you want the perl module be named as
1N/AC<Ext::Ension>. If you need some preprocessor directives and/or
1N/Alinking with external libraries, see the flags C<-F>, C<-L> and C<-l>
1N/Ain L<"OPTIONS">.
1N/A
1N/A=over
1N/A
1N/A=item Find the directory name
1N/A
1N/AStart with a dummy run of h2xs:
1N/A
1N/A h2xs -Afn Ext::Ension
1N/A
1N/AThe only purpose of this step is to create the needed directories, and
1N/Alet you know the names of these directories. From the output you can
1N/Asee that the directory for the extension is F<Ext/Ension>.
1N/A
1N/A=item Copy C files
1N/A
1N/ACopy your header files and C files to this directory F<Ext/Ension>.
1N/A
1N/A=item Create the extension
1N/A
1N/ARun h2xs, overwriting older autogenerated files:
1N/A
1N/A h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
1N/A
1N/Ah2xs looks for header files I<after> changing to the extension
1N/Adirectory, so it will find your header files OK.
1N/A
1N/A=item Archive and test
1N/A
1N/AAs usual, run
1N/A
1N/A cd Ext/Ension
1N/A perl Makefile.PL
1N/A make dist
1N/A make
1N/A make test
1N/A
1N/A=item Hints
1N/A
1N/AIt is important to do C<make dist> as early as possible. This way you
1N/Acan easily merge(1) your changes to autogenerated files if you decide
1N/Ato edit your C<.h> files and rerun h2xs.
1N/A
1N/ADo not forget to edit the documentation in the generated F<.pm> file.
1N/A
1N/AConsider the autogenerated files as skeletons only, you may invent
1N/Abetter interfaces than what h2xs could guess.
1N/A
1N/AConsider this section as a guideline only, some other options of h2xs
1N/Amay better suit your needs.
1N/A
1N/A=back
1N/A
1N/A=head1 ENVIRONMENT
1N/A
1N/ANo environment variables are used.
1N/A
1N/A=head1 AUTHOR
1N/A
1N/ALarry Wall and others
1N/A
1N/A=head1 SEE ALSO
1N/A
1N/AL<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
1N/A
1N/A=head1 DIAGNOSTICS
1N/A
1N/AThe usual warnings if it cannot read or write the files involved.
1N/A
1N/A=head1 LIMITATIONS of B<-x>
1N/A
1N/AF<h2xs> would not distinguish whether an argument to a C function
1N/Awhich is of the form, say, C<int *>, is an input, output, or
1N/Ainput/output parameter. In particular, argument declarations of the
1N/Aform
1N/A
1N/A int
1N/A foo(n)
1N/A int *n
1N/A
1N/Ashould be better rewritten as
1N/A
1N/A int
1N/A foo(n)
1N/A int &n
1N/A
1N/Aif C<n> is an input parameter.
1N/A
1N/AAdditionally, F<h2xs> has no facilities to intuit that a function
1N/A
1N/A int
1N/A foo(addr,l)
1N/A char *addr
1N/A int l
1N/A
1N/Atakes a pair of address and length of data at this address, so it is better
1N/Ato rewrite this function as
1N/A
1N/A int
1N/A foo(sv)
1N/A SV *addr
1N/A PREINIT:
1N/A STRLEN len;
1N/A char *s;
1N/A CODE:
1N/A s = SvPV(sv,len);
1N/A RETVAL = foo(s, len);
1N/A OUTPUT:
1N/A RETVAL
1N/A
1N/Aor alternately
1N/A
1N/A static int
1N/A my_foo(SV *sv)
1N/A {
1N/A STRLEN len;
1N/A char *s = SvPV(sv,len);
1N/A
1N/A return foo(s, len);
1N/A }
1N/A
1N/A MODULE = foo PACKAGE = foo PREFIX = my_
1N/A
1N/A int
1N/A foo(sv)
1N/A SV *sv
1N/A
1N/ASee L<perlxs> and L<perlxstut> for additional details.
1N/A
1N/A=cut
1N/A
1N/A# ' # Grr
1N/Ause strict;
1N/A
1N/A
1N/Amy( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;
1N/Amy $TEMPLATE_VERSION = '0.01';
1N/Amy @ARGS = @ARGV;
1N/Amy $compat_version = $];
1N/A
1N/Ause Getopt::Long;
1N/Ause Config;
1N/Ause Text::Wrap;
1N/A$Text::Wrap::huge = 'overflow';
1N/A$Text::Wrap::columns = 80;
1N/Ause ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
1N/Ause File::Compare;
1N/Ause File::Path;
1N/A
1N/Asub usage {
1N/A warn "@_\n" if @_;
1N/A die <<EOFUSAGE;
1N/Ah2xs [OPTIONS ... ] [headerfile [extra_libraries]]
1N/Aversion: $H2XS_VERSION
1N/AOPTIONS:
1N/A -A, --omit-autoload Omit all autoloading facilities (implies -c).
1N/A -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
1N/A -C, --omit-changes Omit creating the Changes file, add HISTORY heading
1N/A to stub POD.
1N/A -F, --cpp-flags Additional flags for C preprocessor/compile.
1N/A -M, --func-mask Mask to select C functions/macros
1N/A (default is select all).
1N/A -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
1N/A -P, --omit-pod Omit the stub POD section.
1N/A -X, --omit-XS Omit the XS portion (implies both -c and -f).
1N/A -a, --gen-accessors Generate get/set accessors for struct and union members (used with -x).
1N/A -b, --compat-version Specify a perl version to be backwards compatibile with
1N/A -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
1N/A from the XS file.
1N/A -d, --debugging Turn on debugging messages.
1N/A -e, --omit-enums Omit constants from enums in the constant() function.
1N/A If a pattern is given, only the matching enums are
1N/A ignored.
1N/A -f, --force Force creation of the extension even if the C header
1N/A does not exist.
1N/A -g, --global Include code for safely storing static data in the .xs file.
1N/A -h, -?, --help Display this help message
1N/A -k, --omit-const-func Omit 'const' attribute on function arguments
1N/A (used with -x).
1N/A -m, --gen-tied-var Generate tied variables for access to declared
1N/A variables.
1N/A -n, --name Specify a name to use for the extension (recommended).
1N/A -o, --opaque-re Regular expression for \"opaque\" types.
1N/A -p, --remove-prefix Specify a prefix which should be removed from the
1N/A Perl function names.
1N/A -s, --const-subs Create subroutines for specified macros.
1N/A -t, --default-type Default type for autoloaded constants (default is IV)
1N/A --use-new-tests Use Test::More in backward compatible modules
1N/A --use-old-tests Use the module Test rather than Test::More
1N/A --skip-exporter Do not export symbols
1N/A --skip-ppport Do not use portability layer
1N/A --skip-autoloader Do not use the module C<AutoLoader>
1N/A --skip-strict Do not use the pragma C<strict>
1N/A --skip-warnings Do not use the pragma C<warnings>
1N/A -v, --version Specify a version number for this extension.
1N/A -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
1N/A
1N/Aextra_libraries
1N/A are any libraries that might be needed for loading the
1N/A extension, e.g. -lm would try to link in the math library.
1N/AEOFUSAGE
1N/A}
1N/A
1N/Amy ($opt_A,
1N/A $opt_B,
1N/A $opt_C,
1N/A $opt_F,
1N/A $opt_M,
1N/A $opt_O,
1N/A $opt_P,
1N/A $opt_X,
1N/A $opt_a,
1N/A $opt_c,
1N/A $opt_d,
1N/A $opt_e,
1N/A $opt_f,
1N/A $opt_g,
1N/A $opt_h,
1N/A $opt_k,
1N/A $opt_m,
1N/A $opt_n,
1N/A $opt_o,
1N/A $opt_p,
1N/A $opt_s,
1N/A $opt_v,
1N/A $opt_x,
1N/A $opt_b,
1N/A $opt_t,
1N/A $new_test,
1N/A $old_test,
1N/A $skip_exporter,
1N/A $skip_ppport,
1N/A $skip_autoloader,
1N/A $skip_strict,
1N/A $skip_warnings,
1N/A );
1N/A
1N/AGetopt::Long::Configure('bundling');
1N/AGetopt::Long::Configure('pass_through');
1N/A
1N/Amy %options = (
1N/A 'omit-autoload|A' => \$opt_A,
1N/A 'beta-version|B' => \$opt_B,
1N/A 'omit-changes|C' => \$opt_C,
1N/A 'cpp-flags|F=s' => \$opt_F,
1N/A 'func-mask|M=s' => \$opt_M,
1N/A 'overwrite_ok|O' => \$opt_O,
1N/A 'omit-pod|P' => \$opt_P,
1N/A 'omit-XS|X' => \$opt_X,
1N/A 'gen-accessors|a' => \$opt_a,
1N/A 'compat-version|b=s' => \$opt_b,
1N/A 'omit-constant|c' => \$opt_c,
1N/A 'debugging|d' => \$opt_d,
1N/A 'omit-enums|e:s' => \$opt_e,
1N/A 'force|f' => \$opt_f,
1N/A 'global|g' => \$opt_g,
1N/A 'help|h|?' => \$opt_h,
1N/A 'omit-const-func|k' => \$opt_k,
1N/A 'gen-tied-var|m' => \$opt_m,
1N/A 'name|n=s' => \$opt_n,
1N/A 'opaque-re|o=s' => \$opt_o,
1N/A 'remove-prefix|p=s' => \$opt_p,
1N/A 'const-subs|s=s' => \$opt_s,
1N/A 'default-type|t=s' => \$opt_t,
1N/A 'version|v=s' => \$opt_v,
1N/A 'autogen-xsubs|x' => \$opt_x,
1N/A 'use-new-tests' => \$new_test,
1N/A 'use-old-tests' => \$old_test,
1N/A 'skip-exporter' => \$skip_exporter,
1N/A 'skip-ppport' => \$skip_ppport,
1N/A 'skip-autoloader' => \$skip_autoloader,
1N/A 'skip-warnings' => \$skip_warnings,
1N/A 'skip-strict' => \$skip_strict,
1N/A );
1N/A
1N/AGetOptions(%options) || usage;
1N/A
1N/Ausage if $opt_h;
1N/A
1N/Aif( $opt_b ){
1N/A usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
1N/A $opt_b =~ /^\d+\.\d+\.\d+/ ||
1N/A usage "You must provide the backwards compatibility version in X.Y.Z form. "
1N/A . "(i.e. 5.5.0)\n";
1N/A my ($maj,$min,$sub) = split(/\./,$opt_b,3);
1N/A if ($maj < 5 || ($maj == 5 && $min < 6)) {
1N/A $compat_version =
1N/A $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
1N/A sprintf("%d.%03d", $maj,$min);
1N/A } else {
1N/A $compat_version =
1N/A $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) :
1N/A sprintf("%d.%03d", $maj,$min);
1N/A }
1N/A} else {
1N/A my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
1N/A $sub ||= 0;
1N/A warn sprintf <<'EOF', $maj,$min,$sub;
1N/ADefaulting to backwards compatibility with perl %d.%d.%d
1N/AIf you intend this module to be compatible with earlier perl versions, please
1N/Aspecify a minimum perl version with the -b option.
1N/A
1N/AEOF
1N/A}
1N/A
1N/Aif( $opt_B ){
1N/A $TEMPLATE_VERSION = '0.00_01';
1N/A}
1N/A
1N/Aif( $opt_v ){
1N/A $TEMPLATE_VERSION = $opt_v;
1N/A
1N/A # check if it is numeric
1N/A my $temp_version = $TEMPLATE_VERSION;
1N/A my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
1N/A my $notnum;
1N/A {
1N/A local $SIG{__WARN__} = sub { $notnum = 1 };
1N/A use warnings 'numeric';
1N/A $temp_version = 0+$temp_version;
1N/A }
1N/A
1N/A if ($notnum) {
1N/A my $module = $opt_n || 'Your::Module';
1N/A warn <<"EOF";
1N/AYou have specified a non-numeric version. Unless you supply an
1N/Aappropriate VERSION class method, users may not be able to specify a
1N/Aminimum required version with C<use $module versionnum>.
1N/A
1N/AEOF
1N/A }
1N/A else {
1N/A $opt_B = $beta_version;
1N/A }
1N/A}
1N/A
1N/A# -A implies -c.
1N/A$skip_autoloader = $opt_c = 1 if $opt_A;
1N/A
1N/A# -X implies -c and -f
1N/A$opt_c = $opt_f = 1 if $opt_X;
1N/A
1N/A$opt_t ||= 'IV';
1N/A
1N/Amy %const_xsub;
1N/A%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
1N/A
1N/Amy $extralibs = '';
1N/A
1N/Amy @path_h;
1N/A
1N/Awhile (my $arg = shift) {
1N/A if ($arg =~ /^-l/i) {
1N/A $extralibs .= "$arg ";
1N/A next;
1N/A }
1N/A last if $extralibs;
1N/A push(@path_h, $arg);
1N/A}
1N/A
1N/Ausage "Must supply header file or module name\n"
1N/A unless (@path_h or $opt_n);
1N/A
1N/Amy $fmask;
1N/Amy $tmask;
1N/A
1N/A$fmask = qr{$opt_M} if defined $opt_M;
1N/A$tmask = qr{$opt_o} if defined $opt_o;
1N/Amy $tmask_all = $tmask && $opt_o eq '.';
1N/A
1N/Aif ($opt_x) {
1N/A eval {require C::Scan; 1}
1N/A or die <<EOD;
1N/AC::Scan required if you use -x option.
1N/ATo install C::Scan, execute
1N/A perl -MCPAN -e "install C::Scan"
1N/AEOD
1N/A unless ($tmask_all) {
1N/A $C::Scan::VERSION >= 0.70
1N/A or die <<EOD;
1N/AC::Scan v. 0.70 or later required unless you use -o . option.
1N/AYou have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
1N/ATo install C::Scan, execute
1N/A perl -MCPAN -e "install C::Scan"
1N/AEOD
1N/A }
1N/A if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
1N/A die <<EOD;
1N/AC::Scan v. 0.73 or later required to use -m or -a options.
1N/AYou have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
1N/ATo install C::Scan, execute
1N/A perl -MCPAN -e "install C::Scan"
1N/AEOD
1N/A }
1N/A}
1N/Aelsif ($opt_o or $opt_F) {
1N/A warn <<EOD if $opt_o;
1N/AOption -o does not make sense without -x.
1N/AEOD
1N/A warn <<EOD if $opt_F and $opt_X ;
1N/AOption -F does not make sense with -X.
1N/AEOD
1N/A}
1N/A
1N/Amy @path_h_ini = @path_h;
1N/Amy ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
1N/A
1N/Amy $module = $opt_n;
1N/A
1N/Aif( @path_h ){
1N/A use File::Spec;
1N/A my @paths;
1N/A my $pre_sub_tri_graphs = 1;
1N/A if ($^O eq 'VMS') { # Consider overrides of default location
1N/A # XXXX This is not equivalent to what the older version did:
1N/A # it was looking at $hadsys header-file per header-file...
1N/A my($hadsys) = grep s!^sys/!!i , @path_h;
1N/A @paths = qw( Sys$Library VAXC$Include );
1N/A push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
1N/A push @paths, qw( DECC$Library_Include DECC$System_Include );
1N/A }
1N/A else {
1N/A @paths = (File::Spec->curdir(), $Config{usrinc},
1N/A (split ' ', $Config{locincpth}), '/usr/include');
1N/A }
1N/A foreach my $path_h (@path_h) {
1N/A $name ||= $path_h;
1N/A $module ||= do {
1N/A $name =~ s/\.h$//;
1N/A if ( $name !~ /::/ ) {
1N/A $name =~ s#^.*/##;
1N/A $name = "\u$name";
1N/A }
1N/A $name;
1N/A };
1N/A
1N/A if( $path_h =~ s#::#/#g && $opt_n ){
1N/A warn "Nesting of headerfile ignored with -n\n";
1N/A }
1N/A $path_h .= ".h" unless $path_h =~ /\.h$/;
1N/A my $fullpath = $path_h;
1N/A $path_h =~ s/,.*$// if $opt_x;
1N/A $fullpath{$path_h} = $fullpath;
1N/A
1N/A # Minor trickery: we can't chdir() before we processed the headers
1N/A # (so know the name of the extension), but the header may be in the
1N/A # extension directory...
1N/A my $tmp_path_h = $path_h;
1N/A my $rel_path_h = $path_h;
1N/A my @dirs = @paths;
1N/A if (not -f $path_h) {
1N/A my $found;
1N/A for my $dir (@paths) {
1N/A $found++, last
1N/A if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
1N/A }
1N/A if ($found) {
1N/A $rel_path_h = $path_h;
1N/A $fullpath{$path_h} = $fullpath;
1N/A } else {
1N/A (my $epath = $module) =~ s,::,/,g;
1N/A $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
1N/A $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
1N/A $path_h = $tmp_path_h; # Used during -x
1N/A push @dirs, $epath;
1N/A }
1N/A }
1N/A
1N/A if (!$opt_c) {
1N/A die "Can't find $tmp_path_h in @dirs\n"
1N/A if ( ! $opt_f && ! -f "$rel_path_h" );
1N/A # Scan the header file (we should deal with nested header files)
1N/A # Record the names of simple #define constants into const_names
1N/A # Function prototypes are processed below.
1N/A open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
1N/A defines:
1N/A while (<CH>) {
1N/A if ($pre_sub_tri_graphs) {
1N/A # Preprocess all tri-graphs
1N/A # including things stuck in quoted string constants.
1N/A s/\?\?=/#/g; # | ??=| #|
1N/A s/\?\?\!/|/g; # | ??!| ||
1N/A s/\?\?'/^/g; # | ??'| ^|
1N/A s/\?\?\(/[/g; # | ??(| [|
1N/A s/\?\?\)/]/g; # | ??)| ]|
1N/A s/\?\?\-/~/g; # | ??-| ~|
1N/A s/\?\?\//\\/g; # | ??/| \|
1N/A s/\?\?</{/g; # | ??<| {|
1N/A s/\?\?>/}/g; # | ??>| }|
1N/A }
1N/A if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
1N/A my $def = $1;
1N/A my $rest = $2;
1N/A $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
1N/A $rest =~ s/^\s+//;
1N/A $rest =~ s/\s+$//;
1N/A # Cannot do: (-1) and ((LHANDLE)3) are OK:
1N/A #print("Skip non-wordy $def => $rest\n"),
1N/A # next defines if $rest =~ /[^\w\$]/;
1N/A if ($rest =~ /"/) {
1N/A print("Skip stringy $def => $rest\n") if $opt_d;
1N/A next defines;
1N/A }
1N/A print "Matched $_ ($def)\n" if $opt_d;
1N/A $seen_define{$def} = $rest;
1N/A $_ = $def;
1N/A next if /^_.*_h_*$/i; # special case, but for what?
1N/A if (defined $opt_p) {
1N/A if (!/^$opt_p(\d)/) {
1N/A ++$prefix{$_} if s/^$opt_p//;
1N/A }
1N/A else {
1N/A warn "can't remove $opt_p prefix from '$_'!\n";
1N/A }
1N/A }
1N/A $prefixless{$def} = $_;
1N/A if (!$fmask or /$fmask/) {
1N/A print "... Passes mask of -M.\n" if $opt_d and $fmask;
1N/A $const_names{$_}++;
1N/A }
1N/A }
1N/A }
1N/A if (defined $opt_e and !$opt_e) {
1N/A close(CH);
1N/A }
1N/A else {
1N/A # Work from miniperl too - on "normal" systems
1N/A my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
1N/A seek CH, 0, $SEEK_SET;
1N/A my $src = do { local $/; <CH> };
1N/A close CH;
1N/A no warnings 'uninitialized';
1N/A
1N/A # Remove C and C++ comments
1N/A $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
1N/A
1N/A while ($src =~ /(\benum\s*([\w_]*)\s*\{\s([\s\w=,]+)\})/gsc) {
1N/A my ($enum_name, $enum_body) =
1N/A $1 =~ /enum\s*([\w_]*)\s*\{\s([\s\w=,]+)\}/gs;
1N/A # skip enums matching $opt_e
1N/A next if $opt_e && $enum_name =~ /$opt_e/;
1N/A my $val = 0;
1N/A for my $item (split /,/, $enum_body) {
1N/A my ($key, $declared_val) = $item =~ /(\w*)\s*=\s*(.*)/;
1N/A $val = length($declared_val) ? $declared_val : 1 + $val;
1N/A $seen_define{$key} = $declared_val;
1N/A $const_names{$key}++;
1N/A }
1N/A } # while (...)
1N/A } # if (!defined $opt_e or $opt_e)
1N/A }
1N/A }
1N/A}
1N/A
1N/A# Save current directory so that C::Scan can use it
1N/Amy $cwd = File::Spec->rel2abs( File::Spec->curdir );
1N/A
1N/A# As Ilya suggested, use a name that contains - and then it can't clash with
1N/A# the names of any packages. A directory 'fallback' will clash with any
1N/A# new pragmata down the fallback:: tree, but that seems unlikely.
1N/Amy $constscfname = 'const-c.inc';
1N/Amy $constsxsfname = 'const-xs.inc';
1N/Amy $fallbackdirname = 'fallback';
1N/A
1N/Amy $ext = chdir 'ext' ? 'ext/' : '';
1N/A
1N/Amy @modparts = split(/::/,$module);
1N/Amy $modpname = join('-', @modparts);
1N/Amy $modfname = pop @modparts;
1N/Amy $modpmdir = join '/', 'lib', @modparts;
1N/Amy $modpmname = join '/', $modpmdir, $modfname.'.pm';
1N/A
1N/Aif ($opt_O) {
1N/A warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
1N/A}
1N/Aelse {
1N/A die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
1N/A}
1N/A-d "$modpname" || mkpath([$modpname], 0, 0775);
1N/Achdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
1N/A
1N/Amy %types_seen;
1N/Amy %std_types;
1N/Amy $fdecls = [];
1N/Amy $fdecls_parsed = [];
1N/Amy $typedef_rex;
1N/Amy %typedefs_pre;
1N/Amy %known_fnames;
1N/Amy %structs;
1N/A
1N/Amy @fnames;
1N/Amy @fnames_no_prefix;
1N/Amy %vdecl_hash;
1N/Amy @vdecls;
1N/A
1N/Aif( ! $opt_X ){ # use XS, unless it was disabled
1N/A unless ($skip_ppport) {
1N/A require Devel::PPPort;
1N/A warn "Writing $ext$modpname/ppport.h\n";
1N/A Devel::PPPort::WriteFile('ppport.h')
1N/A || die "Can't create $ext$modpname/ppport.h: $!\n";
1N/A }
1N/A open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
1N/A if ($opt_x) {
1N/A warn "Scanning typemaps...\n";
1N/A get_typemap();
1N/A my @td;
1N/A my @good_td;
1N/A my $addflags = $opt_F || '';
1N/A
1N/A foreach my $filename (@path_h) {
1N/A my $c;
1N/A my $filter;
1N/A
1N/A if ($fullpath{$filename} =~ /,/) {
1N/A $filename = $`;
1N/A $filter = $';
1N/A }
1N/A warn "Scanning $filename for functions...\n";
1N/A my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
1N/A $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
1N/A 'add_cppflags' => $addflags, 'c_styles' => \@styles;
1N/A $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
1N/A
1N/A push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
1N/A push(@$fdecls, @{$c->get('fdecls')});
1N/A
1N/A push @td, @{$c->get('typedefs_maybe')};
1N/A if ($opt_a) {
1N/A my $structs = $c->get('typedef_structs');
1N/A @structs{keys %$structs} = values %$structs;
1N/A }
1N/A
1N/A if ($opt_m) {
1N/A %vdecl_hash = %{ $c->get('vdecl_hash') };
1N/A @vdecls = sort keys %vdecl_hash;
1N/A for (local $_ = 0; $_ < @vdecls; ++$_) {
1N/A my $var = $vdecls[$_];
1N/A my($type, $post) = @{ $vdecl_hash{$var} };
1N/A if (defined $post) {
1N/A warn "Can't handle variable '$type $var $post', skipping.\n";
1N/A splice @vdecls, $_, 1;
1N/A redo;
1N/A }
1N/A $type = normalize_type($type);
1N/A $vdecl_hash{$var} = $type;
1N/A }
1N/A }
1N/A
1N/A unless ($tmask_all) {
1N/A warn "Scanning $filename for typedefs...\n";
1N/A my $td = $c->get('typedef_hash');
1N/A # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
1N/A my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
1N/A push @good_td, @f_good_td;
1N/A @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
1N/A }
1N/A }
1N/A { local $" = '|';
1N/A $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
1N/A }
1N/A %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
1N/A if ($fmask) {
1N/A my @good;
1N/A for my $i (0..$#$fdecls_parsed) {
1N/A next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
1N/A push @good, $i;
1N/A print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
1N/A if $opt_d;
1N/A }
1N/A $fdecls = [@$fdecls[@good]];
1N/A $fdecls_parsed = [@$fdecls_parsed[@good]];
1N/A }
1N/A @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
1N/A # Sort declarations:
1N/A {
1N/A my %h = map( ($_->[1], $_), @$fdecls_parsed);
1N/A $fdecls_parsed = [ @h{@fnames} ];
1N/A }
1N/A @fnames_no_prefix = @fnames;
1N/A @fnames_no_prefix
1N/A = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
1N/A if defined $opt_p;
1N/A # Remove macros which expand to typedefs
1N/A print "Typedefs are @td.\n" if $opt_d;
1N/A my %td = map {($_, $_)} @td;
1N/A # Add some other possible but meaningless values for macros
1N/A for my $k (qw(char double float int long short unsigned signed void)) {
1N/A $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
1N/A }
1N/A # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
1N/A my $n = 0;
1N/A my %bad_macs;
1N/A while (keys %td > $n) {
1N/A $n = keys %td;
1N/A my ($k, $v);
1N/A while (($k, $v) = each %seen_define) {
1N/A # print("found '$k'=>'$v'\n"),
1N/A $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
1N/A }
1N/A }
1N/A # Now %bad_macs contains names of bad macros
1N/A for my $k (keys %bad_macs) {
1N/A delete $const_names{$prefixless{$k}};
1N/A print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
1N/A }
1N/A }
1N/A}
1N/Amy @const_names = sort keys %const_names;
1N/A
1N/A-d $modpmdir || mkpath([$modpmdir], 0, 0775);
1N/Aopen(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
1N/A
1N/A$" = "\n\t";
1N/Awarn "Writing $ext$modpname/$modpmname\n";
1N/A
1N/Aprint PM <<"END";
1N/Apackage $module;
1N/A
1N/Ause $compat_version;
1N/AEND
1N/A
1N/Aprint PM <<"END" unless $skip_strict;
1N/Ause strict;
1N/AEND
1N/A
1N/Aprint PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
1N/A
1N/Aunless( $opt_X || $opt_c || $opt_A ){
1N/A # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
1N/A # will want Carp.
1N/A print PM <<'END';
1N/Ause Carp;
1N/AEND
1N/A}
1N/A
1N/Aprint PM <<'END' unless $skip_exporter;
1N/A
1N/Arequire Exporter;
1N/AEND
1N/A
1N/Amy $use_Dyna = (not $opt_X and $compat_version < 5.006);
1N/Aprint PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
1N/Arequire DynaLoader;
1N/AEND
1N/A
1N/A
1N/A# Are we using AutoLoader or not?
1N/Aunless ($skip_autoloader) { # no autoloader whatsoever.
1N/A unless ($opt_c) { # we're doing the AUTOLOAD
1N/A print PM "use AutoLoader;\n";
1N/A }
1N/A else {
1N/A print PM "use AutoLoader qw(AUTOLOAD);\n"
1N/A }
1N/A}
1N/A
1N/Aif ( $compat_version < 5.006 ) {
1N/A my $vars = '$VERSION @ISA';
1N/A $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
1N/A $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
1N/A $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
1N/A print PM "use vars qw($vars);";
1N/A}
1N/A
1N/A# Determine @ISA.
1N/Amy @modISA;
1N/Apush @modISA, 'Exporter' unless $skip_exporter;
1N/Apush @modISA, 'DynaLoader' if $use_Dyna; # no XS
1N/Amy $myISA = "our \@ISA = qw(@modISA);";
1N/A$myISA =~ s/^our // if $compat_version < 5.006;
1N/A
1N/Aprint PM "\n$myISA\n\n";
1N/A
1N/Amy @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1N/A
1N/Amy $tmp='';
1N/A$tmp .= <<"END" unless $skip_exporter;
1N/A# Items to export into callers namespace by default. Note: do not export
1N/A# names by default without a very good reason. Use EXPORT_OK instead.
1N/A# Do not simply export all your public functions/methods/constants.
1N/A
1N/A# This allows declaration use $module ':all';
1N/A# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1N/A# will save memory.
1N/Aour %EXPORT_TAGS = ( 'all' => [ qw(
1N/A @exported_names
1N/A) ] );
1N/A
1N/Aour \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1N/A
1N/Aour \@EXPORT = qw(
1N/A @const_names
1N/A);
1N/A
1N/AEND
1N/A
1N/A$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
1N/Aif ($opt_B) {
1N/A $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
1N/A $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
1N/A}
1N/A$tmp .= "\n";
1N/A
1N/A$tmp =~ s/^our //mg if $compat_version < 5.006;
1N/Aprint PM $tmp;
1N/A
1N/Aif (@vdecls) {
1N/A printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1N/A}
1N/A
1N/A
1N/Aprint PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1N/A
1N/Aif( ! $opt_X ){ # print bootstrap, unless XS is disabled
1N/A if ($use_Dyna) {
1N/A $tmp = <<"END";
1N/Abootstrap $module \$VERSION;
1N/AEND
1N/A } else {
1N/A $tmp = <<"END";
1N/Arequire XSLoader;
1N/AXSLoader::load('$module', \$VERSION);
1N/AEND
1N/A }
1N/A $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
1N/A print PM $tmp;
1N/A}
1N/A
1N/A# tying the variables can happen only after bootstrap
1N/Aif (@vdecls) {
1N/A printf PM <<END;
1N/A{
1N/A@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
1N/A}
1N/A
1N/AEND
1N/A}
1N/A
1N/Amy $after;
1N/Aif( $opt_P ){ # if POD is disabled
1N/A $after = '__END__';
1N/A}
1N/Aelse {
1N/A $after = '=cut';
1N/A}
1N/A
1N/Aprint PM <<"END";
1N/A
1N/A# Preloaded methods go here.
1N/AEND
1N/A
1N/Aprint PM <<"END" unless $opt_A;
1N/A
1N/A# Autoload methods go after $after, and are processed by the autosplit program.
1N/AEND
1N/A
1N/Aprint PM <<"END";
1N/A
1N/A1;
1N/A__END__
1N/AEND
1N/A
1N/Amy ($email,$author,$licence);
1N/A
1N/Aeval {
1N/A my $username;
1N/A ($username,$author) = (getpwuid($>))[0,6];
1N/A if (defined $username && defined $author) {
1N/A $author =~ s/,.*$//; # in case of sub fields
1N/A my $domain = $Config{'mydomain'};
1N/A $domain =~ s/^\.//;
1N/A $email = "$username\@$domain";
1N/A }
1N/A };
1N/A
1N/A$author ||= "A. U. Thor";
1N/A$email ||= 'a.u.thor@a.galaxy.far.far.away';
1N/A
1N/A$licence = sprintf << "DEFAULT", $^V;
1N/ACopyright (C) ${\(1900 + (localtime) [5])} by $author
1N/A
1N/AThis library is free software; you can redistribute it and/or modify
1N/Ait under the same terms as Perl itself, either Perl version %vd or,
1N/Aat your option, any later version of Perl 5 you may have available.
1N/ADEFAULT
1N/A
1N/Amy $revhist = '';
1N/A$revhist = <<EOT if $opt_C;
1N/A#
1N/A#=head1 HISTORY
1N/A#
1N/A#=over 8
1N/A#
1N/A#=item $TEMPLATE_VERSION
1N/A#
1N/A#Original version; created by h2xs $H2XS_VERSION with options
1N/A#
1N/A# @ARGS
1N/A#
1N/A#=back
1N/A#
1N/AEOT
1N/A
1N/Amy $exp_doc = $skip_exporter ? '' : <<EOD;
1N/A#
1N/A#=head2 EXPORT
1N/A#
1N/A#None by default.
1N/A#
1N/AEOD
1N/A
1N/Aif (@const_names and not $opt_P) {
1N/A $exp_doc .= <<EOD unless $skip_exporter;
1N/A#=head2 Exportable constants
1N/A#
1N/A# @{[join "\n ", @const_names]}
1N/A#
1N/AEOD
1N/A}
1N/A
1N/Aif (defined $fdecls and @$fdecls and not $opt_P) {
1N/A $exp_doc .= <<EOD unless $skip_exporter;
1N/A#=head2 Exportable functions
1N/A#
1N/AEOD
1N/A
1N/A# $exp_doc .= <<EOD if $opt_p;
1N/A#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1N/A#
1N/A#EOD
1N/A $exp_doc .= <<EOD unless $skip_exporter;
1N/A# @{[join "\n ", @known_fnames{@fnames}]}
1N/A#
1N/AEOD
1N/A}
1N/A
1N/Amy $meth_doc = '';
1N/A
1N/Aif ($opt_x && $opt_a) {
1N/A my($name, $struct);
1N/A $meth_doc .= accessor_docs($name, $struct)
1N/A while ($name, $struct) = each %structs;
1N/A}
1N/A
1N/A# Prefix the default licence with hash symbols.
1N/A# Is this just cargo cult - it seems that the first thing that happens to this
1N/A# block is that all the hashes are then s///g out.
1N/Amy $licence_hash = $licence;
1N/A$licence_hash =~ s/^/#/gm;
1N/A
1N/Amy $pod;
1N/A$pod = <<"END" unless $opt_P;
1N/A## Below is stub documentation for your module. You'd better edit it!
1N/A#
1N/A#=head1 NAME
1N/A#
1N/A#$module - Perl extension for blah blah blah
1N/A#
1N/A#=head1 SYNOPSIS
1N/A#
1N/A# use $module;
1N/A# blah blah blah
1N/A#
1N/A#=head1 DESCRIPTION
1N/A#
1N/A#Stub documentation for $module, created by h2xs. It looks like the
1N/A#author of the extension was negligent enough to leave the stub
1N/A#unedited.
1N/A#
1N/A#Blah blah blah.
1N/A$exp_doc$meth_doc$revhist
1N/A#
1N/A#=head1 SEE ALSO
1N/A#
1N/A#Mention other useful documentation such as the documentation of
1N/A#related modules or operating system documentation (such as man pages
1N/A#in UNIX), or any relevant external documentation such as RFCs or
1N/A#standards.
1N/A#
1N/A#If you have a mailing list set up for your module, mention it here.
1N/A#
1N/A#If you have a web site set up for your module, mention it here.
1N/A#
1N/A#=head1 AUTHOR
1N/A#
1N/A#$author, E<lt>${email}E<gt>
1N/A#
1N/A#=head1 COPYRIGHT AND LICENSE
1N/A#
1N/A$licence_hash
1N/A#
1N/A#=cut
1N/AEND
1N/A
1N/A$pod =~ s/^\#//gm unless $opt_P;
1N/Aprint PM $pod unless $opt_P;
1N/A
1N/Aclose PM;
1N/A
1N/A
1N/Aif( ! $opt_X ){ # print XS, unless it is disabled
1N/Awarn "Writing $ext$modpname/$modfname.xs\n";
1N/A
1N/Aprint XS <<"END";
1N/A#include "EXTERN.h"
1N/A#include "perl.h"
1N/A#include "XSUB.h"
1N/A
1N/AEND
1N/A
1N/Aprint XS <<"END" unless $skip_ppport;
1N/A#include "ppport.h"
1N/A
1N/AEND
1N/A
1N/Aif( @path_h ){
1N/A foreach my $path_h (@path_h_ini) {
1N/A my($h) = $path_h;
1N/A $h =~ s#^/usr/include/##;
1N/A if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1N/A print XS qq{#include <$h>\n};
1N/A }
1N/A print XS "\n";
1N/A}
1N/A
1N/Aprint XS <<"END" if $opt_g;
1N/A
1N/A/* Global Data */
1N/A
1N/A#define MY_CXT_KEY "${module}::_guts" XS_VERSION
1N/A
1N/Atypedef struct {
1N/A /* Put Global Data in here */
1N/A int dummy; /* you can access this elsewhere as MY_CXT.dummy */
1N/A} my_cxt_t;
1N/A
1N/ASTART_MY_CXT
1N/A
1N/AEND
1N/A
1N/Amy %pointer_typedefs;
1N/Amy %struct_typedefs;
1N/A
1N/Asub td_is_pointer {
1N/A my $type = shift;
1N/A my $out = $pointer_typedefs{$type};
1N/A return $out if defined $out;
1N/A my $otype = $type;
1N/A $out = ($type =~ /\*$/);
1N/A # This converts only the guys which do not have trailing part in the typedef
1N/A if (not $out
1N/A and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1N/A $type = normalize_type($type);
1N/A print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1N/A if $opt_d;
1N/A $out = td_is_pointer($type);
1N/A }
1N/A return ($pointer_typedefs{$otype} = $out);
1N/A}
1N/A
1N/Asub td_is_struct {
1N/A my $type = shift;
1N/A my $out = $struct_typedefs{$type};
1N/A return $out if defined $out;
1N/A my $otype = $type;
1N/A $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1N/A # This converts only the guys which do not have trailing part in the typedef
1N/A if (not $out
1N/A and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1N/A $type = normalize_type($type);
1N/A print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1N/A if $opt_d;
1N/A $out = td_is_struct($type);
1N/A }
1N/A return ($struct_typedefs{$otype} = $out);
1N/A}
1N/A
1N/Aprint_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1N/A
1N/Aif( ! $opt_c ) {
1N/A # We write the "sample" files used when this module is built by perl without
1N/A # ExtUtils::Constant.
1N/A # h2xs will later check that these are the same as those generated by the
1N/A # code embedded into Makefile.PL
1N/A unless (-d $fallbackdirname) {
1N/A mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
1N/A }
1N/A warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
1N/A warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
1N/A my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
1N/A my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
1N/A WriteConstants ( C_FILE => $cfallback,
1N/A XS_FILE => $xsfallback,
1N/A DEFAULT_TYPE => $opt_t,
1N/A NAME => $module,
1N/A NAMES => \@const_names,
1N/A );
1N/A print XS "#include \"$constscfname\"\n";
1N/A}
1N/A
1N/A
1N/Amy $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1N/A
1N/A# Now switch from C to XS by issuing the first MODULE declaration:
1N/Aprint XS <<"END";
1N/A
1N/AMODULE = $module PACKAGE = $module $prefix
1N/A
1N/AEND
1N/A
1N/A# If a constant() function was #included then output a corresponding
1N/A# XS declaration:
1N/Aprint XS "INCLUDE: $constsxsfname\n" unless $opt_c;
1N/A
1N/Aprint XS <<"END" if $opt_g;
1N/A
1N/ABOOT:
1N/A{
1N/A MY_CXT_INIT;
1N/A /* If any of the fields in the my_cxt_t struct need
1N/A to be initialised, do it here.
1N/A */
1N/A}
1N/A
1N/AEND
1N/A
1N/Aforeach (sort keys %const_xsub) {
1N/A print XS <<"END";
1N/Achar *
1N/A$_()
1N/A
1N/A CODE:
1N/A#ifdef $_
1N/A RETVAL = $_;
1N/A#else
1N/A croak("Your vendor has not defined the $module macro $_");
1N/A#endif
1N/A
1N/A OUTPUT:
1N/A RETVAL
1N/A
1N/AEND
1N/A}
1N/A
1N/Amy %seen_decl;
1N/Amy %typemap;
1N/A
1N/Asub print_decl {
1N/A my $fh = shift;
1N/A my $decl = shift;
1N/A my ($type, $name, $args) = @$decl;
1N/A return if $seen_decl{$name}++; # Need to do the same for docs as well?
1N/A
1N/A my @argnames = map {$_->[1]} @$args;
1N/A my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1N/A if ($opt_k) {
1N/A s/^\s*const\b\s*// for @argtypes;
1N/A }
1N/A my @argarrays = map { $_->[4] || '' } @$args;
1N/A my $numargs = @$args;
1N/A if ($numargs and $argtypes[-1] eq '...') {
1N/A $numargs--;
1N/A $argnames[-1] = '...';
1N/A }
1N/A local $" = ', ';
1N/A $type = normalize_type($type, 1);
1N/A
1N/A print $fh <<"EOP";
1N/A
1N/A$type
1N/A$name(@argnames)
1N/AEOP
1N/A
1N/A for my $arg (0 .. $numargs - 1) {
1N/A print $fh <<"EOP";
1N/A $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1N/AEOP
1N/A }
1N/A}
1N/A
1N/Asub print_tievar_subs {
1N/A my($fh, $name, $type) = @_;
1N/A print $fh <<END;
1N/AI32
1N/A_get_$name(IV index, SV *sv) {
1N/A dSP;
1N/A PUSHMARK(SP);
1N/A XPUSHs(sv);
1N/A PUTBACK;
1N/A (void)call_pv("$module\::_get_$name", G_DISCARD);
1N/A return (I32)0;
1N/A}
1N/A
1N/AI32
1N/A_set_$name(IV index, SV *sv) {
1N/A dSP;
1N/A PUSHMARK(SP);
1N/A XPUSHs(sv);
1N/A PUTBACK;
1N/A (void)call_pv("$module\::_set_$name", G_DISCARD);
1N/A return (I32)0;
1N/A}
1N/A
1N/AEND
1N/A}
1N/A
1N/Asub print_tievar_xsubs {
1N/A my($fh, $name, $type) = @_;
1N/A print $fh <<END;
1N/Avoid
1N/A_tievar_$name(sv)
1N/A SV* sv
1N/A PREINIT:
1N/A struct ufuncs uf;
1N/A CODE:
1N/A uf.uf_val = &_get_$name;
1N/A uf.uf_set = &_set_$name;
1N/A uf.uf_index = (IV)&_get_$name;
1N/A sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1N/A
1N/Avoid
1N/A_get_$name(THIS)
1N/A $type THIS = NO_INIT
1N/A CODE:
1N/A THIS = $name;
1N/A OUTPUT:
1N/A SETMAGIC: DISABLE
1N/A THIS
1N/A
1N/Avoid
1N/A_set_$name(THIS)
1N/A $type THIS
1N/A CODE:
1N/A $name = THIS;
1N/A
1N/AEND
1N/A}
1N/A
1N/Asub print_accessors {
1N/A my($fh, $name, $struct) = @_;
1N/A return unless defined $struct && $name !~ /\s|_ANON/;
1N/A $name = normalize_type($name);
1N/A my $ptrname = normalize_type("$name *");
1N/A print $fh <<"EOF";
1N/A
1N/AMODULE = $module PACKAGE = ${name} $prefix
1N/A
1N/A$name *
1N/A_to_ptr(THIS)
1N/A $name THIS = NO_INIT
1N/A PROTOTYPE: \$
1N/A CODE:
1N/A if (sv_derived_from(ST(0), "$name")) {
1N/A STRLEN len;
1N/A char *s = SvPV((SV*)SvRV(ST(0)), len);
1N/A if (len != sizeof(THIS))
1N/A croak("Size \%d of packed data != expected \%d",
1N/A len, sizeof(THIS));
1N/A RETVAL = ($name *)s;
1N/A }
1N/A else
1N/A croak("THIS is not of type $name");
1N/A OUTPUT:
1N/A RETVAL
1N/A
1N/A$name
1N/Anew(CLASS)
1N/A char *CLASS = NO_INIT
1N/A PROTOTYPE: \$
1N/A CODE:
1N/A Zero((void*)&RETVAL, sizeof(RETVAL), char);
1N/A OUTPUT:
1N/A RETVAL
1N/A
1N/AMODULE = $module PACKAGE = ${name}Ptr $prefix
1N/A
1N/AEOF
1N/A my @items = @$struct;
1N/A while (@items) {
1N/A my $item = shift @items;
1N/A if ($item->[0] =~ /_ANON/) {
1N/A if (defined $item->[2]) {
1N/A push @items, map [
1N/A @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1N/A ], @{ $structs{$item->[0]} };
1N/A } else {
1N/A push @items, @{ $structs{$item->[0]} };
1N/A }
1N/A } else {
1N/A my $type = normalize_type($item->[0]);
1N/A my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1N/A print $fh <<"EOF";
1N/A$ttype
1N/A$item->[2](THIS, __value = NO_INIT)
1N/A $ptrname THIS
1N/A $type __value
1N/A PROTOTYPE: \$;\$
1N/A CODE:
1N/A if (items > 1)
1N/A THIS->$item->[-1] = __value;
1N/A RETVAL = @{[
1N/A $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1N/A ]};
1N/A OUTPUT:
1N/A RETVAL
1N/A
1N/AEOF
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub accessor_docs {
1N/A my($name, $struct) = @_;
1N/A return unless defined $struct && $name !~ /\s|_ANON/;
1N/A $name = normalize_type($name);
1N/A my $ptrname = $name . 'Ptr';
1N/A my @items = @$struct;
1N/A my @list;
1N/A while (@items) {
1N/A my $item = shift @items;
1N/A if ($item->[0] =~ /_ANON/) {
1N/A if (defined $item->[2]) {
1N/A push @items, map [
1N/A @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1N/A ], @{ $structs{$item->[0]} };
1N/A } else {
1N/A push @items, @{ $structs{$item->[0]} };
1N/A }
1N/A } else {
1N/A push @list, $item->[2];
1N/A }
1N/A }
1N/A my $methods = (join '(...)>, C<', @list) . '(...)';
1N/A
1N/A my $pod = <<"EOF";
1N/A#
1N/A#=head2 Object and class methods for C<$name>/C<$ptrname>
1N/A#
1N/A#The principal Perl representation of a C object of type C<$name> is an
1N/A#object of class C<$ptrname> which is a reference to an integer
1N/A#representation of a C pointer. To create such an object, one may use
1N/A#a combination
1N/A#
1N/A# my \$buffer = $name->new();
1N/A# my \$obj = \$buffer->_to_ptr();
1N/A#
1N/A#This exersizes the following two methods, and an additional class
1N/A#C<$name>, the internal representation of which is a reference to a
1N/A#packed string with the C structure. Keep in mind that \$buffer should
1N/A#better survive longer than \$obj.
1N/A#
1N/A#=over
1N/A#
1N/A#=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1N/A#
1N/A#Converts an object of type C<$name> to an object of type C<$ptrname>.
1N/A#
1N/A#=item C<$name-E<gt>new()>
1N/A#
1N/A#Creates an empty object of type C<$name>. The corresponding packed
1N/A#string is zeroed out.
1N/A#
1N/A#=item C<$methods>
1N/A#
1N/A#return the current value of the corresponding element if called
1N/A#without additional arguments. Set the element to the supplied value
1N/A#(and return the new value) if called with an additional argument.
1N/A#
1N/A#Applicable to objects of type C<$ptrname>.
1N/A#
1N/A#=back
1N/A#
1N/AEOF
1N/A $pod =~ s/^\#//gm;
1N/A return $pod;
1N/A}
1N/A
1N/A# Should be called before any actual call to normalize_type().
1N/Asub get_typemap {
1N/A # We do not want to read ./typemap by obvios reasons.
1N/A my @tm = qw(../../../typemap ../../typemap ../typemap);
1N/A my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1N/A unshift @tm, $stdtypemap;
1N/A my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1N/A
1N/A # Start with useful default values
1N/A $typemap{float} = 'T_NV';
1N/A
1N/A foreach my $typemap (@tm) {
1N/A next unless -e $typemap ;
1N/A # skip directories, binary files etc.
1N/A warn " Scanning $typemap\n";
1N/A warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1N/A unless -T $typemap ;
1N/A open(TYPEMAP, $typemap)
1N/A or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1N/A my $mode = 'Typemap';
1N/A while (<TYPEMAP>) {
1N/A next if /^\s*\#/;
1N/A if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1N/A elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1N/A elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1N/A elsif ($mode eq 'Typemap') {
1N/A next if /^\s*($|\#)/ ;
1N/A my ($type, $image);
1N/A if ( ($type, $image) =
1N/A /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1N/A # This may reference undefined functions:
1N/A and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1N/A $typemap{normalize_type($type)} = $image;
1N/A }
1N/A }
1N/A }
1N/A close(TYPEMAP) or die "Cannot close $typemap: $!";
1N/A }
1N/A %std_types = %types_seen;
1N/A %types_seen = ();
1N/A}
1N/A
1N/A
1N/Asub normalize_type { # Second arg: do not strip const's before \*
1N/A my $type = shift;
1N/A my $do_keep_deep_const = shift;
1N/A # If $do_keep_deep_const this is heuristical only
1N/A my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1N/A my $ignore_mods
1N/A = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1N/A if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1N/A $type =~ s/$ignore_mods//go;
1N/A }
1N/A else {
1N/A $type =~ s/$ignore_mods//go;
1N/A }
1N/A $type =~ s/([^\s\w])/ $1 /g;
1N/A $type =~ s/\s+$//;
1N/A $type =~ s/^\s+//;
1N/A $type =~ s/\s+/ /g;
1N/A $type =~ s/\* (?=\*)/*/g;
1N/A $type =~ s/\. \. \./.../g;
1N/A $type =~ s/ ,/,/g;
1N/A $types_seen{$type}++
1N/A unless $type eq '...' or $type eq 'void' or $std_types{$type};
1N/A $type;
1N/A}
1N/A
1N/Amy $need_opaque;
1N/A
1N/Asub assign_typemap_entry {
1N/A my $type = shift;
1N/A my $otype = $type;
1N/A my $entry;
1N/A if ($tmask and $type =~ /$tmask/) {
1N/A print "Type $type matches -o mask\n" if $opt_d;
1N/A $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1N/A }
1N/A elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1N/A $type = normalize_type $type;
1N/A print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1N/A $entry = assign_typemap_entry($type);
1N/A }
1N/A # XXX good do better if our UV happens to be long long
1N/A return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1N/A $entry ||= $typemap{$otype}
1N/A || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1N/A $typemap{$otype} = $entry;
1N/A $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1N/A return $entry;
1N/A}
1N/A
1N/Afor (@vdecls) {
1N/A print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1N/A}
1N/A
1N/Aif ($opt_x) {
1N/A for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1N/A if ($opt_a) {
1N/A while (my($name, $struct) = each %structs) {
1N/A print_accessors(\*XS, $name, $struct);
1N/A }
1N/A }
1N/A}
1N/A
1N/Aclose XS;
1N/A
1N/Aif (%types_seen) {
1N/A my $type;
1N/A warn "Writing $ext$modpname/typemap\n";
1N/A open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1N/A
1N/A for $type (sort keys %types_seen) {
1N/A my $entry = assign_typemap_entry $type;
1N/A print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1N/A }
1N/A
1N/A print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1N/A#############################################################################
1N/AINPUT
1N/AT_OPAQUE_STRUCT
1N/A if (sv_derived_from($arg, \"${ntype}\")) {
1N/A STRLEN len;
1N/A char *s = SvPV((SV*)SvRV($arg), len);
1N/A
1N/A if (len != sizeof($var))
1N/A croak(\"Size %d of packed data != expected %d\",
1N/A len, sizeof($var));
1N/A $var = *($type *)s;
1N/A }
1N/A else
1N/A croak(\"$var is not of type ${ntype}\")
1N/A#############################################################################
1N/AOUTPUT
1N/AT_OPAQUE_STRUCT
1N/A sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1N/AEOP
1N/A
1N/A close TM or die "Cannot close typemap file for write: $!";
1N/A}
1N/A
1N/A} # if( ! $opt_X )
1N/A
1N/Awarn "Writing $ext$modpname/Makefile.PL\n";
1N/Aopen(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1N/A
1N/Amy $prereq_pm;
1N/A
1N/Aif ( $compat_version < 5.00702 and $new_test )
1N/A{
1N/A $prereq_pm = q%'Test::More' => 0%;
1N/A}
1N/Aelse
1N/A{
1N/A $prereq_pm = '';
1N/A}
1N/A
1N/Aprint PL <<"END";
1N/Ause $compat_version;
1N/Ause ExtUtils::MakeMaker;
1N/A# See lib/ExtUtils/MakeMaker.pm for details of how to influence
1N/A# the contents of the Makefile that is written.
1N/AWriteMakefile(
1N/A NAME => '$module',
1N/A VERSION_FROM => '$modpmname', # finds \$VERSION
1N/A PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
1N/A (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
1N/A (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
1N/A AUTHOR => '$author <$email>') : ()),
1N/AEND
1N/Aif (!$opt_X) { # print C stuff, unless XS is disabled
1N/A $opt_F = '' unless defined $opt_F;
1N/A my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1N/A my $Ihelp = ($I ? '-I. ' : '');
1N/A my $Icomment = ($I ? '' : <<EOC);
1N/A # Insert -I. if you add *.h files later:
1N/AEOC
1N/A
1N/A print PL <<END;
1N/A LIBS => ['$extralibs'], # e.g., '-lm'
1N/A DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1N/A$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1N/AEND
1N/A
1N/A my $C = grep {$_ ne "$modfname.c"}
1N/A (glob '*.c'), (glob '*.cc'), (glob '*.C');
1N/A my $Cpre = ($C ? '' : '# ');
1N/A my $Ccomment = ($C ? '' : <<EOC);
1N/A # Un-comment this if you add C files to link with later:
1N/AEOC
1N/A
1N/A print PL <<END;
1N/A$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
1N/AEND
1N/A} # ' # Grr
1N/Aprint PL ");\n";
1N/Aif (!$opt_c) {
1N/A my $generate_code =
1N/A WriteMakefileSnippet ( C_FILE => $constscfname,
1N/A XS_FILE => $constsxsfname,
1N/A DEFAULT_TYPE => $opt_t,
1N/A NAME => $module,
1N/A NAMES => \@const_names,
1N/A );
1N/A print PL <<"END";
1N/Aif (eval {require ExtUtils::Constant; 1}) {
1N/A # If you edit these definitions to change the constants used by this module,
1N/A # you will need to use the generated $constscfname and $constsxsfname
1N/A # files to replace their "fallback" counterparts before distributing your
1N/A # changes.
1N/A$generate_code
1N/A}
1N/Aelse {
1N/A use File::Copy;
1N/A use File::Spec;
1N/A foreach my \$file ('$constscfname', '$constsxsfname') {
1N/A my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
1N/A copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
1N/A }
1N/A}
1N/AEND
1N/A
1N/A eval $generate_code;
1N/A if ($@) {
1N/A warn <<"EOM";
1N/AAttempting to test constant code in $ext$modpname/Makefile.PL:
1N/A$generate_code
1N/A__END__
1N/Agave unexpected error $@
1N/APlease report the circumstances of this bug in h2xs version $H2XS_VERSION
1N/Ausing the perlbug script.
1N/AEOM
1N/A } else {
1N/A my $fail;
1N/A
1N/A foreach my $file ($constscfname, $constsxsfname) {
1N/A my $fallback = File::Spec->catfile($fallbackdirname, $file);
1N/A if (compare($file, $fallback)) {
1N/A warn << "EOM";
1N/AFiles "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
1N/AEOM
1N/A $fail++;
1N/A }
1N/A }
1N/A if ($fail) {
1N/A warn fill ('','', <<"EOM") . "\n";
1N/AIt appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1N/Athe files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
1N/Acorrectly.
1N/A
1N/APlease report the circumstances of this bug in h2xs version $H2XS_VERSION
1N/Ausing the perlbug script.
1N/AEOM
1N/A } else {
1N/A unlink $constscfname, $constsxsfname;
1N/A }
1N/A }
1N/A}
1N/Aclose(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1N/A
1N/A# Create a simple README since this is a CPAN requirement
1N/A# and it doesnt hurt to have one
1N/Awarn "Writing $ext$modpname/README\n";
1N/Aopen(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1N/Amy $thisyear = (gmtime)[5] + 1900;
1N/Amy $rmhead = "$modpname version $TEMPLATE_VERSION";
1N/Amy $rmheadeq = "=" x length($rmhead);
1N/A
1N/Amy $rm_prereq;
1N/A
1N/Aif ( $compat_version < 5.00702 and $new_test )
1N/A{
1N/A $rm_prereq = 'Test::More';
1N/A}
1N/Aelse
1N/A{
1N/A $rm_prereq = 'blah blah blah';
1N/A}
1N/A
1N/Aprint RM <<_RMEND_;
1N/A$rmhead
1N/A$rmheadeq
1N/A
1N/AThe README is used to introduce the module and provide instructions on
1N/Ahow to install the module, any machine dependencies it may have (for
1N/Aexample C compilers and installed libraries) and any other information
1N/Athat should be provided before the module is installed.
1N/A
1N/AA README file is required for CPAN modules since CPAN extracts the
1N/AREADME file from a module distribution so that people browsing the
1N/Aarchive can use it get an idea of the modules uses. It is usually a
1N/Agood idea to provide version information here so that people can
1N/Adecide whether fixes for the module are worth downloading.
1N/A
1N/AINSTALLATION
1N/A
1N/ATo install this module type the following:
1N/A
1N/A perl Makefile.PL
1N/A make
1N/A make test
1N/A make install
1N/A
1N/ADEPENDENCIES
1N/A
1N/AThis module requires these other modules and libraries:
1N/A
1N/A $rm_prereq
1N/A
1N/ACOPYRIGHT AND LICENCE
1N/A
1N/APut the correct copyright and licence information here.
1N/A
1N/A$licence
1N/A
1N/A_RMEND_
1N/Aclose(RM) || die "Can't close $ext$modpname/README: $!\n";
1N/A
1N/Amy $testdir = "t";
1N/Amy $testfile = "$testdir/$modpname.t";
1N/Aunless (-d "$testdir") {
1N/A mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
1N/A}
1N/Awarn "Writing $ext$modpname/$testfile\n";
1N/Amy $tests = @const_names ? 2 : 1;
1N/A
1N/Aopen EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
1N/A
1N/Aprint EX <<_END_;
1N/A# Before `make install' is performed this script should be runnable with
1N/A# `make test'. After `make install' it should work as `perl $modpname.t'
1N/A
1N/A#########################
1N/A
1N/A# change 'tests => $tests' to 'tests => last_test_to_print';
1N/A
1N/A_END_
1N/A
1N/Amy $test_mod = 'Test::More';
1N/A
1N/Aif ( $old_test or ($compat_version < 5.007 and not $new_test ))
1N/A{
1N/A my $test_mod = 'Test';
1N/A
1N/A print EX <<_END_;
1N/Ause Test;
1N/ABEGIN { plan tests => $tests };
1N/Ause $module;
1N/Aok(1); # If we made it this far, we're ok.
1N/A
1N/A_END_
1N/A
1N/A if (@const_names) {
1N/A my $const_names = join " ", @const_names;
1N/A print EX <<'_END_';
1N/A
1N/Amy $fail;
1N/Aforeach my $constname (qw(
1N/A_END_
1N/A
1N/A print EX wrap ("\t", "\t", $const_names);
1N/A print EX (")) {\n");
1N/A
1N/A print EX <<_END_;
1N/A next if (eval "my \\\$a = \$constname; 1");
1N/A if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1N/A print "# pass: \$\@";
1N/A } else {
1N/A print "# fail: \$\@";
1N/A \$fail = 1;
1N/A }
1N/A}
1N/Aif (\$fail) {
1N/A print "not ok 2\\n";
1N/A} else {
1N/A print "ok 2\\n";
1N/A}
1N/A
1N/A_END_
1N/A }
1N/A}
1N/Aelse
1N/A{
1N/A print EX <<_END_;
1N/Ause Test::More tests => $tests;
1N/ABEGIN { use_ok('$module') };
1N/A
1N/A_END_
1N/A
1N/A if (@const_names) {
1N/A my $const_names = join " ", @const_names;
1N/A print EX <<'_END_';
1N/A
1N/Amy $fail = 0;
1N/Aforeach my $constname (qw(
1N/A_END_
1N/A
1N/A print EX wrap ("\t", "\t", $const_names);
1N/A print EX (")) {\n");
1N/A
1N/A print EX <<_END_;
1N/A next if (eval "my \\\$a = \$constname; 1");
1N/A if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1N/A print "# pass: \$\@";
1N/A } else {
1N/A print "# fail: \$\@";
1N/A \$fail = 1;
1N/A }
1N/A
1N/A}
1N/A
1N/Aok( \$fail == 0 , 'Constants' );
1N/A_END_
1N/A }
1N/A}
1N/A
1N/Aprint EX <<_END_;
1N/A#########################
1N/A
1N/A# Insert your test code below, the $test_mod module is use()ed here so read
1N/A# its man page ( perldoc $test_mod ) for help writing this test script.
1N/A
1N/A_END_
1N/A
1N/Aclose(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
1N/A
1N/Aunless ($opt_C) {
1N/A warn "Writing $ext$modpname/Changes\n";
1N/A $" = ' ';
1N/A open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1N/A @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1N/A print EX <<EOP;
1N/ARevision history for Perl extension $module.
1N/A
1N/A$TEMPLATE_VERSION @{[scalar localtime]}
1N/A\t- original version; created by h2xs $H2XS_VERSION with options
1N/A\t\t@ARGS
1N/A
1N/AEOP
1N/A close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
1N/A}
1N/A
1N/Awarn "Writing $ext$modpname/MANIFEST\n";
1N/Aopen(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1N/Amy @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
1N/Aif (!@files) {
1N/A eval {opendir(D,'.');};
1N/A unless ($@) { @files = readdir(D); closedir(D); }
1N/A}
1N/Aif (!@files) { @files = map {chomp && $_} `ls`; }
1N/Aif ($^O eq 'VMS') {
1N/A foreach (@files) {
1N/A # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1N/A s%\.$%%;
1N/A # Fix up for case-sensitive file systems
1N/A s/$modfname/$modfname/i && next;
1N/A $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1N/A $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1N/A }
1N/A}
1N/Aprint MANI join("\n",@files), "\n";
1N/Aclose MANI;
1N/A!NO!SUBS!
1N/A
1N/Aclose OUT or die "Can't close $file: $!";
1N/Achmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1N/Aexec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1N/Achdir $origdir;