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 END
 803 }
 804 else {
 805 print PM <<"END";
 806 package $module;
 807
 808 use 5.006;
 809 use strict;
 810 use warnings;
 811 END
 812 }
 813
 814 unless( $opt_X || $opt_c || $opt_A ){
 815         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 816         # will want Carp.
 817         print PM <<'END';
 818 use Carp;
 819 END
 820 }
 821
 822 print PM <<'END';
 823
 824 require Exporter;
 825 END
 826
 827 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 828 require DynaLoader;
 829 END
 830
 831
 832 # Are we using AutoLoader or not?
 833 unless ($opt_A) { # no autoloader whatsoever.
 834         unless ($opt_c) { # we're doing the AUTOLOAD
 835                 print PM "use AutoLoader;\n";
 836         }
 837         else {
 838                 print PM "use AutoLoader qw(AUTOLOAD);\n"
 839         }
 840 }
 841
 842 if ( $compat_version < 5.006 ) {
 843     if ( $opt_X || $opt_c || $opt_A ) {
 844         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
 845     } else {
 846         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
 847     }
 848 }
 849
 850 # Determine @ISA.
 851 my $myISA = 'our @ISA = qw(Exporter';   # We seem to always want this.
 852 $myISA .= ' DynaLoader'         unless $opt_X;  # no XS
 853 $myISA .= ');';
 854 $myISA =~ s/^our // if $compat_version < 5.006;
 855
 856 print PM "\n$myISA\n\n";
 857
 858 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
 859
 860 my $tmp=<<"END";
 861 # Items to export into callers namespace by default. Note: do not export
 862 # names by default without a very good reason. Use EXPORT_OK instead.
 863 # Do not simply export all your public functions/methods/constants.
 864
 865 # This allows declaration       use $module ':all';
 866 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
 867 # will save memory.
 868 our %EXPORT_TAGS = ( 'all' => [ qw(
 869         @exported_names
 870 ) ] );
 871
 872 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
 873
 874 our \@EXPORT = qw(
 875         @const_names
 876 );
 877 our \$VERSION = '$TEMPLATE_VERSION';
 878
 879 END
 880
 881 $tmp =~ s/^our //mg if $compat_version < 5.006;
 882 print PM $tmp;
 883
 884 if (@vdecls) {
 885     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
 886 }
 887
 888
 889 $tmp = ( $compat_version < 5.006 ?  "" : "our \$AUTOLOAD;" );
 890 print PM <<"END" unless $opt_c or $opt_X;
 891 sub AUTOLOAD {
 892     # This AUTOLOAD is used to 'autoload' constants from the constant()
 893     # XS function.  If a constant is not found then control is passed
 894     # to the AUTOLOAD in AutoLoader.
 895
 896     my \$constname;
 897     $tmp
 898     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 899     croak "&$module::constant not defined" if \$constname eq 'constant';
 900     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 901     if (\$! != 0) {
 902         if (\$! =~ /Invalid/ || \$!{EINVAL}) {
 903             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 904             goto &AutoLoader::AUTOLOAD;
 905         }
 906         else {
 907             croak "Your vendor has not defined $module macro \$constname";
 908         }
 909     }
 910     {
 911         no strict 'refs';
 912         # Fixed between 5.005_53 and 5.005_61
 913         if (\$] >= 5.00561) {
 914             *\$AUTOLOAD = sub () { \$val };
 915         }
 916         else {
 917             *\$AUTOLOAD = sub { \$val };
 918         }
 919     }
 920     goto &\$AUTOLOAD;
 921 }
 922
 923 END
 924
 925 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 926         print PM <<"END";
 927 bootstrap $module \$VERSION;
 928 END
 929 }
 930
 931 # tying the variables can happen only after bootstrap
 932 if (@vdecls) {
 933     printf PM <<END;
 934 {
 935 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
 936 }
 937
 938 END
 939 }
 940
 941 my $after;
 942 if( $opt_P ){ # if POD is disabled
 943         $after = '__END__';
 944 }
 945 else {
 946         $after = '=cut';
 947 }
 948
 949 print PM <<"END";
 950
 951 # Preloaded methods go here.
 952 END
 953
 954 print PM <<"END" unless $opt_A;
 955
 956 # Autoload methods go after $after, and are processed by the autosplit program.
 957 END
 958
 959 print PM <<"END";
 960
 961 1;
 962 __END__
 963 END
 964
 965 my ($email,$author);
 966
 967 eval {
 968        my $user;
 969        ($user,$author) = (getpwuid($>))[0,6];
 970        $author =~ s/,.*$//; # in case of sub fields
 971        my $domain = $Config{'mydomain'};
 972        $domain =~ s/^\.//;
 973        $email = "$user\@$domain";
 974      };
 975
 976 $author ||= "A. U. Thor";
 977 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
 978
 979 my $revhist = '';
 980 $revhist = <<EOT if $opt_C;
 981 #
 982 #=head1 HISTORY
 983 #
 984 #=over 8
 985 #
 986 #=item $TEMPLATE_VERSION
 987 #
 988 #Original version; created by h2xs $H2XS_VERSION with options
 989 #
 990 #  @ARGS
 991 #
 992 #=back
 993 #
 994 EOT
 995
 996 my $exp_doc = <<EOD;
 997 #
 998 #=head2 EXPORT
 999 #
