utils/h2xs.PL

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