utils/h2xs.PL

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