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