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