summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/bin/h2xs.bat
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/bin/h2xs.bat')
-rwxr-xr-xMaster/tlpkg/tlperl/bin/h2xs.bat2203
1 files changed, 0 insertions, 2203 deletions
diff --git a/Master/tlpkg/tlperl/bin/h2xs.bat b/Master/tlpkg/tlperl/bin/h2xs.bat
deleted file mode 100755
index 136eeea2fad..00000000000
--- a/Master/tlpkg/tlperl/bin/h2xs.bat
+++ /dev/null
@@ -1,2203 +0,0 @@
-@rem = '--*-Perl-*--
-@echo off
-if "%OS%" == "Windows_NT" goto WinNT
-perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
-goto endofperl
-:WinNT
-perl -x -S %0 %*
-if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
-if %errorlevel% == 9009 echo You do not have Perl in your PATH.
-if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
-goto endofperl
-@rem ';
-#!perl
-#line 15
- eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
- if $running_under_some_shell;
-
-use warnings;
-
-=head1 NAME
-
-h2xs - convert .h C header files to Perl extensions
-
-=head1 SYNOPSIS
-
-B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
-
-B<h2xs> B<-h>|B<-?>|B<--help>
-
-=head1 DESCRIPTION
-
-I<h2xs> 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<module_name> will be used for the name of the extension. If
-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.
-
-In spite of its name, I<h2xs> may also be used to create a skeleton pure
-Perl module. See the B<-X> option.
-
-=head1 OPTIONS
-
-=over 5
-
-=item B<-A>, B<--omit-autoload>
-
-Omit all autoload facilities. This is the same as B<-c> but also
-removes the S<C<use AutoLoader>> statement from the .pm file.
-
-=item B<-B>, B<--beta-version>
-
-Use an alpha/beta style version number. Causes version number to
-be "0.00_01" unless B<-v> is specified.
-
-=item B<-C>, B<--omit-changes>
-
-Omits creation of the F<Changes> file, and adds a HISTORY section to
-the POD template.
-
-=item B<-F>, B<--cpp-flags>=I<addflags>
-
-Additional flags to specify to C preprocessor when scanning header for
-function declarations. Writes these options in the generated F<Makefile.PL>
-too.
-
-=item B<-M>, B<--func-mask>=I<regular expression>
-
-selects functions/macros to process.
-
-=item B<-O>, B<--overwrite-ok>
-
-Allows a pre-existing extension directory to be overwritten.
-
-=item B<-P>, B<--omit-pod>
-
-Omit the autogenerated stub POD section.
-
-=item B<-X>, B<--omit-XS>
-
-Omit the XS portion. Used to generate a skeleton pure Perl module.
-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<new>
-method to construct and return a new structure, initialised to zeroes.
-
-=item B<-b>, B<--compat-version>=I<version>
-
-Generates a .pm file which is backwards compatible with the specified
-perl version.
-
-For versions < 5.6.0, the changes are.
- - no use of 'our' (uses 'use vars' instead)
- - no 'use warnings'
-
-Specifying a compatibility version higher than the version of perl you
-are using to run h2xs will have no effect. If unspecified h2xs will default
-to compatibility with the version of perl you are using to run h2xs.
-
-=item B<-c>, B<--omit-constant>
-
-Omit C<constant()> from the .xs file and corresponding specialised
-C<AUTOLOAD> from the .pm file.
-
-=item B<-d>, B<--debugging>
-
-Turn on debugging messages.
-
-=item B<-e>, B<--omit-enums>=[I<regular expression>]
-
-If I<regular expression> is not given, skip all constants that are defined in
-a C enumeration. Otherwise skip only those constants that are defined in an
-enum whose name matches I<regular expression>.
-
-Since I<regular expression> is optional, make sure that this switch is followed
-by at least one other switch if you omit I<regular expression> and have some
-pending arguments such as header-file names. This is ok:
-
- h2xs -e -n Module::Foo foo.h
-
-This is not ok:
-
- h2xs -n Module::Foo -e foo.h
-
-In the latter, foo.h is taken as I<regular expression>.
-
-=item B<-f>, B<--force>
-
-Allows an extension to be created for a header even if that header is
-not found in standard include directories.
-
-=item B<-g>, B<--global>
-
-Include code for safely storing static data in the .xs file.
-Extensions that do no make use of static data can ignore this option.
-
-=item B<-h>, B<-?>, B<--help>
-
-Print the usage, help and version for this h2xs and exit.
-
-=item B<-k>, B<--omit-const-func>
-
-For function arguments declared as C<const>, omit the const attribute in the
-generated XS code.
-
-=item B<-m>, B<--gen-tied-var>
-
-B<Experimental>: 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<module_name>
-
-Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
-
-=item B<-o>, B<--opaque-re>=I<regular expression>
-
-Use "opaque" data type for the C types matched by the regular
-expression, even if these types are C<typedef>-equivalent to types
-from typemaps. Should not be used without B<-x>.
-
-This may be useful since, say, types which are C<typedef>-equivalent
-to integers may represent OS-related handles, and one may want to work
-with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
-Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
-types.
-
-The type-to-match is whitewashed (except for commas, which have no
-whitespace before them, and multiple C<*> which have no whitespace
-between them).
-
-=item B<-p>, B<--remove-prefix>=I<prefix>
-
-Specify a prefix which should be removed from the Perl function names,
-e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
-the prefix from functions that are autoloaded via the C<constant()>
-mechanism.
-
-=item B<-s>, B<--const-subs>=I<sub1,sub2>
-
-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<char *>, e.g.,
-S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
-
-=item B<-t>, B<--default-type>=I<type>
-
-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<h2xs> 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<Test::More> rather than C<Test> which is the default for versions before
-5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
-C<Makefile.PL>.
-
-=item B<--use-old-tests>
-
-Will force the generation of test code that uses the older C<Test> module.
-
-=item B<--skip-exporter>
-
-Do not use C<Exporter> and/or export any symbol.
-
-=item B<--skip-ppport>
-
-Do not use C<Devel::PPPort>: no portability to older version.
-
-=item B<--skip-autoloader>
-
-Do not use the module C<AutoLoader>; but keep the constant() function
-and C<sub AUTOLOAD> for constants.
-
-=item B<--skip-strict>
-
-Do not use the pragma C<strict>.
-
-=item B<--skip-warnings>
-
-Do not use the pragma C<warnings>.
-
-=item B<-v>, B<--version>=I<version>
-
-Specify a version number for this extension. This version number is added
-to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
-The version specified should be numeric.
-
-=item B<-x>, B<--autogen-xsubs>
-
-Automatically generate XSUBs basing on function declarations in the
-header file. The package C<C::Scan> should be installed. If this
-option is specified, the name of the header file may look like
-C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
-string, but XSUBs are emitted only for the declarations included from
-file NAME2.
-
-Note that some types of arguments/return-values for functions may
-result in XSUB-declarations/typemap-entries which need
-hand-editing. Such may be objects which cannot be converted from/to a
-pointer (like C<long long>), pointers to functions, or arrays. See
-also the section on L<LIMITATIONS of B<-x>>.
-
-=back
-
-=head1 EXAMPLES
-
-
- # Default behavior, extension is Rusers
- h2xs rpcsvc/rusers
-
- # Same, but extension is RUSERS
- h2xs -n RUSERS rpcsvc/rusers
-
- # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
- h2xs rpcsvc::rusers
-
- # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
- h2xs -n ONC::RPC rpcsvc/rusers
-
- # Without constant() or AUTOLOAD
- h2xs -c rpcsvc/rusers
-
- # Creates templates for an extension named RPC
- h2xs -cfn RPC
-
- # Extension is ONC::RPC.
- h2xs -cfn ONC::RPC
-
- # Extension is a pure Perl module with no XS code.
- h2xs -X My::Module
-
- # Extension is Lib::Foo which works at least with Perl5.005_03.
- # Constants are created for all #defines and enums h2xs can find
- # in foo.h.
- h2xs -b 5.5.3 -n Lib::Foo foo.h
-
- # Extension is Lib::Foo which works at least with Perl5.005_03.
- # Constants are created for all #defines but only for enums
- # whose names do not start with 'bar_'.
- h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
-
- # Makefile.PL will look for library -lrpc in
- # additional directory /opt/net/lib
- h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
-
- # Extension is DCE::rgynbase
- # prefix "sec_rgy_" is dropped from perl function names
- h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
-
- # Extension is DCE::rgynbase
- # prefix "sec_rgy_" is dropped from perl function names
- # subroutines are created for sec_rgy_wildcard_name and
- # sec_rgy_wildcard_sid
- h2xs -n DCE::rgynbase -p sec_rgy_ \
- -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
-
- # Make XS without defines in perl.h, but with function declarations
- # visible from perl.h. Name of the extension is perl1.
- # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
- # Extra backslashes below because the string is passed to shell.
- # Note that a directory with perl header files would
- # be added automatically to include path.
- h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
-
- # Same with function declaration in proto.h as visible from perl.h.
- h2xs -xAn perl2 perl.h,proto.h
-
- # Same but 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 accessible in Perl? The example below
-assumes that the header files are F<interface_simple.h> and
-I<interface_hairy.h>, and you want the perl module be named as
-C<Ext::Ension>. 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<Ext/Ension>.
-
-=item Copy C files
-
-Copy your header files and C files to this directory F<Ext/Ension>.
-
-=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<after> 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<make dist> 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
-
-No environment variables are used.
-
-=head1 AUTHOR
-
-Larry Wall and others
-
-=head1 SEE ALSO
-
-L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
-
-=head1 DIAGNOSTICS
-
-The usual warnings if it cannot read or write the files involved.
-
-=head1 LIMITATIONS of B<-x>
-
-F<h2xs> would not distinguish whether an argument to a C function
-which is of the form, say, C<int *>, 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<n> is an input parameter.
-
-Additionally, F<h2xs> 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<perlxs> and L<perlxstut> for additional details.
-
-=cut
-
-# ' # Grr
-use strict;
-
-
-my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$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 (WriteConstants WriteMakefileSnippet autoload);
-use File::Compare;
-use File::Path;
-
-sub usage {
- warn "@_\n" if @_;
- die <<EOFUSAGE;
-h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
-version: $H2XS_VERSION
-OPTIONS:
- -A, --omit-autoload Omit all autoloading facilities (implies -c).
- -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
- -C, --omit-changes Omit creating the Changes file, add HISTORY heading
- to stub POD.
- -F, --cpp-flags Additional flags for C preprocessor/compile.
- -M, --func-mask Mask to select C functions/macros
- (default is select all).
- -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
- -P, --omit-pod Omit the stub POD section.
- -X, --omit-XS Omit the XS portion (implies both -c and -f).
- -a, --gen-accessors Generate get/set accessors for struct and union members
- (used with -x).
- -b, --compat-version Specify a perl version to be backwards compatibile with.
- -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
- from the XS file.
- -d, --debugging Turn on debugging messages.
- -e, --omit-enums Omit constants from enums in the constant() function.
- If a pattern is given, only the matching enums are
- ignored.
- -f, --force Force creation of the extension even if the C header
- does not exist.
- -g, --global Include code for safely storing static data in the .xs file.
- -h, -?, --help Display this help message.
- -k, --omit-const-func Omit 'const' attribute on function arguments
- (used with -x).
- -m, --gen-tied-var Generate tied variables for access to declared
- variables.
- -n, --name Specify a name to use for the extension (recommended).
- -o, --opaque-re Regular expression for \"opaque\" types.
- -p, --remove-prefix Specify a prefix which should be removed from the
- Perl function names.
- -s, --const-subs Create subroutines for specified macros.
- -t, --default-type Default type for autoloaded constants (default is IV).
- --use-new-tests Use Test::More in backward compatible modules.
- --use-old-tests Use the module Test rather than Test::More.
- --skip-exporter Do not export symbols.
- --skip-ppport Do not use portability layer.
- --skip-autoloader Do not use the module C<AutoLoader>.
- --skip-strict Do not use the pragma C<strict>.
- --skip-warnings Do not use the pragma C<warnings>.
- -v, --version Specify a version number for this extension.
- -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
- --use-xsloader Use XSLoader in backward compatible modules (ignored
- when used with -X).
-
-extra_libraries
- are any libraries that might be needed for loading the
- extension, e.g. -lm would try to link in the math library.
-EOFUSAGE
-}
-
-my ($opt_A,
- $opt_B,
- $opt_C,
- $opt_F,
- $opt_M,
- $opt_O,
- $opt_P,
- $opt_X,
- $opt_a,
- $opt_c,
- $opt_d,
- $opt_e,
- $opt_f,
- $opt_g,
- $opt_h,
- $opt_k,
- $opt_m,
- $opt_n,
- $opt_o,
- $opt_p,
- $opt_s,
- $opt_v,
- $opt_x,
- $opt_b,
- $opt_t,
- $new_test,
- $old_test,
- $skip_exporter,
- $skip_ppport,
- $skip_autoloader,
- $skip_strict,
- $skip_warnings,
- $use_xsloader
- );
-
-Getopt::Long::Configure('bundling');
-Getopt::Long::Configure('pass_through');
-
-my %options = (
- 'omit-autoload|A' => \$opt_A,
- 'beta-version|B' => \$opt_B,
- 'omit-changes|C' => \$opt_C,
- 'cpp-flags|F=s' => \$opt_F,
- 'func-mask|M=s' => \$opt_M,
- 'overwrite_ok|O' => \$opt_O,
- 'omit-pod|P' => \$opt_P,
- 'omit-XS|X' => \$opt_X,
- 'gen-accessors|a' => \$opt_a,
- 'compat-version|b=s' => \$opt_b,
- 'omit-constant|c' => \$opt_c,
- 'debugging|d' => \$opt_d,
- 'omit-enums|e:s' => \$opt_e,
- 'force|f' => \$opt_f,
- 'global|g' => \$opt_g,
- 'help|h|?' => \$opt_h,
- 'omit-const-func|k' => \$opt_k,
- 'gen-tied-var|m' => \$opt_m,
- 'name|n=s' => \$opt_n,
- 'opaque-re|o=s' => \$opt_o,
- 'remove-prefix|p=s' => \$opt_p,
- 'const-subs|s=s' => \$opt_s,
- 'default-type|t=s' => \$opt_t,
- 'version|v=s' => \$opt_v,
- 'autogen-xsubs|x' => \$opt_x,
- 'use-new-tests' => \$new_test,
- 'use-old-tests' => \$old_test,
- 'skip-exporter' => \$skip_exporter,
- 'skip-ppport' => \$skip_ppport,
- 'skip-autoloader' => \$skip_autoloader,
- 'skip-warnings' => \$skip_warnings,
- 'skip-strict' => \$skip_strict,
- 'use-xsloader' => \$use_xsloader,
- );
-
-GetOptions(%options) || usage;
-
-usage if $opt_h;
-
-if( $opt_b ){
- usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
- $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ ||
- usage "You must provide the backwards compatibility version in X.Y.Z form. "
- . "(i.e. 5.5.0)\n";
- my ($maj,$min,$sub) = ($1,$2,$3);
- if ($maj < 5 || ($maj == 5 && $min < 6)) {
- $compat_version =
- $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
- sprintf("%d.%03d", $maj,$min);
- } else {
- $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub);
- }
-} else {
- my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
- $sub ||= 0;
- warn sprintf <<'EOF', $maj,$min,$sub;
-Defaulting to backwards compatibility with perl %d.%d.%d
-If you intend this module to be compatible with earlier perl versions, please
-specify a minimum perl version with the -b option.
-
-EOF
-}
-
-if( $opt_B ){
- $TEMPLATE_VERSION = '0.00_01';
-}
-
-if( $opt_v ){
- $TEMPLATE_VERSION = $opt_v;
-
- # check if it is numeric
- my $temp_version = $TEMPLATE_VERSION;
- my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
- my $notnum;
- {
- local $SIG{__WARN__} = sub { $notnum = 1 };
- use warnings 'numeric';
- $temp_version = 0+$temp_version;
- }
-
- if ($notnum) {
- my $module = $opt_n || 'Your::Module';
- warn <<"EOF";
-You have specified a non-numeric version. Unless you supply an
-appropriate VERSION class method, users may not be able to specify a
-minimum required version with C<use $module versionnum>.
-
-EOF
- }
- else {
- $opt_B = $beta_version;
- }
-}
-
-# -A implies -c.
-$skip_autoloader = $opt_c = 1 if $opt_A;
-
-# -X implies -c and -f
-$opt_c = $opt_f = 1 if $opt_X;
-
-$opt_t ||= 'IV';
-
-my %const_xsub;
-%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
-
-my $extralibs = '';
-
-my @path_h;
-
-while (my $arg = shift) {
- if ($arg =~ /^-l/i) {
- $extralibs .= "$arg ";
- next;
- }
- last if $extralibs;
- push(@path_h, $arg);
-}
-
-usage "Must supply header file or module name\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 <<EOD;
-C::Scan required if you use -x option.
-To install C::Scan, execute
- perl -MCPAN -e "install C::Scan"
-EOD
- unless ($tmask_all) {
- $C::Scan::VERSION >= 0.70
- or die <<EOD;
-C::Scan v. 0.70 or later required unless you use -o . option.
-You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
-To install C::Scan, execute
- perl -MCPAN -e "install C::Scan"
-EOD
- }
- if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
- die <<EOD;
-C::Scan v. 0.73 or later required to use -m or -a options.
-You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
-To install C::Scan, execute
- perl -MCPAN -e "install C::Scan"
-EOD
- }
-}
-elsif ($opt_o or $opt_F) {
- warn <<EOD if $opt_o;
-Option -o does not make sense without -x.
-EOD
- warn <<EOD if $opt_F and $opt_X ;
-Option -F does not make sense with -X.
-EOD
-}
-
-my @path_h_ini = @path_h;
-my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
-
-my $module = $opt_n;
-
-if( @path_h ){
- use File::Spec;
- my @paths;
- my $pre_sub_tri_graphs = 1;
- if ($^O eq 'VMS') { # Consider overrides of default location
- # XXXX This is not equivalent to what the older version did:
- # it was looking at $hadsys header-file per header-file...
- my($hadsys) = grep s!^sys/!!i , @path_h;
- @paths = qw( Sys$Library VAXC$Include );
- push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
- push @paths, qw( DECC$Library_Include DECC$System_Include );
- }
- else {
- @paths = (File::Spec->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 =~ s#::#/#g && $opt_n ){
- warn "Nesting of headerfile ignored with -n\n";
- }
- $path_h .= ".h" unless $path_h =~ /\.h$/;
- my $fullpath = $path_h;
- $path_h =~ s/,.*$// if $opt_x;
- $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;
- $fullpath{$path_h} = $fullpath;
- } else {
- (my $epath = $module) =~ s,::,/,g;
- $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
- $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
- $path_h = $tmp_path_h; # Used during -x
- push @dirs, $epath;
- }
- }
-
- if (!$opt_c) {
- die "Can't find $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 (<CH>) {
- 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; # | ??<| {|
- s/\?\?>/}/g; # | ??>| }|
- }
- if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
- 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";
- }
- }
- $prefixless{$def} = $_;
- if (!$fmask or /$fmask/) {
- print "... Passes mask of -M.\n" if $opt_d and $fmask;
- $const_names{$_}++;
- }
- }
- }
- if (defined $opt_e and !$opt_e) {
- close(CH);
- }
- else {
- # Work from miniperl too - on "normal" systems
- my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
- seek CH, 0, $SEEK_SET;
- my $src = do { local $/; <CH> };
- close CH;
- no warnings 'uninitialized';
-
- # Remove C and C++ comments
- $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
- $src =~ s#//.*$##gm;
-
- while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
- my ($enum_name, $enum_body) = ($1, $2);
- # skip enums matching $opt_e
- next if $opt_e && $enum_name =~ /$opt_e/;
- my $val = 0;
- for my $item (split /,/, $enum_body) {
- next if $item =~ /\A\s*\Z/;
- my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
- $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
- $seen_define{$key} = $val;
- $const_names{$key} = { name => $key, macro => 1 };
- }
- } # while (...)
- } # if (!defined $opt_e or $opt_e)
- }
- }
-}
-
-# Save current directory so that C::Scan can use it
-my $cwd = File::Spec->rel2abs( File::Spec->curdir );
-
-# As Ilya suggested, use a name that contains - and then it can't clash with
-# the names of any packages. A directory 'fallback' will clash with any
-# new pragmata down the fallback:: tree, but that seems unlikely.
-my $constscfname = 'const-c.inc';
-my $constsxsfname = 'const-xs.inc';
-my $fallbackdirname = 'fallback';
-
-my $ext = chdir 'ext' ? 'ext/' : '';
-
-my @modparts = split(/::/,$module);
-my $modpname = join('-', @modparts);
-my $modfname = pop @modparts;
-my $modpmdir = join '/', 'lib', @modparts;
-my $modpmname = join '/', $modpmdir, $modfname.'.pm';
-
-if ($opt_O) {
- warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
-}
-else {
- die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
-}
--d "$modpname" || mkpath([$modpname], 0, 0775);
-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
- unless ($skip_ppport) {
- require Devel::PPPort;
- warn "Writing $ext$modpname/ppport.h\n";
- Devel::PPPort::WriteFile('ppport.h')
- || die "Can't create $ext$modpname/ppport.h: $!\n";
- }
- open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
- if ($opt_x) {
- 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", $cwd]);
-
- $c->get('keywords')->{'__restrict'} = 1;
-
- 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(?<!struct )(?:@good_td)\b) if @good_td;
- }
- %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
- if ($fmask) {
- my @good;
- for my $i (0..$#$fdecls_parsed) {
- next unless $fdecls_parsed->[$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
- if defined $opt_p;
- # 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_specs, @const_names);
-
-for (sort(keys(%const_names))) {
- my $v = $const_names{$_};
-
- push(@const_specs, ref($v) ? $v : $_);
- push(@const_names, $_);
-}
-
--d $modpmdir || mkpath([$modpmdir], 0, 0775);
-open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
-
-$" = "\n\t";
-warn "Writing $ext$modpname/$modpmname\n";
-
-print PM <<"END";
-package $module;
-
-use $compat_version;
-END
-
-print PM <<"END" unless $skip_strict;
-use strict;
-END
-
-print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
-
-unless( $opt_X || $opt_c || $opt_A ){
- # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
- # will want Carp.
- print PM <<'END';
-use Carp;
-END
-}
-
-print PM <<'END' unless $skip_exporter;
-
-require Exporter;
-END
-
-my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
-print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
-require DynaLoader;
-END
-
-
-# Are we using AutoLoader or not?
-unless ($skip_autoloader) { # no autoloader whatsoever.
- unless ($opt_c) { # we're doing the AUTOLOAD
- print PM "use AutoLoader;\n";
- }
- else {
- print PM "use AutoLoader qw(AUTOLOAD);\n"
- }
-}
-
-if ( $compat_version < 5.006 ) {
- my $vars = '$VERSION @ISA';
- $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
- $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
- $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
- print PM "use vars qw($vars);";
-}
-
-# Determine @ISA.
-my @modISA;
-push @modISA, 'Exporter' unless $skip_exporter;
-push @modISA, 'DynaLoader' if $use_Dyna; # no XS
-my $myISA = "our \@ISA = qw(@modISA);";
-$myISA =~ s/^our // if $compat_version < 5.006;
-
-print PM "\n$myISA\n\n";
-
-my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
-
-my $tmp='';
-$tmp .= <<"END" unless $skip_exporter;
-# Items to export into callers namespace by default. Note: do not export
-# names by default without a very good reason. Use EXPORT_OK instead.
-# Do not simply export all your public functions/methods/constants.
-
-# 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
-);
-
-END
-
-$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
-if ($opt_B) {
- $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
- $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
-}
-$tmp .= "\n";
-
-$tmp =~ s/^our //mg if $compat_version < 5.006;
-print PM $tmp;
-
-if (@vdecls) {
- printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
-}
-
-
-print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
-
-if( ! $opt_X ){ # print bootstrap, unless XS is disabled
- if ($use_Dyna) {
- $tmp = <<"END";
-bootstrap $module \$VERSION;
-END
- } else {
- $tmp = <<"END";
-require XSLoader;
-XSLoader::load('$module', \$VERSION);
-END
- }
- $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
- print PM $tmp;
-}
-
-# tying the variables can happen only after bootstrap
-if (@vdecls) {
- printf PM <<END;
-{
-@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
-}
-
-END
-}
-
-my $after;
-if( $opt_P ){ # if POD is disabled
- $after = '__END__';
-}
-else {
- $after = '=cut';
-}
-
-print PM <<"END";
-
-# Preloaded methods go here.
-END
-
-print PM <<"END" unless $opt_A;
-
-# Autoload methods go after $after, and are processed by the autosplit program.
-END
-
-print PM <<"END";
-
-1;
-__END__
-END
-
-my ($email,$author,$licence);
-
-eval {
- my $username;
- ($username,$author) = (getpwuid($>))[0,6];
- if (defined $username && defined $author) {
- $author =~ s/,.*$//; # in case of sub fields
- my $domain = $Config{'mydomain'};
- $domain =~ s/^\.//;
- $email = "$username\@$domain";
- }
- };
-
-$author =~ s/'/\\'/g if defined $author;
-$author ||= "A. U. Thor";
-$email ||= 'a.u.thor@a.galaxy.far.far.away';
-
-$licence = sprintf << "DEFAULT", $^V;
-Copyright (C) ${\(1900 + (localtime) [5])} by $author
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself, either Perl version %vd or,
-at your option, any later version of Perl 5 you may have available.
-DEFAULT
-
-my $revhist = '';
-$revhist = <<EOT if $opt_C;
-#
-#=head1 HISTORY
-#
-#=over 8
-#
-#=item $TEMPLATE_VERSION
-#
-#Original version; created by h2xs $H2XS_VERSION with options
-#
-# @ARGS
-#
-#=back
-#
-EOT
-
-my $exp_doc = $skip_exporter ? '' : <<EOD;
-#
-#=head2 EXPORT
-#
-#None by default.
-#
-EOD
-
-if (@const_names and not $opt_P) {
- $exp_doc .= <<EOD unless $skip_exporter;
-#=head2 Exportable constants
-#
-# @{[join "\n ", @const_names]}
-#
-EOD
-}
-
-if (defined $fdecls and @$fdecls and not $opt_P) {
- $exp_doc .= <<EOD unless $skip_exporter;
-#=head2 Exportable functions
-#
-EOD
-
-# $exp_doc .= <<EOD if $opt_p;
-#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
-#
-#EOD
- $exp_doc .= <<EOD unless $skip_exporter;
-# @{[join "\n ", @known_fnames{@fnames}]}
-#
-EOD
-}
-
-my $meth_doc = '';
-
-if ($opt_x && $opt_a) {
- my($name, $struct);
- $meth_doc .= accessor_docs($name, $struct)
- while ($name, $struct) = each %structs;
-}
-
-# Prefix the default licence with hash symbols.
-# Is this just cargo cult - it seems that the first thing that happens to this
-# block is that all the hashes are then s///g out.
-my $licence_hash = $licence;
-$licence_hash =~ s/^/#/gm;
-
-my $pod;
-$pod = <<"END" unless $opt_P;
-## Below is stub documentation for your module. You'd better edit it!
-#
-#=head1 NAME
-#
-#$module - Perl extension for blah blah blah
-#
-#=head1 SYNOPSIS
-#
-# use $module;
-# blah blah blah
-#
-#=head1 DESCRIPTION
-#
-#Stub documentation for $module, created by h2xs. It looks like the
-#author of the extension was negligent enough to leave the stub
-#unedited.
-#
-#Blah blah blah.
-$exp_doc$meth_doc$revhist
-#
-#=head1 SEE ALSO
-#
-#Mention other useful documentation such as the documentation of
-#related modules or operating system documentation (such as man pages
-#in UNIX), or any relevant external documentation such as RFCs or
-#standards.
-#
-#If you have a mailing list set up for your module, mention it here.
-#
-#If you have a web site set up for your module, mention it here.
-#
-#=head1 AUTHOR
-#
-#$author, E<lt>${email}E<gt>
-#
-#=head1 COPYRIGHT AND LICENSE
-#
-$licence_hash
-#
-#=cut
-END
-
-$pod =~ s/^\#//gm unless $opt_P;
-print PM $pod unless $opt_P;
-
-close PM;
-
-
-if( ! $opt_X ){ # print XS, unless it is disabled
-warn "Writing $ext$modpname/$modfname.xs\n";
-
-print XS <<"END";
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-END
-
-print XS <<"END" unless $skip_ppport;
-#include "ppport.h"
-
-END
-
-if( @path_h ){
- foreach my $path_h (@path_h_ini) {
- my($h) = $path_h;
- $h =~ s#^/usr/include/##;
- if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
- print XS qq{#include <$h>\n};
- }
- print XS "\n";
-}
-
-print XS <<"END" if $opt_g;
-
-/* Global Data */
-
-#define MY_CXT_KEY "${module}::_guts" XS_VERSION
-
-typedef struct {
- /* Put Global Data in here */
- int dummy; /* you can access this elsewhere as MY_CXT.dummy */
-} my_cxt_t;
-
-START_MY_CXT
-
-END
-
-my %pointer_typedefs;
-my %struct_typedefs;
-
-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);
-}
-
-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);
-}
-
-print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
-
-if( ! $opt_c ) {
- # We write the "sample" files used when this module is built by perl without
- # ExtUtils::Constant.
- # h2xs will later check that these are the same as those generated by the
- # code embedded into Makefile.PL
- unless (-d $fallbackdirname) {
- mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
- }
- warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
- warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
- my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
- my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
- WriteConstants ( C_FILE => $cfallback,
- XS_FILE => $xsfallback,
- DEFAULT_TYPE => $opt_t,
- NAME => $module,
- NAMES => \@const_specs,
- );
- print XS "#include \"$constscfname\"\n";
-}
-
-
-my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
-
-# Now switch from C to XS by issuing the first MODULE declaration:
-print XS <<"END";
-
-MODULE = $module PACKAGE = $module $prefix
-
-END
-
-# If a constant() function was #included then output a corresponding
-# XS declaration:
-print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
-
-print XS <<"END" if $opt_g;
-
-BOOT:
-{
- MY_CXT_INIT;
- /* If any of the fields in the my_cxt_t struct need
- to be initialised, do it here.
- */
-}
-
-END
-
-foreach (sort keys %const_xsub) {
- print XS <<"END";
-char *
-$_()
-
- CODE:
-#ifdef $_
- RETVAL = $_;
-#else
- croak("Your vendor has not defined the $module macro $_");
-#endif
-
- OUTPUT:
- RETVAL
-
-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], 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, 1);
-
- print $fh <<"EOP";
-
-$type
-$name(@argnames)
-EOP
-
- for my $arg (0 .. $numargs - 1) {
- print $fh <<"EOP";
- $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
-EOP
- }
-}
-
-sub print_tievar_subs {
- my($fh, $name, $type) = @_;
- print $fh <<END;
-I32
-_get_$name(IV index, SV *sv) {
- dSP;
- PUSHMARK(SP);
- XPUSHs(sv);
- PUTBACK;
- (void)call_pv("$module\::_get_$name", G_DISCARD);
- return (I32)0;
-}
-
-I32
-_set_$name(IV index, SV *sv) {
- dSP;
- PUSHMARK(SP);
- XPUSHs(sv);
- PUTBACK;
- (void)call_pv("$module\::_set_$name", G_DISCARD);
- return (I32)0;
-}
-
-END
-}
-
-sub print_tievar_xsubs {
- my($fh, $name, $type) = @_;
- print $fh <<END;
-void
-_tievar_$name(sv)
- SV* sv
- PREINIT:
- struct ufuncs uf;
- CODE:
- uf.uf_val = &_get_$name;
- uf.uf_set = &_set_$name;
- uf.uf_index = (IV)&_get_$name;
- sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
-
-void
-_get_$name(THIS)
- $type THIS = NO_INIT
- CODE:
- THIS = $name;
- OUTPUT:
- SETMAGIC: DISABLE
- THIS
-
-void
-_set_$name(THIS)
- $type THIS
- CODE:
- $name = THIS;
-
-END
-}
-
-sub print_accessors {
- my($fh, $name, $struct) = @_;
- return unless defined $struct && $name !~ /\s|_ANON/;
- $name = normalize_type($name);
- my $ptrname = normalize_type("$name *");
- print $fh <<"EOF";
-
-MODULE = $module PACKAGE = ${name} $prefix
-
-$name *
-_to_ptr(THIS)
- $name THIS = NO_INIT
- PROTOTYPE: \$
- CODE:
- if (sv_derived_from(ST(0), "$name")) {
- STRLEN len;
- char *s = SvPV((SV*)SvRV(ST(0)), len);
- if (len != sizeof(THIS))
- croak("Size \%d of packed data != expected \%d",
- len, sizeof(THIS));
- RETVAL = ($name *)s;
- }
- else
- croak("THIS is not of type $name");
- OUTPUT:
- RETVAL
-
-$name
-new(CLASS)
- char *CLASS = NO_INIT
- PROTOTYPE: \$
- CODE:
- Zero((void*)&RETVAL, sizeof(RETVAL), char);
- OUTPUT:
- RETVAL
-
-MODULE = $module PACKAGE = ${name}Ptr $prefix
-
-EOF
- my @items = @$struct;
- 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 {
- 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<gt>_to_ptr()>
-#
-#Converts an object of type C<$name> to an object of type C<$ptrname>.
-#
-#=item C<$name-E<gt>new()>
-#
-#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 (<TYPEMAP>) {
- 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 { # Second arg: do not strip const's before \*
- my $type = shift;
- my $do_keep_deep_const = shift;
- # If $do_keep_deep_const this is heuristical only
- 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/\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) {
- for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
- if ($opt_a) {
- while (my($name, $struct) = each %structs) {
- print_accessors(\*XS, $name, $struct);
- }
- }
-}
-
-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";
-
-my $prereq_pm = '';
-
-if ( $compat_version < 5.00702 and $new_test )
-{
- $prereq_pm .= q%'Test::More' => 0, %;
-}
-
-if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader)
-{
- $prereq_pm .= q%'XSLoader' => 0, %;
-}
-
-print PL <<"END";
-use $compat_version;
-use ExtUtils::MakeMaker;
-# See lib/ExtUtils/MakeMaker.pm for details of how to influence
-# the contents of the Makefile that is written.
-WriteMakefile(
- NAME => '$module',
- VERSION_FROM => '$modpmname', # finds \$VERSION
- PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
- (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
- AUTHOR => '$author <$email>') : ()),
-END
-if (!$opt_X) { # print C stuff, unless XS is disabled
- $opt_F = '' unless defined $opt_F;
- my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
- my $Ihelp = ($I ? '-I. ' : '');
- my $Icomment = ($I ? '' : <<EOC);
- # Insert -I. if you add *.h files later:
-EOC
-
- print PL <<END;
- LIBS => ['$extralibs'], # e.g., '-lm'
- DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
-$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
-END
-
- my $C = grep {$_ ne "$modfname.c"}
- (glob '*.c'), (glob '*.cc'), (glob '*.C');
- my $Cpre = ($C ? '' : '# ');
- my $Ccomment = ($C ? '' : <<EOC);
- # Un-comment this if you add C files to link with later:
-EOC
-
- print PL <<END;
-$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
-END
-} # ' # Grr
-print PL ");\n";
-if (!$opt_c) {
- my $generate_code =
- WriteMakefileSnippet ( C_FILE => $constscfname,
- XS_FILE => $constsxsfname,
- DEFAULT_TYPE => $opt_t,
- NAME => $module,
- NAMES => \@const_specs,
- );
- print PL <<"END";
-if (eval {require ExtUtils::Constant; 1}) {
- # If you edit these definitions to change the constants used by this module,
- # you will need to use the generated $constscfname and $constsxsfname
- # files to replace their "fallback" counterparts before distributing your
- # changes.
-$generate_code
-}
-else {
- use File::Copy;
- use File::Spec;
- foreach my \$file ('$constscfname', '$constsxsfname') {
- my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
- copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
- }
-}
-END
-
- eval $generate_code;
- if ($@) {
- warn <<"EOM";
-Attempting to test constant code in $ext$modpname/Makefile.PL:
-$generate_code
-__END__
-gave unexpected error $@
-Please report the circumstances of this bug in h2xs version $H2XS_VERSION
-using the perlbug script.
-EOM
- } else {
- my $fail;
-
- foreach my $file ($constscfname, $constsxsfname) {
- my $fallback = File::Spec->catfile($fallbackdirname, $file);
- if (compare($file, $fallback)) {
- warn << "EOM";
-Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
-EOM
- $fail++;
- }
- }
- if ($fail) {
- warn fill ('','', <<"EOM") . "\n";
-It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
-the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
-correctly.
-
-Please report the circumstances of this bug in h2xs version $H2XS_VERSION
-using the perlbug script.
-EOM
- } else {
- unlink $constscfname, $constsxsfname;
- }
- }
-}
-close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
-
-# 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.
-
-$licence
-
-_RMEND_
-close(RM) || die "Can't close $ext$modpname/README: $!\n";
-
-my $testdir = "t";
-my $testfile = "$testdir/$modpname.t";
-unless (-d "$testdir") {
- mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
-}
-warn "Writing $ext$modpname/$testfile\n";
-my $tests = @const_names ? 2 : 1;
-
-open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
-
-print EX <<_END_;
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl $modpname.t'
-
-#########################
-
-# change 'tests => $tests' to 'tests => last_test_to_print';
-
-_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_
- }
-}
-else
-{
- print EX <<_END_;
-use Test::More tests => $tests;
-BEGIN { use_ok('$module') };
-
-_END_
-
- if (@const_names) {
- my $const_names = join " ", @const_names;
- print EX <<'_END_';
-
-my $fail = 0;
-foreach my $constname (qw(
-_END_
-
- print EX wrap ("\t", "\t", $const_names);
- print EX (")) {\n");
-
- print EX <<_END_;
- next if (eval "my \\\$a = \$constname; 1");
- if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
- print "# pass: \$\@";
- } else {
- print "# fail: \$\@";
- \$fail = 1;
- }
-
-}
-
-ok( \$fail == 0 , 'Constants' );
-_END_
- }
-}
-
-print EX <<_END_;
-#########################
-
-# Insert your test code below, the $test_mod module is use()ed here so read
-# its man page ( perldoc $test_mod ) for help writing this test script.
-
-_END_
-
-close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
-
-unless ($opt_C) {
- warn "Writing $ext$modpname/Changes\n";
- $" = ' ';
- open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
- @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
- print EX <<EOP;
-Revision history for Perl extension $module.
-
-$TEMPLATE_VERSION @{[scalar localtime]}
-\t- original version; created by h2xs $H2XS_VERSION with options
-\t\t@ARGS
-
-EOP
- close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
-}
-
-warn "Writing $ext$modpname/MANIFEST\n";
-open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
-my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
-if (!@files) {
- eval {opendir(D,'.');};
- unless ($@) { @files = readdir(D); closedir(D); }
-}
-if (!@files) { @files = map {chomp && $_} `ls`; }
-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;
-
-__END__
-:endofperl