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