utils/h2xs.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12
  13 # This forces PL files to create target in same directory as PL file.
  14 # This is so that make depend always knows where to find PL derivatives.
  15 chdir(dirname($0));
  16 ($file = basename($0)) =~ s/\.PL$//;
  17 $file =~ s/\.pl$//
  18         if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  19
  20 open OUT,">$file" or die "Can't create $file: $!";
  21
  22 print "Extracting $file (with variable substitutions)\n";
  23
  24 # In this section, perl variables will be expanded during extraction.
  25 # You can use $Config{...} to use Configure variables.
  26
  27 print OUT <<"!GROK!THIS!";
  28 $Config{'startperl'}
  29     eval 'exec perl -S \$0 "\$@"'
  30         if 0;
  31 !GROK!THIS!
  32
  33 # In the following, perl variables are not expanded during extraction.
  34
  35 print OUT <<'!NO!SUBS!';
  36
  37 =head1 NAME
  38
  39 h2xs - convert .h C header files to Perl extensions
  40
  41 =head1 SYNOPSIS
  42
  43 B<h2xs> [B<-AOPXcf>] [B<-v> version] [B<-n> module_name] [headerfile [extra_libraries]]
  44
  45 B<h2xs> B<-h>
  46
  47 =head1 DESCRIPTION
  48
  49 I<h2xs> builds a Perl extension from any C header file.  The extension will
  50 include functions which can be used to retrieve the value of any #define
  51 statement which was in the C header.
  52
  53 The I<module_name> will be used for the name of the extension.  If
  54 module_name is not supplied then the name of the header file will be used,
  55 with the first character capitalized.
  56
  57 If the extension might need extra libraries, they should be included
  58 here.  The extension Makefile.PL will take care of checking whether
  59 the libraries actually exist and how they should be loaded.
  60 The extra libraries should be specified in the form -lm -lposix, etc,
  61 just as on the cc command line.  By default, the Makefile.PL will
  62 search through the library path determined by Configure.  That path
  63 can be augmented by including arguments of the form B<-L/another/library/path>
  64 in the extra-libraries argument.
  65
  66 =head1 OPTIONS
  67
  68 =over 5
  69
  70 =item B<-A>
  71
  72 Omit all autoload facilities.  This is the same as B<-c> but also removes the
  73 S<C<require AutoLoader>> statement from the .pm file.
  74
  75 =item B<-O>
  76
  77 Allows a pre-existing extension directory to be overwritten.
  78
  79 =item B<-P>
  80
  81 Omit the autogenerated stub POD section.
  82
  83 =item B<-c>
  84
  85 Omit C<constant()> from the .xs file and corresponding specialised
  86 C<AUTOLOAD> from the .pm file.
  87
  88 =item B<-f>
  89
  90 Allows an extension to be created for a header even if that header is
  91 not found in /usr/include.
  92
  93 =item B<-h>
  94
  95 Print the usage, help and version for this h2xs and exit.
  96
  97 =item B<-n> I<module_name>
  98
  99 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 100
 101 =item B<-v> I<version>
 102
 103 Specify a version number for this extension.  This version number is added
 104 to the templates.  The default is 0.01.
 105
 106 =item B<-X>
 107
 108 Omit the XS portion.  Used to generate templates for a module which is not
 109 XS-based.
 110
 111 =back
 112
 113 =head1 EXAMPLES
 114
 115
 116         # Default behavior, extension is Rusers
 117         h2xs rpcsvc/rusers
 118
 119         # Same, but extension is RUSERS
 120         h2xs -n RUSERS rpcsvc/rusers
 121
 122         # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
 123         h2xs rpcsvc::rusers
 124
 125         # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
 126         h2xs -n ONC::RPC rpcsvc/rusers
 127
 128         # Without constant() or AUTOLOAD
 129         h2xs -c rpcsvc/rusers
 130
 131         # Creates templates for an extension named RPC
 132         h2xs -cfn RPC
 133
 134         # Extension is ONC::RPC.
 135         h2xs -cfn ONC::RPC
 136
 137         # Makefile.PL will look for library -lrpc in
 138         # additional directory /opt/net/lib
 139         h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
 140
 141
 142 =head1 ENVIRONMENT
 143
 144 No environment variables are used.
 145
 146 =head1 AUTHOR
 147
 148 Larry Wall and others
 149
 150 =head1 SEE ALSO
 151
 152 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 153
 154 =head1 DIAGNOSTICS
 155
 156 The usual warnings if it can't read or write the files involved.
 157
 158 =cut
 159
 160 my( $H2XS_VERSION ) = '$Revision: 1.16 $' =~ /\$Revision:\s+([^\s]+)/;
 161 my $TEMPLATE_VERSION = '0.01';
 162
 163 use Getopt::Std;
 164
 165 sub usage{
 166         warn "@_\n" if @_;
 167     die "h2xs [-AOPXcfh] [-v version] [-n module_name] [headerfile [extra_libraries]]
 168 version: $H2XS_VERSION
 169     -f   Force creation of the extension even if the C header does not exist.
 170     -n   Specify a name to use for the extension (recommended).
 171     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
 172     -A   Omit all autoloading facilities (implies -c).
 173     -O   Allow overwriting of a pre-existing extension directory.
 174     -P   Omit the stub POD section.
 175     -X   Omit the XS portion.
 176     -v   Specify a version number for this extension.
 177     -h   Display this help message
 178 extra_libraries
 179          are any libraries that might be needed for loading the
 180          extension, e.g. -lm would try to link in the math library.
 181 ";
 182 }
 183
 184
 185 getopts("AOPXcfhv:n:") || usage;
 186
 187 usage if $opt_h;
 188
 189 if( $opt_v ){
 190         $TEMPLATE_VERSION = $opt_v;
 191 }
 192 $opt_c = 1 if $opt_A;
 193
 194 $path_h    = shift;
 195 $extralibs = "@ARGV";
 196
 197 usage "Must supply header file or module name\n"
 198         unless ($path_h or $opt_n);
 199
 200
 201 if( $path_h ){
 202     $name = $path_h;
 203     if( $path_h =~ s#::#/#g && $opt_n ){
 204         warn "Nesting of headerfile ignored with -n\n";
 205     }
 206     $path_h .= ".h" unless $path_h =~ /\.h$/;
 207     $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#;
 208     die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
 209
 210     # Scan the header file (we should deal with nested header files)
 211     # Record the names of simple #define constants into const_names
 212     # Function prototypes are not (currently) processed.
 213     open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
 214     while (<CH>) {
 215         if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) {
 216             $_ = $1;
 217             next if /^_.*_h_*$/i; # special case, but for what?
 218             $const_names{$_}++;
 219         }
 220     }
 221     close(CH);
 222     @const_names = sort keys %const_names;
 223 }
 224
 225
 226 $module = $opt_n || do {
 227         $name =~ s/\.h$//;
 228         if( $name !~ /::/ ){
 229                 $name =~ s#^.*/##;
 230                 $name = "\u$name";
 231         }
 232         $name;
 233 };
 234
 235 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 236
 237 if( $module =~ /::/ ){
 238         $nested = 1;
 239         @modparts = split(/::/,$module);
 240         $modfname = $modparts[-1];
 241         $modpname = join('/',@modparts);
 242 }
 243 else {
 244         $nested = 0;
 245         @modparts = ();
 246         $modfname = $modpname = $module;
 247 }
 248
 249
 250 if ($opt_O) {
 251         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 252 } else {
 253         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 254 }
 255 if( $nested ){
 256         $modpath = "";
 257         foreach (@modparts){
 258                 mkdir("$modpath$_", 0777);
 259                 $modpath .= "$_/";
 260         }
 261 }
 262 mkdir($modpname, 0777);
 263 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 264
 265 if( ! $opt_X ){  # use XS, unless it was disabled
 266   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 267 }
 268 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 269
 270 $" = "\n\t";
 271 warn "Writing $ext$modpname/$modfname.pm\n";
 272
 273 print PM <<"END";
 274 package $module;
 275
 276 use strict;
 277 END
 278
 279 if( $opt_X || $opt_c || $opt_A ){
 280         # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
 281         print PM <<'END';
 282 use vars qw($VERSION @ISA @EXPORT);
 283 END
 284 }
 285 else{
 286         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 287         # will want Carp.
 288         print PM <<'END';
 289 use Carp;
 290 use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
 291 END
 292 }
 293
 294 print PM <<'END';
 295
 296 require Exporter;
 297 END
 298
 299 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 300 require DynaLoader;
 301 END
 302
 303 # require autoloader if XS is disabled.
 304 # if XS is enabled, require autoloader unless autoloading is disabled.
 305 if( $opt_X || (! $opt_A) ){
 306         print PM <<"END";
 307 require AutoLoader;
 308 END
 309 }
 310
 311 if( $opt_X || ($opt_c && ! $opt_A) ){
 312         # we won't have our own AUTOLOAD(), so we'll inherit it.
 313         if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
 314                 print PM <<"END";
 315
 316 \@ISA = qw(Exporter AutoLoader DynaLoader);
 317 END
 318         }
 319         else{
 320                 print PM <<"END";
 321
 322 \@ISA = qw(Exporter AutoLoader);
 323 END
 324         }
 325 }
 326 else{
 327         # 1) we have our own AUTOLOAD(), so don't need to inherit it.
 328         # or
 329         # 2) we don't want autoloading mentioned.
 330         if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
 331                 print PM <<"END";
 332
 333 \@ISA = qw(Exporter DynaLoader);
 334 END
 335         }
 336         else{
 337                 print PM <<"END";
 338
 339 \@ISA = qw(Exporter);
 340 END
 341         }
 342 }
 343
 344 print PM<<"END";
 345 # Items to export into callers namespace by default. Note: do not export
 346 # names by default without a very good reason. Use EXPORT_OK instead.
 347 # Do not simply export all your public functions/methods/constants.
 348 \@EXPORT = qw(
 349         @const_names
 350 );
 351 \$VERSION = '$TEMPLATE_VERSION';
 352
 353 END
 354
 355 print PM <<"END" unless $opt_c or $opt_X;
 356 sub AUTOLOAD {
 357     # This AUTOLOAD is used to 'autoload' constants from the constant()
 358     # XS function.  If a constant is not found then control is passed
 359     # to the AUTOLOAD in AutoLoader.
 360
 361     my \$constname;
 362     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 363     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 364     if (\$! != 0) {
 365         if (\$! =~ /Invalid/) {
 366             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 367             goto &AutoLoader::AUTOLOAD;
 368         }
 369         else {
 370                 croak "Your vendor has not defined $module macro \$constname";
 371         }
 372     }
 373     eval "sub \$AUTOLOAD { \$val }";
 374     goto &\$AUTOLOAD;
 375 }
 376
 377 END
 378
 379 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 380         print PM <<"END";
 381 bootstrap $module \$VERSION;
 382 END
 383 }
 384
 385 if( $opt_P ){ # if POD is disabled
 386         $after = '__END__';
 387 }
 388 else {
 389         $after = '=cut';
 390 }
 391
 392 print PM <<"END";
 393
 394 # Preloaded methods go here.
 395
 396 # Autoload methods go after $after, and are processed by the autosplit program.
 397
 398 1;
 399 __END__
 400 END
 401
 402 $author = "A. U. Thor";
 403 $email = 'a.u.thor@a.galaxy.far.far.away';
 404
 405 $pod = <<"END" unless $opt_P;
 406 ## Below is the stub of documentation for your module. You better edit it!
 407 #
 408 #=head1 NAME
 409 #
 410 #$module - Perl extension for blah blah blah
 411 #
 412 #=head1 SYNOPSIS
 413 #
 414 #  use $module;
 415 #  blah blah blah
 416 #
 417 #=head1 DESCRIPTION
 418 #
 419 #Stub documentation for $module was created by h2xs. It looks like the
 420 #author of the extension was negligent enough to leave the stub
 421 #unedited.
 422 #
 423 #Blah blah blah.
 424 #
 425 #=head1 AUTHOR
 426 #
 427 #$author, $email
 428 #
 429 #=head1 SEE ALSO
 430 #
 431 #perl(1).
 432 #
 433 #=cut
 434 END
 435
 436 $pod =~ s/^\#//gm unless $opt_P;
 437 print PM $pod unless $opt_P;
 438
 439 close PM;
 440
 441
 442 if( ! $opt_X ){ # print XS, unless it is disabled
 443 warn "Writing $ext$modpname/$modfname.xs\n";
 444
 445 print XS <<"END";
 446 #ifdef __cplusplus
 447 extern "C" {
 448 #endif
 449 #include "EXTERN.h"
 450 #include "perl.h"
 451 #include "XSUB.h"
 452 #ifdef __cplusplus
 453 }
 454 #endif
 455
 456 END
 457 if( $path_h ){
 458         my($h) = $path_h;
 459         $h =~ s#^/usr/include/##;
 460 print XS <<"END";
 461 #include <$h>
 462
 463 END
 464 }
 465
 466 if( ! $opt_c ){
 467 print XS <<"END";
 468 static int
 469 not_here(s)
 470 char *s;
 471 {
 472     croak("$module::%s not implemented on this architecture", s);
 473     return -1;
 474 }
 475
 476 static double
 477 constant(name, arg)
 478 char *name;
 479 int arg;
 480 {
 481     errno = 0;
 482     switch (*name) {
 483 END
 484
 485 my(@AZ, @az, @under);
 486
 487 foreach(@const_names){
 488     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 489     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 490     @under = '_'  if !@under && /^_/;
 491 }
 492
 493 foreach $letter (@AZ, @az, @under) {
 494
 495     last if $letter eq 'a' && !@const_names;
 496
 497     print XS "    case '$letter':\n";
 498     my($name);
 499     while (substr($const_names[0],0,1) eq $letter) {
 500         $name = shift(@const_names);
 501         print XS <<"END";
 502         if (strEQ(name, "$name"))
 503 #ifdef $name
 504             return $name;
 505 #else
 506             goto not_there;
 507 #endif
 508 END
 509     }
 510     print XS <<"END";
 511         break;
 512 END
 513 }
 514 print XS <<"END";
 515     }
 516     errno = EINVAL;
 517     return 0;
 518
 519 not_there:
 520     errno = ENOENT;
 521     return 0;
 522 }
 523
 524 END
 525 }
 526
 527 # Now switch from C to XS by issuing the first MODULE declaration:
 528 print XS <<"END";
 529
 530 MODULE = $module                PACKAGE = $module
 531
 532 END
 533
 534 # If a constant() function was written then output a corresponding
 535 # XS declaration:
 536 print XS <<"END" unless $opt_c;
 537
 538 double
 539 constant(name,arg)
 540         char *          name
 541         int             arg
 542
 543 END
 544
 545 close XS;
 546 } # if( ! $opt_X )
 547
 548 warn "Writing $ext$modpname/Makefile.PL\n";
 549 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 550
 551 print PL <<'END';
 552 use ExtUtils::MakeMaker;
 553 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 554 # the contents of the Makefile that is written.
 555 END
 556 print PL "WriteMakefile(\n";
 557 print PL "    'NAME'    => '$module',\n";
 558 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
 559 if( ! $opt_X ){ # print C stuff, unless XS is disabled
 560   print PL "    'LIBS'  => ['$extralibs'],   # e.g., '-lm' \n";
 561   print PL "    'DEFINE'        => '',     # e.g., '-DHAVE_SOMETHING' \n";
 562   print PL "    'INC'   => '',     # e.g., '-I/usr/include/other' \n";
 563 }
 564 print PL ");\n";
 565 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 566
 567 warn "Writing $ext$modpname/test.pl\n";
 568 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 569 print EX <<'_END_';
 570 # Before `make install' is performed this script should be runnable with
 571 # `make test'. After `make install' it should work as `perl test.pl'
 572
 573 ######################### We start with some black magic to print on failure.
 574
 575 # Change 1..1 below to 1..last_test_to_print .
 576 # (It may become useful if the test is moved to ./t subdirectory.)
 577
 578 BEGIN { $| = 1; print "1..1\n"; }
 579 END {print "not ok 1\n" unless $loaded;}
 580 _END_
 581 print EX <<_END_;
 582 use $module;
 583 _END_
 584 print EX <<'_END_';
 585 $loaded = 1;
 586 print "ok 1\n";
 587
 588 ######################### End of black magic.
 589
 590 # Insert your test code below (better if it prints "ok 13"
 591 # (correspondingly "not ok 13") depending on the success of chunk 13
 592 # of the test code):
 593
 594 _END_
 595 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 596
 597 warn "Writing $ext$modpname/Changes\n";
 598 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
 599 print EX "Revision history for Perl extension $module.\n\n";
 600 print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
 601 print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
 602 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
 603
 604 warn "Writing $ext$modpname/MANIFEST\n";
 605 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
 606 @files = <*>;
 607 if (!@files) {
 608   eval {opendir(D,'.');};
 609   unless ($@) { @files = readdir(D); closedir(D); }
 610 }
 611 if (!@files) { @files = map {chomp && $_} `ls`; }
 612 print MANI join("\n",@files);
 613 close MANI;
 614 !NO!SUBS!
 615
 616 close OUT or die "Can't close $file: $!";
 617 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 618 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';