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