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