[REPATCH] Re: [PATCH] Re: socketpair blip on unicos/mk, too
[p5sagit/p5-mst-13.2.git] / utils / h2xs.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use File::Basename qw(&basename &dirname);
5 use Cwd;
6
7 # List explicitly here the variables you want Configure to
8 # generate.  Metaconfig only looks for shell variables, so you
9 # have to mention them as if they were shell variables, not
10 # %Config entries.  Thus you write
11 #  $startperl
12 # to ensure Configure will look for $Config{startperl}.
13
14 # This forces PL files to create target in same directory as PL file.
15 # This is so that make depend always knows where to find PL derivatives.
16 my $origdir = cwd;
17 chdir dirname($0);
18 my $file = basename($0, '.PL');
19 $file .= '.com' if $^O eq 'VMS';
20
21 open OUT,">$file" or die "Can't create $file: $!";
22
23 print "Extracting $file (with variable substitutions)\n";
24
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
27
28 print OUT <<"!GROK!THIS!";
29 $Config{startperl}
30     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31         if \$running_under_some_shell;
32 !GROK!THIS!
33
34 # In the following, perl variables are not expanded during extraction.
35
36 print OUT <<'!NO!SUBS!';
37
38 use warnings;
39
40 =head1 NAME
41
42 h2xs - convert .h C header files to Perl extensions
43
44 =head1 SYNOPSIS
45
46 B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
47
48 B<h2xs> B<-h>|B<-?>|B<--help>
49
50 =head1 DESCRIPTION
51
52 I<h2xs> builds a Perl extension from C header files.  The extension
53 will include functions which can be used to retrieve the value of any
54 #define statement which was in the C header files.
55
56 The I<module_name> will be used for the name of the extension.  If
57 module_name is not supplied then the name of the first header file
58 will be used, with the first character capitalized.
59
60 If the extension might need extra libraries, they should be included
61 here.  The extension Makefile.PL will take care of checking whether
62 the libraries actually exist and how they should be loaded.  The extra
63 libraries should be specified in the form -lm -lposix, etc, just as on
64 the cc command line.  By default, the Makefile.PL will search through
65 the library path determined by Configure.  That path can be augmented
66 by including arguments of the form B<-L/another/library/path> in the
67 extra-libraries argument.
68
69 =head1 OPTIONS
70
71 =over 5
72
73 =item B<-A>, B<--omit-autoload>
74
75 Omit all autoload facilities.  This is the same as B<-c> but also
76 removes the S<C<use AutoLoader>> statement from the .pm file.
77
78 =item B<-C>, B<--omit-changes>
79
80 Omits creation of the F<Changes> file, and adds a HISTORY section to
81 the POD template.
82
83 =item B<-F>, B<--cpp-flags>=I<addflags>
84
85 Additional flags to specify to C preprocessor when scanning header for
86 function declarations.  Should not be used without B<-x>.
87
88 =item B<-M>, B<--func-mask>=I<regular expression>
89
90 selects functions/macros to process.
91
92 =item B<-O>, B<--overwrite-ok>
93
94 Allows a pre-existing extension directory to be overwritten.
95
96 =item B<-P>, B<--omit-pod>
97
98 Omit the autogenerated stub POD section. 
99
100 =item B<-X>, B<--omit-XS>
101
102 Omit the XS portion.  Used to generate templates for a module which is not
103 XS-based.  C<-c> and C<-f> are implicitly enabled.
104
105 =item B<-a>, B<--gen-accessors>
106
107 Generate an accessor method for each element of structs and unions. The
108 generated methods are named after the element name; will return the current
109 value of the element if called without additional arguments; and will set
110 the element to the supplied value (and return the new value) if called with
111 an additional argument. Embedded structures and unions are returned as a
112 pointer rather than the complete structure, to facilitate chained calls.
113
114 These methods all apply to the Ptr type for the structure; additionally
115 two methods are constructed for the structure type itself, C<_to_ptr>
116 which returns a Ptr type pointing to the same structure, and a C<new>
117 method to construct and return a new structure, initialised to zeroes.
118
119 =item B<-b>, B<--compat-version>=I<version>
120
121 Generates a .pm file which is backwards compatible with the specified
122 perl version.
123
124 For versions < 5.6.0, the changes are.
125     - no use of 'our' (uses 'use vars' instead)
126     - no 'use warnings'
127
128 Specifying a compatibility version higher than the version of perl you
129 are using to run h2xs will have no effect.  If unspecified h2xs will default
130 to compatibility with the version of perl you are using to run h2xs.
131
132 =item B<-c>, B<--omit-constant>
133
134 Omit C<constant()> from the .xs file and corresponding specialised
135 C<AUTOLOAD> from the .pm file.
136
137 =item B<-d>, B<--debugging>
138
139 Turn on debugging messages.
140
141 =item B<-f>, B<--force>
142
143 Allows an extension to be created for a header even if that header is
144 not found in standard include directories.
145
146 =item B<-g>, B<--global>
147
148 Include code for safely storing static data in the .xs file. 
149 Extensions that do no make use of static data can ignore this option.
150
151 =item B<-h>, B<-?>, B<--help>
152
153 Print the usage, help and version for this h2xs and exit.
154
155 =item B<-k>, B<--omit-const-func>
156
157 For function arguments declared as C<const>, omit the const attribute in the
158 generated XS code.
159
160 =item B<-m>, B<--gen-tied-var>
161
162 B<Experimental>: for each variable declared in the header file(s), declare
163 a perl variable of the same name magically tied to the C variable.
164
165 =item B<-n>, B<--name>=I<module_name>
166
167 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
168
169 =item B<-o>, B<--opaque-re>=I<regular expression>
170
171 Use "opaque" data type for the C types matched by the regular
172 expression, even if these types are C<typedef>-equivalent to types
173 from typemaps.  Should not be used without B<-x>.
174
175 This may be useful since, say, types which are C<typedef>-equivalent
176 to integers may represent OS-related handles, and one may want to work
177 with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
178 Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
179 types.
180
181 The type-to-match is whitewashed (except for commas, which have no
182 whitespace before them, and multiple C<*> which have no whitespace
183 between them).
184
185 =item B<-p>, B<--remove-prefix>=I<prefix>
186
187 Specify a prefix which should be removed from the Perl function names,
188 e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
189 the prefix from functions that are autoloaded via the C<constant()>
190 mechanism.
191
192 =item B<-s>, B<--const-subs>=I<sub1,sub2>
193
194 Create a perl subroutine for the specified macros rather than autoload
195 with the constant() subroutine.  These macros are assumed to have a
196 return type of B<char *>, e.g.,
197 S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
198
199 =item B<-t>, B<--default-type>=I<type>
200
201 Specify the internal type that the constant() mechanism uses for macros.
202 The default is IV (signed integer).  Currently all macros found during the
203 header scanning process will be assumed to have this type.  Future versions
204 of C<h2xs> may gain the ability to make educated guesses.
205
206 =item B<--use-new-tests>
207
208 When B<--compat-version> (B<-b>) is present the generated tests will use
209 C<Test::More> rather then C<Test> which is the default for versions before
210 5.7.2 .   C<Test::More> will be added to PREREQ_PM in the generated
211 C<Makefile.PL>.
212
213 =item B<--use-old-tests>
214
215 Will force the generation of test code that uses the older C<Test> module.
216
217 =item B<-v>, B<--version>=I<version>
218
219 Specify a version number for this extension.  This version number is added
220 to the templates.  The default is 0.01.
221
222 =item B<-x>, B<--autogen-xsubs>
223
224 Automatically generate XSUBs basing on function declarations in the
225 header file.  The package C<C::Scan> should be installed. If this
226 option is specified, the name of the header file may look like
227 C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
228 string, but XSUBs are emitted only for the declarations included from
229 file NAME2.
230
231 Note that some types of arguments/return-values for functions may
232 result in XSUB-declarations/typemap-entries which need
233 hand-editing. Such may be objects which cannot be converted from/to a
234 pointer (like C<long long>), pointers to functions, or arrays.  See
235 also the section on L<LIMITATIONS of B<-x>>.
236
237 =back
238
239 =head1 EXAMPLES
240
241
242         # Default behavior, extension is Rusers
243         h2xs rpcsvc/rusers
244
245         # Same, but extension is RUSERS
246         h2xs -n RUSERS rpcsvc/rusers
247
248         # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
249         h2xs rpcsvc::rusers
250
251         # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
252         h2xs -n ONC::RPC rpcsvc/rusers
253
254         # Without constant() or AUTOLOAD
255         h2xs -c rpcsvc/rusers
256
257         # Creates templates for an extension named RPC
258         h2xs -cfn RPC
259
260         # Extension is ONC::RPC.
261         h2xs -cfn ONC::RPC
262
263         # Makefile.PL will look for library -lrpc in 
264         # additional directory /opt/net/lib
265         h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
266
267         # Extension is DCE::rgynbase
268         # prefix "sec_rgy_" is dropped from perl function names
269         h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
270
271         # Extension is DCE::rgynbase
272         # prefix "sec_rgy_" is dropped from perl function names
273         # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
274         h2xs -n DCE::rgynbase -p sec_rgy_ \
275         -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
276
277         # Make XS without defines in perl.h, but with function declarations
278         # visible from perl.h. Name of the extension is perl1.
279         # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
280         # Extra backslashes below because the string is passed to shell.
281         # Note that a directory with perl header files would 
282         #  be added automatically to include path.
283         h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
284
285         # Same with function declaration in proto.h as visible from perl.h.
286         h2xs -xAn perl2 perl.h,proto.h
287
288         # Same but select only functions which match /^av_/
289         h2xs -M '^av_' -xAn perl2 perl.h,proto.h
290
291         # Same but treat SV* etc as "opaque" types
292         h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
293
294 =head2 Extension based on F<.h> and F<.c> files
295
296 Suppose that you have some C files implementing some functionality,
297 and the corresponding header files.  How to create an extension which
298 makes this functionality accessable in Perl?  The example below
299 assumes that the header files are F<interface_simple.h> and
300 I<interface_hairy.h>, and you want the perl module be named as
301 C<Ext::Ension>.  If you need some preprocessor directives and/or
302 linking with external libraries, see the flags C<-F>, C<-L> and C<-l>
303 in L<"OPTIONS">.
304
305 =over
306
307 =item Find the directory name
308
309 Start with a dummy run of h2xs:
310
311   h2xs -Afn Ext::Ension
312
313 The only purpose of this step is to create the needed directories, and
314 let you know the names of these directories.  From the output you can
315 see that the directory for the extension is F<Ext/Ension>.
316
317 =item Copy C files
318
319 Copy your header files and C files to this directory F<Ext/Ension>.
320
321 =item Create the extension
322
323 Run h2xs, overwriting older autogenerated files:
324
325   h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
326
327 h2xs looks for header files I<after> changing to the extension
328 directory, so it will find your header files OK.
329
330 =item Archive and test
331
332 As usual, run
333
334   cd Ext/Ension
335   perl Makefile.PL
336   make dist
337   make
338   make test
339
340 =item Hints
341
342 It is important to do C<make dist> as early as possible.  This way you
343 can easily merge(1) your changes to autogenerated files if you decide
344 to edit your C<.h> files and rerun h2xs.
345
346 Do not forget to edit the documentation in the generated F<.pm> file.
347
348 Consider the autogenerated files as skeletons only, you may invent
349 better interfaces than what h2xs could guess.
350
351 Consider this section as a guideline only, some other options of h2xs
352 may better suit your needs.
353
354 =back
355
356 =head1 ENVIRONMENT
357
358 No environment variables are used.
359
360 =head1 AUTHOR
361
362 Larry Wall and others
363
364 =head1 SEE ALSO
365
366 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
367
368 =head1 DIAGNOSTICS
369
370 The usual warnings if it cannot read or write the files involved.
371
372 =head1 LIMITATIONS of B<-x>
373
374 F<h2xs> would not distinguish whether an argument to a C function
375 which is of the form, say, C<int *>, is an input, output, or
376 input/output parameter.  In particular, argument declarations of the
377 form
378
379     int
380     foo(n)
381         int *n
382
383 should be better rewritten as
384
385     int
386     foo(n)
387         int &n
388
389 if C<n> is an input parameter.
390
391 Additionally, F<h2xs> has no facilities to intuit that a function
392
393    int
394    foo(addr,l)
395         char *addr
396         int   l
397
398 takes a pair of address and length of data at this address, so it is better
399 to rewrite this function as
400
401     int
402     foo(sv)
403             SV *addr
404         PREINIT:
405             STRLEN len;
406             char *s;
407         CODE:
408             s = SvPV(sv,len);
409             RETVAL = foo(s, len);
410         OUTPUT:
411             RETVAL
412
413 or alternately
414
415     static int
416     my_foo(SV *sv)
417     {
418         STRLEN len;
419         char *s = SvPV(sv,len);
420
421         return foo(s, len);
422     }
423
424     MODULE = foo        PACKAGE = foo   PREFIX = my_
425
426     int
427     foo(sv)
428         SV *sv
429
430 See L<perlxs> and L<perlxstut> for additional details.
431
432 =cut
433
434 # ' # Grr
435 use strict;
436
437
438 my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/;
439 my $TEMPLATE_VERSION = '0.01';
440 my @ARGS = @ARGV;
441 my $compat_version = $];
442
443 use Getopt::Long;
444 use Config;
445 use Text::Wrap;
446 $Text::Wrap::huge = 'overflow';
447 $Text::Wrap::columns = 80;
448 use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
449 use File::Compare;
450 use Devel::PPPort;
451
452 sub usage {
453     warn "@_\n" if @_;
454     die <<EOFUSAGE;
455 h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
456 version: $H2XS_VERSION
457 OPTIONS:
458     -A, --omit-autoload   Omit all autoloading facilities (implies -c).
459     -C, --omit-changes    Omit creating the Changes file, add HISTORY heading
460                           to stub POD.
461     -F, --cpp-flags       Additional flags for C preprocessor (used with -x).
462     -M, --func-mask       Mask to select C functions/macros
463                           (default is select all).
464     -O, --overwrite-ok    Allow overwriting of a pre-existing extension directory.
465     -P, --omit-pod        Omit the stub POD section.
466     -X, --omit-XS         Omit the XS portion (implies both -c and -f).
467     -a, --gen-accessors   Generate get/set accessors for struct and union members                           (used with -x).
468     -b, --compat-version  Specify a perl version to be backwards compatibile with
469     -c, --omit-constant   Omit the constant() function and specialised AUTOLOAD
470                           from the XS file.
471     -d, --debugging       Turn on debugging messages.
472     -f, --force           Force creation of the extension even if the C header
473                           does not exist.
474     -g, --global          Include code for safely storing static data in the .xs file. 
475     -h, -?, --help        Display this help message
476     -k, --omit-const-func Omit 'const' attribute on function arguments
477                           (used with -x).
478     -m, --gen-tied-var    Generate tied variables for access to declared
479                           variables.
480     -n, --name            Specify a name to use for the extension (recommended).
481     -o, --opaque-re       Regular expression for \"opaque\" types.
482     -p, --remove-prefix   Specify a prefix which should be removed from the
483                           Perl function names.
484     -s, --const-subs      Create subroutines for specified macros.
485     -t, --default-type    Default type for autoloaded constants (default is IV)
486         --use-new-tests   Use Test::More in backward compatible modules
487         --use-old-tests   Use the module Test rather than Test::More
488     -v, --version         Specify a version number for this extension.
489     -x, --autogen-xsubs   Autogenerate XSUBs using C::Scan.
490
491 extra_libraries
492          are any libraries that might be needed for loading the
493          extension, e.g. -lm would try to link in the math library.
494 EOFUSAGE
495 }
496
497 my ($opt_A,
498     $opt_C,
499     $opt_F,
500     $opt_M,
501     $opt_O,
502     $opt_P,
503     $opt_X,
504     $opt_a,
505     $opt_c,
506     $opt_d,
507     $opt_f,
508     $opt_g,
509     $opt_h,
510     $opt_k,
511     $opt_m,
512     $opt_n,
513     $opt_o,
514     $opt_p,
515     $opt_s,
516     $opt_v,
517     $opt_x,
518     $opt_b,
519     $opt_t,
520     $new_test,
521     $old_test
522    );
523
524 Getopt::Long::Configure('bundling');
525
526 my %options = (
527                 'omit-autoload|A'    => \$opt_A,
528                 'omit-changes|C'     => \$opt_C,
529                 'cpp-flags|F=s'      => \$opt_F,
530                 'func-mask|M=s'      => \$opt_M,
531                 'overwrite_ok|O'     => \$opt_O,
532                 'omit-pod|P'         => \$opt_P,
533                 'omit-XS|X'          => \$opt_X,
534                 'gen-accessors|a'    => \$opt_a,
535                 'compat-version|b=s' => \$opt_b,
536                 'omit-constant|c'    => \$opt_c,
537                 'debugging|d'        => \$opt_d,
538                 'force|f'            => \$opt_f,
539                 'global|g'           => \$opt_g,
540                 'help|h|?'           => \$opt_h,
541                 'omit-const-func|k'  => \$opt_k,
542                 'gen-tied-var|m'     => \$opt_m,
543                 'name|n=s'           => \$opt_n,
544                 'opaque-re|o=s'      => \$opt_o,
545                 'remove-prefix|p=s'  => \$opt_p,
546                 'const-subs|s=s'     => \$opt_s,
547                 'default-type|t=s'   => \$opt_t,
548                 'version|v=s'        => \$opt_v,
549                 'autogen-xsubs|x'    => \$opt_x,
550                 'use-new-tests'      => \$new_test,
551                 'use-old-tests'      => \$old_test
552               );
553
554 GetOptions(%options) || usage;
555
556 usage if $opt_h;
557
558 if( $opt_b ){
559     usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
560     $opt_b =~ /^\d+\.\d+\.\d+/ ||
561     usage "You must provide the backwards compatibility version in X.Y.Z form. "
562           .  "(i.e. 5.5.0)\n";
563     my ($maj,$min,$sub) = split(/\./,$opt_b,3);
564     if ($maj < 5 || ($maj == 5 && $min < 6)) {
565         $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub);
566     } else {
567         $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub);
568     }
569 } else {
570     my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d\d\d?)/;
571     warn sprintf <<'EOF', $maj,$min,$sub;
572 Defaulting to backwards compatibility with perl %d.%d.%d
573 If you intend this module to be compatible with earlier perl versions, please
574 specify a minimum perl version with the -b option.
575
576 EOF
577 }
578
579 if( $opt_v ){
580         $TEMPLATE_VERSION = $opt_v;
581 }
582
583 # -A implies -c.
584 $opt_c = 1 if $opt_A;
585
586 # -X implies -c and -f
587 $opt_c = $opt_f = 1 if $opt_X;
588
589 $opt_t ||= 'IV';
590
591 my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
592
593 my $extralibs = '';
594
595 my @path_h;
596
597 while (my $arg = shift) {
598     if ($arg =~ /^-l/i) {
599         $extralibs = "$arg @ARGV";
600         last;
601     }
602     push(@path_h, $arg);
603 }
604
605 usage "Must supply header file or module name\n"
606         unless (@path_h or $opt_n);
607
608 my $fmask;
609 my $tmask;
610
611 $fmask = qr{$opt_M} if defined $opt_M;
612 $tmask = qr{$opt_o} if defined $opt_o;
613 my $tmask_all = $tmask && $opt_o eq '.';
614
615 if ($opt_x) {
616   eval {require C::Scan; 1}
617     or die <<EOD;
618 C::Scan required if you use -x option.
619 To install C::Scan, execute
620    perl -MCPAN -e "install C::Scan"
621 EOD
622   unless ($tmask_all) {
623     $C::Scan::VERSION >= 0.70
624       or die <<EOD;
625 C::Scan v. 0.70 or later required unless you use -o . option.
626 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
627 To install C::Scan, execute
628    perl -MCPAN -e "install C::Scan"
629 EOD
630   }
631   if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
632     die <<EOD;
633 C::Scan v. 0.73 or later required to use -m or -a options.
634 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
635 To install C::Scan, execute
636    perl -MCPAN -e "install C::Scan"
637 EOD
638   }
639 }
640 elsif ($opt_o or $opt_F) {
641   warn <<EOD;
642 Options -o and -F do not make sense without -x.
643 EOD
644 }
645
646 my @path_h_ini = @path_h;
647 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
648
649 my $module = $opt_n;
650
651 if( @path_h ){
652     use Config;
653     use File::Spec;
654     my @paths;
655     my $pre_sub_tri_graphs = 1;
656     if ($^O eq 'VMS') {  # Consider overrides of default location
657       # XXXX This is not equivalent to what the older version did:
658       #         it was looking at $hadsys header-file per header-file...
659       my($hadsys) = grep s!^sys/!!i , @path_h;
660       @paths = qw( Sys$Library VAXC$Include );
661       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
662       push @paths, qw( DECC$Library_Include DECC$System_Include );
663     }
664     else {
665       @paths = (File::Spec->curdir(), $Config{usrinc},
666                 (split ' ', $Config{locincpth}), '/usr/include');
667     }
668     foreach my $path_h (@path_h) {
669         $name ||= $path_h;
670     $module ||= do {
671       $name =~ s/\.h$//;
672       if ( $name !~ /::/ ) {
673         $name =~ s#^.*/##;
674         $name = "\u$name";
675       }
676       $name;
677     };
678
679     if( $path_h =~ s#::#/#g && $opt_n ){
680         warn "Nesting of headerfile ignored with -n\n";
681     }
682     $path_h .= ".h" unless $path_h =~ /\.h$/;
683     my $fullpath = $path_h;
684     $path_h =~ s/,.*$// if $opt_x;
685     $fullpath{$path_h} = $fullpath;
686
687     # Minor trickery: we can't chdir() before we processed the headers
688     # (so know the name of the extension), but the header may be in the
689     # extension directory...
690     my $tmp_path_h = $path_h;
691     my $rel_path_h = $path_h;
692     my @dirs = @paths;
693     if (not -f $path_h) {
694       my $found;
695       for my $dir (@paths) {
696         $found++, last
697           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
698       }
699       if ($found) {
700         $rel_path_h = $path_h;
701         $fullpath{$path_h} = $fullpath;
702       } else {
703         (my $epath = $module) =~ s,::,/,g;
704         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
705         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
706         $path_h = $tmp_path_h;  # Used during -x
707         push @dirs, $epath;
708       }
709     }
710
711     if (!$opt_c) {
712       die "Can't find $tmp_path_h in @dirs\n" 
713         if ( ! $opt_f && ! -f "$rel_path_h" );
714       # Scan the header file (we should deal with nested header files)
715       # Record the names of simple #define constants into const_names
716             # Function prototypes are processed below.
717       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
718     defines:
719       while (<CH>) {
720         if ($pre_sub_tri_graphs) {
721             # Preprocess all tri-graphs 
722             # including things stuck in quoted string constants.
723             s/\?\?=/#/g;                         # | ??=|  #|
724             s/\?\?\!/|/g;                        # | ??!|  ||
725             s/\?\?'/^/g;                         # | ??'|  ^|
726             s/\?\?\(/[/g;                        # | ??(|  [|
727             s/\?\?\)/]/g;                        # | ??)|  ]|
728             s/\?\?\-/~/g;                        # | ??-|  ~|
729             s/\?\?\//\\/g;                       # | ??/|  \|
730             s/\?\?</{/g;                         # | ??<|  {|
731             s/\?\?>/}/g;                         # | ??>|  }|
732         }
733         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
734             my $def = $1;
735             my $rest = $2;
736             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
737             $rest =~ s/^\s+//;
738             $rest =~ s/\s+$//;
739             # Cannot do: (-1) and ((LHANDLE)3) are OK:
740             #print("Skip non-wordy $def => $rest\n"),
741             #  next defines if $rest =~ /[^\w\$]/;
742             if ($rest =~ /"/) {
743               print("Skip stringy $def => $rest\n") if $opt_d;
744               next defines;
745             }
746             print "Matched $_ ($def)\n" if $opt_d;
747             $seen_define{$def} = $rest;
748             $_ = $def;
749             next if /^_.*_h_*$/i; # special case, but for what?
750             if (defined $opt_p) {
751               if (!/^$opt_p(\d)/) {
752                 ++$prefix{$_} if s/^$opt_p//;
753               }
754               else {
755                 warn "can't remove $opt_p prefix from '$_'!\n";
756               }
757             }
758             $prefixless{$def} = $_;
759             if (!$fmask or /$fmask/) {
760                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
761                 $const_names{$_}++;
762             }
763           }
764       }
765       close(CH);
766     }
767     }
768 }
769
770 # Save current directory so that C::Scan can use it
771 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
772
773 my ($ext, $nested, @modparts, $modfname, $modpname, $constsfname);
774
775 $ext = chdir 'ext' ? 'ext/' : '';
776
777 if( $module =~ /::/ ){
778         $nested = 1;
779         @modparts = split(/::/,$module);
780         $modfname = $modparts[-1];
781         $modpname = join('/',@modparts);
782 }
783 else {
784         $nested = 0;
785         @modparts = ();
786         $modfname = $modpname = $module;
787 }
788 # Don't trip up if someone calls their module 'constants'
789 $constsfname = $modfname eq 'constants' ? 'constdefs' : 'constants';
790
791
792 if ($opt_O) {
793         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
794 }
795 else {
796         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
797 }
798 if( $nested ){
799         my $modpath = "";
800         foreach (@modparts){
801                 -d "$modpath$_" || mkdir("$modpath$_", 0777);
802                 $modpath .= "$_/";
803         }
804 }
805 -d "$modpname"   || mkdir($modpname, 0777);
806 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
807
808 my %types_seen;
809 my %std_types;
810 my $fdecls = [];
811 my $fdecls_parsed = [];
812 my $typedef_rex;
813 my %typedefs_pre;
814 my %known_fnames;
815 my %structs;
816
817 my @fnames;
818 my @fnames_no_prefix;
819 my %vdecl_hash;
820 my @vdecls;
821
822 if( ! $opt_X ){  # use XS, unless it was disabled
823   warn "Writing $ext$modpname/ppport.h\n";
824   Devel::PPPort::WriteFile('ppport.h')
825       || die "Can't create $ext$modpname/ppport.h: $!\n";
826
827   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
828   if ($opt_x) {
829     require Config;             # Run-time directive
830     warn "Scanning typemaps...\n";
831     get_typemap();
832     my @td;
833     my @good_td;
834     my $addflags = $opt_F || '';
835
836     foreach my $filename (@path_h) {
837       my $c;
838       my $filter;
839
840       if ($fullpath{$filename} =~ /,/) {
841         $filename = $`;
842         $filter = $';
843       }
844       warn "Scanning $filename for functions...\n";
845       my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
846       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
847         'add_cppflags' => $addflags, 'c_styles' => \@styles;
848       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
849
850       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
851       push(@$fdecls, @{$c->get('fdecls')});
852
853       push @td, @{$c->get('typedefs_maybe')};
854       if ($opt_a) {
855         my $structs = $c->get('typedef_structs');
856         @structs{keys %$structs} = values %$structs;
857       }
858
859       if ($opt_m) {
860         %vdecl_hash = %{ $c->get('vdecl_hash') };
861         @vdecls = sort keys %vdecl_hash;
862         for (local $_ = 0; $_ < @vdecls; ++$_) {
863           my $var = $vdecls[$_];
864           my($type, $post) = @{ $vdecl_hash{$var} };
865           if (defined $post) {
866             warn "Can't handle variable '$type $var $post', skipping.\n";
867             splice @vdecls, $_, 1;
868             redo;
869           }
870           $type = normalize_type($type);
871           $vdecl_hash{$var} = $type;
872         }
873       }
874
875       unless ($tmask_all) {
876         warn "Scanning $filename for typedefs...\n";
877         my $td = $c->get('typedef_hash');
878         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
879         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
880         push @good_td, @f_good_td;
881         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
882       }
883     }
884     { local $" = '|';
885       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
886     }
887     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
888     if ($fmask) {
889       my @good;
890       for my $i (0..$#$fdecls_parsed) {
891         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
892         push @good, $i;
893         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
894           if $opt_d;
895       }
896       $fdecls = [@$fdecls[@good]];
897       $fdecls_parsed = [@$fdecls_parsed[@good]];
898     }
899     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
900     # Sort declarations:
901     {
902       my %h = map( ($_->[1], $_), @$fdecls_parsed);
903       $fdecls_parsed = [ @h{@fnames} ];
904     }
905     @fnames_no_prefix = @fnames;
906     @fnames_no_prefix
907       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
908          if defined $opt_p;
909     # Remove macros which expand to typedefs
910     print "Typedefs are @td.\n" if $opt_d;
911     my %td = map {($_, $_)} @td;
912     # Add some other possible but meaningless values for macros
913     for my $k (qw(char double float int long short unsigned signed void)) {
914       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
915     }
916     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
917     my $n = 0;
918     my %bad_macs;
919     while (keys %td > $n) {
920       $n = keys %td;
921       my ($k, $v);
922       while (($k, $v) = each %seen_define) {
923         # print("found '$k'=>'$v'\n"), 
924         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
925       }
926     }
927     # Now %bad_macs contains names of bad macros
928     for my $k (keys %bad_macs) {
929       delete $const_names{$prefixless{$k}};
930       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
931     }
932   }
933 }
934 my @const_names = sort keys %const_names;
935
936 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
937
938 $" = "\n\t";
939 warn "Writing $ext$modpname/$modfname.pm\n";
940
941 print PM <<"END";
942 package $module;
943
944 use $compat_version;
945 use strict;
946 END
947 print PM "use warnings;\n" unless $compat_version < 5.006;
948
949 unless( $opt_X || $opt_c || $opt_A ){
950         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
951         # will want Carp.
952         print PM <<'END';
953 use Carp;
954 END
955 }
956
957 print PM <<'END';
958
959 require Exporter;
960 END
961
962 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
963 require DynaLoader;
964 END
965
966
967 # Are we using AutoLoader or not?
968 unless ($opt_A) { # no autoloader whatsoever.
969         unless ($opt_c) { # we're doing the AUTOLOAD
970                 print PM "use AutoLoader;\n";
971         }
972         else {
973                 print PM "use AutoLoader qw(AUTOLOAD);\n"
974         }
975 }
976
977 if ( $compat_version < 5.006 ) {
978     if ( $opt_X || $opt_c || $opt_A ) {
979         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
980     } else {
981         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
982     }
983 }
984
985 # Determine @ISA.
986 my $myISA = 'our @ISA = qw(Exporter';   # We seem to always want this.
987 $myISA .= ' DynaLoader'         unless $opt_X;  # no XS
988 $myISA .= ');';
989 $myISA =~ s/^our // if $compat_version < 5.006;
990
991 print PM "\n$myISA\n\n";
992
993 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
994
995 my $tmp=<<"END";
996 # Items to export into callers namespace by default. Note: do not export
997 # names by default without a very good reason. Use EXPORT_OK instead.
998 # Do not simply export all your public functions/methods/constants.
999
1000 # This allows declaration       use $module ':all';
1001 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1002 # will save memory.
1003 our %EXPORT_TAGS = ( 'all' => [ qw(
1004         @exported_names
1005 ) ] );
1006
1007 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1008
1009 our \@EXPORT = qw(
1010         @const_names
1011 );
1012 our \$VERSION = '$TEMPLATE_VERSION';
1013
1014 END
1015
1016 $tmp =~ s/^our //mg if $compat_version < 5.006;
1017 print PM $tmp;
1018
1019 if (@vdecls) {
1020     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1021 }
1022
1023
1024 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1025
1026 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1027         print PM <<"END";
1028 bootstrap $module \$VERSION;
1029 END
1030 }
1031
1032 # tying the variables can happen only after bootstrap
1033 if (@vdecls) {
1034     printf PM <<END;
1035 {
1036 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
1037 }
1038
1039 END
1040 }
1041
1042 my $after;
1043 if( $opt_P ){ # if POD is disabled
1044         $after = '__END__';
1045 }
1046 else {
1047         $after = '=cut';
1048 }
1049
1050 print PM <<"END";
1051
1052 # Preloaded methods go here.
1053 END
1054
1055 print PM <<"END" unless $opt_A;
1056
1057 # Autoload methods go after $after, and are processed by the autosplit program.
1058 END
1059
1060 print PM <<"END";
1061
1062 1;
1063 __END__
1064 END
1065
1066 my ($email,$author);
1067
1068 eval {
1069        my $username;
1070        ($username,$author) = (getpwuid($>))[0,6];
1071        if (defined $username && defined $author) {
1072            $author =~ s/,.*$//; # in case of sub fields
1073            my $domain = $Config{'mydomain'};
1074            $domain =~ s/^\.//;
1075            $email = "$username\@$domain";
1076        }
1077      };
1078
1079 $author ||= "A. U. Thor";
1080 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1081
1082 my $revhist = '';
1083 $revhist = <<EOT if $opt_C;
1084 #
1085 #=head1 HISTORY
1086 #
1087 #=over 8
1088 #
1089 #=item $TEMPLATE_VERSION
1090 #
1091 #Original version; created by h2xs $H2XS_VERSION with options
1092 #
1093 #  @ARGS
1094 #
1095 #=back
1096 #
1097 EOT
1098
1099 my $exp_doc = <<EOD;
1100 #
1101 #=head2 EXPORT
1102 #
1103 #None by default.
1104 #
1105 EOD
1106
1107 if (@const_names and not $opt_P) {
1108   $exp_doc .= <<EOD;
1109 #=head2 Exportable constants
1110 #
1111 #  @{[join "\n  ", @const_names]}
1112 #
1113 EOD
1114 }
1115
1116 if (defined $fdecls and @$fdecls and not $opt_P) {
1117   $exp_doc .= <<EOD;
1118 #=head2 Exportable functions
1119 #
1120 EOD
1121
1122 #  $exp_doc .= <<EOD if $opt_p;
1123 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1124 #
1125 #EOD
1126   $exp_doc .= <<EOD;
1127 #  @{[join "\n  ", @known_fnames{@fnames}]}
1128 #
1129 EOD
1130 }
1131
1132 my $meth_doc = '';
1133
1134 if ($opt_x && $opt_a) {
1135   my($name, $struct);
1136   $meth_doc .= accessor_docs($name, $struct)
1137     while ($name, $struct) = each %structs;
1138 }
1139
1140 my $pod = <<"END" unless $opt_P;
1141 ## Below is stub documentation for your module. You'd better edit it!
1142 #
1143 #=head1 NAME
1144 #
1145 #$module - Perl extension for blah blah blah
1146 #
1147 #=head1 SYNOPSIS
1148 #
1149 #  use $module;
1150 #  blah blah blah
1151 #
1152 #=head1 ABSTRACT
1153 #
1154 #  This should be the abstract for $module.
1155 #  The abstract is used when making PPD (Perl Package Description) files.
1156 #  If you don't want an ABSTRACT you should also edit Makefile.PL to
1157 #  remove the ABSTRACT_FROM option.
1158 #
1159 #=head1 DESCRIPTION
1160 #
1161 #Stub documentation for $module, created by h2xs. It looks like the
1162 #author of the extension was negligent enough to leave the stub
1163 #unedited.
1164 #
1165 #Blah blah blah.
1166 $exp_doc$meth_doc$revhist
1167 #
1168 #=head1 SEE ALSO
1169 #
1170 #Mention other useful documentation such as the documentation of
1171 #related modules or operating system documentation (such as man pages
1172 #in UNIX), or any relevant external documentation such as RFCs or
1173 #standards.
1174 #
1175 #If you have a mailing list set up for your module, mention it here.
1176 #
1177 #If you have a web site set up for your module, mention it here.
1178 #
1179 #=head1 AUTHOR
1180 #
1181 #$author, E<lt>${email}E<gt>
1182 #
1183 #=head1 COPYRIGHT AND LICENSE
1184 #
1185 #Copyright ${\(1900 + (localtime) [5])} by $author
1186 #
1187 #This library is free software; you can redistribute it and/or modify
1188 #it under the same terms as Perl itself. 
1189 #
1190 #=cut
1191 END
1192
1193 $pod =~ s/^\#//gm unless $opt_P;
1194 print PM $pod unless $opt_P;
1195
1196 close PM;
1197
1198
1199 if( ! $opt_X ){ # print XS, unless it is disabled
1200 warn "Writing $ext$modpname/$modfname.xs\n";
1201
1202 print XS <<"END";
1203 #include "EXTERN.h"
1204 #include "perl.h"
1205 #include "XSUB.h"
1206 #include "ppport.h"
1207
1208 END
1209 if( @path_h ){
1210     foreach my $path_h (@path_h_ini) {
1211         my($h) = $path_h;
1212         $h =~ s#^/usr/include/##;
1213         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1214         print XS qq{#include <$h>\n};
1215     }
1216     print XS "\n";
1217 }
1218
1219 print XS <<"END" if $opt_g;
1220
1221 /* Global Data */
1222
1223 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1224
1225 typedef struct {
1226     /* Put Global Data in here */
1227     int dummy;          /* you can access this elsewhere as MY_CXT.dummy */
1228 } my_cxt_t;
1229
1230 START_MY_CXT
1231
1232 END
1233
1234 my %pointer_typedefs;
1235 my %struct_typedefs;
1236
1237 sub td_is_pointer {
1238   my $type = shift;
1239   my $out = $pointer_typedefs{$type};
1240   return $out if defined $out;
1241   my $otype = $type;
1242   $out = ($type =~ /\*$/);
1243   # This converts only the guys which do not have trailing part in the typedef
1244   if (not $out
1245       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1246     $type = normalize_type($type);
1247     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1248       if $opt_d;
1249     $out = td_is_pointer($type);
1250   }
1251   return ($pointer_typedefs{$otype} = $out);
1252 }
1253
1254 sub td_is_struct {
1255   my $type = shift;
1256   my $out = $struct_typedefs{$type};
1257   return $out if defined $out;
1258   my $otype = $type;
1259   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1260   # This converts only the guys which do not have trailing part in the typedef
1261   if (not $out
1262       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1263     $type = normalize_type($type);
1264     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1265       if $opt_d;
1266     $out = td_is_struct($type);
1267   }
1268   return ($struct_typedefs{$otype} = $out);
1269 }
1270
1271 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1272
1273 if( ! $opt_c ) {
1274   # We write the "sample" files used when this module is built by perl without
1275   # ExtUtils::Constant.
1276   # h2xs will later check that these are the same as those generated by the
1277   # code embedded into Makefile.PL
1278   warn "Writing $ext$modpname/fallback.c\n";
1279   warn "Writing $ext$modpname/fallback.xs\n";
1280   WriteConstants ( C_FILE =>       "fallback.c",
1281                    XS_FILE =>      "fallback.xs",
1282                    DEFAULT_TYPE => $opt_t,
1283                    NAME =>         $module,
1284                    NAMES =>        \@const_names,
1285                  );
1286   print XS "#include \"$constsfname.c\"\n";
1287 }
1288
1289
1290 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1291
1292 # Now switch from C to XS by issuing the first MODULE declaration:
1293 print XS <<"END";
1294
1295 MODULE = $module                PACKAGE = $module               $prefix
1296
1297 END
1298
1299 # If a constant() function was #included then output a corresponding
1300 # XS declaration:
1301 print XS "INCLUDE: $constsfname.xs\n" unless $opt_c;
1302
1303 print XS <<"END" if $opt_g;
1304
1305 BOOT:
1306 {
1307     MY_CXT_INIT;
1308     /* If any of the fields in the my_cxt_t struct need
1309        to be initialised, do it here.
1310      */
1311 }
1312
1313 END
1314
1315 foreach (sort keys %const_xsub) {
1316     print XS <<"END";
1317 char *
1318 $_()
1319
1320     CODE:
1321 #ifdef $_
1322         RETVAL = $_;
1323 #else
1324         croak("Your vendor has not defined the $module macro $_");
1325 #endif
1326
1327     OUTPUT:
1328         RETVAL
1329
1330 END
1331 }
1332
1333 my %seen_decl;
1334 my %typemap;
1335
1336 sub print_decl {
1337   my $fh = shift;
1338   my $decl = shift;
1339   my ($type, $name, $args) = @$decl;
1340   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1341
1342   my @argnames = map {$_->[1]} @$args;
1343   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1344   if ($opt_k) {
1345     s/^\s*const\b\s*// for @argtypes;
1346   }
1347   my @argarrays = map { $_->[4] || '' } @$args;
1348   my $numargs = @$args;
1349   if ($numargs and $argtypes[-1] eq '...') {
1350     $numargs--;
1351     $argnames[-1] = '...';
1352   }
1353   local $" = ', ';
1354   $type = normalize_type($type, 1);
1355
1356   print $fh <<"EOP";
1357
1358 $type
1359 $name(@argnames)
1360 EOP
1361
1362   for my $arg (0 .. $numargs - 1) {
1363     print $fh <<"EOP";
1364         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1365 EOP
1366   }
1367 }
1368
1369 sub print_tievar_subs {
1370   my($fh, $name, $type) = @_;
1371   print $fh <<END;
1372 I32
1373 _get_$name(IV index, SV *sv) {
1374     dSP;
1375     PUSHMARK(SP);
1376     XPUSHs(sv);
1377     PUTBACK;
1378     (void)call_pv("$module\::_get_$name", G_DISCARD);
1379     return (I32)0;
1380 }
1381
1382 I32
1383 _set_$name(IV index, SV *sv) {
1384     dSP;
1385     PUSHMARK(SP);
1386     XPUSHs(sv);
1387     PUTBACK;
1388     (void)call_pv("$module\::_set_$name", G_DISCARD);
1389     return (I32)0;
1390 }
1391
1392 END
1393 }
1394
1395 sub print_tievar_xsubs {
1396   my($fh, $name, $type) = @_;
1397   print $fh <<END;
1398 void
1399 _tievar_$name(sv)
1400         SV* sv
1401     PREINIT:
1402         struct ufuncs uf;
1403     CODE:
1404         uf.uf_val = &_get_$name;
1405         uf.uf_set = &_set_$name;
1406         uf.uf_index = (IV)&_get_$name;
1407         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1408
1409 void
1410 _get_$name(THIS)
1411         $type THIS = NO_INIT
1412     CODE:
1413         THIS = $name;
1414     OUTPUT:
1415         SETMAGIC: DISABLE
1416         THIS
1417
1418 void
1419 _set_$name(THIS)
1420         $type THIS
1421     CODE:
1422         $name = THIS;
1423
1424 END
1425 }
1426
1427 sub print_accessors {
1428   my($fh, $name, $struct) = @_;
1429   return unless defined $struct && $name !~ /\s|_ANON/;
1430   $name = normalize_type($name);
1431   my $ptrname = normalize_type("$name *");
1432   print $fh <<"EOF";
1433
1434 MODULE = $module                PACKAGE = ${name}               $prefix
1435
1436 $name *
1437 _to_ptr(THIS)
1438         $name THIS = NO_INIT
1439     PROTOTYPE: \$
1440     CODE:
1441         if (sv_derived_from(ST(0), "$name")) {
1442             STRLEN len;
1443             char *s = SvPV((SV*)SvRV(ST(0)), len);
1444             if (len != sizeof(THIS))
1445                 croak("Size \%d of packed data != expected \%d",
1446                         len, sizeof(THIS));
1447             RETVAL = ($name *)s;
1448         }   
1449         else
1450             croak("THIS is not of type $name");
1451     OUTPUT:
1452         RETVAL
1453
1454 $name
1455 new(CLASS)
1456         char *CLASS = NO_INIT
1457     PROTOTYPE: \$
1458     CODE:
1459         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1460     OUTPUT:
1461         RETVAL
1462
1463 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1464
1465 EOF
1466   my @items = @$struct;
1467   while (@items) {
1468     my $item = shift @items;
1469     if ($item->[0] =~ /_ANON/) {
1470       if (defined $item->[2]) {
1471         push @items, map [
1472           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1473         ], @{ $structs{$item->[0]} };
1474       } else {
1475         push @items, @{ $structs{$item->[0]} };
1476       }
1477     } else {
1478       my $type = normalize_type($item->[0]);
1479       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1480       print $fh <<"EOF";
1481 $ttype
1482 $item->[2](THIS, __value = NO_INIT)
1483         $ptrname THIS
1484         $type __value
1485     PROTOTYPE: \$;\$
1486     CODE:
1487         if (items > 1)
1488             THIS->$item->[-1] = __value;
1489         RETVAL = @{[
1490             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1491         ]};
1492     OUTPUT:
1493         RETVAL
1494
1495 EOF
1496     }
1497   }
1498 }
1499
1500 sub accessor_docs {
1501   my($name, $struct) = @_;
1502   return unless defined $struct && $name !~ /\s|_ANON/;
1503   $name = normalize_type($name);
1504   my $ptrname = $name . 'Ptr';
1505   my @items = @$struct;
1506   my @list;
1507   while (@items) {
1508     my $item = shift @items;
1509     if ($item->[0] =~ /_ANON/) {
1510       if (defined $item->[2]) {
1511         push @items, map [
1512           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1513         ], @{ $structs{$item->[0]} };
1514       } else {
1515         push @items, @{ $structs{$item->[0]} };
1516       }
1517     } else {
1518       push @list, $item->[2];
1519     }
1520   }
1521   my $methods = (join '(...)>, C<', @list) . '(...)';
1522
1523   my $pod = <<"EOF";
1524 #
1525 #=head2 Object and class methods for C<$name>/C<$ptrname>
1526 #
1527 #The principal Perl representation of a C object of type C<$name> is an
1528 #object of class C<$ptrname> which is a reference to an integer
1529 #representation of a C pointer.  To create such an object, one may use
1530 #a combination
1531 #
1532 #  my \$buffer = $name->new();
1533 #  my \$obj = \$buffer->_to_ptr();
1534 #
1535 #This exersizes the following two methods, and an additional class
1536 #C<$name>, the internal representation of which is a reference to a
1537 #packed string with the C structure.  Keep in mind that \$buffer should
1538 #better survive longer than \$obj.
1539 #
1540 #=over
1541 #
1542 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1543 #
1544 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1545 #
1546 #=item C<$name-E<gt>new()>
1547 #
1548 #Creates an empty object of type C<$name>.  The corresponding packed
1549 #string is zeroed out.
1550 #
1551 #=item C<$methods>
1552 #
1553 #return the current value of the corresponding element if called
1554 #without additional arguments.  Set the element to the supplied value
1555 #(and return the new value) if called with an additional argument.
1556 #
1557 #Applicable to objects of type C<$ptrname>.
1558 #
1559 #=back
1560 #
1561 EOF
1562   $pod =~ s/^\#//gm;
1563   return $pod;
1564 }
1565
1566 # Should be called before any actual call to normalize_type().
1567 sub get_typemap {
1568   # We do not want to read ./typemap by obvios reasons.
1569   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1570   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1571   unshift @tm, $stdtypemap;
1572   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1573
1574   # Start with useful default values
1575   $typemap{float} = 'T_NV';
1576
1577   foreach my $typemap (@tm) {
1578     next unless -e $typemap ;
1579     # skip directories, binary files etc.
1580     warn " Scanning $typemap\n";
1581     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
1582       unless -T $typemap ;
1583     open(TYPEMAP, $typemap) 
1584       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1585     my $mode = 'Typemap';
1586     while (<TYPEMAP>) {
1587       next if /^\s*\#/;
1588       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1589       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1590       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1591       elsif ($mode eq 'Typemap') {
1592         next if /^\s*($|\#)/ ;
1593         my ($type, $image);
1594         if ( ($type, $image) =
1595              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1596              # This may reference undefined functions:
1597              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1598           $typemap{normalize_type($type)} = $image;
1599         }
1600       }
1601     }
1602     close(TYPEMAP) or die "Cannot close $typemap: $!";
1603   }
1604   %std_types = %types_seen;
1605   %types_seen = ();
1606 }
1607
1608
1609 sub normalize_type {            # Second arg: do not strip const's before \*
1610   my $type = shift;
1611   my $do_keep_deep_const = shift;
1612   # If $do_keep_deep_const this is heuristical only
1613   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1614   my $ignore_mods 
1615     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1616   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1617     $type =~ s/$ignore_mods//go;
1618   }
1619   else {
1620     $type =~ s/$ignore_mods//go;
1621   }
1622   $type =~ s/([^\s\w])/ $1 /g;
1623   $type =~ s/\s+$//;
1624   $type =~ s/^\s+//;
1625   $type =~ s/\s+/ /g;
1626   $type =~ s/\* (?=\*)/*/g;
1627   $type =~ s/\. \. \./.../g;
1628   $type =~ s/ ,/,/g;
1629   $types_seen{$type}++ 
1630     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1631   $type;
1632 }
1633
1634 my $need_opaque;
1635
1636 sub assign_typemap_entry {
1637   my $type = shift;
1638   my $otype = $type;
1639   my $entry;
1640   if ($tmask and $type =~ /$tmask/) {
1641     print "Type $type matches -o mask\n" if $opt_d;
1642     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1643   }
1644   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1645     $type = normalize_type $type;
1646     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1647     $entry = assign_typemap_entry($type);
1648   }
1649   # XXX good do better if our UV happens to be long long
1650   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1651   $entry ||= $typemap{$otype}
1652     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1653   $typemap{$otype} = $entry;
1654   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1655   return $entry;
1656 }
1657
1658 for (@vdecls) {
1659   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1660 }
1661
1662 if ($opt_x) {
1663   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1664   if ($opt_a) {
1665     while (my($name, $struct) = each %structs) {
1666       print_accessors(\*XS, $name, $struct);
1667     }
1668   }
1669 }
1670
1671 close XS;
1672
1673 if (%types_seen) {
1674   my $type;
1675   warn "Writing $ext$modpname/typemap\n";
1676   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1677
1678   for $type (sort keys %types_seen) {
1679     my $entry = assign_typemap_entry $type;
1680     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1681   }
1682
1683   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1684 #############################################################################
1685 INPUT
1686 T_OPAQUE_STRUCT
1687         if (sv_derived_from($arg, \"${ntype}\")) {
1688             STRLEN len;
1689             char  *s = SvPV((SV*)SvRV($arg), len);
1690
1691             if (len != sizeof($var))
1692                 croak(\"Size %d of packed data != expected %d\",
1693                         len, sizeof($var));
1694             $var = *($type *)s;
1695         }
1696         else
1697             croak(\"$var is not of type ${ntype}\")
1698 #############################################################################
1699 OUTPUT
1700 T_OPAQUE_STRUCT
1701         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1702 EOP
1703
1704   close TM or die "Cannot close typemap file for write: $!";
1705 }
1706
1707 } # if( ! $opt_X )
1708
1709 warn "Writing $ext$modpname/Makefile.PL\n";
1710 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1711
1712 my $prereq_pm;
1713
1714 if ( $compat_version < 5.00702 and $new_test )
1715 {
1716   $prereq_pm = q%'Test::More'  =>  0%;
1717 }
1718 else
1719 {
1720   $prereq_pm = '';
1721 }
1722
1723 print PL <<"END";
1724 use $compat_version;
1725 use ExtUtils::MakeMaker;
1726 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1727 # the contents of the Makefile that is written.
1728 WriteMakefile(
1729     'NAME'              => '$module',
1730     'VERSION_FROM'      => '$modfname.pm', # finds \$VERSION
1731     'PREREQ_PM'         => {$prereq_pm}, # e.g., Module::Name => 1.1
1732     (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
1733       (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1734        AUTHOR     => '$author <$email>') : ()),
1735 END
1736 if (!$opt_X) { # print C stuff, unless XS is disabled
1737   $opt_F = '' unless defined $opt_F;
1738   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1739   my $Ihelp = ($I ? '-I. ' : '');
1740   my $Icomment = ($I ? '' : <<EOC);
1741         # Insert -I. if you add *.h files later:
1742 EOC
1743
1744   print PL <<END;
1745     'LIBS'              => ['$extralibs'], # e.g., '-lm'
1746     'DEFINE'            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1747 $Icomment    'INC'              => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1748 END
1749
1750   if (!$opt_c) {
1751     print PL <<"END";
1752     # Without this the constants xs files are spotted, and cause rules to be
1753     # added to delete the similarly names C files, which isn't what we want.
1754     'XS'                => {'$modfname.xs' => '$modfname.c'},
1755     realclean           => {FILES => '$constsfname.c $constsfname.xs'},
1756 END
1757   }
1758
1759   my $C = grep {$_ ne "$modfname.c" && $_ ne "fallback.c"}
1760     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1761   my $Cpre = ($C ? '' : '# ');
1762   my $Ccomment = ($C ? '' : <<EOC);
1763         # Un-comment this if you add C files to link with later:
1764 EOC
1765
1766   print PL <<END;
1767 $Ccomment    $Cpre\'OBJECT'             => '\$(O_FILES)', # link all the C files too
1768 END
1769 } # ' # Grr
1770 print PL ");\n";
1771 if (!$opt_c) {
1772   my $generate_code =
1773     WriteMakefileSnippet ( C_FILE =>       "$constsfname.c",
1774                            XS_FILE =>      "$constsfname.xs",
1775                            DEFAULT_TYPE => $opt_t,
1776                            NAME =>         $module,
1777                            NAMES =>        \@const_names,
1778                  );
1779   print PL <<"END";
1780 if  (eval {require ExtUtils::Constant; 1}) {
1781   # If you edit these definitions to change the constants used by this module,
1782   # you will need to use the generated $constsfname.c and $constsfname.xs
1783   # files to replace their "fallback" counterparts before distributing your
1784   # changes.
1785 $generate_code
1786 }
1787 else {
1788   use File::Copy;
1789   copy ('fallback.c', '$constsfname.c')
1790     or die "Can't copy fallback.c to $constsfname.c: \$!";
1791   copy ('fallback.xs', '$constsfname.xs')
1792     or die "Can't copy fallback.xs to $constsfname.xs: \$!";
1793 }
1794 END
1795
1796   eval $generate_code;
1797   if ($@) {
1798     warn <<"EOM";
1799 Attempting to test constant code in $ext$modpname/Makefile.PL:
1800 $generate_code
1801 __END__
1802 gave unexpected error $@
1803 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1804 using the perlbug script.
1805 EOM
1806   } else {
1807     my $fail;
1808
1809     foreach ('c', 'xs') {
1810       if (compare("fallback.$_", "$constsfname.$_")) {
1811         warn << "EOM";
1812 Files "$ext$modpname/fallback.$_" and "$ext$modpname/$constsfname.$_" differ.
1813 EOM
1814         $fail++;
1815       }
1816     }
1817     if ($fail) {
1818       warn fill ('','', <<"EOM") . "\n";
1819 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1820 the files $ext$modpname/$constsfname.c and $ext$modpname/$constsfname.xs
1821 correctly.
1822  
1823 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1824 using the perlbug script.
1825 EOM
1826     } else {
1827       unlink "$constsfname.c", "$constsfname.xs";
1828     }
1829   }
1830 }
1831 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1832
1833 # Create a simple README since this is a CPAN requirement
1834 # and it doesnt hurt to have one
1835 warn "Writing $ext$modpname/README\n";
1836 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1837 my $thisyear = (gmtime)[5] + 1900;
1838 my $rmhead = "$modpname version $TEMPLATE_VERSION";
1839 my $rmheadeq = "=" x length($rmhead);
1840
1841 my $rm_prereq;
1842
1843 if ( $compat_version < 5.00702 and $new_test )
1844 {
1845    $rm_prereq = 'Test::More';
1846 }
1847 else
1848 {
1849    $rm_prereq = 'blah blah blah';
1850 }
1851
1852 print RM <<_RMEND_;
1853 $rmhead
1854 $rmheadeq
1855
1856 The README is used to introduce the module and provide instructions on
1857 how to install the module, any machine dependencies it may have (for
1858 example C compilers and installed libraries) and any other information
1859 that should be provided before the module is installed.
1860
1861 A README file is required for CPAN modules since CPAN extracts the
1862 README file from a module distribution so that people browsing the
1863 archive can use it get an idea of the modules uses. It is usually a
1864 good idea to provide version information here so that people can
1865 decide whether fixes for the module are worth downloading.
1866
1867 INSTALLATION
1868
1869 To install this module type the following:
1870
1871    perl Makefile.PL
1872    make
1873    make test
1874    make install
1875
1876 DEPENDENCIES
1877
1878 This module requires these other modules and libraries:
1879
1880   $rm_prereq
1881
1882 COPYRIGHT AND LICENCE
1883
1884 Put the correct copyright and licence information here.
1885
1886 Copyright (C) $thisyear $author
1887
1888 This library is free software; you can redistribute it and/or modify
1889 it under the same terms as Perl itself. 
1890
1891 _RMEND_
1892 close(RM) || die "Can't close $ext$modpname/README: $!\n";
1893
1894 my $testdir  = "t";
1895 my $testfile = "$testdir/1.t";
1896 unless (-d "$testdir") {
1897   mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
1898 }
1899 warn "Writing $ext$modpname/$testfile\n";
1900 my $tests = @const_names ? 2 : 1;
1901
1902 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
1903
1904 print EX <<_END_;
1905 # Before `make install' is performed this script should be runnable with
1906 # `make test'. After `make install' it should work as `perl 1.t'
1907
1908 #########################
1909
1910 # change 'tests => $tests' to 'tests => last_test_to_print';
1911
1912 _END_
1913
1914 my $test_mod = 'Test::More';
1915
1916 if ( $old_test or ($compat_version < 5.007 and not $new_test ))
1917 {
1918   my $test_mod = 'Test';
1919
1920   print EX <<_END_;
1921 use Test;
1922 BEGIN { plan tests => $tests };
1923 use $module;
1924 ok(1); # If we made it this far, we're ok.
1925
1926 _END_
1927
1928    if (@const_names) {
1929      my $const_names = join " ", @const_names;
1930      print EX <<'_END_';
1931
1932 my $fail;
1933 foreach my $constname (qw(
1934 _END_
1935
1936      print EX wrap ("\t", "\t", $const_names);
1937      print EX (")) {\n");
1938
1939      print EX <<_END_;
1940   next if (eval "my \\\$a = \$constname; 1");
1941   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1942     print "# pass: \$\@";
1943   } else {
1944     print "# fail: \$\@";
1945     \$fail = 1;    
1946   }
1947 }
1948 if (\$fail) {
1949   print "not ok 2\\n";
1950 } else {
1951   print "ok 2\\n";
1952 }
1953
1954 _END_
1955   }
1956 }
1957 else
1958 {
1959   print EX <<_END_;
1960 use Test::More tests => $tests;
1961 BEGIN { use_ok('$module') };
1962
1963 _END_
1964
1965    if (@const_names) {
1966      my $const_names = join " ", @const_names;
1967      print EX <<'_END_';
1968
1969 my $fail = 0;
1970 foreach my $constname (qw(
1971 _END_
1972
1973      print EX wrap ("\t", "\t", $const_names);
1974      print EX (")) {\n");
1975
1976      print EX <<_END_;
1977   next if (eval "my \\\$a = \$constname; 1");
1978   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1979     print "# pass: \$\@";
1980   } else {
1981     print "# fail: \$\@";
1982     \$fail = 1;
1983   }
1984
1985 }
1986
1987 ok( \$fail == 0 , 'Constants' );
1988 _END_
1989   }
1990 }
1991
1992 print EX <<_END_;
1993 #########################
1994
1995 # Insert your test code below, the $test_mod module is use()ed here so read
1996 # its man page ( perldoc $test_mod ) for help writing this test script.
1997
1998 _END_
1999
2000 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
2001
2002 unless ($opt_C) {
2003   warn "Writing $ext$modpname/Changes\n";
2004   $" = ' ';
2005   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
2006   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
2007   print EX <<EOP;
2008 Revision history for Perl extension $module.
2009
2010 $TEMPLATE_VERSION  @{[scalar localtime]}
2011 \t- original version; created by h2xs $H2XS_VERSION with options
2012 \t\t@ARGS
2013
2014 EOP
2015   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
2016 }
2017
2018 warn "Writing $ext$modpname/MANIFEST\n";
2019 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
2020 my @files = grep { -f } (<*>, <t/*>);
2021 if (!@files) {
2022   eval {opendir(D,'.');};
2023   unless ($@) { @files = readdir(D); closedir(D); }
2024 }
2025 if (!@files) { @files = map {chomp && $_} `ls`; }
2026 if ($^O eq 'VMS') {
2027   foreach (@files) {
2028     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
2029     s%\.$%%;
2030     # Fix up for case-sensitive file systems
2031     s/$modfname/$modfname/i && next;
2032     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
2033     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
2034   }
2035 }
2036 if (!$opt_c) {
2037   @files = grep {$_ ne "$constsfname.c" and $_ ne "$constsfname.xs"} @files;
2038 }
2039 print MANI join("\n",@files), "\n";
2040 close MANI;
2041 !NO!SUBS!
2042
2043 close OUT or die "Can't close $file: $!";
2044 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2045 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2046 chdir $origdir;