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