1000 #None by default.
1001 #
1002 EOD
1003
1004 if (@const_names and not $opt_P) {
1005   $exp_doc .= <<EOD;
1006 #=head2 Exportable constants
1007 #
1008 #  @{[join "\n  ", @const_names]}
1009 #
1010 EOD
1011 }
1012
1013 if (defined $fdecls and @$fdecls and not $opt_P) {
1014   $exp_doc .= <<EOD;
1015 #=head2 Exportable functions
1016 #
1017 EOD
1018
1019 #  $exp_doc .= <<EOD if $opt_p;
1020 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1021 #
1022 #EOD
1023   $exp_doc .= <<EOD;
1024 #  @{[join "\n  ", @known_fnames{@fnames}]}
1025 #
1026 EOD
1027 }
1028
1029 my $meth_doc = '';
1030
1031 if ($opt_x && $opt_a) {
1032   my($name, $struct);
1033   $meth_doc .= accessor_docs($name, $struct)
1034     while ($name, $struct) = each %structs;
1035 }
1036
1037 my $pod = <<"END" unless $opt_P;
1038 ## Below is stub documentation for your module. You better edit it!
1039 #
1040 #=head1 NAME
1041 #
1042 #$module - Perl extension for blah blah blah
1043 #
1044 #=head1 SYNOPSIS
1045 #
1046 #  use $module;
1047 #  blah blah blah
1048 #
1049 #=head1 DESCRIPTION
1050 #
1051 #Stub documentation for $module, created by h2xs. It looks like the
1052 #author of the extension was negligent enough to leave the stub
1053 #unedited.
1054 #
1055 #Blah blah blah.
1056 $exp_doc$meth_doc$revhist
1057 #=head1 AUTHOR
1058 #
1059 #$author, E<lt>${email}E<gt>
1060 #
1061 #=head1 SEE ALSO
1062 #
1063 #L<perl>.
1064 #
1065 #=cut
1066 END
1067
1068 $pod =~ s/^\#//gm unless $opt_P;
1069 print PM $pod unless $opt_P;
1070
1071 close PM;
1072
1073
1074 if( ! $opt_X ){ # print XS, unless it is disabled
1075 warn "Writing $ext$modpname/$modfname.xs\n";
1076
1077 print XS <<"END";
1078 #include "EXTERN.h"
1079 #include "perl.h"
1080 #include "XSUB.h"
1081
1082 END
1083 if( @path_h ){
1084     foreach my $path_h (@path_h_ini) {
1085         my($h) = $path_h;
1086         $h =~ s#^/usr/include/##;
1087         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1088         print XS qq{#include <$h>\n};
1089     }
1090     print XS "\n";
1091 }
1092
1093 my %pointer_typedefs;
1094 my %struct_typedefs;
1095
1096 sub td_is_pointer {
1097   my $type = shift;
1098   my $out = $pointer_typedefs{$type};
1099   return $out if defined $out;
1100   my $otype = $type;
1101   $out = ($type =~ /\*$/);
1102   # This converts only the guys which do not have trailing part in the typedef
1103   if (not $out
1104       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1105     $type = normalize_type($type);
1106     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1107       if $opt_d;
1108     $out = td_is_pointer($type);
1109   }
1110   return ($pointer_typedefs{$otype} = $out);
1111 }
1112
1113 sub td_is_struct {
1114   my $type = shift;
1115   my $out = $struct_typedefs{$type};
1116   return $out if defined $out;
1117   my $otype = $type;
1118   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($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-Struct: Type mutation via typedefs: $otype ==> $type\n"
1124       if $opt_d;
1125     $out = td_is_struct($type);
1126   }
1127   return ($struct_typedefs{$otype} = $out);
1128 }
1129
1130 # Some macros will bomb if you try to return them from a double-returning func.
1131 # Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
1132 # Fortunately, we can detect both these cases...
1133 sub protect_convert_to_double {
1134   my $in = shift;
1135   my $val;
1136   return '' unless defined ($val = $seen_define{$in});
1137   return '(IV)' if $known_fnames{$val};
1138   # OUT_t of ((OUT_t)-1):
1139   return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
1140   td_is_pointer($2) ? '(IV)' : '';
1141 }
1142
1143 # For each of the generated functions, length($pref) leading
1144 # letters are already checked.  Moreover, it is recommended that
1145 # the generated functions uses switch on letter at offset at least
1146 # $off + length($pref).
1147 #
1148 # The given list has length($pref) chars removed at front, it is
1149 # guarantied that $off leading chars in the rest are the same for all
1150 # elts of the list.
1151 #
1152 # Returns: how at which offset it was decided to make a switch, or -1 if none.
1153
1154 sub write_const;
1155
1156 sub write_const {
1157   my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1158   my %leading;
1159   my $offarg = length $pref;
1160
1161   if (@$list == 0) {            # Can happen on the initial iteration only
1162     print $fh <<"END";
1163 static double
1164 constant(char *name, int len, int arg)
1165 {
1166     errno = EINVAL;
1167     return 0;
1168 }
1169 END
1170     return -1;
1171   }
1172
1173   if (@$list == 1) {            # Can happen on the initial iteration only
1174     my $protect = protect_convert_to_double("$pref$list->[0]");
1175
1176     print $fh <<"END";
1177 static double
1178 constant(char *name, int len, int arg)
1179 {
1180     errno = 0;
1181     if (strEQ(name + $offarg, "$list->[0]")) {  /* $pref removed */
1182 #ifdef $pref$list->[0]
1183         return $protect$pref$list->[0];
1184 #else
1185         errno = ENOENT;
1186         return 0;
1187 #endif
1188     }
1189     errno = EINVAL;
1190     return 0;
1191 }
1192 END
1193     return -1;
1194   }
1195
1196   for my $n (@$list) {
1197     my $c = substr $n, $off, 1;
1198     $leading{$c} = [] unless exists $leading{$c};
1199     push @{$leading{$c}}, substr $n, $off + 1;
1200   }
1201
1202   if (keys(%leading) == 1) {
1203     return 1 + write_const $fh, $pref, $off + 1, $list;
1204   }
1205
1206   my $leader = substr $list->[0], 0, $off;
1207   foreach my $letter (keys %leading) {
1208     write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1209       if @{$leading{$letter}} > 1;
1210   }
1211
1212   my $npref = "_$pref";
1213   $npref = '' if $pref eq '';
1214
1215   print $fh <<"END";
1216 static double
1217 constant$npref(char *name, int len, int arg)
1218 {
1219 END
1220
1221   print $fh <<"END" if $npref eq '';
1222     errno = 0;
1223 END
1224
1225   print $fh <<"END" if $off;
1226     if ($offarg + $off >= len ) {
1227         errno = EINVAL;
1228         return 0;
1229     }
1230 END
1231
1232   print $fh <<"END";
1233     switch (name[$offarg + $off]) {
1234 END
1235
1236   foreach my $letter (sort keys %leading) {
1237     my $let = $letter;
1238     $let = '\0' if $letter eq '';
1239
1240     print $fh <<EOP;
1241     case '$let':
1242 EOP
1243     if (@{$leading{$letter}} > 1) {
1244       # It makes sense to call a function
1245       if ($off) {
1246         print $fh <<EOP;
1247         if (!strnEQ(name + $offarg,"$leader", $off))
1248             break;
1249 EOP
1250       }
1251       print $fh <<EOP;
1252         return constant_$pref$leader$letter(name, len, arg);
1253 EOP
1254     }
1255     else {
1256       # Do it ourselves
1257       my $protect
1258         = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1259
1260       print $fh <<EOP;
1261         if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {      /* $pref removed */
1262 #ifdef $pref$leader$letter$leading{$letter}[0]
1263             return $protect$pref$leader$letter$leading{$letter}[0];
1264 #else
1265             goto not_there;
1266 #endif
1267         }
1268 EOP
1269     }
1270   }
1271   print $fh <<"END";
1272     }
1273     errno = EINVAL;
1274     return 0;
1275
1276 not_there:
1277     errno = ENOENT;
1278     return 0;
1279 }
1280
1281 END
1282
1283 }
1284
1285 if( ! $opt_c ) {
1286   print XS <<"END";
1287 static int
1288 not_here(char *s)
1289 {
1290     croak("$module::%s not implemented on this architecture", s);
1291     return -1;
1292 }
1293
1294 END
1295
1296   write_const(\*XS, '', 0, \@const_names);
1297 }
1298
1299 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1300
1301 my $prefix;
1302 $prefix = "PREFIX = $opt_p" if defined $opt_p;
1303
1304 # Now switch from C to XS by issuing the first MODULE declaration:
1305 print XS <<"END";
1306
1307 MODULE = $module                PACKAGE = $module               $prefix
1308
1309 END
1310
1311 foreach (sort keys %const_xsub) {
1312     print XS <<"END";
1313 char *
1314 $_()
1315
1316     CODE:
1317 #ifdef $_
1318         RETVAL = $_;
1319 #else
1320         croak("Your vendor has not defined the $module macro $_");
1321 #endif
1322
1323     OUTPUT:
1324         RETVAL
1325
1326 END
1327 }
1328
1329 # If a constant() function was written then output a corresponding
1330 # XS declaration:
1331 print XS <<"END" unless $opt_c;
1332
1333 double
1334 constant(sv,arg)
1335     PREINIT:
1336         STRLEN          len;
1337     INPUT:
1338         SV *            sv
1339         char *          s = SvPV(sv, len);
1340         int             arg
1341     CODE:
1342         RETVAL = constant(s,len,arg);
1343     OUTPUT:
1344         RETVAL
1345
1346 END
1347
1348 my %seen_decl;
1349 my %typemap;
1350
1351 sub print_decl {
1352   my $fh = shift;
1353   my $decl = shift;
1354   my ($type, $name, $args) = @$decl;
1355   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1356
1357   my @argnames = map {$_->[1]} @$args;
1358   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1359   if ($opt_k) {
1360     s/^\s*const\b\s*// for @argtypes;
1361   }
1362   my @argarrays = map { $_->[4] || '' } @$args;
1363   my $numargs = @$args;
1364   if ($numargs and $argtypes[-1] eq '...') {
1365     $numargs--;
1366     $argnames[-1] = '...';
1367   }
1368   local $" = ', ';
1369   $type = normalize_type($type, 1);
1370
1371   print $fh <<"EOP";
1372
1373 $type
1374 $name(@argnames)
1375 EOP
1376
1377   for my $arg (0 .. $numargs - 1) {
1378     print $fh <<"EOP";
1379         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1380 EOP
1381   }
1382 }
1383
1384 sub print_tievar_subs {
1385   my($fh, $name, $type) = @_;
1386   print $fh <<END;
1387 I32
1388 _get_$name(IV index, SV *sv) {
1389     dSP;
1390     PUSHMARK(SP);
1391     XPUSHs(sv);
1392     PUTBACK;
1393     (void)call_pv("$module\::_get_$name", G_DISCARD);
1394     return (I32)0;
1395 }
1396
1397 I32
1398 _set_$name(IV index, SV *sv) {
1399     dSP;
1400     PUSHMARK(SP);
1401     XPUSHs(sv);
1402     PUTBACK;
1403     (void)call_pv("$module\::_set_$name", G_DISCARD);
1404     return (I32)0;
1405 }
1406
1407 END
1408 }
1409
1410 sub print_tievar_xsubs {
1411   my($fh, $name, $type) = @_;
1412   print $fh <<END;
1413 void
1414 _tievar_$name(sv)
1415         SV* sv
1416     PREINIT:
1417         struct ufuncs uf;
1418     CODE:
1419         uf.uf_val = &_get_$name;
1420         uf.uf_set = &_set_$name;
1421         uf.uf_index = (IV)&_get_$name;
1422         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1423
1424 void
1425 _get_$name(THIS)
1426         $type THIS = NO_INIT
1427     CODE:
1428         THIS = $name;
1429     OUTPUT:
1430         SETMAGIC: DISABLE
1431         THIS
1432
1433 void
1434 _set_$name(THIS)
1435         $type THIS
1436     CODE:
1437         $name = THIS;
1438
1439 END
1440 }
1441
1442 sub print_accessors {
1443   my($fh, $name, $struct) = @_;
1444   return unless defined $struct && $name !~ /\s|_ANON/;
1445   $name = normalize_type($name);
1446   my $ptrname = normalize_type("$name *");
1447   print $fh <<"EOF";
1448
1449 MODULE = $module                PACKAGE = ${name}               $prefix
1450
1451 $name *
1452 _to_ptr(THIS)
1453         $name THIS = NO_INIT
1454     PROTOTYPE: \$
1455     CODE:
1456         if (sv_derived_from(ST(0), "$name")) {
1457             STRLEN len;
1458             char *s = SvPV((SV*)SvRV(ST(0)), len);
1459             if (len != sizeof(THIS))
1460                 croak("Size \%d of packed data != expected \%d",
1461                         len, sizeof(THIS));
1462             RETVAL = ($name *)s;
1463         }
1464         else
1465             croak("THIS is not of type $name");
1466     OUTPUT:
1467         RETVAL
1468
1469 $name
1470 new(CLASS)
1471         char *CLASS = NO_INIT
1472     PROTOTYPE: \$
1473     CODE:
1474         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1475     OUTPUT:
1476         RETVAL
1477
1478 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1479
1480 EOF
1481   my @items = @$struct;
1482   while (@items) {
1483     my $item = shift @items;
1484     if ($item->[0] =~ /_ANON/) {
1485       if (defined $item->[2]) {
1486         push @items, map [
1487           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1488         ], @{ $structs{$item->[0]} };
1489       } else {
1490         push @items, @{ $structs{$item->[0]} };
1491       }
1492     } else {
1493       my $type = normalize_type($item->[0]);
1494       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1495       print $fh <<"EOF";
1496 $ttype
1497 $item->[2](THIS, __value = NO_INIT)
1498         $ptrname THIS
1499         $type __value
1500     PROTOTYPE: \$;\$
1501     CODE:
1502         if (items > 1)
1503             THIS->$item->[-1] = __value;
1504         RETVAL = @{[
1505             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1506         ]};
1507     OUTPUT:
1508         RETVAL
1509
1510 EOF
1511     }
1512   }
1513 }
1514
1515 sub accessor_docs {
1516   my($name, $struct) = @_;
1517   return unless defined $struct && $name !~ /\s|_ANON/;
1518   $name = normalize_type($name);
1519   my $ptrname = $name . 'Ptr';
1520   my @items = @$struct;
1521   my @list;
1522   while (@items) {
1523     my $item = shift @items;
1524     if ($item->[0] =~ /_ANON/) {
1525       if (defined $item->[2]) {
1526         push @items, map [
1527           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1528         ], @{ $structs{$item->[0]} };
1529       } else {
1530         push @items, @{ $structs{$item->[0]} };
1531       }
1532     } else {
1533       push @list, $item->[2];
1534     }
1535   }
1536   my $methods = (join '(...)>, C<', @list) . '(...)';
1537
1538   my $pod = <<"EOF";
1539 #
1540 #=head2 Object and class methods for C<$name>/C<$ptrname>
1541 #
1542 #The principal Perl representation of a C object of type C<$name> is an
1543 #object of class C<$ptrname> which is a reference to an integer
1544 #representation of a C pointer.  To create such an object, one may use
1545 #a combination
1546 #
1547 #  my \$buffer = $name->new();
1548 #  my \$obj = \$buffer->_to_ptr();
1549 #
1550 #This exersizes the following two methods, and an additional class
1551 #C<$name>, the internal representation of which is a reference to a
1552 #packed string with the C structure.  Keep in mind that \$buffer should
1553 #better survive longer than \$obj.
1554 #
1555 #=over
1556 #
1557 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1558 #
1559 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1560 #
1561 #=item C<$name-E<gt>new()>
1562 #
1563 #Creates an empty object of type C<$name>.  The corresponding packed
1564 #string is zeroed out.
1565 #
1566 #=item C<$methods>
1567 #
1568 #return the current value of the corresponding element if called
1569 #without additional arguments.  Set the element to the supplied value
1570 #(and return the new value) if called with an additional argument.
1571 #
1572 #Applicable to objects of type C<$ptrname>.
1573 #
1574 #=back
1575 #
1576 EOF
1577   $pod =~ s/^\#//gm;
1578   return $pod;
1579 }
1580
1581 # Should be called before any actual call to normalize_type().
1582 sub get_typemap {
1583   # We do not want to read ./typemap by obvios reasons.
1584   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1585   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1586   unshift @tm, $stdtypemap;
1587   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1588
1589   # Start with useful default values
1590   $typemap{float} = 'T_DOUBLE';
1591
1592   foreach my $typemap (@tm) {
1593     next unless -e $typemap ;
1594     # skip directories, binary files etc.
1595     warn " Scanning $typemap\n";
1596     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1597       unless -T $typemap ;
1598     open(TYPEMAP, $typemap)
1599       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1600     my $mode = 'Typemap';
1601     while (<TYPEMAP>) {
1602       next if /^\s*\#/;
1603       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1604       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1605       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1606       elsif ($mode eq 'Typemap') {
1607         next if /^\s*($|\#)/ ;
1608         my ($type, $image);
1609         if ( ($type, $image) =
1610              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1611              # This may reference undefined functions:
1612              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1613           $typemap{normalize_type($type)} = $image;
1614         }
1615       }
1616     }
1617     close(TYPEMAP) or die "Cannot close $typemap: $!";
1618   }
1619   %std_types = %types_seen;
1620   %types_seen = ();
1621 }
1622
1623
1624 sub normalize_type {            # Second arg: do not strip const's before \*
1625   my $type = shift;
1626   my $do_keep_deep_const = shift;
1627   # If $do_keep_deep_const this is heuristical only
1628   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1629   my $ignore_mods
1630     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1631   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1632     $type =~ s/$ignore_mods//go;
1633   }
1634   else {
1635     $type =~ s/$ignore_mods//go;
1636   }
1637   $type =~ s/([^\s\w])/ \1 /g;
1638   $type =~ s/\s+$//;
1639   $type =~ s/^\s+//;
1640   $type =~ s/\s+/ /g;
1641   $type =~ s/\* (?=\*)/*/g;
1642   $type =~ s/\. \. \./.../g;
1643   $type =~ s/ ,/,/g;
1644   $types_seen{$type}++
1645     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1646   $type;
1647 }
1648
1649 my $need_opaque;
1650
1651 sub assign_typemap_entry {
1652   my $type = shift;
1653   my $otype = $type;
1654   my $entry;
1655   if ($tmask and $type =~ /$tmask/) {
1656     print "Type $type matches -o mask\n" if $opt_d;
1657     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1658   }
1659   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1660     $type = normalize_type $type;
1661     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1662     $entry = assign_typemap_entry($type);
1663   }
1664   $entry ||= $typemap{$otype}
1665     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1666   $typemap{$otype} = $entry;
1667   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1668   return $entry;
1669 }
1670
1671 for (@vdecls) {
1672   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1673 }
1674
1675 if ($opt_x) {
1676   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1677   if ($opt_a) {
1678     while (my($name, $struct) = each %structs) {
1679       print_accessors(\*XS, $name, $struct);
1680     }
1681   }
1682 }
1683
1684 close XS;
1685
1686 if (%types_seen) {
1687   my $type;
1688   warn "Writing $ext$modpname/typemap\n";
1689   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1690
1691   for $type (sort keys %types_seen) {
1692     my $entry = assign_typemap_entry $type;
1693     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1694   }
1695
1696   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1697 #############################################################################
1698 INPUT
1699 T_OPAQUE_STRUCT
1700         if (sv_derived_from($arg, \"${ntype}\")) {
1701             STRLEN len;
1702             char  *s = SvPV((SV*)SvRV($arg), len);
1703
1704             if (len != sizeof($var))
1705                 croak(\"Size %d of packed data != expected %d\",
1706                         len, sizeof($var));
1707             $var = *($type *)s;
1708         }
1709         else
1710             croak(\"$var is not of type ${ntype}\")
1711 #############################################################################
1712 OUTPUT
1713 T_OPAQUE_STRUCT
1714         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1715 EOP
1716
1717   close TM or die "Cannot close typemap file for write: $!";
1718 }
1719
1720 } # if( ! $opt_X )
1721
1722 warn "Writing $ext$modpname/Makefile.PL\n";
1723 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1724
1725 print PL <<END;
1726 use ExtUtils::MakeMaker;
1727 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1728 # the contents of the Makefile that is written.
1729 WriteMakefile(
1730     'NAME'              => '$module',
1731     'VERSION_FROM'      => '$modfname.pm', # finds \$VERSION
1732     'PREREQ_PM'         => {}, # e.g., Module::Name => 1.1
1733     (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
1734       (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1735        AUTHOR     => '$author <$email>') : ()),
1736 END
1737 if (!$opt_X) { # print C stuff, unless XS is disabled
1738   $opt_F = '' unless defined $opt_F;
1739   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1740   my $Ihelp = ($I ? '-I. ' : '');
1741   my $Icomment = ($I ? '' : <<EOC);
1742         # Insert -I. if you add *.h files later:
1743 EOC
1744
1745   print PL <<END;
1746     'LIBS'              => ['$extralibs'], # e.g., '-lm'
1747     'DEFINE'            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1748 $Icomment    'INC'              => '$I', # e.g., '$Ihelp-I/usr/include/other'
1749 END
1750
1751   my $C = grep $_ ne "$modfname.c", (glob '*.c'), (glob '*.cc'), (glob '*.C');
1752   my $Cpre = ($C ? '' : '# ');
1753   my $Ccomment = ($C ? '' : <<EOC);
1754         # Un-comment this if you add C files to link with later:
1755 EOC
1756
1757   print PL <<END;
1758 $Ccomment    $Cpre\'OBJECT'             => '\$(O_FILES)', # link all the C files too
1759 END
1760 }
1761 print PL ");\n";
1762 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1763
1764 # Create a simple README since this is a CPAN requirement
1765 # and it doesnt hurt to have one
1766 warn "Writing $ext$modpname/README\n";
1767 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1768 my $thisyear = (gmtime)[5] + 1900;
1769 my $rmhead = "$modpname version $TEMPLATE_VERSION";
1770 my $rmheadeq = "=" x length($rmhead);
1771 print RM <<_RMEND_;
1772 $rmhead
1773 $rmheadeq
1774
1775 The README is used to introduce the module and provide instructions on
1776 how to install the module, any machine dependencies it may have (for
1777 example C compilers and installed libraries) and any other information
1778 that should be provided before the module is installed.
1779
1780 A README file is required for CPAN modules since CPAN extracts the
1781 README file from a module distribution so that people browsing the
1782 archive can use it get an idea of the modules uses. It is usually a
1783 good idea to provide version information here so that people can
1784 decide whether fixes for the module are worth downloading.
1785
1786 INSTALLATION
1787
1788 To install this module type the following:
1789
1790    perl Makefile.PL
1791    make
1792    make test
1793    make install
1794
1795 DEPENDENCIES
1796
1797 This module requires these other modules and libraries:
1798
1799   blah blah blah
1800
1801 COPYRIGHT AND LICENCE
1802
1803 Put the correct copyright and licence information here.
1804
1805 Copyright (C) $thisyear $author blah blah blah
1806
1807 _RMEND_
1808 close(RM) || die "Can't close $ext$modpname/README: $!\n";
1809
1810 warn "Writing $ext$modpname/test.pl\n";
1811 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1812 print EX <<'_END_';
1813 # Before `make install' is performed this script should be runnable with
1814 # `make test'. After `make install' it should work as `perl test.pl'
1815
1816 #########################
1817
1818 # change 'tests => 1' to 'tests => last_test_to_print';
1819
1820 use Test;
1821 BEGIN { plan tests => 1 };
1822 _END_
1823 print EX <<_END_;
1824 use $module;
1825 _END_
1826 print EX <<'_END_';
1827 ok(1); # If we made it this far, we're ok.
1828
1829 #########################
1830
1831 # Insert your test code below, the Test module is use()ed here so read
1832 # its man page ( perldoc Test ) for help writing this test script.
1833
1834 _END_
1835 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
1836
1837 unless ($opt_C) {
1838   warn "Writing $ext$modpname/Changes\n";
1839   $" = ' ';
1840   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1841   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1842   print EX <<EOP;
1843 Revision history for Perl extension $module.
1844
1845 $TEMPLATE_VERSION  @{[scalar localtime]}
1846 \t- original version; created by h2xs $H2XS_VERSION with options
1847 \t\t@ARGS
1848
1849 EOP
1850   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
1851 }
1852
1853 warn "Writing $ext$modpname/MANIFEST\n";
1854 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1855 my @files = <*>;
1856 if (!@files) {
1857   eval {opendir(D,'.');};
1858   unless ($@) { @files = readdir(D); closedir(D); }
1859 }
1860 if (!@files) { @files = map {chomp && $_} `ls`; }
1861 if ($^O eq 'VMS') {
1862   foreach (@files) {
1863     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1864     s%\.$%%;
1865     # Fix up for case-sensitive file systems
1866     s/$modfname/$modfname/i && next;
1867     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1868     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1869   }
1870 }
1871 print MANI join("\n",@files), "\n";
1872 close MANI;
1873 !NO!SUBS!
1874
1875 close OUT or die "Can't close $file: $!";
1876 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1877 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1878 chdir $origdir;