h2xs

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