[patch perl@8150] h2xs SYNOPSIS
[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
413 sub usage{
414         warn "@_\n" if @_;
415     die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]]
416 version: $H2XS_VERSION
417     -A   Omit all autoloading facilities (implies -c).
418     -C   Omit creating the Changes file, add HISTORY heading to stub POD.
419     -F   Additional flags for C preprocessor (used with -x).
420     -M   Mask to select C functions/macros (default is select all).
421     -O   Allow overwriting of a pre-existing extension directory.
422     -P   Omit the stub POD section.
423     -X   Omit the XS portion (implies both -c and -f).
424     -a   Generate get/set accessors for struct and union members (used with -x).
425     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
426     -d   Turn on debugging messages.
427     -f   Force creation of the extension even if the C header does not exist.
428     -h   Display this help message
429     -k   Omit 'const' attribute on function arguments (used with -x).
430     -m   Generate tied variables for access to declared variables.
431     -n   Specify a name to use for the extension (recommended).
432     -o   Regular expression for \"opaque\" types.
433     -p   Specify a prefix which should be removed from the Perl function names.
434     -s   Create subroutines for specified macros.
435     -v   Specify a version number for this extension.
436     -x   Autogenerate XSUBs using C::Scan.
437     -b   Specify a perl version to be backwards compatibile with
438 extra_libraries
439          are any libraries that might be needed for loading the
440          extension, e.g. -lm would try to link in the math library.
441 ";
442 }
443
444
445 getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage;
446 use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
447             $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x 
448             $opt_b);
449
450 usage if $opt_h;
451
452 if( $opt_b ){
453     usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
454     $opt_b =~ /^\d+\.\d+\.\d+/ ||
455         usage "You must provide the backwards compatibility version in X.Y.Z form. " .
456             "(i.e. 5.5.0)\n";
457     my ($maj,$min,$sub) = split(/\./,$opt_b,3);
458     $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub);
459
460
461 if( $opt_v ){
462         $TEMPLATE_VERSION = $opt_v;
463 }
464
465 # -A implies -c.
466 $opt_c = 1 if $opt_A;
467
468 # -X implies -c and -f
469 $opt_c = $opt_f = 1 if $opt_X;
470
471 my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
472 my $extralibs;
473 my @path_h;
474
475 while (my $arg = shift) {
476     if ($arg =~ /^-l/i) {
477         $extralibs = "$arg @ARGV";
478         last;
479     }
480     push(@path_h, $arg);
481 }
482
483 usage "Must supply header file or module name\n"
484         unless (@path_h or $opt_n);
485
486 my $fmask;
487 my $tmask;
488
489 $fmask = qr{$opt_M} if defined $opt_M;
490 $tmask = qr{$opt_o} if defined $opt_o;
491 my $tmask_all = $tmask && $opt_o eq '.';
492
493 if ($opt_x) {
494   eval {require C::Scan; 1}
495     or die <<EOD;
496 C::Scan required if you use -x option.
497 To install C::Scan, execute
498    perl -MCPAN -e "install C::Scan"
499 EOD
500   unless ($tmask_all) {
501     $C::Scan::VERSION >= 0.70
502       or die <<EOD;
503 C::Scan v. 0.70 or later required unless you use -o . option.
504 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
505 To install C::Scan, execute
506    perl -MCPAN -e "install C::Scan"
507 EOD
508   }
509   if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
510     die <<EOD;
511 C::Scan v. 0.73 or later required to use -m or -a options.
512 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
513 To install C::Scan, execute
514    perl -MCPAN -e "install C::Scan"
515 EOD
516   }
517 }
518 elsif ($opt_o or $opt_F) {
519   warn <<EOD;
520 Options -o and -F do not make sense without -x.
521 EOD
522 }
523
524 my @path_h_ini = @path_h;
525 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
526
527 my $module = $opt_n;
528
529 if( @path_h ){
530     use Config;
531     use File::Spec;
532     my @paths;
533     if ($^O eq 'VMS') {  # Consider overrides of default location
534       # XXXX This is not equivalent to what the older version did:
535       #         it was looking at $hadsys header-file per header-file...
536       my($hadsys) = grep s!^sys/!!i , @path_h;
537       @paths = qw( Sys$Library VAXC$Include );
538       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
539       push @paths, qw( DECC$Library_Include DECC$System_Include );
540     }
541     else {
542       @paths = (File::Spec->curdir(), $Config{usrinc},
543                 (split ' ', $Config{locincpth}), '/usr/include');
544     }
545     foreach my $path_h (@path_h) {
546         $name ||= $path_h;
547     $module ||= do {
548       $name =~ s/\.h$//;
549       if ( $name !~ /::/ ) {
550         $name =~ s#^.*/##;
551         $name = "\u$name";
552       }
553       $name;
554     };
555
556     if( $path_h =~ s#::#/#g && $opt_n ){
557         warn "Nesting of headerfile ignored with -n\n";
558     }
559     $path_h .= ".h" unless $path_h =~ /\.h$/;
560     my $fullpath = $path_h;
561     $path_h =~ s/,.*$// if $opt_x;
562     $fullpath{$path_h} = $fullpath;
563
564     # Minor trickery: we can't chdir() before we processed the headers
565     # (so know the name of the extension), but the header may be in the
566     # extension directory...
567     my $tmp_path_h = $path_h;
568     my $rel_path_h = $path_h;
569     my @dirs = @paths;
570     if (not -f $path_h) {
571       my $found;
572       for my $dir (@paths) {
573         $found++, last
574           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
575       }
576       if ($found) {
577         $rel_path_h = $path_h;
578       } else {
579         (my $epath = $module) =~ s,::,/,g;
580         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
581         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
582         $path_h = $tmp_path_h;  # Used during -x
583         push @dirs, $epath;
584       }
585     }
586
587     if (!$opt_c) {
588       die "Can't find $tmp_path_h in @dirs\n" 
589         if ( ! $opt_f && ! -f "$rel_path_h" );
590       # Scan the header file (we should deal with nested header files)
591       # Record the names of simple #define constants into const_names
592             # Function prototypes are processed below.
593       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
594     defines:
595       while (<CH>) {
596         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
597             my $def = $1;
598             my $rest = $2;
599             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
600             $rest =~ s/^\s+//;
601             $rest =~ s/\s+$//;
602             # Cannot do: (-1) and ((LHANDLE)3) are OK:
603             #print("Skip non-wordy $def => $rest\n"),
604             #  next defines if $rest =~ /[^\w\$]/;
605             if ($rest =~ /"/) {
606               print("Skip stringy $def => $rest\n") if $opt_d;
607               next defines;
608             }
609             print "Matched $_ ($def)\n" if $opt_d;
610             $seen_define{$def} = $rest;
611             $_ = $def;
612             next if /^_.*_h_*$/i; # special case, but for what?
613             if (defined $opt_p) {
614               if (!/^$opt_p(\d)/) {
615                 ++$prefix{$_} if s/^$opt_p//;
616               }
617               else {
618                 warn "can't remove $opt_p prefix from '$_'!\n";
619               }
620             }
621             $prefixless{$def} = $_;
622             if (!$fmask or /$fmask/) {
623                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
624                 $const_names{$_}++;
625             }
626           }
627       }
628       close(CH);
629     }
630     }
631 }
632
633
634
635 my ($ext, $nested, @modparts, $modfname, $modpname);
636 (chdir 'ext', $ext = 'ext/') if -d 'ext';
637
638 if( $module =~ /::/ ){
639         $nested = 1;
640         @modparts = split(/::/,$module);
641         $modfname = $modparts[-1];
642         $modpname = join('/',@modparts);
643 }
644 else {
645         $nested = 0;
646         @modparts = ();
647         $modfname = $modpname = $module;
648 }
649
650
651 if ($opt_O) {
652         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
653 }
654 else {
655         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
656 }
657 if( $nested ){
658         my $modpath = "";
659         foreach (@modparts){
660                 mkdir("$modpath$_", 0777);
661                 $modpath .= "$_/";
662         }
663 }
664 mkdir($modpname, 0777);
665 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
666
667 my %types_seen;
668 my %std_types;
669 my $fdecls = [];
670 my $fdecls_parsed = [];
671 my $typedef_rex;
672 my %typedefs_pre;
673 my %known_fnames;
674 my %structs;
675
676 my @fnames;
677 my @fnames_no_prefix;
678 my %vdecl_hash;
679 my @vdecls;
680
681 if( ! $opt_X ){  # use XS, unless it was disabled
682   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
683   if ($opt_x) {
684     require Config;             # Run-time directive
685     warn "Scanning typemaps...\n";
686     get_typemap();
687     my @td;
688     my @good_td;
689     my $addflags = $opt_F || '';
690
691     foreach my $filename (@path_h) {
692       my $c;
693       my $filter;
694
695       if ($fullpath{$filename} =~ /,/) {
696         $filename = $`;
697         $filter = $';
698       }
699       warn "Scanning $filename for functions...\n";
700       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
701         'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
702       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
703
704       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
705       push(@$fdecls, @{$c->get('fdecls')});
706
707       push @td, @{$c->get('typedefs_maybe')};
708       if ($opt_a) {
709         my $structs = $c->get('typedef_structs');
710         @structs{keys %$structs} = values %$structs;
711       }
712
713       if ($opt_m) {
714         %vdecl_hash = %{ $c->get('vdecl_hash') };
715         @vdecls = sort keys %vdecl_hash;
716         for (local $_ = 0; $_ < @vdecls; ++$_) {
717           my $var = $vdecls[$_];
718           my($type, $post) = @{ $vdecl_hash{$var} };
719           if (defined $post) {
720             warn "Can't handle variable '$type $var $post', skipping.\n";
721             splice @vdecls, $_, 1;
722             redo;
723           }
724           $type = normalize_type($type);
725           $vdecl_hash{$var} = $type;
726         }
727       }
728
729       unless ($tmask_all) {
730         warn "Scanning $filename for typedefs...\n";
731         my $td = $c->get('typedef_hash');
732         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
733         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
734         push @good_td, @f_good_td;
735         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
736       }
737     }
738     { local $" = '|';
739       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
740     }
741     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
742     if ($fmask) {
743       my @good;
744       for my $i (0..$#$fdecls_parsed) {
745         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
746         push @good, $i;
747         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
748           if $opt_d;
749       }
750       $fdecls = [@$fdecls[@good]];
751       $fdecls_parsed = [@$fdecls_parsed[@good]];
752     }
753     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
754     # Sort declarations:
755     {
756       my %h = map( ($_->[1], $_), @$fdecls_parsed);
757       $fdecls_parsed = [ @h{@fnames} ];
758     }
759     @fnames_no_prefix = @fnames;
760     @fnames_no_prefix
761       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
762     # Remove macros which expand to typedefs
763     print "Typedefs are @td.\n" if $opt_d;
764     my %td = map {($_, $_)} @td;
765     # Add some other possible but meaningless values for macros
766     for my $k (qw(char double float int long short unsigned signed void)) {
767       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
768     }
769     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
770     my $n = 0;
771     my %bad_macs;
772     while (keys %td > $n) {
773       $n = keys %td;
774       my ($k, $v);
775       while (($k, $v) = each %seen_define) {
776         # print("found '$k'=>'$v'\n"), 
777         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
778       }
779     }
780     # Now %bad_macs contains names of bad macros
781     for my $k (keys %bad_macs) {
782       delete $const_names{$prefixless{$k}};
783       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
784     }
785   }
786 }
787 my @const_names = sort keys %const_names;
788
789 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
790
791 $" = "\n\t";
792 warn "Writing $ext$modpname/$modfname.pm\n";
793
794 if ( $compat_version < 5.006 ) {
795 print PM <<"END";
796 package $module;
797
798 use $compat_version;
799 use strict;
800 END
801
802 else {
803 print PM <<"END";
804 package $module;
805
806 use 5.006;
807 use strict;
808 use warnings;
809 END
810 }
811
812 unless( $opt_X || $opt_c || $opt_A ){
813         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
814         # will want Carp.
815         print PM <<'END';
816 use Carp;
817 END
818 }
819
820 print PM <<'END';
821
822 require Exporter;
823 END
824
825 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
826 require DynaLoader;
827 END
828
829
830 # Are we using AutoLoader or not?
831 unless ($opt_A) { # no autoloader whatsoever.
832         unless ($opt_c) { # we're doing the AUTOLOAD
833                 print PM "use AutoLoader;\n";
834         }
835         else {
836                 print PM "use AutoLoader qw(AUTOLOAD);\n"
837         }
838 }
839
840 if ( $compat_version < 5.006 ) {
841     if ( $opt_X || $opt_c || $opt_A ) {
842         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
843     } else {
844         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
845     }
846 }
847
848 # Determine @ISA.
849 my $myISA = 'our @ISA = qw(Exporter';   # We seem to always want this.
850 $myISA .= ' DynaLoader'         unless $opt_X;  # no XS
851 $myISA .= ');';
852 $myISA =~ s/^our // if $compat_version < 5.006;
853
854 print PM "\n$myISA\n\n";
855
856 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
857
858 my $tmp=<<"END";
859 # Items to export into callers namespace by default. Note: do not export
860 # names by default without a very good reason. Use EXPORT_OK instead.
861 # Do not simply export all your public functions/methods/constants.
862
863 # This allows declaration       use $module ':all';
864 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
865 # will save memory.
866 our %EXPORT_TAGS = ( 'all' => [ qw(
867         @exported_names
868 ) ] );
869
870 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
871
872 our \@EXPORT = qw(
873         @const_names
874 );
875 our \$VERSION = '$TEMPLATE_VERSION';
876
877 END
878
879 $tmp =~ s/^our //mg if $compat_version < 5.006;
880 print PM $tmp;
881
882 if (@vdecls) {
883     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
884 }
885
886
887 $tmp = ( $compat_version < 5.006 ?  "" : "our \$AUTOLOAD;" );
888 print PM <<"END" unless $opt_c or $opt_X;
889 sub AUTOLOAD {
890     # This AUTOLOAD is used to 'autoload' constants from the constant()
891     # XS function.  If a constant is not found then control is passed
892     # to the AUTOLOAD in AutoLoader.
893
894     my \$constname;
895     $tmp
896     (\$constname = \$AUTOLOAD) =~ s/.*:://;
897     croak "&$module::constant not defined" if \$constname eq 'constant';
898     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
899     if (\$! != 0) {
900         if (\$! =~ /Invalid/ || \$!{EINVAL}) {
901             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
902             goto &AutoLoader::AUTOLOAD;
903         }
904         else {
905             croak "Your vendor has not defined $module macro \$constname";
906         }
907     }
908     {
909         no strict 'refs';
910         # Fixed between 5.005_53 and 5.005_61
911         if (\$] >= 5.00561) {
912             *\$AUTOLOAD = sub () { \$val };
913         }
914         else {
915             *\$AUTOLOAD = sub { \$val };
916         }
917     }
918     goto &\$AUTOLOAD;
919 }
920
921 END
922
923 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
924         print PM <<"END";
925 bootstrap $module \$VERSION;
926 END
927 }
928
929 # tying the variables can happen only after bootstrap
930 if (@vdecls) {
931     printf PM <<END;
932 {
933 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
934 }
935
936 END
937 }
938
939 my $after;
940 if( $opt_P ){ # if POD is disabled
941         $after = '__END__';
942 }
943 else {
944         $after = '=cut';
945 }
946
947 print PM <<"END";
948
949 # Preloaded methods go here.
950 END
951
952 print PM <<"END" unless $opt_A;
953
954 # Autoload methods go after $after, and are processed by the autosplit program.
955 END
956
957 print PM <<"END";
958
959 1;
960 __END__
961 END
962
963 my $author = "A. U. Thor";
964 my $email = 'a.u.thor@a.galaxy.far.far.away';
965
966 my $revhist = '';
967 $revhist = <<EOT if $opt_C;
968 #
969 #=head1 HISTORY
970 #
971 #=over 8
972 #
973 #=item $TEMPLATE_VERSION
974 #
975 #Original version; created by h2xs $H2XS_VERSION with options
976 #
977 #  @ARGS
978 #
979 #=back
980 #
981 EOT
982
983 my $exp_doc = <<EOD;
984 #
985 #=head2 EXPORT
986 #
987 #None by default.
988 #
989 EOD
990
991 if (@const_names and not $opt_P) {
992   $exp_doc .= <<EOD;
993 #=head2 Exportable constants
994 #
995 #  @{[join "\n  ", @const_names]}
996 #
997 EOD
998 }
999
1000 if (defined $fdecls and @$fdecls and not $opt_P) {
1001   $exp_doc .= <<EOD;
1002 #=head2 Exportable functions
1003 #
1004 EOD
1005
1006 #  $exp_doc .= <<EOD if $opt_p;
1007 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1008 #
1009 #EOD
1010   $exp_doc .= <<EOD;
1011 #  @{[join "\n  ", @known_fnames{@fnames}]}
1012 #
1013 EOD
1014 }
1015
1016 my $meth_doc = '';
1017
1018 if ($opt_x && $opt_a) {
1019   my($name, $struct);
1020   $meth_doc .= accessor_docs($name, $struct)
1021     while ($name, $struct) = each %structs;
1022 }
1023
1024 my $pod = <<"END" unless $opt_P;
1025 ## Below is stub documentation for your module. You better edit it!
1026 #
1027 #=head1 NAME
1028 #
1029 #$module - Perl extension for blah blah blah
1030 #
1031 #=head1 SYNOPSIS
1032 #
1033 #  use $module;
1034 #  blah blah blah
1035 #
1036 #=head1 DESCRIPTION
1037 #
1038 #Stub documentation for $module, created by h2xs. It looks like the
1039 #author of the extension was negligent enough to leave the stub
1040 #unedited.
1041 #
1042 #Blah blah blah.
1043 $exp_doc$meth_doc$revhist
1044 #=head1 AUTHOR
1045 #
1046 #$author, E<lt>${email}E<gt>
1047 #
1048 #=head1 SEE ALSO
1049 #
1050 #L<perl>.
1051 #
1052 #=cut
1053 END
1054
1055 $pod =~ s/^\#//gm unless $opt_P;
1056 print PM $pod unless $opt_P;
1057
1058 close PM;
1059
1060
1061 if( ! $opt_X ){ # print XS, unless it is disabled
1062 warn "Writing $ext$modpname/$modfname.xs\n";
1063
1064 print XS <<"END";
1065 #include "EXTERN.h"
1066 #include "perl.h"
1067 #include "XSUB.h"
1068
1069 END
1070 if( @path_h ){
1071     foreach my $path_h (@path_h_ini) {
1072         my($h) = $path_h;
1073         $h =~ s#^/usr/include/##;
1074         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1075         print XS qq{#include <$h>\n};
1076     }
1077     print XS "\n";
1078 }
1079
1080 my %pointer_typedefs;
1081 my %struct_typedefs;
1082
1083 sub td_is_pointer {
1084   my $type = shift;
1085   my $out = $pointer_typedefs{$type};
1086   return $out if defined $out;
1087   my $otype = $type;
1088   $out = ($type =~ /\*$/);
1089   # This converts only the guys which do not have trailing part in the typedef
1090   if (not $out
1091       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1092     $type = normalize_type($type);
1093     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1094       if $opt_d;
1095     $out = td_is_pointer($type);
1096   }
1097   return ($pointer_typedefs{$otype} = $out);
1098 }
1099
1100 sub td_is_struct {
1101   my $type = shift;
1102   my $out = $struct_typedefs{$type};
1103   return $out if defined $out;
1104   my $otype = $type;
1105   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1106   # This converts only the guys which do not have trailing part in the typedef
1107   if (not $out
1108       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1109     $type = normalize_type($type);
1110     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1111       if $opt_d;
1112     $out = td_is_struct($type);
1113   }
1114   return ($struct_typedefs{$otype} = $out);
1115 }
1116
1117 # Some macros will bomb if you try to return them from a double-returning func.
1118 # Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
1119 # Fortunately, we can detect both these cases...
1120 sub protect_convert_to_double {
1121   my $in = shift;
1122   my $val;
1123   return '' unless defined ($val = $seen_define{$in});
1124   return '(IV)' if $known_fnames{$val};
1125   # OUT_t of ((OUT_t)-1):
1126   return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
1127   td_is_pointer($2) ? '(IV)' : '';
1128 }
1129
1130 # For each of the generated functions, length($pref) leading
1131 # letters are already checked.  Moreover, it is recommended that
1132 # the generated functions uses switch on letter at offset at least
1133 # $off + length($pref).
1134 #
1135 # The given list has length($pref) chars removed at front, it is
1136 # guarantied that $off leading chars in the rest are the same for all
1137 # elts of the list.
1138 #
1139 # Returns: how at which offset it was decided to make a switch, or -1 if none.
1140
1141 sub write_const;
1142
1143 sub write_const {
1144   my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1145   my %leading;
1146   my $offarg = length $pref;
1147
1148   if (@$list == 0) {            # Can happen on the initial iteration only
1149     print $fh <<"END";
1150 static double
1151 constant(char *name, int len, int arg)
1152 {
1153     errno = EINVAL;
1154     return 0;
1155 }
1156 END
1157     return -1;
1158   }
1159
1160   if (@$list == 1) {            # Can happen on the initial iteration only
1161     my $protect = protect_convert_to_double("$pref$list->[0]");
1162
1163     print $fh <<"END";
1164 static double
1165 constant(char *name, int len, int arg)
1166 {
1167     errno = 0;
1168     if (strEQ(name + $offarg, "$list->[0]")) {  /* $pref removed */
1169 #ifdef $pref$list->[0]
1170         return $protect$pref$list->[0];
1171 #else
1172         errno = ENOENT;
1173         return 0;
1174 #endif
1175     }
1176     errno = EINVAL;
1177     return 0;
1178 }
1179 END
1180     return -1;
1181   }
1182
1183   for my $n (@$list) {
1184     my $c = substr $n, $off, 1;
1185     $leading{$c} = [] unless exists $leading{$c};
1186     push @{$leading{$c}}, substr $n, $off + 1;
1187   }
1188
1189   if (keys(%leading) == 1) {
1190     return 1 + write_const $fh, $pref, $off + 1, $list;
1191   }
1192
1193   my $leader = substr $list->[0], 0, $off;
1194   foreach my $letter (keys %leading) {
1195     write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1196       if @{$leading{$letter}} > 1;
1197   }
1198
1199   my $npref = "_$pref";
1200   $npref = '' if $pref eq '';
1201
1202   print $fh <<"END";
1203 static double
1204 constant$npref(char *name, int len, int arg)
1205 {
1206 END
1207
1208   print $fh <<"END" if $npref eq '';
1209     errno = 0;
1210 END
1211
1212   print $fh <<"END" if $off;
1213     if ($offarg + $off >= len ) {
1214         errno = EINVAL;
1215         return 0;
1216     }
1217 END
1218
1219   print $fh <<"END";
1220     switch (name[$offarg + $off]) {
1221 END
1222
1223   foreach my $letter (sort keys %leading) {
1224     my $let = $letter;
1225     $let = '\0' if $letter eq '';
1226
1227     print $fh <<EOP;
1228     case '$let':
1229 EOP
1230     if (@{$leading{$letter}} > 1) {
1231       # It makes sense to call a function
1232       if ($off) {
1233         print $fh <<EOP;
1234         if (!strnEQ(name + $offarg,"$leader", $off))
1235             break;
1236 EOP
1237       }
1238       print $fh <<EOP;
1239         return constant_$pref$leader$letter(name, len, arg);
1240 EOP
1241     }
1242     else {
1243       # Do it ourselves
1244       my $protect
1245         = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1246
1247       print $fh <<EOP;
1248         if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {      /* $pref removed */
1249 #ifdef $pref$leader$letter$leading{$letter}[0]
1250             return $protect$pref$leader$letter$leading{$letter}[0];
1251 #else
1252             goto not_there;
1253 #endif
1254         }
1255 EOP
1256     }
1257   }
1258   print $fh <<"END";
1259     }
1260     errno = EINVAL;
1261     return 0;
1262
1263 not_there:
1264     errno = ENOENT;
1265     return 0;
1266 }
1267
1268 END
1269
1270 }
1271
1272 if( ! $opt_c ) {
1273   print XS <<"END";
1274 static int
1275 not_here(char *s)
1276 {
1277     croak("$module::%s not implemented on this architecture", s);
1278     return -1;
1279 }
1280
1281 END
1282
1283   write_const(\*XS, '', 0, \@const_names);
1284 }
1285
1286 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1287
1288 my $prefix;
1289 $prefix = "PREFIX = $opt_p" if defined $opt_p;
1290
1291 # Now switch from C to XS by issuing the first MODULE declaration:
1292 print XS <<"END";
1293
1294 MODULE = $module                PACKAGE = $module               $prefix
1295
1296 END
1297
1298 foreach (sort keys %const_xsub) {
1299     print XS <<"END";
1300 char *
1301 $_()
1302
1303     CODE:
1304 #ifdef $_
1305         RETVAL = $_;
1306 #else
1307         croak("Your vendor has not defined the $module macro $_");
1308 #endif
1309
1310     OUTPUT:
1311         RETVAL
1312
1313 END
1314 }
1315
1316 # If a constant() function was written then output a corresponding
1317 # XS declaration:
1318 print XS <<"END" unless $opt_c;
1319
1320 double
1321 constant(sv,arg)
1322     PREINIT:
1323         STRLEN          len;
1324     INPUT:
1325         SV *            sv
1326         char *          s = SvPV(sv, len);
1327         int             arg
1328     CODE:
1329         RETVAL = constant(s,len,arg);
1330     OUTPUT:
1331         RETVAL
1332
1333 END
1334
1335 my %seen_decl;
1336 my %typemap;
1337
1338 sub print_decl {
1339   my $fh = shift;
1340   my $decl = shift;
1341   my ($type, $name, $args) = @$decl;
1342   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1343
1344   my @argnames = map {$_->[1]} @$args;
1345   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1346   if ($opt_k) {
1347     s/^\s*const\b\s*// for @argtypes;
1348   }
1349   my @argarrays = map { $_->[4] || '' } @$args;
1350   my $numargs = @$args;
1351   if ($numargs and $argtypes[-1] eq '...') {
1352     $numargs--;
1353     $argnames[-1] = '...';
1354   }
1355   local $" = ', ';
1356   $type = normalize_type($type, 1);
1357
1358   print $fh <<"EOP";
1359
1360 $type
1361 $name(@argnames)
1362 EOP
1363
1364   for my $arg (0 .. $numargs - 1) {
1365     print $fh <<"EOP";
1366         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1367 EOP
1368   }
1369 }
1370
1371 sub print_tievar_subs {
1372   my($fh, $name, $type) = @_;
1373   print $fh <<END;
1374 I32
1375 _get_$name(IV index, SV *sv) {
1376     dSP;
1377     PUSHMARK(SP);
1378     XPUSHs(sv);
1379     PUTBACK;
1380     (void)call_pv("$module\::_get_$name", G_DISCARD);
1381     return (I32)0;
1382 }
1383
1384 I32
1385 _set_$name(IV index, SV *sv) {
1386     dSP;
1387     PUSHMARK(SP);
1388     XPUSHs(sv);
1389     PUTBACK;
1390     (void)call_pv("$module\::_set_$name", G_DISCARD);
1391     return (I32)0;
1392 }
1393
1394 END
1395 }
1396
1397 sub print_tievar_xsubs {
1398   my($fh, $name, $type) = @_;
1399   print $fh <<END;
1400 void
1401 _tievar_$name(sv)
1402         SV* sv
1403     PREINIT:
1404         struct ufuncs uf;
1405     CODE:
1406         uf.uf_val = &_get_$name;
1407         uf.uf_set = &_set_$name;
1408         uf.uf_index = (IV)&_get_$name;
1409         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1410
1411 void
1412 _get_$name(THIS)
1413         $type THIS = NO_INIT
1414     CODE:
1415         THIS = $name;
1416     OUTPUT:
1417         SETMAGIC: DISABLE
1418         THIS
1419
1420 void
1421 _set_$name(THIS)
1422         $type THIS
1423     CODE:
1424         $name = THIS;
1425
1426 END
1427 }
1428
1429 sub print_accessors {
1430   my($fh, $name, $struct) = @_;
1431   return unless defined $struct && $name !~ /\s|_ANON/;
1432   $name = normalize_type($name);
1433   my $ptrname = normalize_type("$name *");
1434   print $fh <<"EOF";
1435
1436 MODULE = $module                PACKAGE = ${name}               $prefix
1437
1438 $name *
1439 _to_ptr(THIS)
1440         $name THIS = NO_INIT
1441     PROTOTYPE: \$
1442     CODE:
1443         if (sv_derived_from(ST(0), "$name")) {
1444             STRLEN len;
1445             char *s = SvPV((SV*)SvRV(ST(0)), len);
1446             if (len != sizeof(THIS))
1447                 croak("Size \%d of packed data != expected \%d",
1448                         len, sizeof(THIS));
1449             RETVAL = ($name *)s;
1450         }   
1451         else
1452             croak("THIS is not of type $name");
1453     OUTPUT:
1454         RETVAL
1455
1456 $name
1457 new(CLASS)
1458         char *CLASS = NO_INIT
1459     PROTOTYPE: \$
1460     CODE:
1461         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1462     OUTPUT:
1463         RETVAL
1464
1465 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1466
1467 EOF
1468   my @items = @$struct;
1469   while (@items) {
1470     my $item = shift @items;
1471     if ($item->[0] =~ /_ANON/) {
1472       if (defined $item->[2]) {
1473         push @items, map [
1474           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1475         ], @{ $structs{$item->[0]} };
1476       } else {
1477         push @items, @{ $structs{$item->[0]} };
1478       }
1479     } else {
1480       my $type = normalize_type($item->[0]);
1481       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1482       print $fh <<"EOF";
1483 $ttype
1484 $item->[2](THIS, __value = NO_INIT)
1485         $ptrname THIS
1486         $type __value
1487     PROTOTYPE: \$;\$
1488     CODE:
1489         if (items > 1)
1490             THIS->$item->[-1] = __value;
1491         RETVAL = @{[
1492             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1493         ]};
1494     OUTPUT:
1495         RETVAL
1496
1497 EOF
1498     }
1499   }
1500 }
1501
1502 sub accessor_docs {
1503   my($name, $struct) = @_;
1504   return unless defined $struct && $name !~ /\s|_ANON/;
1505   $name = normalize_type($name);
1506   my $ptrname = $name . 'Ptr';
1507   my @items = @$struct;
1508   my @list;
1509   while (@items) {
1510     my $item = shift @items;
1511     if ($item->[0] =~ /_ANON/) {
1512       if (defined $item->[2]) {
1513         push @items, map [
1514           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1515         ], @{ $structs{$item->[0]} };
1516       } else {
1517         push @items, @{ $structs{$item->[0]} };
1518       }
1519     } else {
1520       push @list, $item->[2];
1521     }
1522   }
1523   my $methods = (join '(...)>, C<', @list) . '(...)';
1524
1525   my $pod = <<"EOF";
1526 #
1527 #=head2 Object and class methods for C<$name>/C<$ptrname>
1528 #
1529 #The principal Perl representation of a C object of type C<$name> is an
1530 #object of class C<$ptrname> which is a reference to an integer
1531 #representation of a C pointer.  To create such an object, one may use
1532 #a combination
1533 #
1534 #  my \$buffer = $name->new();
1535 #  my \$obj = \$buffer->_to_ptr();
1536 #
1537 #This exersizes the following two methods, and an additional class
1538 #C<$name>, the internal representation of which is a reference to a
1539 #packed string with the C structure.  Keep in mind that \$buffer should
1540 #better survive longer than \$obj.
1541 #
1542 #=over
1543 #
1544 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1545 #
1546 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1547 #
1548 #=item C<$name-E<gt>new()>
1549 #
1550 #Creates an empty object of type C<$name>.  The corresponding packed
1551 #string is zeroed out.
1552 #
1553 #=item C<$methods>
1554 #
1555 #return the current value of the corresponding element if called
1556 #without additional arguments.  Set the element to the supplied value
1557 #(and return the new value) if called with an additional argument.
1558 #
1559 #Applicable to objects of type C<$ptrname>.
1560 #
1561 #=back
1562 #
1563 EOF
1564   $pod =~ s/^\#//gm;
1565   return $pod;
1566 }
1567
1568 # Should be called before any actual call to normalize_type().
1569 sub get_typemap {
1570   # We do not want to read ./typemap by obvios reasons.
1571   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1572   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1573   unshift @tm, $stdtypemap;
1574   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1575
1576   # Start with useful default values
1577   $typemap{float} = 'T_DOUBLE';
1578
1579   foreach my $typemap (@tm) {
1580     next unless -e $typemap ;
1581     # skip directories, binary files etc.
1582     warn " Scanning $typemap\n";
1583     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
1584       unless -T $typemap ;
1585     open(TYPEMAP, $typemap) 
1586       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1587     my $mode = 'Typemap';
1588     while (<TYPEMAP>) {
1589       next if /^\s*\#/;
1590       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1591       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1592       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1593       elsif ($mode eq 'Typemap') {
1594         next if /^\s*($|\#)/ ;
1595         my ($type, $image);
1596         if ( ($type, $image) =
1597              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1598              # This may reference undefined functions:
1599              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1600           $typemap{normalize_type($type)} = $image;
1601         }
1602       }
1603     }
1604     close(TYPEMAP) or die "Cannot close $typemap: $!";
1605   }
1606   %std_types = %types_seen;
1607   %types_seen = ();
1608 }
1609
1610
1611 sub normalize_type {            # Second arg: do not strip const's before \*
1612   my $type = shift;
1613   my $do_keep_deep_const = shift;
1614   # If $do_keep_deep_const this is heuristical only
1615   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1616   my $ignore_mods 
1617     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1618   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1619     $type =~ s/$ignore_mods//go;
1620   }
1621   else {
1622     $type =~ s/$ignore_mods//go;
1623   }
1624   $type =~ s/([^\s\w])/ \1 /g;
1625   $type =~ s/\s+$//;
1626   $type =~ s/^\s+//;
1627   $type =~ s/\s+/ /g;
1628   $type =~ s/\* (?=\*)/*/g;
1629   $type =~ s/\. \. \./.../g;
1630   $type =~ s/ ,/,/g;
1631   $types_seen{$type}++ 
1632     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1633   $type;
1634 }
1635
1636 my $need_opaque;
1637
1638 sub assign_typemap_entry {
1639   my $type = shift;
1640   my $otype = $type;
1641   my $entry;
1642   if ($tmask and $type =~ /$tmask/) {
1643     print "Type $type matches -o mask\n" if $opt_d;
1644     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1645   }
1646   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1647     $type = normalize_type $type;
1648     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1649     $entry = assign_typemap_entry($type);
1650   }
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 print PL <<END;
1713 use ExtUtils::MakeMaker;
1714 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1715 # the contents of the Makefile that is written.
1716 WriteMakefile(
1717     'NAME'              => '$module',
1718     'VERSION_FROM'      => '$modfname.pm', # finds \$VERSION
1719     'PREREQ_PM'         => {}, # e.g., Module::Name => 1.1
1720     (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
1721       (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1722        AUTHOR     => '$author <$email>') : ()),
1723 END
1724 if (!$opt_X) { # print C stuff, unless XS is disabled
1725   $opt_F = '' unless defined $opt_F;
1726   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1727   my $Ihelp = ($I ? '-I. ' : '');
1728   my $Icomment = ($I ? '' : <<EOC);
1729         # Insert -I. if you add *.h files later:
1730 EOC
1731
1732   print PL <<END;
1733     'LIBS'              => ['$extralibs'], # e.g., '-lm'
1734     'DEFINE'            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1735 $Icomment    'INC'              => '$I', # e.g., '$Ihelp-I/usr/include/other'
1736 END
1737
1738   my $C = grep $_ ne "$modfname.c", (glob '*.c'), (glob '*.cc'), (glob '*.C');
1739   my $Cpre = ($C ? '' : '# ');
1740   my $Ccomment = ($C ? '' : <<EOC);
1741         # Un-comment this if you add C files to link with later:
1742 EOC
1743
1744   print PL <<END;
1745 $Ccomment    $Cpre\'OBJECT'             => '\$(O_FILES)', # link all the C files too
1746 END
1747 }
1748 print PL ");\n";
1749 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1750
1751 # Create a simple README since this is a CPAN requirement
1752 # and it doesnt hurt to have one
1753 warn "Writing $ext$modpname/README\n";
1754 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1755 my $thisyear = (gmtime)[5] + 1900;
1756 my $rmhead = "$modpname version $TEMPLATE_VERSION";
1757 my $rmheadeq = "=" x length($rmhead);
1758 print RM <<_RMEND_;
1759 $rmhead
1760 $rmheadeq
1761
1762 The README is used to introduce the module and provide instructions on
1763 how to install the module, any machine dependencies it may have (for
1764 example C compilers and installed libraries) and any other information
1765 that should be provided before the module is installed.
1766
1767 A README file is required for CPAN modules since CPAN extracts the
1768 README file from a module distribution so that people browsing the
1769 archive can use it get an idea of the modules uses. It is usually a
1770 good idea to provide version information here so that people can
1771 decide whether fixes for the module are worth downloading.
1772
1773 INSTALLATION
1774
1775 To install this module type the following:
1776
1777    perl Makefile.PL
1778    make
1779    make test
1780    make install
1781
1782 DEPENDENCIES
1783
1784 This module requires these other modules and libraries:
1785
1786   blah blah blah
1787
1788 COPYRIGHT AND LICENCE
1789
1790 Put the correct copyright and licence information here.
1791
1792 Copyright (C) $thisyear $author blah blah blah
1793
1794 _RMEND_
1795 close(RM) || die "Can't close $ext$modpname/README: $!\n";
1796
1797 warn "Writing $ext$modpname/test.pl\n";
1798 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1799 print EX <<'_END_';
1800 # Before `make install' is performed this script should be runnable with
1801 # `make test'. After `make install' it should work as `perl test.pl'
1802
1803 #########################
1804
1805 # change 'tests => 1' to 'tests => last_test_to_print';
1806
1807 use Test;
1808 BEGIN { plan tests => 1 };
1809 _END_
1810 print EX <<_END_;
1811 use $module;
1812 _END_
1813 print EX <<'_END_';
1814 ok(1); # If we made it this far, we're ok.
1815
1816 #########################
1817
1818 # Insert your test code below, the Test module is use()ed here so read
1819 # its man page ( perldoc Test ) for help writing this test script.
1820
1821 _END_
1822 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
1823
1824 unless ($opt_C) {
1825   warn "Writing $ext$modpname/Changes\n";
1826   $" = ' ';
1827   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1828   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1829   print EX <<EOP;
1830 Revision history for Perl extension $module.
1831
1832 $TEMPLATE_VERSION  @{[scalar localtime]}
1833 \t- original version; created by h2xs $H2XS_VERSION with options
1834 \t\t@ARGS
1835
1836 EOP
1837   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
1838 }
1839
1840 warn "Writing $ext$modpname/MANIFEST\n";
1841 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1842 my @files = <*>;
1843 if (!@files) {
1844   eval {opendir(D,'.');};
1845   unless ($@) { @files = readdir(D); closedir(D); }
1846 }
1847 if (!@files) { @files = map {chomp && $_} `ls`; }
1848 if ($^O eq 'VMS') {
1849   foreach (@files) {
1850     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1851     s%\.$%%;
1852     # Fix up for case-sensitive file systems
1853     s/$modfname/$modfname/i && next;
1854     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1855     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1856   }
1857 }
1858 print MANI join("\n",@files), "\n";
1859 close MANI;
1860 !NO!SUBS!
1861
1862 close OUT or die "Can't close $file: $!";
1863 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1864 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1865 chdir $origdir;