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} -w
  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
 475 my $extralibs = '';
 476
 477 my @path_h;
 478
 479 while (my $arg = shift) {
 480     if ($arg =~ /^-l/i) {
 481         $extralibs = "$arg @ARGV";
 482         last;
 483     }
 484     push(@path_h, $arg);
 485 }
 486
 487 usage "Must supply header file or module name\n"
 488         unless (@path_h or $opt_n);
 489
 490 my $fmask;
 491 my $tmask;
 492
 493 $fmask = qr{$opt_M} if defined $opt_M;
 494 $tmask = qr{$opt_o} if defined $opt_o;
 495 my $tmask_all = $tmask && $opt_o eq '.';
 496
 497 if ($opt_x) {
 498   eval {require C::Scan; 1}
 499     or die <<EOD;
 500 C::Scan required if you use -x option.
 501 To install C::Scan, execute
 502    perl -MCPAN -e "install C::Scan"
 503 EOD
 504   unless ($tmask_all) {
 505     $C::Scan::VERSION >= 0.70
 506       or die <<EOD;
 507 C::Scan v. 0.70 or later required unless you use -o . option.
 508 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 509 To install C::Scan, execute
 510    perl -MCPAN -e "install C::Scan"
 511 EOD
 512   }
 513   if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
 514     die <<EOD;
 515 C::Scan v. 0.73 or later required to use -m or -a options.
 516 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 517 To install C::Scan, execute
 518    perl -MCPAN -e "install C::Scan"
 519 EOD
 520   }
 521 }
 522 elsif ($opt_o or $opt_F) {
 523   warn <<EOD;
 524 Options -o and -F do not make sense without -x.
 525 EOD
 526 }
 527
 528 my @path_h_ini = @path_h;
 529 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 530
 531 my $module = $opt_n;
 532
 533 if( @path_h ){
 534     use Config;
 535     use File::Spec;
 536     my @paths;
 537     if ($^O eq 'VMS') {  # Consider overrides of default location
 538       # XXXX This is not equivalent to what the older version did:
 539       #         it was looking at $hadsys header-file per header-file...
 540       my($hadsys) = grep s!^sys/!!i , @path_h;
 541       @paths = qw( Sys$Library VAXC$Include );
 542       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
 543       push @paths, qw( DECC$Library_Include DECC$System_Include );
 544     }
 545     else {
 546       @paths = (File::Spec->curdir(), $Config{usrinc},
 547                 (split ' ', $Config{locincpth}), '/usr/include');
 548     }
 549     foreach my $path_h (@path_h) {
 550         $name ||= $path_h;
 551     $module ||= do {
 552       $name =~ s/\.h$//;
 553       if ( $name !~ /::/ ) {
 554         $name =~ s#^.*/##;
 555         $name = "\u$name";
 556       }
 557       $name;
 558     };
 559
 560     if( $path_h =~ s#::#/#g && $opt_n ){
 561         warn "Nesting of headerfile ignored with -n\n";
 562     }
 563     $path_h .= ".h" unless $path_h =~ /\.h$/;
 564     my $fullpath = $path_h;
 565     $path_h =~ s/,.*$// if $opt_x;
 566     $fullpath{$path_h} = $fullpath;
 567
 568     # Minor trickery: we can't chdir() before we processed the headers
 569     # (so know the name of the extension), but the header may be in the
 570     # extension directory...
 571     my $tmp_path_h = $path_h;
 572     my $rel_path_h = $path_h;
 573     my @dirs = @paths;
 574     if (not -f $path_h) {
 575       my $found;
 576       for my $dir (@paths) {
 577         $found++, last
 578           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
 579       }
 580       if ($found) {
 581         $rel_path_h = $path_h;
 582       } else {
 583         (my $epath = $module) =~ s,::,/,g;
 584         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
 585         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
 586         $path_h = $tmp_path_h;  # Used during -x
 587         push @dirs, $epath;
 588       }
 589     }
 590
 591     if (!$opt_c) {
 592       die "Can't find $tmp_path_h in @dirs\n"
 593         if ( ! $opt_f && ! -f "$rel_path_h" );
 594       # Scan the header file (we should deal with nested header files)
 595       # Record the names of simple #define constants into const_names
 596             # Function prototypes are processed below.
 597       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
 598     defines:
 599       while (<CH>) {
 600         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
 601             my $def = $1;
 602             my $rest = $2;
 603             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
 604             $rest =~ s/^\s+//;
 605             $rest =~ s/\s+$//;
 606             # Cannot do: (-1) and ((LHANDLE)3) are OK:
 607             #print("Skip non-wordy $def => $rest\n"),
 608             #  next defines if $rest =~ /[^\w\$]/;
 609             if ($rest =~ /"/) {
 610               print("Skip stringy $def => $rest\n") if $opt_d;
 611               next defines;
 612             }
 613             print "Matched $_ ($def)\n" if $opt_d;
 614             $seen_define{$def} = $rest;
 615             $_ = $def;
 616             next if /^_.*_h_*$/i; # special case, but for what?
 617             if (defined $opt_p) {
 618               if (!/^$opt_p(\d)/) {
 619                 ++$prefix{$_} if s/^$opt_p//;
 620               }
 621               else {
 622                 warn "can't remove $opt_p prefix from '$_'!\n";
 623               }
 624             }
 625             $prefixless{$def} = $_;
 626             if (!$fmask or /$fmask/) {
 627                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
 628                 $const_names{$_}++;
 629             }
 630           }
 631       }
 632       close(CH);
 633     }
 634     }
 635 }
 636
 637
 638
 639 my ($ext, $nested, @modparts, $modfname, $modpname);
 640
 641 $ext = chdir 'ext' ? 'ext/' : '';
 642
 643 if( $module =~ /::/ ){
 644         $nested = 1;
 645         @modparts = split(/::/,$module);
 646         $modfname = $modparts[-1];
 647         $modpname = join('/',@modparts);
 648 }
 649 else {
 650         $nested = 0;
 651         @modparts = ();
 652         $modfname = $modpname = $module;
 653 }
 654
 655
 656 if ($opt_O) {
 657         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 658 }
 659 else {
 660         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 661 }
 662 if( $nested ){
 663         my $modpath = "";
 664         foreach (@modparts){
 665                 mkdir("$modpath$_", 0777);
 666                 $modpath .= "$_/";
 667         }
 668 }
 669 mkdir($modpname, 0777);
 670 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 671
 672 my %types_seen;
 673 my %std_types;
 674 my $fdecls = [];
 675 my $fdecls_parsed = [];
 676 my $typedef_rex;
 677 my %typedefs_pre;
 678 my %known_fnames;
 679 my %structs;
 680
 681 my @fnames;
 682 my @fnames_no_prefix;
 683 my %vdecl_hash;
 684 my @vdecls;
 685
 686 if( ! $opt_X ){  # use XS, unless it was disabled
 687   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 688   if ($opt_x) {
 689     require Config;             # Run-time directive
 690     warn "Scanning typemaps...\n";
 691     get_typemap();
 692     my @td;
 693     my @good_td;
 694     my $addflags = $opt_F || '';
 695
 696     foreach my $filename (@path_h) {
 697       my $c;
 698       my $filter;
 699
 700       if ($fullpath{$filename} =~ /,/) {
 701         $filename = $`;
 702         $filter = $';
 703       }
 704       warn "Scanning $filename for functions...\n";
 705       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 706         'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
 707       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 708
 709       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
 710       push(@$fdecls, @{$c->get('fdecls')});
 711
 712       push @td, @{$c->get('typedefs_maybe')};
 713       if ($opt_a) {
 714         my $structs = $c->get('typedef_structs');
 715         @structs{keys %$structs} = values %$structs;
 716       }
 717
 718       if ($opt_m) {
 719         %vdecl_hash = %{ $c->get('vdecl_hash') };
 720         @vdecls = sort keys %vdecl_hash;
 721         for (local $_ = 0; $_ < @vdecls; ++$_) {
 722           my $var = $vdecls[$_];
 723           my($type, $post) = @{ $vdecl_hash{$var} };
 724           if (defined $post) {
 725             warn "Can't handle variable '$type $var $post', skipping.\n";
 726             splice @vdecls, $_, 1;
 727             redo;
 728           }
 729           $type = normalize_type($type);
 730           $vdecl_hash{$var} = $type;
 731         }
 732       }
 733
 734       unless ($tmask_all) {
 735         warn "Scanning $filename for typedefs...\n";
 736         my $td = $c->get('typedef_hash');
 737         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
 738         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
 739         push @good_td, @f_good_td;
 740         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
 741       }
 742     }
 743     { local $" = '|';
 744       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
 745     }
 746     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
 747     if ($fmask) {
 748       my @good;
 749       for my $i (0..$#$fdecls_parsed) {
 750         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
 751         push @good, $i;
 752         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
 753           if $opt_d;
 754       }
 755       $fdecls = [@$fdecls[@good]];
 756       $fdecls_parsed = [@$fdecls_parsed[@good]];
 757     }
 758     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
 759     # Sort declarations:
 760     {
 761       my %h = map( ($_->[1], $_), @$fdecls_parsed);
 762       $fdecls_parsed = [ @h{@fnames} ];
 763     }
 764     @fnames_no_prefix = @fnames;
 765     @fnames_no_prefix
 766       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
 767     # Remove macros which expand to typedefs
 768     print "Typedefs are @td.\n" if $opt_d;
 769     my %td = map {($_, $_)} @td;
 770     # Add some other possible but meaningless values for macros
 771     for my $k (qw(char double float int long short unsigned signed void)) {
 772       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
 773     }
 774     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
 775     my $n = 0;
 776     my %bad_macs;
 777     while (keys %td > $n) {
 778       $n = keys %td;
 779       my ($k, $v);
 780       while (($k, $v) = each %seen_define) {
 781         # print("found '$k'=>'$v'\n"),
 782         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
 783       }
 784     }
 785     # Now %bad_macs contains names of bad macros
 786     for my $k (keys %bad_macs) {
 787       delete $const_names{$prefixless{$k}};
 788       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
 789     }
 790   }
 791 }
 792 my @const_names = sort keys %const_names;
 793
 794 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 795
 796 $" = "\n\t";
 797 warn "Writing $ext$modpname/$modfname.pm\n";
 798
 799 if ( $compat_version < 5.006 ) {
 800 print PM <<"END";
 801 package $module;
 802
 803 use $compat_version;
 804 use strict;
 805 END
 806 }
 807 else {
 808 print PM <<"END";
 809 package $module;
 810
 811 use 5.006;
 812 use strict;
 813 use warnings;
 814 END
 815 }
 816
 817 unless( $opt_X || $opt_c || $opt_A ){
 818         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 819         # will want Carp.
 820         print PM <<'END';
 821 use Carp;
 822 END
 823 }
 824
 825 print PM <<'END';
 826
 827 require Exporter;
 828 END
 829
 830 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 831 require DynaLoader;
 832 END
 833
 834
 835 # Are we using AutoLoader or not?
 836 unless ($opt_A) { # no autoloader whatsoever.
 837         unless ($opt_c) { # we're doing the AUTOLOAD
 838                 print PM "use AutoLoader;\n";
 839         }
 840         else {
 841                 print PM "use AutoLoader qw(AUTOLOAD);\n"
 842         }
 843 }
 844
 845 if ( $compat_version < 5.006 ) {
 846     if ( $opt_X || $opt_c || $opt_A ) {
 847         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
 848     } else {
 849         print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
 850     }
 851 }
 852
 853 # Determine @ISA.
 854 my $myISA = 'our @ISA = qw(Exporter';   # We seem to always want this.
 855 $myISA .= ' DynaLoader'         unless $opt_X;  # no XS
 856 $myISA .= ');';
 857 $myISA =~ s/^our // if $compat_version < 5.006;
 858
 859 print PM "\n$myISA\n\n";
 860
 861 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
 862
 863 my $tmp=<<"END";
 864 # Items to export into callers namespace by default. Note: do not export
 865 # names by default without a very good reason. Use EXPORT_OK instead.
 866 # Do not simply export all your public functions/methods/constants.
 867
 868 # This allows declaration       use $module ':all';
 869 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
 870 # will save memory.
 871 our %EXPORT_TAGS = ( 'all' => [ qw(
 872         @exported_names
 873 ) ] );
 874
 875 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
 876
 877 our \@EXPORT = qw(
 878         @const_names
 879 );
 880 our \$VERSION = '$TEMPLATE_VERSION';
 881
 882 END
 883
 884 $tmp =~ s/^our //mg if $compat_version < 5.006;
 885 print PM $tmp;
 886
 887 if (@vdecls) {
 888     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
 889 }
 890
 891
 892 $tmp = ( $compat_version < 5.006 ?  "" : "our \$AUTOLOAD;" );
 893 print PM <<"END" unless $opt_c or $opt_X;
 894 sub AUTOLOAD {
 895     # This AUTOLOAD is used to 'autoload' constants from the constant()
 896     # XS function.  If a constant is not found then control is passed
 897     # to the AUTOLOAD in AutoLoader.
 898
 899     my \$constname;
 900     $tmp
 901     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 902     croak "&${module}::constant not defined" if \$constname eq 'constant';
 903     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 904     if (\$! != 0) {
 905         if (\$! =~ /Invalid/ || \$!{EINVAL}) {
 906             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 907             goto &AutoLoader::AUTOLOAD;
 908         }
 909         else {
 910             croak "Your vendor has not defined $module macro \$constname";
 911         }
 912     }
 913     {
 914         no strict 'refs';
 915         # Fixed between 5.005_53 and 5.005_61
 916         if (\$] >= 5.00561) {
 917             *\$AUTOLOAD = sub () { \$val };
 918         }
 919         else {
 920             *\$AUTOLOAD = sub { \$val };
 921         }
 922     }
 923     goto &\$AUTOLOAD;
 924 }
 925
 926 END
 927
 928 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 929         print PM <<"END";
 930 bootstrap $module \$VERSION;
 931 END
 932 }
 933
 934 # tying the variables can happen only after bootstrap
 935 if (@vdecls) {
 936     printf PM <<END;
 937 {
 938 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
 939 }
 940
 941 END
 942 }
 943
 944 my $after;
 945 if( $opt_P ){ # if POD is disabled
 946         $after = '__END__';
 947 }
 948 else {
 949         $after = '=cut';
 950 }
 951
 952 print PM <<"END";
 953
 954 # Preloaded methods go here.
 955 END
 956
 957 print PM <<"END" unless $opt_A;
 958
 959 # Autoload methods go after $after, and are processed by the autosplit program.
 960 END
 961
 962 print PM <<"END";
 963
 964 1;
 965 __END__
 966 END
 967
 968 my ($email,$author);
 969
 970 eval {
 971        my $user;
 972        ($user,$author) = (getpwuid($>))[0,6];
 973        $author =~ s/,.*$//; # in case of sub fields
 974        my $domain = $Config{'mydomain'};
 975        $domain =~ s/^\.//;
 976        $email = "$user\@$domain";
 977      };
 978
 979 $author ||= "A. U. Thor";
 980 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
 981
 982 my $revhist = '';
 983 $revhist = <<EOT if $opt_C;
 984 #
 985 #=head1 HISTORY
 986 #
 987 #=over 8
 988 #
 989 #=item $TEMPLATE_VERSION
 990 #
 991 #Original version; created by h2xs $H2XS_VERSION with options
 992 #
 993 #  @ARGS
 994 #
 995 #=back
 996 #
 997 EOT
 998
 999 my $exp_doc = <<EOD;
1000 #
1001 #=head2 EXPORT
1002 #
1003 #None by default.
1004 #
1005 EOD
1006
1007 if (@const_names and not $opt_P) {
1008   $exp_doc .= <<EOD;
1009 #=head2 Exportable constants
1010 #
1011 #  @{[join "\n  ", @const_names]}
1012 #
1013 EOD
1014 }
1015
1016 if (defined $fdecls and @$fdecls and not $opt_P) {
1017   $exp_doc .= <<EOD;
1018 #=head2 Exportable functions
1019 #
1020 EOD
1021
1022 #  $exp_doc .= <<EOD if $opt_p;
1023 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1024 #
1025 #EOD
1026   $exp_doc .= <<EOD;
1027 #  @{[join "\n  ", @known_fnames{@fnames}]}
1028 #
1029 EOD
1030 }
1031
1032 my $meth_doc = '';
1033
1034 if ($opt_x && $opt_a) {
1035   my($name, $struct);
1036   $meth_doc .= accessor_docs($name, $struct)
1037     while ($name, $struct) = each %structs;
1038 }
1039
1040 my $pod = <<"END" unless $opt_P;
1041 ## Below is stub documentation for your module. You better edit it!
1042 #
1043 #=head1 NAME
1044 #
1045 #$module - Perl extension for blah blah blah
1046 #
1047 #=head1 SYNOPSIS
1048 #
1049 #  use $module;
1050 #  blah blah blah
1051 #
1052 #=head1 DESCRIPTION
1053 #
1054 #Stub documentation for $module, created by h2xs. It looks like the
1055 #author of the extension was negligent enough to leave the stub
1056 #unedited.
1057 #
1058 #Blah blah blah.
1059 $exp_doc$meth_doc$revhist
1060 #=head1 AUTHOR
1061 #
1062 #$author, E<lt>${email}E<gt>
1063 #
1064 #=head1 SEE ALSO
1065 #
1066 #L<perl>.
1067 #
1068 #=cut
1069 END
1070
1071 $pod =~ s/^\#//gm unless $opt_P;
1072 print PM $pod unless $opt_P;
1073
1074 close PM;
1075
1076
1077 if( ! $opt_X ){ # print XS, unless it is disabled
1078 warn "Writing $ext$modpname/$modfname.xs\n";
1079
1080 print XS <<"END";
1081 #include "EXTERN.h"
1082 #include "perl.h"
1083 #include "XSUB.h"
1084
1085 END
1086 if( @path_h ){
1087     foreach my $path_h (@path_h_ini) {
1088         my($h) = $path_h;
1089         $h =~ s#^/usr/include/##;
1090         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1091         print XS qq{#include <$h>\n};
1092     }
1093     print XS "\n";
1094 }
1095
1096 my %pointer_typedefs;
1097 my %struct_typedefs;
1098
1099 sub td_is_pointer {
1100   my $type = shift;
1101   my $out = $pointer_typedefs{$type};
1102   return $out if defined $out;
1103   my $otype = $type;
1104   $out = ($type =~ /\*$/);
1105   # This converts only the guys which do not have trailing part in the typedef
1106   if (not $out
1107       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1108     $type = normalize_type($type);
1109     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1110       if $opt_d;
1111     $out = td_is_pointer($type);
1112   }
1113   return ($pointer_typedefs{$otype} = $out);
1114 }
1115
1116 sub td_is_struct {
1117   my $type = shift;
1118   my $out = $struct_typedefs{$type};
1119   return $out if defined $out;
1120   my $otype = $type;
1121   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1122   # This converts only the guys which do not have trailing part in the typedef
1123   if (not $out
1124       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1125     $type = normalize_type($type);
1126     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1127       if $opt_d;
1128     $out = td_is_struct($type);
1129   }
1130   return ($struct_typedefs{$otype} = $out);
1131 }
1132
1133 # Some macros will bomb if you try to return them from a double-returning func.
1134 # Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
1135 # Fortunately, we can detect both these cases...
1136 sub protect_convert_to_double {
1137   my $in = shift;
1138   my $val;
1139   return '' unless defined ($val = $seen_define{$in});
1140   return '(IV)' if $known_fnames{$val};
1141   # OUT_t of ((OUT_t)-1):
1142   return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
1143   td_is_pointer($2) ? '(IV)' : '';
1144 }
1145
1146 # For each of the generated functions, length($pref) leading
1147 # letters are already checked.  Moreover, it is recommended that
1148 # the generated functions uses switch on letter at offset at least
1149 # $off + length($pref).
1150 #
1151 # The given list has length($pref) chars removed at front, it is
1152 # guarantied that $off leading chars in the rest are the same for all
1153 # elts of the list.
1154 #
1155 # Returns: how at which offset it was decided to make a switch, or -1 if none.
1156
1157 sub write_const;
1158
1159 sub write_const {
1160   my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1161   my %leading;
1162   my $offarg = length $pref;
1163
1164   if (@$list == 0) {            # Can happen on the initial iteration only
1165     print $fh <<"END";
1166 static double
1167 constant(char *name, int len, int arg)
1168 {
1169     errno = EINVAL;
1170     return 0;
1171 }
1172 END
1173     return -1;
1174   }
1175
1176   if (@$list == 1) {            # Can happen on the initial iteration only
1177     my $protect = protect_convert_to_double("$pref$list->[0]");
1178
1179     print $fh <<"END";
1180 static double
1181 constant(char *name, int len, int arg)
1182 {
1183     errno = 0;
1184     if (strEQ(name + $offarg, "$list->[0]")) {  /* $pref removed */
1185 #ifdef $pref$list->[0]
1186         return $protect$pref$list->[0];
1187 #else
1188         errno = ENOENT;
1189         return 0;
1190 #endif
1191     }
1192     errno = EINVAL;
1193     return 0;
1194 }
1195 END
1196     return -1;
1197   }
1198
1199   for my $n (@$list) {
1200     my $c = substr $n, $off, 1;
1201     $leading{$c} = [] unless exists $leading{$c};
1202     push @{$leading{$c}}, $off < length $n ? substr $n,  $off + 1 : $n
1203   }
1204
1205   if (keys(%leading) == 1) {
1206     return 1 + write_const $fh, $pref, $off + 1, $list;
1207   }
1208
1209   my $leader = substr $list->[0], 0, $off;
1210   foreach my $letter (keys %leading) {
1211     write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1212       if @{$leading{$letter}} > 1;
1213   }
1214
1215   my $npref = "_$pref";
1216   $npref = '' if $pref eq '';
1217
1218   print $fh <<"END";
1219 static double
1220 constant$npref(char *name, int len, int arg)
1221 {
1222 END
1223
1224   print $fh <<"END" if $npref eq '';
1225     errno = 0;
1226 END
1227
1228   print $fh <<"END" if $off;
1229     if ($offarg + $off >= len ) {
1230         errno = EINVAL;
1231         return 0;
1232     }
1233 END
1234
1235   print $fh <<"END";
1236     switch (name[$offarg + $off]) {
1237 END
1238
1239   foreach my $letter (sort keys %leading) {
1240     my $let = $letter;
1241     $let = '\0' if $letter eq '';
1242
1243     print $fh <<EOP;
1244     case '$let':
1245 EOP
1246     if (@{$leading{$letter}} > 1) {
1247       # It makes sense to call a function
1248       if ($off) {
1249         print $fh <<EOP;
1250         if (!strnEQ(name + $offarg,"$leader", $off))
1251             break;
1252 EOP
1253       }
1254       print $fh <<EOP;
1255         return constant_$pref$leader$letter(name, len, arg);
1256 EOP
1257     }
1258     else {
1259       # Do it ourselves
1260       my $protect
1261         = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1262
1263       print $fh <<EOP;
1264         if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {      /* $pref removed */
1265 #ifdef $pref$leader$letter$leading{$letter}[0]
1266             return $protect$pref$leader$letter$leading{$letter}[0];
1267 #else
1268             goto not_there;
1269 #endif
1270         }
1271 EOP
1272     }
1273   }
1274   print $fh <<"END";
1275     }
1276     errno = EINVAL;
1277     return 0;
1278
1279 not_there:
1280     errno = ENOENT;
1281     return 0;
1282 }
1283
1284 END
1285
1286 }
1287
1288 if( ! $opt_c ) {
1289   print XS <<"END";
1290 static int
1291 not_here(char *s)
1292 {
1293     croak("${module}::%s not implemented on this architecture", s);
1294     return -1;
1295 }
1296
1297 END
1298
1299   write_const(\*XS, '', 0, \@const_names);
1300 }
1301
1302 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1303
1304 my $prefix = defined $opt_p ? "PREFIX = $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;