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.12 $' =~ /\$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 # quick hack, should really loop over @modparts
 242 mkdir($modparts[0], 0777) if $nested;
 243 mkdir($modpname, 0777);
 244 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 245
 246 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 247 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 248
 249 $" = "\n\t";
 250 warn "Writing $ext$modpname/$modfname.pm\n";
 251
 252 print PM <<"END";
 253 package $module;
 254
 255 require Exporter;
 256 require DynaLoader;
 257 END
 258
 259 if( ! $opt_A ){
 260         print PM <<"END";
 261 require AutoLoader;
 262 END
 263 }
 264
 265 if( $opt_c && ! $opt_A ){
 266         # we won't have our own AUTOLOAD(), so we'll inherit it.
 267         print PM <<"END";
 268
 269 \@ISA = qw(Exporter AutoLoader DynaLoader);
 270 END
 271 }
 272 else{
 273         # 1) we have our own AUTOLOAD(), so don't need to inherit it.
 274         # or
 275         # 2) we don't want autoloading mentioned.
 276         print PM <<"END";
 277
 278 \@ISA = qw(Exporter DynaLoader);
 279 END
 280 }
 281
 282 print PM<<"END";
 283 # Items to export into callers namespace by default. Note: do not export
 284 # names by default without a very good reason. Use EXPORT_OK instead.
 285 # Do not simply export all your public functions/methods/constants.
 286 \@EXPORT = qw(
 287         @const_names
 288 );
 289 \$VERSION = '$TEMPLATE_VERSION';
 290
 291 END
 292
 293 print PM <<"END" unless $opt_c;
 294 sub AUTOLOAD {
 295     # This AUTOLOAD is used to 'autoload' constants from the constant()
 296     # XS function.  If a constant is not found then control is passed
 297     # to the AUTOLOAD in AutoLoader.
 298
 299     local(\$constname);
 300     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 301     \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 302     if (\$! != 0) {
 303         if (\$! =~ /Invalid/) {
 304             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 305             goto &AutoLoader::AUTOLOAD;
 306         }
 307         else {
 308             (\$pack,\$file,\$line) = caller;
 309             die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n";
 310         }
 311     }
 312     eval "sub \$AUTOLOAD { \$val }";
 313     goto &\$AUTOLOAD;
 314 }
 315
 316 END
 317
 318 print PM <<"END";
 319 bootstrap $module \$VERSION;
 320
 321 # Preloaded methods go here.
 322
 323 # Autoload methods go after __END__, and are processed by the autosplit program.
 324
 325 1;
 326 __END__
 327 END
 328
 329 $author = "A. U. Thor";
 330 $email = 'a.u.thor@a.galaxy.far.far.away';
 331
 332 $pod = <<"END" unless $opt_P;
 333 ## Below is the stub of documentation for your module. You better edit it!
 334 #
 335 #=head1 NAME
 336 #
 337 #$module - Perl extension for blah blah blah
 338 #
 339 #=head1 SYNOPSIS
 340 #
 341 #  use $module;
 342 #  blah blah blah
 343 #
 344 #=head1 DESCRIPTION
 345 #
 346 #Stub documentation for $module was created by h2xs. It looks like the
 347 #author of the extension was negligent enough to leave the stub
 348 #unedited.
 349 #
 350 #Blah blah blah.
 351 #
 352 #=head1 AUTHOR
 353 #
 354 #$author, $email
 355 #
 356 #=head1 SEE ALSO
 357 #
 358 #perl(1).
 359 #
 360 #=cut
 361 END
 362
 363 $pod =~ s/^\#//gm unless $opt_P;
 364 print PM $pod unless $opt_P;
 365
 366 close PM;
 367
 368
 369 warn "Writing $ext$modpname/$modfname.xs\n";
 370
 371 print XS <<"END";
 372 #ifdef __cplusplus
 373 extern "C" {
 374 #endif
 375 #include "EXTERN.h"
 376 #include "perl.h"
 377 #include "XSUB.h"
 378 #ifdef __cplusplus
 379 }
 380 #endif
 381
 382 END
 383 if( $path_h ){
 384         my($h) = $path_h;
 385         $h =~ s#^/usr/include/##;
 386 print XS <<"END";
 387 #include <$h>
 388
 389 END
 390 }
 391
 392 if( ! $opt_c ){
 393 print XS <<"END";
 394 static int
 395 not_here(s)
 396 char *s;
 397 {
 398     croak("$module::%s not implemented on this architecture", s);
 399     return -1;
 400 }
 401
 402 static double
 403 constant(name, arg)
 404 char *name;
 405 int arg;
 406 {
 407     errno = 0;
 408     switch (*name) {
 409 END
 410
 411 my(@AZ, @az, @under);
 412
 413 foreach(@const_names){
 414     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 415     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 416     @under = '_'  if !@under && /^_/;
 417 }
 418
 419 foreach $letter (@AZ, @az, @under) {
 420
 421     last if $letter eq 'a' && !@const_names;
 422
 423     print XS "    case '$letter':\n";
 424     my($name);
 425     while (substr($const_names[0],0,1) eq $letter) {
 426         $name = shift(@const_names);
 427         print XS <<"END";
 428         if (strEQ(name, "$name"))
 429 #ifdef $name
 430             return $name;
 431 #else
 432             goto not_there;
 433 #endif
 434 END
 435     }
 436     print XS <<"END";
 437         break;
 438 END
 439 }
 440 print XS <<"END";
 441     }
 442     errno = EINVAL;
 443     return 0;
 444
 445 not_there:
 446     errno = ENOENT;
 447     return 0;
 448 }
 449
 450 END
 451 }
 452
 453 # Now switch from C to XS by issuing the first MODULE declaration:
 454 print XS <<"END";
 455
 456 MODULE = $module                PACKAGE = $module
 457
 458 END
 459
 460 # If a constant() function was written then output a corresponding
 461 # XS declaration:
 462 print XS <<"END" unless $opt_c;
 463
 464 double
 465 constant(name,arg)
 466         char *          name
 467         int             arg
 468
 469 END
 470
 471 close XS;
 472
 473
 474 warn "Writing $ext$modpname/Makefile.PL\n";
 475 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 476
 477 print PL <<'END';
 478 use ExtUtils::MakeMaker;
 479 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 480 # the contents of the Makefile that is written.
 481 END
 482 print PL "WriteMakefile(\n";
 483 print PL "    'NAME'    => '$module',\n";
 484 print PL "    'VERSION' => '$TEMPLATE_VERSION',\n";
 485 print PL "    'LIBS'    => ['$extralibs'],   # e.g., '-lm' \n";
 486 print PL "    'DEFINE'  => '',     # e.g., '-DHAVE_SOMETHING' \n";
 487 print PL "    'INC'     => '',     # e.g., '-I/usr/include/other' \n";
 488 print PL ");\n";
 489 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 490
 491 warn "Writing $ext$modpname/test.pl\n";
 492 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 493 print EX <<'_END_';
 494 # Before `make install' is performed this script should be runnable with
 495 # `make test'. After `make install' it should work as `perl test.pl'
 496
 497 ######################### We start with some black magic to print on failure.
 498
 499 # Change 1..1 below to 1..last_test_to_print .
 500 # (It may become useful if the test is moved to ./t subdirectory.)
 501
 502 BEGIN {print "1..1\n";}
 503 END {print "not ok 1\n" unless $loaded;}
 504 _END_
 505 print EX <<_END_;
 506 use $module;
 507 _END_
 508 print EX <<'_END_';
 509 $loaded = 1;
 510 print "ok 1\n";
 511
 512 ######################### End of black magic.
 513
 514 # Insert your test code below (better if it prints "ok 13"
 515 # (correspondingly "not ok 13") depending on the success of chunk 13
 516 # of the test code):
 517
 518 _END_
 519 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 520
 521 system '/bin/ls > MANIFEST' or system 'ls > MANIFEST';
 522 !NO!SUBS!
 523
 524 close OUT or die "Can't close $file: $!";
 525 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 526 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';