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