perl 5.002beta1h patch: utils/h2xs.PL
[perl.git] / 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 ':';