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<-Acfh>] [B<-n> module_name] [headerfile [extra_libraries]]
  45
  46 =head1 DESCRIPTION
  47
  48 I<h2xs> builds a Perl extension from any C header file.  The extension will
  49 include functions which can be used to retrieve the value of any #define
  50 statement which was in the C header.
  51
  52 The I<module_name> will be used for the name of the extension.  If
  53 module_name is not supplied then the name of the header file will be used,
  54 with the first character capitalized.
  55
  56 If the extension might need extra libraries, they should be included
  57 here.  The extension Makefile.PL will take care of checking whether
  58 the libraries actually exist and how they should be loaded.
  59 The extra libraries should be specified in the form -lm -lposix, etc,
  60 just as on the cc command line.  By default, the Makefile.PL will
  61 search through the library path determined by Configure.  That path
  62 can be augmented by including arguments of the form B<-L/another/library/path>
  63 in the extra-libraries argument.
  64
  65 =head1 OPTIONS
  66
  67 =over 5
  68
  69 =item B<-n> I<module_name>
  70
  71 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
  72
  73 =item B<-f>
  74
  75 Allows an extension to be created for a header even if that header is
  76 not found in /usr/include.
  77
  78 =item B<-c>
  79
  80 Omit C<constant()> from the .xs file and corresponding specialised
  81 C<AUTOLOAD> from the .pm file.
  82
  83 =item B<-A>
  84
  85 Omit all autoload facilities.  This is the same as B<-c> but also removes the
  86 S<C<require AutoLoader>> statement from the .pm file.
  87
  88 =back
  89
  90 =head1 EXAMPLES
  91
  92
  93         # Default behavior, extension is Rusers
  94         h2xs rpcsvc/rusers
  95
  96         # Same, but extension is RUSERS
  97         h2xs -n RUSERS rpcsvc/rusers
  98
  99         # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
 100         h2xs rpcsvc::rusers
 101
 102         # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
 103         h2xs -n ONC::RPC rpcsvc/rusers
 104
 105         # Without constant() or AUTOLOAD
 106         h2xs -c rpcsvc/rusers
 107
 108         # Creates templates for an extension named RPC
 109         h2xs -cfn RPC
 110
 111         # Extension is ONC::RPC.
 112         h2xs -cfn ONC::RPC
 113
 114         # Makefile.PL will look for library -lrpc in
 115         # additional directory /opt/net/lib
 116         h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
 117
 118
 119 =head1 ENVIRONMENT
 120
 121 No environment variables are used.
 122
 123 =head1 AUTHOR
 124
 125 Larry Wall and others
 126
 127 =head1 SEE ALSO
 128
 129 L<perl>, L<ExtUtils::MakeMaker>, L<AutoLoader>
 130
 131 =head1 DIAGNOSTICS
 132
 133 The usual warnings if it can't read or write the files involved.
 134
 135 =cut
 136
 137
 138 use Getopt::Std;
 139
 140 sub usage{
 141         warn "@_\n" if @_;
 142     die 'h2xs [-Acfh] [-n module_name] [headerfile [extra_libraries]]
 143     -f   Force creation of the extension even if the C header does not exist.
 144     -n   Specify a name to use for the extension (recommended).
 145     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
 146     -A   Omit all autoloading facilities (implies -c).
 147     -h   Display this help message
 148 extra_libraries
 149          are any libraries that might be needed for loading the
 150          extension, e.g. -lm would try to link in the math library.
 151 ';
 152 }
 153
 154
 155 getopts("Acfhn:") || usage;
 156
 157 usage if $opt_h;
 158 $opt_c = 1 if $opt_A;
 159
 160 $path_h    = shift;
 161 $extralibs = "@ARGV";
 162
 163 usage "Must supply header file or module name\n"
 164         unless ($path_h or $opt_n);
 165
 166
 167 if( $path_h ){
 168     $name = $path_h;
 169     if( $path_h =~ s#::#/#g && $opt_n ){
 170         warn "Nesting of headerfile ignored with -n\n";
 171     }
 172     $path_h .= ".h" unless $path_h =~ /\.h$/;
 173     $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#;
 174     die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
 175
 176     # Scan the header file (we should deal with nested header files)
 177     # Record the names of simple #define constants into const_names
 178     # Function prototypes are not (currently) processed.
 179     open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
 180     while (<CH>) {
 181         if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) {
 182             $_ = $1;
 183             next if /^_.*_h_*$/i; # special case, but for what?
 184             $const_names{$_}++;
 185         }
 186     }
 187     close(CH);
 188     @const_names = sort keys %const_names;
 189 }
 190
 191
 192 $module = $opt_n || do {
 193         $name =~ s/\.h$//;
 194         if( $name !~ /::/ ){
 195                 $name =~ s#^.*/##;
 196                 $name = "\u$name";
 197         }
 198         $name;
 199 };
 200
 201 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 202
 203 if( $module =~ /::/ ){
 204         $nested = 1;
 205         @modparts = split(/::/,$module);
 206         $modfname = $modparts[-1];
 207         $modpname = join('/',@modparts);
 208 }
 209 else {
 210         $nested = 0;
 211         @modparts = ();
 212         $modfname = $modpname = $module;
 213 }
 214
 215
 216 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 217 # quick hack, should really loop over @modparts
 218 mkdir($modparts[0], 0777) if $nested;
 219 mkdir($modpname, 0777);
 220 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 221
 222 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 223 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 224
 225 $" = "\n\t";
 226 warn "Writing $ext$modpname/$modfname.pm\n";
 227
 228 print PM <<"END";
 229 package $module;
 230
 231 require Exporter;
 232 require DynaLoader;
 233 END
 234
 235 if( ! $opt_A ){
 236         print PM <<"END";
 237 require AutoLoader;
 238 END
 239 }
 240
 241 if( $opt_c && ! $opt_A ){
 242         # we won't have our own AUTOLOAD(), so we'll inherit it.
 243         print PM <<"END";
 244
 245 \@ISA = qw(Exporter AutoLoader DynaLoader);
 246 END
 247 }
 248 else{
 249         # 1) we have our own AUTOLOAD(), so don't need to inherit it.
 250         # or
 251         # 2) we don't want autoloading mentioned.
 252         print PM <<"END";
 253
 254 \@ISA = qw(Exporter DynaLoader);
 255 END
 256 }
 257
 258 print PM<<"END";
 259 # Items to export into callers namespace by default. Note: do not export
 260 # names by default without a very good reason. Use EXPORT_OK instead.
 261 # Do not simply export all your public functions/methods/constants.
 262 \@EXPORT = qw(
 263         @const_names
 264 );
 265 END
 266
 267 print PM <<"END" unless $opt_c;
 268 sub AUTOLOAD {
 269     # This AUTOLOAD is used to 'autoload' constants from the constant()
 270     # XS function.  If a constant is not found then control is passed
 271     # to the AUTOLOAD in AutoLoader.
 272
 273     local(\$constname);
 274     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 275     \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 276     if (\$! != 0) {
 277         if (\$! =~ /Invalid/) {
 278             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 279             goto &AutoLoader::AUTOLOAD;
 280         }
 281         else {
 282             (\$pack,\$file,\$line) = caller;
 283             die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n";
 284         }
 285     }
 286     eval "sub \$AUTOLOAD { \$val }";
 287     goto &\$AUTOLOAD;
 288 }
 289
 290 END
 291
 292 print PM <<"END";
 293 bootstrap $module;
 294
 295 # Preloaded methods go here.
 296
 297 # Autoload methods go after __END__, and are processed by the autosplit program.
 298
 299 1;
 300 __END__
 301 END
 302
 303 close PM;
 304
 305
 306 warn "Writing $ext$modpname/$modfname.xs\n";
 307
 308 print XS <<"END";
 309 #ifdef __cplusplus
 310 extern "C" {
 311 #endif
 312 #include "EXTERN.h"
 313 #include "perl.h"
 314 #include "XSUB.h"
 315 #ifdef __cplusplus
 316 }
 317 #endif
 318
 319 END
 320 if( $path_h ){
 321         my($h) = $path_h;
 322         $h =~ s#^/usr/include/##;
 323 print XS <<"END";
 324 #include <$h>
 325
 326 END
 327 }
 328
 329 if( ! $opt_c ){
 330 print XS <<"END";
 331 static int
 332 not_here(s)
 333 char *s;
 334 {
 335     croak("$module::%s not implemented on this architecture", s);
 336     return -1;
 337 }
 338
 339 static double
 340 constant(name, arg)
 341 char *name;
 342 int arg;
 343 {
 344     errno = 0;
 345     switch (*name) {
 346 END
 347
 348 my(@AZ, @az, @under);
 349
 350 foreach(@const_names){
 351     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 352     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 353     @under = '_'  if !@under && /^_/;
 354 }
 355
 356 foreach $letter (@AZ, @az, @under) {
 357
 358     last if $letter eq 'a' && !@const_names;
 359
 360     print XS "    case '$letter':\n";
 361     my($name);
 362     while (substr($const_names[0],0,1) eq $letter) {
 363         $name = shift(@const_names);
 364         print XS <<"END";
 365         if (strEQ(name, "$name"))
 366 #ifdef $name
 367             return $name;
 368 #else
 369             goto not_there;
 370 #endif
 371 END
 372     }
 373     print XS <<"END";
 374         break;
 375 END
 376 }
 377 print XS <<"END";
 378     }
 379     errno = EINVAL;
 380     return 0;
 381
 382 not_there:
 383     errno = ENOENT;
 384     return 0;
 385 }
 386
 387 END
 388 }
 389
 390 # Now switch from C to XS by issuing the first MODULE declaration:
 391 print XS <<"END";
 392
 393 MODULE = $module                PACKAGE = $module
 394
 395 END
 396
 397 # If a constant() function was written then output a corresponding
 398 # XS declaration:
 399 print XS <<"END" unless $opt_c;
 400
 401 double
 402 constant(name,arg)
 403         char *          name
 404         int             arg
 405
 406 END
 407
 408 close XS;
 409
 410
 411 warn "Writing $ext$modpname/Makefile.PL\n";
 412 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 413
 414 print PL <<'END';
 415 use ExtUtils::MakeMaker;
 416 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 417 # the contents of the Makefile that is written.
 418 END
 419 print PL "WriteMakefile(\n";
 420 print PL "    'NAME'    => '$module',\n";
 421 print PL "    'VERSION' => '0.1',\n";
 422 print PL "    'LIBS'    => ['$extralibs'],   # e.g., '-lm' \n";
 423 print PL "    'DEFINE'  => '',     # e.g., '-DHAVE_SOMETHING' \n";
 424 print PL "    'INC'     => '',     # e.g., '-I/usr/include/other' \n";
 425 print PL ");\n";
 426
 427
 428 system '/bin/ls > MANIFEST' or system 'ls > MANIFEST';
 429 !NO!SUBS!
 430
 431 close OUT or die "Can't close $file: $!";
 432 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 433 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';