Installer: Early check whether the installation directory is writable
[msysgit.git] / bin / h2xs
blobbadd1fc01189e0661670a3cd15697cc3c51634d6
1 #!/usr/bin/perl
2 eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
3 if $running_under_some_shell;
5 use warnings;
7 =head1 NAME
9 h2xs - convert .h C header files to Perl extensions
11 =head1 SYNOPSIS
13 B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
15 B<h2xs> B<-h>|B<-?>|B<--help>
17 =head1 DESCRIPTION
19 I<h2xs> builds a Perl extension from C header files. The extension
20 will include functions which can be used to retrieve the value of any
21 #define statement which was in the C header files.
23 The I<module_name> will be used for the name of the extension. If
24 module_name is not supplied then the name of the first header file
25 will be used, with the first character capitalized.
27 If the extension might need extra libraries, they should be included
28 here. The extension Makefile.PL will take care of checking whether
29 the libraries actually exist and how they should be loaded. The extra
30 libraries should be specified in the form -lm -lposix, etc, just as on
31 the cc command line. By default, the Makefile.PL will search through
32 the library path determined by Configure. That path can be augmented
33 by including arguments of the form B<-L/another/library/path> in the
34 extra-libraries argument.
36 =head1 OPTIONS
38 =over 5
40 =item B<-A>, B<--omit-autoload>
42 Omit all autoload facilities. This is the same as B<-c> but also
43 removes the S<C<use AutoLoader>> statement from the .pm file.
45 =item B<-B>, B<--beta-version>
47 Use an alpha/beta style version number. Causes version number to
48 be "0.00_01" unless B<-v> is specified.
50 =item B<-C>, B<--omit-changes>
52 Omits creation of the F<Changes> file, and adds a HISTORY section to
53 the POD template.
55 =item B<-F>, B<--cpp-flags>=I<addflags>
57 Additional flags to specify to C preprocessor when scanning header for
58 function declarations. Writes these options in the generated F<Makefile.PL>
59 too.
61 =item B<-M>, B<--func-mask>=I<regular expression>
63 selects functions/macros to process.
65 =item B<-O>, B<--overwrite-ok>
67 Allows a pre-existing extension directory to be overwritten.
69 =item B<-P>, B<--omit-pod>
71 Omit the autogenerated stub POD section.
73 =item B<-X>, B<--omit-XS>
75 Omit the XS portion. Used to generate templates for a module which is not
76 XS-based. C<-c> and C<-f> are implicitly enabled.
78 =item B<-a>, B<--gen-accessors>
80 Generate an accessor method for each element of structs and unions. The
81 generated methods are named after the element name; will return the current
82 value of the element if called without additional arguments; and will set
83 the element to the supplied value (and return the new value) if called with
84 an additional argument. Embedded structures and unions are returned as a
85 pointer rather than the complete structure, to facilitate chained calls.
87 These methods all apply to the Ptr type for the structure; additionally
88 two methods are constructed for the structure type itself, C<_to_ptr>
89 which returns a Ptr type pointing to the same structure, and a C<new>
90 method to construct and return a new structure, initialised to zeroes.
92 =item B<-b>, B<--compat-version>=I<version>
94 Generates a .pm file which is backwards compatible with the specified
95 perl version.
97 For versions < 5.6.0, the changes are.
98 - no use of 'our' (uses 'use vars' instead)
99 - no 'use warnings'
101 Specifying a compatibility version higher than the version of perl you
102 are using to run h2xs will have no effect. If unspecified h2xs will default
103 to compatibility with the version of perl you are using to run h2xs.
105 =item B<-c>, B<--omit-constant>
107 Omit C<constant()> from the .xs file and corresponding specialised
108 C<AUTOLOAD> from the .pm file.
110 =item B<-d>, B<--debugging>
112 Turn on debugging messages.
114 =item B<-e>, B<--omit-enums>=[I<regular expression>]
116 If I<regular expression> is not given, skip all constants that are defined in
117 a C enumeration. Otherwise skip only those constants that are defined in an
118 enum whose name matches I<regular expression>.
120 Since I<regular expression> is optional, make sure that this switch is followed
121 by at least one other switch if you omit I<regular expression> and have some
122 pending arguments such as header-file names. This is ok:
124 h2xs -e -n Module::Foo foo.h
126 This is not ok:
128 h2xs -n Module::Foo -e foo.h
130 In the latter, foo.h is taken as I<regular expression>.
132 =item B<-f>, B<--force>
134 Allows an extension to be created for a header even if that header is
135 not found in standard include directories.
137 =item B<-g>, B<--global>
139 Include code for safely storing static data in the .xs file.
140 Extensions that do no make use of static data can ignore this option.
142 =item B<-h>, B<-?>, B<--help>
144 Print the usage, help and version for this h2xs and exit.
146 =item B<-k>, B<--omit-const-func>
148 For function arguments declared as C<const>, omit the const attribute in the
149 generated XS code.
151 =item B<-m>, B<--gen-tied-var>
153 B<Experimental>: for each variable declared in the header file(s), declare
154 a perl variable of the same name magically tied to the C variable.
156 =item B<-n>, B<--name>=I<module_name>
158 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
160 =item B<-o>, B<--opaque-re>=I<regular expression>
162 Use "opaque" data type for the C types matched by the regular
163 expression, even if these types are C<typedef>-equivalent to types
164 from typemaps. Should not be used without B<-x>.
166 This may be useful since, say, types which are C<typedef>-equivalent
167 to integers may represent OS-related handles, and one may want to work
168 with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
169 Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
170 types.
172 The type-to-match is whitewashed (except for commas, which have no
173 whitespace before them, and multiple C<*> which have no whitespace
174 between them).
176 =item B<-p>, B<--remove-prefix>=I<prefix>
178 Specify a prefix which should be removed from the Perl function names,
179 e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
180 the prefix from functions that are autoloaded via the C<constant()>
181 mechanism.
183 =item B<-s>, B<--const-subs>=I<sub1,sub2>
185 Create a perl subroutine for the specified macros rather than autoload
186 with the constant() subroutine. These macros are assumed to have a
187 return type of B<char *>, e.g.,
188 S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
190 =item B<-t>, B<--default-type>=I<type>
192 Specify the internal type that the constant() mechanism uses for macros.
193 The default is IV (signed integer). Currently all macros found during the
194 header scanning process will be assumed to have this type. Future versions
195 of C<h2xs> may gain the ability to make educated guesses.
197 =item B<--use-new-tests>
199 When B<--compat-version> (B<-b>) is present the generated tests will use
200 C<Test::More> rather than C<Test> which is the default for versions before
201 5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
202 C<Makefile.PL>.
204 =item B<--use-old-tests>
206 Will force the generation of test code that uses the older C<Test> module.
208 =item B<--skip-exporter>
210 Do not use C<Exporter> and/or export any symbol.
212 =item B<--skip-ppport>
214 Do not use C<Devel::PPPort>: no portability to older version.
216 =item B<--skip-autoloader>
218 Do not use the module C<AutoLoader>; but keep the constant() function
219 and C<sub AUTOLOAD> for constants.
221 =item B<--skip-strict>
223 Do not use the pragma C<strict>.
225 =item B<--skip-warnings>
227 Do not use the pragma C<warnings>.
229 =item B<-v>, B<--version>=I<version>
231 Specify a version number for this extension. This version number is added
232 to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
233 The version specified should be numeric.
235 =item B<-x>, B<--autogen-xsubs>
237 Automatically generate XSUBs basing on function declarations in the
238 header file. The package C<C::Scan> should be installed. If this
239 option is specified, the name of the header file may look like
240 C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
241 string, but XSUBs are emitted only for the declarations included from
242 file NAME2.
244 Note that some types of arguments/return-values for functions may
245 result in XSUB-declarations/typemap-entries which need
246 hand-editing. Such may be objects which cannot be converted from/to a
247 pointer (like C<long long>), pointers to functions, or arrays. See
248 also the section on L<LIMITATIONS of B<-x>>.
250 =back
252 =head1 EXAMPLES
255 # Default behavior, extension is Rusers
256 h2xs rpcsvc/rusers
258 # Same, but extension is RUSERS
259 h2xs -n RUSERS rpcsvc/rusers
261 # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
262 h2xs rpcsvc::rusers
264 # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
265 h2xs -n ONC::RPC rpcsvc/rusers
267 # Without constant() or AUTOLOAD
268 h2xs -c rpcsvc/rusers
270 # Creates templates for an extension named RPC
271 h2xs -cfn RPC
273 # Extension is ONC::RPC.
274 h2xs -cfn ONC::RPC
276 # Extension is Lib::Foo which works at least with Perl5.005_03.
277 # Constants are created for all #defines and enums h2xs can find
278 # in foo.h.
279 h2xs -b 5.5.3 -n Lib::Foo foo.h
281 # Extension is Lib::Foo which works at least with Perl5.005_03.
282 # Constants are created for all #defines but only for enums
283 # whose names do not start with 'bar_'.
284 h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
286 # Makefile.PL will look for library -lrpc in
287 # additional directory /opt/net/lib
288 h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
290 # Extension is DCE::rgynbase
291 # prefix "sec_rgy_" is dropped from perl function names
292 h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
294 # Extension is DCE::rgynbase
295 # prefix "sec_rgy_" is dropped from perl function names
296 # subroutines are created for sec_rgy_wildcard_name and
297 # sec_rgy_wildcard_sid
298 h2xs -n DCE::rgynbase -p sec_rgy_ \
299 -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
301 # Make XS without defines in perl.h, but with function declarations
302 # visible from perl.h. Name of the extension is perl1.
303 # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
304 # Extra backslashes below because the string is passed to shell.
305 # Note that a directory with perl header files would
306 # be added automatically to include path.
307 h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
309 # Same with function declaration in proto.h as visible from perl.h.
310 h2xs -xAn perl2 perl.h,proto.h
312 # Same but select only functions which match /^av_/
313 h2xs -M '^av_' -xAn perl2 perl.h,proto.h
315 # Same but treat SV* etc as "opaque" types
316 h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
318 =head2 Extension based on F<.h> and F<.c> files
320 Suppose that you have some C files implementing some functionality,
321 and the corresponding header files. How to create an extension which
322 makes this functionality accessible in Perl? The example below
323 assumes that the header files are F<interface_simple.h> and
324 I<interface_hairy.h>, and you want the perl module be named as
325 C<Ext::Ension>. If you need some preprocessor directives and/or
326 linking with external libraries, see the flags C<-F>, C<-L> and C<-l>
327 in L<"OPTIONS">.
329 =over
331 =item Find the directory name
333 Start with a dummy run of h2xs:
335 h2xs -Afn Ext::Ension
337 The only purpose of this step is to create the needed directories, and
338 let you know the names of these directories. From the output you can
339 see that the directory for the extension is F<Ext/Ension>.
341 =item Copy C files
343 Copy your header files and C files to this directory F<Ext/Ension>.
345 =item Create the extension
347 Run h2xs, overwriting older autogenerated files:
349 h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
351 h2xs looks for header files I<after> changing to the extension
352 directory, so it will find your header files OK.
354 =item Archive and test
356 As usual, run
358 cd Ext/Ension
359 perl Makefile.PL
360 make dist
361 make
362 make test
364 =item Hints
366 It is important to do C<make dist> as early as possible. This way you
367 can easily merge(1) your changes to autogenerated files if you decide
368 to edit your C<.h> files and rerun h2xs.
370 Do not forget to edit the documentation in the generated F<.pm> file.
372 Consider the autogenerated files as skeletons only, you may invent
373 better interfaces than what h2xs could guess.
375 Consider this section as a guideline only, some other options of h2xs
376 may better suit your needs.
378 =back
380 =head1 ENVIRONMENT
382 No environment variables are used.
384 =head1 AUTHOR
386 Larry Wall and others
388 =head1 SEE ALSO
390 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
392 =head1 DIAGNOSTICS
394 The usual warnings if it cannot read or write the files involved.
396 =head1 LIMITATIONS of B<-x>
398 F<h2xs> would not distinguish whether an argument to a C function
399 which is of the form, say, C<int *>, is an input, output, or
400 input/output parameter. In particular, argument declarations of the
401 form
404 foo(n)
405 int *n
407 should be better rewritten as
410 foo(n)
411 int &n
413 if C<n> is an input parameter.
415 Additionally, F<h2xs> has no facilities to intuit that a function
418 foo(addr,l)
419 char *addr
420 int l
422 takes a pair of address and length of data at this address, so it is better
423 to rewrite this function as
426 foo(sv)
427 SV *addr
428 PREINIT:
429 STRLEN len;
430 char *s;
431 CODE:
432 s = SvPV(sv,len);
433 RETVAL = foo(s, len);
434 OUTPUT:
435 RETVAL
437 or alternately
439 static int
440 my_foo(SV *sv)
442 STRLEN len;
443 char *s = SvPV(sv,len);
445 return foo(s, len);
448 MODULE = foo PACKAGE = foo PREFIX = my_
451 foo(sv)
452 SV *sv
454 See L<perlxs> and L<perlxstut> for additional details.
456 =cut
458 # ' # Grr
459 use strict;
462 my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;
463 my $TEMPLATE_VERSION = '0.01';
464 my @ARGS = @ARGV;
465 my $compat_version = $];
467 use Getopt::Long;
468 use Config;
469 use Text::Wrap;
470 $Text::Wrap::huge = 'overflow';
471 $Text::Wrap::columns = 80;
472 use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
473 use File::Compare;
474 use File::Path;
476 sub usage {
477 warn "@_\n" if @_;
478 die <<EOFUSAGE;
479 h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
480 version: $H2XS_VERSION
481 OPTIONS:
482 -A, --omit-autoload Omit all autoloading facilities (implies -c).
483 -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
484 -C, --omit-changes Omit creating the Changes file, add HISTORY heading
485 to stub POD.
486 -F, --cpp-flags Additional flags for C preprocessor/compile.
487 -M, --func-mask Mask to select C functions/macros
488 (default is select all).
489 -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
490 -P, --omit-pod Omit the stub POD section.
491 -X, --omit-XS Omit the XS portion (implies both -c and -f).
492 -a, --gen-accessors Generate get/set accessors for struct and union members
493 (used with -x).
494 -b, --compat-version Specify a perl version to be backwards compatibile with.
495 -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
496 from the XS file.
497 -d, --debugging Turn on debugging messages.
498 -e, --omit-enums Omit constants from enums in the constant() function.
499 If a pattern is given, only the matching enums are
500 ignored.
501 -f, --force Force creation of the extension even if the C header
502 does not exist.
503 -g, --global Include code for safely storing static data in the .xs file.
504 -h, -?, --help Display this help message.
505 -k, --omit-const-func Omit 'const' attribute on function arguments
506 (used with -x).
507 -m, --gen-tied-var Generate tied variables for access to declared
508 variables.
509 -n, --name Specify a name to use for the extension (recommended).
510 -o, --opaque-re Regular expression for \"opaque\" types.
511 -p, --remove-prefix Specify a prefix which should be removed from the
512 Perl function names.
513 -s, --const-subs Create subroutines for specified macros.
514 -t, --default-type Default type for autoloaded constants (default is IV).
515 --use-new-tests Use Test::More in backward compatible modules.
516 --use-old-tests Use the module Test rather than Test::More.
517 --skip-exporter Do not export symbols.
518 --skip-ppport Do not use portability layer.
519 --skip-autoloader Do not use the module C<AutoLoader>.
520 --skip-strict Do not use the pragma C<strict>.
521 --skip-warnings Do not use the pragma C<warnings>.
522 -v, --version Specify a version number for this extension.
523 -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
524 --use-xsloader Use XSLoader in backward compatible modules (ignored
525 when used with -X).
527 extra_libraries
528 are any libraries that might be needed for loading the
529 extension, e.g. -lm would try to link in the math library.
530 EOFUSAGE
533 my ($opt_A,
534 $opt_B,
535 $opt_C,
536 $opt_F,
537 $opt_M,
538 $opt_O,
539 $opt_P,
540 $opt_X,
541 $opt_a,
542 $opt_c,
543 $opt_d,
544 $opt_e,
545 $opt_f,
546 $opt_g,
547 $opt_h,
548 $opt_k,
549 $opt_m,
550 $opt_n,
551 $opt_o,
552 $opt_p,
553 $opt_s,
554 $opt_v,
555 $opt_x,
556 $opt_b,
557 $opt_t,
558 $new_test,
559 $old_test,
560 $skip_exporter,
561 $skip_ppport,
562 $skip_autoloader,
563 $skip_strict,
564 $skip_warnings,
565 $use_xsloader
568 Getopt::Long::Configure('bundling');
569 Getopt::Long::Configure('pass_through');
571 my %options = (
572 'omit-autoload|A' => \$opt_A,
573 'beta-version|B' => \$opt_B,
574 'omit-changes|C' => \$opt_C,
575 'cpp-flags|F=s' => \$opt_F,
576 'func-mask|M=s' => \$opt_M,
577 'overwrite_ok|O' => \$opt_O,
578 'omit-pod|P' => \$opt_P,
579 'omit-XS|X' => \$opt_X,
580 'gen-accessors|a' => \$opt_a,
581 'compat-version|b=s' => \$opt_b,
582 'omit-constant|c' => \$opt_c,
583 'debugging|d' => \$opt_d,
584 'omit-enums|e:s' => \$opt_e,
585 'force|f' => \$opt_f,
586 'global|g' => \$opt_g,
587 'help|h|?' => \$opt_h,
588 'omit-const-func|k' => \$opt_k,
589 'gen-tied-var|m' => \$opt_m,
590 'name|n=s' => \$opt_n,
591 'opaque-re|o=s' => \$opt_o,
592 'remove-prefix|p=s' => \$opt_p,
593 'const-subs|s=s' => \$opt_s,
594 'default-type|t=s' => \$opt_t,
595 'version|v=s' => \$opt_v,
596 'autogen-xsubs|x' => \$opt_x,
597 'use-new-tests' => \$new_test,
598 'use-old-tests' => \$old_test,
599 'skip-exporter' => \$skip_exporter,
600 'skip-ppport' => \$skip_ppport,
601 'skip-autoloader' => \$skip_autoloader,
602 'skip-warnings' => \$skip_warnings,
603 'skip-strict' => \$skip_strict,
604 'use-xsloader' => \$use_xsloader,
607 GetOptions(%options) || usage;
609 usage if $opt_h;
611 if( $opt_b ){
612 usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
613 $opt_b =~ /^\d+\.\d+\.\d+/ ||
614 usage "You must provide the backwards compatibility version in X.Y.Z form. "
615 . "(i.e. 5.5.0)\n";
616 my ($maj,$min,$sub) = split(/\./,$opt_b,3);
617 if ($maj < 5 || ($maj == 5 && $min < 6)) {
618 $compat_version =
619 $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
620 sprintf("%d.%03d", $maj,$min);
621 } else {
622 $compat_version =
623 $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) :
624 sprintf("%d.%03d", $maj,$min);
626 } else {
627 my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
628 $sub ||= 0;
629 warn sprintf <<'EOF', $maj,$min,$sub;
630 Defaulting to backwards compatibility with perl %d.%d.%d
631 If you intend this module to be compatible with earlier perl versions, please
632 specify a minimum perl version with the -b option.
637 if( $opt_B ){
638 $TEMPLATE_VERSION = '0.00_01';
641 if( $opt_v ){
642 $TEMPLATE_VERSION = $opt_v;
644 # check if it is numeric
645 my $temp_version = $TEMPLATE_VERSION;
646 my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
647 my $notnum;
649 local $SIG{__WARN__} = sub { $notnum = 1 };
650 use warnings 'numeric';
651 $temp_version = 0+$temp_version;
654 if ($notnum) {
655 my $module = $opt_n || 'Your::Module';
656 warn <<"EOF";
657 You have specified a non-numeric version. Unless you supply an
658 appropriate VERSION class method, users may not be able to specify a
659 minimum required version with C<use $module versionnum>.
663 else {
664 $opt_B = $beta_version;
668 # -A implies -c.
669 $skip_autoloader = $opt_c = 1 if $opt_A;
671 # -X implies -c and -f
672 $opt_c = $opt_f = 1 if $opt_X;
674 $opt_t ||= 'IV';
676 my %const_xsub;
677 %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
679 my $extralibs = '';
681 my @path_h;
683 while (my $arg = shift) {
684 if ($arg =~ /^-l/i) {
685 $extralibs .= "$arg ";
686 next;
688 last if $extralibs;
689 push(@path_h, $arg);
692 usage "Must supply header file or module name\n"
693 unless (@path_h or $opt_n);
695 my $fmask;
696 my $tmask;
698 $fmask = qr{$opt_M} if defined $opt_M;
699 $tmask = qr{$opt_o} if defined $opt_o;
700 my $tmask_all = $tmask && $opt_o eq '.';
702 if ($opt_x) {
703 eval {require C::Scan; 1}
704 or die <<EOD;
705 C::Scan required if you use -x option.
706 To install C::Scan, execute
707 perl -MCPAN -e "install C::Scan"
709 unless ($tmask_all) {
710 $C::Scan::VERSION >= 0.70
711 or die <<EOD;
712 C::Scan v. 0.70 or later required unless you use -o . option.
713 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
714 To install C::Scan, execute
715 perl -MCPAN -e "install C::Scan"
718 if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
719 die <<EOD;
720 C::Scan v. 0.73 or later required to use -m or -a options.
721 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
722 To install C::Scan, execute
723 perl -MCPAN -e "install C::Scan"
727 elsif ($opt_o or $opt_F) {
728 warn <<EOD if $opt_o;
729 Option -o does not make sense without -x.
731 warn <<EOD if $opt_F and $opt_X ;
732 Option -F does not make sense with -X.
736 my @path_h_ini = @path_h;
737 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
739 my $module = $opt_n;
741 if( @path_h ){
742 use File::Spec;
743 my @paths;
744 my $pre_sub_tri_graphs = 1;
745 if ($^O eq 'VMS') { # Consider overrides of default location
746 # XXXX This is not equivalent to what the older version did:
747 # it was looking at $hadsys header-file per header-file...
748 my($hadsys) = grep s!^sys/!!i , @path_h;
749 @paths = qw( Sys$Library VAXC$Include );
750 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
751 push @paths, qw( DECC$Library_Include DECC$System_Include );
753 else {
754 @paths = (File::Spec->curdir(), $Config{usrinc},
755 (split ' ', $Config{locincpth}), '/usr/include');
757 foreach my $path_h (@path_h) {
758 $name ||= $path_h;
759 $module ||= do {
760 $name =~ s/\.h$//;
761 if ( $name !~ /::/ ) {
762 $name =~ s#^.*/##;
763 $name = "\u$name";
765 $name;
768 if( $path_h =~ s#::#/#g && $opt_n ){
769 warn "Nesting of headerfile ignored with -n\n";
771 $path_h .= ".h" unless $path_h =~ /\.h$/;
772 my $fullpath = $path_h;
773 $path_h =~ s/,.*$// if $opt_x;
774 $fullpath{$path_h} = $fullpath;
776 # Minor trickery: we can't chdir() before we processed the headers
777 # (so know the name of the extension), but the header may be in the
778 # extension directory...
779 my $tmp_path_h = $path_h;
780 my $rel_path_h = $path_h;
781 my @dirs = @paths;
782 if (not -f $path_h) {
783 my $found;
784 for my $dir (@paths) {
785 $found++, last
786 if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
788 if ($found) {
789 $rel_path_h = $path_h;
790 $fullpath{$path_h} = $fullpath;
791 } else {
792 (my $epath = $module) =~ s,::,/,g;
793 $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
794 $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
795 $path_h = $tmp_path_h; # Used during -x
796 push @dirs, $epath;
800 if (!$opt_c) {
801 die "Can't find $tmp_path_h in @dirs\n"
802 if ( ! $opt_f && ! -f "$rel_path_h" );
803 # Scan the header file (we should deal with nested header files)
804 # Record the names of simple #define constants into const_names
805 # Function prototypes are processed below.
806 open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
807 defines:
808 while (<CH>) {
809 if ($pre_sub_tri_graphs) {
810 # Preprocess all tri-graphs
811 # including things stuck in quoted string constants.
812 s/\?\?=/#/g; # | ??=| #|
813 s/\?\?\!/|/g; # | ??!| ||
814 s/\?\?'/^/g; # | ??'| ^|
815 s/\?\?\(/[/g; # | ??(| [|
816 s/\?\?\)/]/g; # | ??)| ]|
817 s/\?\?\-/~/g; # | ??-| ~|
818 s/\?\?\//\\/g; # | ??/| \|
819 s/\?\?</{/g; # | ??<| {|
820 s/\?\?>/}/g; # | ??>| }|
822 if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
823 my $def = $1;
824 my $rest = $2;
825 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
826 $rest =~ s/^\s+//;
827 $rest =~ s/\s+$//;
828 # Cannot do: (-1) and ((LHANDLE)3) are OK:
829 #print("Skip non-wordy $def => $rest\n"),
830 # next defines if $rest =~ /[^\w\$]/;
831 if ($rest =~ /"/) {
832 print("Skip stringy $def => $rest\n") if $opt_d;
833 next defines;
835 print "Matched $_ ($def)\n" if $opt_d;
836 $seen_define{$def} = $rest;
837 $_ = $def;
838 next if /^_.*_h_*$/i; # special case, but for what?
839 if (defined $opt_p) {
840 if (!/^$opt_p(\d)/) {
841 ++$prefix{$_} if s/^$opt_p//;
843 else {
844 warn "can't remove $opt_p prefix from '$_'!\n";
847 $prefixless{$def} = $_;
848 if (!$fmask or /$fmask/) {
849 print "... Passes mask of -M.\n" if $opt_d and $fmask;
850 $const_names{$_}++;
854 if (defined $opt_e and !$opt_e) {
855 close(CH);
857 else {
858 # Work from miniperl too - on "normal" systems
859 my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
860 seek CH, 0, $SEEK_SET;
861 my $src = do { local $/; <CH> };
862 close CH;
863 no warnings 'uninitialized';
865 # Remove C and C++ comments
866 $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
868 while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
869 my ($enum_name, $enum_body) = ($1, $2);
870 # skip enums matching $opt_e
871 next if $opt_e && $enum_name =~ /$opt_e/;
872 my $val = 0;
873 for my $item (split /,/, $enum_body) {
874 my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
875 $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
876 $seen_define{$key} = $val;
877 $const_names{$key}++;
879 } # while (...)
880 } # if (!defined $opt_e or $opt_e)
885 # Save current directory so that C::Scan can use it
886 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
888 # As Ilya suggested, use a name that contains - and then it can't clash with
889 # the names of any packages. A directory 'fallback' will clash with any
890 # new pragmata down the fallback:: tree, but that seems unlikely.
891 my $constscfname = 'const-c.inc';
892 my $constsxsfname = 'const-xs.inc';
893 my $fallbackdirname = 'fallback';
895 my $ext = chdir 'ext' ? 'ext/' : '';
897 my @modparts = split(/::/,$module);
898 my $modpname = join('-', @modparts);
899 my $modfname = pop @modparts;
900 my $modpmdir = join '/', 'lib', @modparts;
901 my $modpmname = join '/', $modpmdir, $modfname.'.pm';
903 if ($opt_O) {
904 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
906 else {
907 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
909 -d "$modpname" || mkpath([$modpname], 0, 0775);
910 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
912 my %types_seen;
913 my %std_types;
914 my $fdecls = [];
915 my $fdecls_parsed = [];
916 my $typedef_rex;
917 my %typedefs_pre;
918 my %known_fnames;
919 my %structs;
921 my @fnames;
922 my @fnames_no_prefix;
923 my %vdecl_hash;
924 my @vdecls;
926 if( ! $opt_X ){ # use XS, unless it was disabled
927 unless ($skip_ppport) {
928 require Devel::PPPort;
929 warn "Writing $ext$modpname/ppport.h\n";
930 Devel::PPPort::WriteFile('ppport.h')
931 || die "Can't create $ext$modpname/ppport.h: $!\n";
933 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
934 if ($opt_x) {
935 warn "Scanning typemaps...\n";
936 get_typemap();
937 my @td;
938 my @good_td;
939 my $addflags = $opt_F || '';
941 foreach my $filename (@path_h) {
942 my $c;
943 my $filter;
945 if ($fullpath{$filename} =~ /,/) {
946 $filename = $`;
947 $filter = $';
949 warn "Scanning $filename for functions...\n";
950 my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
951 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
952 'add_cppflags' => $addflags, 'c_styles' => \@styles;
953 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
955 $c->get('keywords')->{'__restrict'} = 1;
957 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
958 push(@$fdecls, @{$c->get('fdecls')});
960 push @td, @{$c->get('typedefs_maybe')};
961 if ($opt_a) {
962 my $structs = $c->get('typedef_structs');
963 @structs{keys %$structs} = values %$structs;
966 if ($opt_m) {
967 %vdecl_hash = %{ $c->get('vdecl_hash') };
968 @vdecls = sort keys %vdecl_hash;
969 for (local $_ = 0; $_ < @vdecls; ++$_) {
970 my $var = $vdecls[$_];
971 my($type, $post) = @{ $vdecl_hash{$var} };
972 if (defined $post) {
973 warn "Can't handle variable '$type $var $post', skipping.\n";
974 splice @vdecls, $_, 1;
975 redo;
977 $type = normalize_type($type);
978 $vdecl_hash{$var} = $type;
982 unless ($tmask_all) {
983 warn "Scanning $filename for typedefs...\n";
984 my $td = $c->get('typedef_hash');
985 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
986 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
987 push @good_td, @f_good_td;
988 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
991 { local $" = '|';
992 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
994 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
995 if ($fmask) {
996 my @good;
997 for my $i (0..$#$fdecls_parsed) {
998 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
999 push @good, $i;
1000 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
1001 if $opt_d;
1003 $fdecls = [@$fdecls[@good]];
1004 $fdecls_parsed = [@$fdecls_parsed[@good]];
1006 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
1007 # Sort declarations:
1009 my %h = map( ($_->[1], $_), @$fdecls_parsed);
1010 $fdecls_parsed = [ @h{@fnames} ];
1012 @fnames_no_prefix = @fnames;
1013 @fnames_no_prefix
1014 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
1015 if defined $opt_p;
1016 # Remove macros which expand to typedefs
1017 print "Typedefs are @td.\n" if $opt_d;
1018 my %td = map {($_, $_)} @td;
1019 # Add some other possible but meaningless values for macros
1020 for my $k (qw(char double float int long short unsigned signed void)) {
1021 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
1023 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
1024 my $n = 0;
1025 my %bad_macs;
1026 while (keys %td > $n) {
1027 $n = keys %td;
1028 my ($k, $v);
1029 while (($k, $v) = each %seen_define) {
1030 # print("found '$k'=>'$v'\n"),
1031 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
1034 # Now %bad_macs contains names of bad macros
1035 for my $k (keys %bad_macs) {
1036 delete $const_names{$prefixless{$k}};
1037 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
1041 my @const_names = sort keys %const_names;
1043 -d $modpmdir || mkpath([$modpmdir], 0, 0775);
1044 open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
1046 $" = "\n\t";
1047 warn "Writing $ext$modpname/$modpmname\n";
1049 print PM <<"END";
1050 package $module;
1052 use $compat_version;
1055 print PM <<"END" unless $skip_strict;
1056 use strict;
1059 print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
1061 unless( $opt_X || $opt_c || $opt_A ){
1062 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
1063 # will want Carp.
1064 print PM <<'END';
1065 use Carp;
1069 print PM <<'END' unless $skip_exporter;
1071 require Exporter;
1074 my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
1075 print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
1076 require DynaLoader;
1080 # Are we using AutoLoader or not?
1081 unless ($skip_autoloader) { # no autoloader whatsoever.
1082 unless ($opt_c) { # we're doing the AUTOLOAD
1083 print PM "use AutoLoader;\n";
1085 else {
1086 print PM "use AutoLoader qw(AUTOLOAD);\n"
1090 if ( $compat_version < 5.006 ) {
1091 my $vars = '$VERSION @ISA';
1092 $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
1093 $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
1094 $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
1095 print PM "use vars qw($vars);";
1098 # Determine @ISA.
1099 my @modISA;
1100 push @modISA, 'Exporter' unless $skip_exporter;
1101 push @modISA, 'DynaLoader' if $use_Dyna; # no XS
1102 my $myISA = "our \@ISA = qw(@modISA);";
1103 $myISA =~ s/^our // if $compat_version < 5.006;
1105 print PM "\n$myISA\n\n";
1107 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1109 my $tmp='';
1110 $tmp .= <<"END" unless $skip_exporter;
1111 # Items to export into callers namespace by default. Note: do not export
1112 # names by default without a very good reason. Use EXPORT_OK instead.
1113 # Do not simply export all your public functions/methods/constants.
1115 # This allows declaration use $module ':all';
1116 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1117 # will save memory.
1118 our %EXPORT_TAGS = ( 'all' => [ qw(
1119 @exported_names
1120 ) ] );
1122 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1124 our \@EXPORT = qw(
1125 @const_names
1130 $tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
1131 if ($opt_B) {
1132 $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
1133 $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
1135 $tmp .= "\n";
1137 $tmp =~ s/^our //mg if $compat_version < 5.006;
1138 print PM $tmp;
1140 if (@vdecls) {
1141 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1145 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1147 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1148 if ($use_Dyna) {
1149 $tmp = <<"END";
1150 bootstrap $module \$VERSION;
1152 } else {
1153 $tmp = <<"END";
1154 require XSLoader;
1155 XSLoader::load('$module', \$VERSION);
1158 $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
1159 print PM $tmp;
1162 # tying the variables can happen only after bootstrap
1163 if (@vdecls) {
1164 printf PM <<END;
1166 @{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
1172 my $after;
1173 if( $opt_P ){ # if POD is disabled
1174 $after = '__END__';
1176 else {
1177 $after = '=cut';
1180 print PM <<"END";
1182 # Preloaded methods go here.
1185 print PM <<"END" unless $opt_A;
1187 # Autoload methods go after $after, and are processed by the autosplit program.
1190 print PM <<"END";
1193 __END__
1196 my ($email,$author,$licence);
1198 eval {
1199 my $username;
1200 ($username,$author) = (getpwuid($>))[0,6];
1201 if (defined $username && defined $author) {
1202 $author =~ s/,.*$//; # in case of sub fields
1203 my $domain = $Config{'mydomain'};
1204 $domain =~ s/^\.//;
1205 $email = "$username\@$domain";
1209 $author =~ s/'/\\'/g if defined $author;
1210 $author ||= "A. U. Thor";
1211 $email ||= 'a.u.thor@a.galaxy.far.far.away';
1213 $licence = sprintf << "DEFAULT", $^V;
1214 Copyright (C) ${\(1900 + (localtime) [5])} by $author
1216 This library is free software; you can redistribute it and/or modify
1217 it under the same terms as Perl itself, either Perl version %vd or,
1218 at your option, any later version of Perl 5 you may have available.
1219 DEFAULT
1221 my $revhist = '';
1222 $revhist = <<EOT if $opt_C;
1224 #=head1 HISTORY
1226 #=over 8
1228 #=item $TEMPLATE_VERSION
1230 #Original version; created by h2xs $H2XS_VERSION with options
1232 # @ARGS
1234 #=back
1238 my $exp_doc = $skip_exporter ? '' : <<EOD;
1240 #=head2 EXPORT
1242 #None by default.
1246 if (@const_names and not $opt_P) {
1247 $exp_doc .= <<EOD unless $skip_exporter;
1248 #=head2 Exportable constants
1250 # @{[join "\n ", @const_names]}
1255 if (defined $fdecls and @$fdecls and not $opt_P) {
1256 $exp_doc .= <<EOD unless $skip_exporter;
1257 #=head2 Exportable functions
1261 # $exp_doc .= <<EOD if $opt_p;
1262 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1264 #EOD
1265 $exp_doc .= <<EOD unless $skip_exporter;
1266 # @{[join "\n ", @known_fnames{@fnames}]}
1271 my $meth_doc = '';
1273 if ($opt_x && $opt_a) {
1274 my($name, $struct);
1275 $meth_doc .= accessor_docs($name, $struct)
1276 while ($name, $struct) = each %structs;
1279 # Prefix the default licence with hash symbols.
1280 # Is this just cargo cult - it seems that the first thing that happens to this
1281 # block is that all the hashes are then s///g out.
1282 my $licence_hash = $licence;
1283 $licence_hash =~ s/^/#/gm;
1285 my $pod;
1286 $pod = <<"END" unless $opt_P;
1287 ## Below is stub documentation for your module. You'd better edit it!
1289 #=head1 NAME
1291 #$module - Perl extension for blah blah blah
1293 #=head1 SYNOPSIS
1295 # use $module;
1296 # blah blah blah
1298 #=head1 DESCRIPTION
1300 #Stub documentation for $module, created by h2xs. It looks like the
1301 #author of the extension was negligent enough to leave the stub
1302 #unedited.
1304 #Blah blah blah.
1305 $exp_doc$meth_doc$revhist
1307 #=head1 SEE ALSO
1309 #Mention other useful documentation such as the documentation of
1310 #related modules or operating system documentation (such as man pages
1311 #in UNIX), or any relevant external documentation such as RFCs or
1312 #standards.
1314 #If you have a mailing list set up for your module, mention it here.
1316 #If you have a web site set up for your module, mention it here.
1318 #=head1 AUTHOR
1320 #$author, E<lt>${email}E<gt>
1322 #=head1 COPYRIGHT AND LICENSE
1324 $licence_hash
1326 #=cut
1329 $pod =~ s/^\#//gm unless $opt_P;
1330 print PM $pod unless $opt_P;
1332 close PM;
1335 if( ! $opt_X ){ # print XS, unless it is disabled
1336 warn "Writing $ext$modpname/$modfname.xs\n";
1338 print XS <<"END";
1339 #include "EXTERN.h"
1340 #include "perl.h"
1341 #include "XSUB.h"
1345 print XS <<"END" unless $skip_ppport;
1346 #include "ppport.h"
1350 if( @path_h ){
1351 foreach my $path_h (@path_h_ini) {
1352 my($h) = $path_h;
1353 $h =~ s#^/usr/include/##;
1354 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1355 print XS qq{#include <$h>\n};
1357 print XS "\n";
1360 print XS <<"END" if $opt_g;
1362 /* Global Data */
1364 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1366 typedef struct {
1367 /* Put Global Data in here */
1368 int dummy; /* you can access this elsewhere as MY_CXT.dummy */
1369 } my_cxt_t;
1371 START_MY_CXT
1375 my %pointer_typedefs;
1376 my %struct_typedefs;
1378 sub td_is_pointer {
1379 my $type = shift;
1380 my $out = $pointer_typedefs{$type};
1381 return $out if defined $out;
1382 my $otype = $type;
1383 $out = ($type =~ /\*$/);
1384 # This converts only the guys which do not have trailing part in the typedef
1385 if (not $out
1386 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1387 $type = normalize_type($type);
1388 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1389 if $opt_d;
1390 $out = td_is_pointer($type);
1392 return ($pointer_typedefs{$otype} = $out);
1395 sub td_is_struct {
1396 my $type = shift;
1397 my $out = $struct_typedefs{$type};
1398 return $out if defined $out;
1399 my $otype = $type;
1400 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1401 # This converts only the guys which do not have trailing part in the typedef
1402 if (not $out
1403 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1404 $type = normalize_type($type);
1405 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1406 if $opt_d;
1407 $out = td_is_struct($type);
1409 return ($struct_typedefs{$otype} = $out);
1412 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1414 if( ! $opt_c ) {
1415 # We write the "sample" files used when this module is built by perl without
1416 # ExtUtils::Constant.
1417 # h2xs will later check that these are the same as those generated by the
1418 # code embedded into Makefile.PL
1419 unless (-d $fallbackdirname) {
1420 mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
1422 warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
1423 warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
1424 my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
1425 my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
1426 WriteConstants ( C_FILE => $cfallback,
1427 XS_FILE => $xsfallback,
1428 DEFAULT_TYPE => $opt_t,
1429 NAME => $module,
1430 NAMES => \@const_names,
1432 print XS "#include \"$constscfname\"\n";
1436 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1438 # Now switch from C to XS by issuing the first MODULE declaration:
1439 print XS <<"END";
1441 MODULE = $module PACKAGE = $module $prefix
1445 # If a constant() function was #included then output a corresponding
1446 # XS declaration:
1447 print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
1449 print XS <<"END" if $opt_g;
1451 BOOT:
1453 MY_CXT_INIT;
1454 /* If any of the fields in the my_cxt_t struct need
1455 to be initialised, do it here.
1461 foreach (sort keys %const_xsub) {
1462 print XS <<"END";
1463 char *
1464 $_()
1466 CODE:
1467 #ifdef $_
1468 RETVAL = $_;
1469 #else
1470 croak("Your vendor has not defined the $module macro $_");
1471 #endif
1473 OUTPUT:
1474 RETVAL
1479 my %seen_decl;
1480 my %typemap;
1482 sub print_decl {
1483 my $fh = shift;
1484 my $decl = shift;
1485 my ($type, $name, $args) = @$decl;
1486 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1488 my @argnames = map {$_->[1]} @$args;
1489 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1490 if ($opt_k) {
1491 s/^\s*const\b\s*// for @argtypes;
1493 my @argarrays = map { $_->[4] || '' } @$args;
1494 my $numargs = @$args;
1495 if ($numargs and $argtypes[-1] eq '...') {
1496 $numargs--;
1497 $argnames[-1] = '...';
1499 local $" = ', ';
1500 $type = normalize_type($type, 1);
1502 print $fh <<"EOP";
1504 $type
1505 $name(@argnames)
1508 for my $arg (0 .. $numargs - 1) {
1509 print $fh <<"EOP";
1510 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1515 sub print_tievar_subs {
1516 my($fh, $name, $type) = @_;
1517 print $fh <<END;
1519 _get_$name(IV index, SV *sv) {
1520 dSP;
1521 PUSHMARK(SP);
1522 XPUSHs(sv);
1523 PUTBACK;
1524 (void)call_pv("$module\::_get_$name", G_DISCARD);
1525 return (I32)0;
1529 _set_$name(IV index, SV *sv) {
1530 dSP;
1531 PUSHMARK(SP);
1532 XPUSHs(sv);
1533 PUTBACK;
1534 (void)call_pv("$module\::_set_$name", G_DISCARD);
1535 return (I32)0;
1541 sub print_tievar_xsubs {
1542 my($fh, $name, $type) = @_;
1543 print $fh <<END;
1544 void
1545 _tievar_$name(sv)
1546 SV* sv
1547 PREINIT:
1548 struct ufuncs uf;
1549 CODE:
1550 uf.uf_val = &_get_$name;
1551 uf.uf_set = &_set_$name;
1552 uf.uf_index = (IV)&_get_$name;
1553 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1555 void
1556 _get_$name(THIS)
1557 $type THIS = NO_INIT
1558 CODE:
1559 THIS = $name;
1560 OUTPUT:
1561 SETMAGIC: DISABLE
1562 THIS
1564 void
1565 _set_$name(THIS)
1566 $type THIS
1567 CODE:
1568 $name = THIS;
1573 sub print_accessors {
1574 my($fh, $name, $struct) = @_;
1575 return unless defined $struct && $name !~ /\s|_ANON/;
1576 $name = normalize_type($name);
1577 my $ptrname = normalize_type("$name *");
1578 print $fh <<"EOF";
1580 MODULE = $module PACKAGE = ${name} $prefix
1582 $name *
1583 _to_ptr(THIS)
1584 $name THIS = NO_INIT
1585 PROTOTYPE: \$
1586 CODE:
1587 if (sv_derived_from(ST(0), "$name")) {
1588 STRLEN len;
1589 char *s = SvPV((SV*)SvRV(ST(0)), len);
1590 if (len != sizeof(THIS))
1591 croak("Size \%d of packed data != expected \%d",
1592 len, sizeof(THIS));
1593 RETVAL = ($name *)s;
1595 else
1596 croak("THIS is not of type $name");
1597 OUTPUT:
1598 RETVAL
1600 $name
1601 new(CLASS)
1602 char *CLASS = NO_INIT
1603 PROTOTYPE: \$
1604 CODE:
1605 Zero((void*)&RETVAL, sizeof(RETVAL), char);
1606 OUTPUT:
1607 RETVAL
1609 MODULE = $module PACKAGE = ${name}Ptr $prefix
1612 my @items = @$struct;
1613 while (@items) {
1614 my $item = shift @items;
1615 if ($item->[0] =~ /_ANON/) {
1616 if (defined $item->[2]) {
1617 push @items, map [
1618 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1619 ], @{ $structs{$item->[0]} };
1620 } else {
1621 push @items, @{ $structs{$item->[0]} };
1623 } else {
1624 my $type = normalize_type($item->[0]);
1625 my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1626 print $fh <<"EOF";
1627 $ttype
1628 $item->[2](THIS, __value = NO_INIT)
1629 $ptrname THIS
1630 $type __value
1631 PROTOTYPE: \$;\$
1632 CODE:
1633 if (items > 1)
1634 THIS->$item->[-1] = __value;
1635 RETVAL = @{[
1636 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1638 OUTPUT:
1639 RETVAL
1646 sub accessor_docs {
1647 my($name, $struct) = @_;
1648 return unless defined $struct && $name !~ /\s|_ANON/;
1649 $name = normalize_type($name);
1650 my $ptrname = $name . 'Ptr';
1651 my @items = @$struct;
1652 my @list;
1653 while (@items) {
1654 my $item = shift @items;
1655 if ($item->[0] =~ /_ANON/) {
1656 if (defined $item->[2]) {
1657 push @items, map [
1658 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1659 ], @{ $structs{$item->[0]} };
1660 } else {
1661 push @items, @{ $structs{$item->[0]} };
1663 } else {
1664 push @list, $item->[2];
1667 my $methods = (join '(...)>, C<', @list) . '(...)';
1669 my $pod = <<"EOF";
1671 #=head2 Object and class methods for C<$name>/C<$ptrname>
1673 #The principal Perl representation of a C object of type C<$name> is an
1674 #object of class C<$ptrname> which is a reference to an integer
1675 #representation of a C pointer. To create such an object, one may use
1676 #a combination
1678 # my \$buffer = $name->new();
1679 # my \$obj = \$buffer->_to_ptr();
1681 #This exersizes the following two methods, and an additional class
1682 #C<$name>, the internal representation of which is a reference to a
1683 #packed string with the C structure. Keep in mind that \$buffer should
1684 #better survive longer than \$obj.
1686 #=over
1688 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1690 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1692 #=item C<$name-E<gt>new()>
1694 #Creates an empty object of type C<$name>. The corresponding packed
1695 #string is zeroed out.
1697 #=item C<$methods>
1699 #return the current value of the corresponding element if called
1700 #without additional arguments. Set the element to the supplied value
1701 #(and return the new value) if called with an additional argument.
1703 #Applicable to objects of type C<$ptrname>.
1705 #=back
1708 $pod =~ s/^\#//gm;
1709 return $pod;
1712 # Should be called before any actual call to normalize_type().
1713 sub get_typemap {
1714 # We do not want to read ./typemap by obvios reasons.
1715 my @tm = qw(../../../typemap ../../typemap ../typemap);
1716 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1717 unshift @tm, $stdtypemap;
1718 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1720 # Start with useful default values
1721 $typemap{float} = 'T_NV';
1723 foreach my $typemap (@tm) {
1724 next unless -e $typemap ;
1725 # skip directories, binary files etc.
1726 warn " Scanning $typemap\n";
1727 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1728 unless -T $typemap ;
1729 open(TYPEMAP, $typemap)
1730 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1731 my $mode = 'Typemap';
1732 while (<TYPEMAP>) {
1733 next if /^\s*\#/;
1734 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1735 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1736 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1737 elsif ($mode eq 'Typemap') {
1738 next if /^\s*($|\#)/ ;
1739 my ($type, $image);
1740 if ( ($type, $image) =
1741 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1742 # This may reference undefined functions:
1743 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1744 $typemap{normalize_type($type)} = $image;
1748 close(TYPEMAP) or die "Cannot close $typemap: $!";
1750 %std_types = %types_seen;
1751 %types_seen = ();
1755 sub normalize_type { # Second arg: do not strip const's before \*
1756 my $type = shift;
1757 my $do_keep_deep_const = shift;
1758 # If $do_keep_deep_const this is heuristical only
1759 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1760 my $ignore_mods
1761 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1762 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1763 $type =~ s/$ignore_mods//go;
1765 else {
1766 $type =~ s/$ignore_mods//go;
1768 $type =~ s/([^\s\w])/ $1 /g;
1769 $type =~ s/\s+$//;
1770 $type =~ s/^\s+//;
1771 $type =~ s/\s+/ /g;
1772 $type =~ s/\* (?=\*)/*/g;
1773 $type =~ s/\. \. \./.../g;
1774 $type =~ s/ ,/,/g;
1775 $types_seen{$type}++
1776 unless $type eq '...' or $type eq 'void' or $std_types{$type};
1777 $type;
1780 my $need_opaque;
1782 sub assign_typemap_entry {
1783 my $type = shift;
1784 my $otype = $type;
1785 my $entry;
1786 if ($tmask and $type =~ /$tmask/) {
1787 print "Type $type matches -o mask\n" if $opt_d;
1788 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1790 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1791 $type = normalize_type $type;
1792 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1793 $entry = assign_typemap_entry($type);
1795 # XXX good do better if our UV happens to be long long
1796 return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1797 $entry ||= $typemap{$otype}
1798 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1799 $typemap{$otype} = $entry;
1800 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1801 return $entry;
1804 for (@vdecls) {
1805 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1808 if ($opt_x) {
1809 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1810 if ($opt_a) {
1811 while (my($name, $struct) = each %structs) {
1812 print_accessors(\*XS, $name, $struct);
1817 close XS;
1819 if (%types_seen) {
1820 my $type;
1821 warn "Writing $ext$modpname/typemap\n";
1822 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1824 for $type (sort keys %types_seen) {
1825 my $entry = assign_typemap_entry $type;
1826 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1829 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1830 #############################################################################
1831 INPUT
1832 T_OPAQUE_STRUCT
1833 if (sv_derived_from($arg, \"${ntype}\")) {
1834 STRLEN len;
1835 char *s = SvPV((SV*)SvRV($arg), len);
1837 if (len != sizeof($var))
1838 croak(\"Size %d of packed data != expected %d\",
1839 len, sizeof($var));
1840 $var = *($type *)s;
1842 else
1843 croak(\"$var is not of type ${ntype}\")
1844 #############################################################################
1845 OUTPUT
1846 T_OPAQUE_STRUCT
1847 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1850 close TM or die "Cannot close typemap file for write: $!";
1853 } # if( ! $opt_X )
1855 warn "Writing $ext$modpname/Makefile.PL\n";
1856 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1858 my $prereq_pm = '';
1860 if ( $compat_version < 5.00702 and $new_test )
1862 $prereq_pm .= q%'Test::More' => 0, %;
1865 if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader)
1867 $prereq_pm .= q%'XSLoader' => 0, %;
1870 print PL <<"END";
1871 use $compat_version;
1872 use ExtUtils::MakeMaker;
1873 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1874 # the contents of the Makefile that is written.
1875 WriteMakefile(
1876 NAME => '$module',
1877 VERSION_FROM => '$modpmname', # finds \$VERSION
1878 PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
1879 (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
1880 (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
1881 AUTHOR => '$author <$email>') : ()),
1883 if (!$opt_X) { # print C stuff, unless XS is disabled
1884 $opt_F = '' unless defined $opt_F;
1885 my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1886 my $Ihelp = ($I ? '-I. ' : '');
1887 my $Icomment = ($I ? '' : <<EOC);
1888 # Insert -I. if you add *.h files later:
1891 print PL <<END;
1892 LIBS => ['$extralibs'], # e.g., '-lm'
1893 DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1894 $Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1897 my $C = grep {$_ ne "$modfname.c"}
1898 (glob '*.c'), (glob '*.cc'), (glob '*.C');
1899 my $Cpre = ($C ? '' : '# ');
1900 my $Ccomment = ($C ? '' : <<EOC);
1901 # Un-comment this if you add C files to link with later:
1904 print PL <<END;
1905 $Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
1907 } # ' # Grr
1908 print PL ");\n";
1909 if (!$opt_c) {
1910 my $generate_code =
1911 WriteMakefileSnippet ( C_FILE => $constscfname,
1912 XS_FILE => $constsxsfname,
1913 DEFAULT_TYPE => $opt_t,
1914 NAME => $module,
1915 NAMES => \@const_names,
1917 print PL <<"END";
1918 if (eval {require ExtUtils::Constant; 1}) {
1919 # If you edit these definitions to change the constants used by this module,
1920 # you will need to use the generated $constscfname and $constsxsfname
1921 # files to replace their "fallback" counterparts before distributing your
1922 # changes.
1923 $generate_code
1925 else {
1926 use File::Copy;
1927 use File::Spec;
1928 foreach my \$file ('$constscfname', '$constsxsfname') {
1929 my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
1930 copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
1935 eval $generate_code;
1936 if ($@) {
1937 warn <<"EOM";
1938 Attempting to test constant code in $ext$modpname/Makefile.PL:
1939 $generate_code
1940 __END__
1941 gave unexpected error $@
1942 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1943 using the perlbug script.
1945 } else {
1946 my $fail;
1948 foreach my $file ($constscfname, $constsxsfname) {
1949 my $fallback = File::Spec->catfile($fallbackdirname, $file);
1950 if (compare($file, $fallback)) {
1951 warn << "EOM";
1952 Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
1954 $fail++;
1957 if ($fail) {
1958 warn fill ('','', <<"EOM") . "\n";
1959 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1960 the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
1961 correctly.
1963 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1964 using the perlbug script.
1966 } else {
1967 unlink $constscfname, $constsxsfname;
1971 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1973 # Create a simple README since this is a CPAN requirement
1974 # and it doesnt hurt to have one
1975 warn "Writing $ext$modpname/README\n";
1976 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1977 my $thisyear = (gmtime)[5] + 1900;
1978 my $rmhead = "$modpname version $TEMPLATE_VERSION";
1979 my $rmheadeq = "=" x length($rmhead);
1981 my $rm_prereq;
1983 if ( $compat_version < 5.00702 and $new_test )
1985 $rm_prereq = 'Test::More';
1987 else
1989 $rm_prereq = 'blah blah blah';
1992 print RM <<_RMEND_;
1993 $rmhead
1994 $rmheadeq
1996 The README is used to introduce the module and provide instructions on
1997 how to install the module, any machine dependencies it may have (for
1998 example C compilers and installed libraries) and any other information
1999 that should be provided before the module is installed.
2001 A README file is required for CPAN modules since CPAN extracts the
2002 README file from a module distribution so that people browsing the
2003 archive can use it get an idea of the modules uses. It is usually a
2004 good idea to provide version information here so that people can
2005 decide whether fixes for the module are worth downloading.
2007 INSTALLATION
2009 To install this module type the following:
2011 perl Makefile.PL
2012 make
2013 make test
2014 make install
2016 DEPENDENCIES
2018 This module requires these other modules and libraries:
2020 $rm_prereq
2022 COPYRIGHT AND LICENCE
2024 Put the correct copyright and licence information here.
2026 $licence
2028 _RMEND_
2029 close(RM) || die "Can't close $ext$modpname/README: $!\n";
2031 my $testdir = "t";
2032 my $testfile = "$testdir/$modpname.t";
2033 unless (-d "$testdir") {
2034 mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
2036 warn "Writing $ext$modpname/$testfile\n";
2037 my $tests = @const_names ? 2 : 1;
2039 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
2041 print EX <<_END_;
2042 # Before `make install' is performed this script should be runnable with
2043 # `make test'. After `make install' it should work as `perl $modpname.t'
2045 #########################
2047 # change 'tests => $tests' to 'tests => last_test_to_print';
2049 _END_
2051 my $test_mod = 'Test::More';
2053 if ( $old_test or ($compat_version < 5.007 and not $new_test ))
2055 my $test_mod = 'Test';
2057 print EX <<_END_;
2058 use Test;
2059 BEGIN { plan tests => $tests };
2060 use $module;
2061 ok(1); # If we made it this far, we're ok.
2063 _END_
2065 if (@const_names) {
2066 my $const_names = join " ", @const_names;
2067 print EX <<'_END_';
2069 my $fail;
2070 foreach my $constname (qw(
2071 _END_
2073 print EX wrap ("\t", "\t", $const_names);
2074 print EX (")) {\n");
2076 print EX <<_END_;
2077 next if (eval "my \\\$a = \$constname; 1");
2078 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2079 print "# pass: \$\@";
2080 } else {
2081 print "# fail: \$\@";
2082 \$fail = 1;
2085 if (\$fail) {
2086 print "not ok 2\\n";
2087 } else {
2088 print "ok 2\\n";
2091 _END_
2094 else
2096 print EX <<_END_;
2097 use Test::More tests => $tests;
2098 BEGIN { use_ok('$module') };
2100 _END_
2102 if (@const_names) {
2103 my $const_names = join " ", @const_names;
2104 print EX <<'_END_';
2106 my $fail = 0;
2107 foreach my $constname (qw(
2108 _END_
2110 print EX wrap ("\t", "\t", $const_names);
2111 print EX (")) {\n");
2113 print EX <<_END_;
2114 next if (eval "my \\\$a = \$constname; 1");
2115 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2116 print "# pass: \$\@";
2117 } else {
2118 print "# fail: \$\@";
2119 \$fail = 1;
2124 ok( \$fail == 0 , 'Constants' );
2125 _END_
2129 print EX <<_END_;
2130 #########################
2132 # Insert your test code below, the $test_mod module is use()ed here so read
2133 # its man page ( perldoc $test_mod ) for help writing this test script.
2135 _END_
2137 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
2139 unless ($opt_C) {
2140 warn "Writing $ext$modpname/Changes\n";
2141 $" = ' ';
2142 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
2143 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
2144 print EX <<EOP;
2145 Revision history for Perl extension $module.
2147 $TEMPLATE_VERSION @{[scalar localtime]}
2148 \t- original version; created by h2xs $H2XS_VERSION with options
2149 \t\t@ARGS
2152 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
2155 warn "Writing $ext$modpname/MANIFEST\n";
2156 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
2157 my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
2158 if (!@files) {
2159 eval {opendir(D,'.');};
2160 unless ($@) { @files = readdir(D); closedir(D); }
2162 if (!@files) { @files = map {chomp && $_} `ls`; }
2163 if ($^O eq 'VMS') {
2164 foreach (@files) {
2165 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
2166 s%\.$%%;
2167 # Fix up for case-sensitive file systems
2168 s/$modfname/$modfname/i && next;
2169 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
2170 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
2173 print MANI join("\n",@files), "\n";
2174 close MANI;