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