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