1#!/usr/local/bin/perl 2 3use Config; 4use File::Basename qw(&basename &dirname); 5use Cwd; 6 7# List explicitly here the variables you want Configure to 8# generate. Metaconfig only looks for shell variables, so you 9# have to mention them as if they were shell variables, not 10# %Config entries. Thus you write 11# $startperl 12# to ensure Configure will look for $Config{startperl}. 13 14# This forces PL files to create target in same directory as PL file. 15# This is so that make depend always knows where to find PL derivatives. 16my $origdir = cwd; 17chdir dirname($0); 18my $file = basename($0, '.PL'); 19$file .= '.com' if $^O eq 'VMS'; 20 21open OUT,">$file" or die "Can't create $file: $!"; 22 23print "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 28print OUT <<"!GROK!THIS!"; 29$Config{startperl} 30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' 31 if \$running_under_some_shell; 32!GROK!THIS! 33 34# In the following, perl variables are not expanded during extraction. 35 36print OUT <<'!NO!SUBS!'; 37 38use warnings; 39 40=head1 NAME 41 42h2xs - convert .h C header files to Perl extensions 43 44=head1 SYNOPSIS 45 46B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]] 47 48B<h2xs> B<-h>|B<-?>|B<--help> 49 50=head1 DESCRIPTION 51 52I<h2xs> builds a Perl extension from C header files. The extension 53will include functions which can be used to retrieve the value of any 54#define statement which was in the C header files. 55 56The I<module_name> will be used for the name of the extension. If 57module_name is not supplied then the name of the first header file 58will be used, with the first character capitalized. 59 60If the extension might need extra libraries, they should be included 61here. The extension Makefile.PL will take care of checking whether 62the libraries actually exist and how they should be loaded. The extra 63libraries should be specified in the form -lm -lposix, etc, just as on 64the cc command line. By default, the Makefile.PL will search through 65the library path determined by Configure. That path can be augmented 66by including arguments of the form B<-L/another/library/path> in the 67extra-libraries argument. 68 69=head1 OPTIONS 70 71=over 5 72 73=item B<-A>, B<--omit-autoload> 74 75Omit all autoload facilities. This is the same as B<-c> but also 76removes the S<C<use AutoLoader>> statement from the .pm file. 77 78=item B<-B>, B<--beta-version> 79 80Use an alpha/beta style version number. Causes version number to 81be "0.00_01" unless B<-v> is specified. 82 83=item B<-C>, B<--omit-changes> 84 85Omits creation of the F<Changes> file, and adds a HISTORY section to 86the POD template. 87 88=item B<-F>, B<--cpp-flags>=I<addflags> 89 90Additional flags to specify to C preprocessor when scanning header for 91function declarations. Writes these options in the generated F<Makefile.PL> 92too. 93 94=item B<-M>, B<--func-mask>=I<regular expression> 95 96selects functions/macros to process. 97 98=item B<-O>, B<--overwrite-ok> 99 100Allows a pre-existing extension directory to be overwritten. 101 102=item B<-P>, B<--omit-pod> 103 104Omit the autogenerated stub POD section. 105 106=item B<-X>, B<--omit-XS> 107 108Omit the XS portion. Used to generate templates for a module which is not 109XS-based. C<-c> and C<-f> are implicitly enabled. 110 111=item B<-a>, B<--gen-accessors> 112 113Generate an accessor method for each element of structs and unions. The 114generated methods are named after the element name; will return the current 115value of the element if called without additional arguments; and will set 116the element to the supplied value (and return the new value) if called with 117an additional argument. Embedded structures and unions are returned as a 118pointer rather than the complete structure, to facilitate chained calls. 119 120These methods all apply to the Ptr type for the structure; additionally 121two methods are constructed for the structure type itself, C<_to_ptr> 122which returns a Ptr type pointing to the same structure, and a C<new> 123method to construct and return a new structure, initialised to zeroes. 124 125=item B<-b>, B<--compat-version>=I<version> 126 127Generates a .pm file which is backwards compatible with the specified 128perl version. 129 130For versions < 5.6.0, the changes are. 131 - no use of 'our' (uses 'use vars' instead) 132 - no 'use warnings' 133 134Specifying a compatibility version higher than the version of perl you 135are using to run h2xs will have no effect. If unspecified h2xs will default 136to compatibility with the version of perl you are using to run h2xs. 137 138=item B<-c>, B<--omit-constant> 139 140Omit C<constant()> from the .xs file and corresponding specialised 141C<AUTOLOAD> from the .pm file. 142 143=item B<-d>, B<--debugging> 144 145Turn on debugging messages. 146 147=item B<-e>, B<--omit-enums>=[I<regular expression>] 148 149If I<regular expression> is not given, skip all constants that are defined in 150a C enumeration. Otherwise skip only those constants that are defined in an 151enum whose name matches I<regular expression>. 152 153Since I<regular expression> is optional, make sure that this switch is followed 154by at least one other switch if you omit I<regular expression> and have some 155pending arguments such as header-file names. This is ok: 156 157 h2xs -e -n Module::Foo foo.h 158 159This is not ok: 160 161 h2xs -n Module::Foo -e foo.h 162 163In the latter, foo.h is taken as I<regular expression>. 164 165=item B<-f>, B<--force> 166 167Allows an extension to be created for a header even if that header is 168not found in standard include directories. 169 170=item B<-g>, B<--global> 171 172Include code for safely storing static data in the .xs file. 173Extensions that do no make use of static data can ignore this option. 174 175=item B<-h>, B<-?>, B<--help> 176 177Print the usage, help and version for this h2xs and exit. 178 179=item B<-k>, B<--omit-const-func> 180 181For function arguments declared as C<const>, omit the const attribute in the 182generated XS code. 183 184=item B<-m>, B<--gen-tied-var> 185 186B<Experimental>: for each variable declared in the header file(s), declare 187a perl variable of the same name magically tied to the C variable. 188 189=item B<-n>, B<--name>=I<module_name> 190 191Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> 192 193=item B<-o>, B<--opaque-re>=I<regular expression> 194 195Use "opaque" data type for the C types matched by the regular 196expression, even if these types are C<typedef>-equivalent to types 197from typemaps. Should not be used without B<-x>. 198 199This may be useful since, say, types which are C<typedef>-equivalent 200to integers may represent OS-related handles, and one may want to work 201with these handles in OO-way, as in C<$handle-E<gt>do_something()>. 202Use C<-o .> if you want to handle all the C<typedef>ed types as opaque 203types. 204 205The type-to-match is whitewashed (except for commas, which have no 206whitespace before them, and multiple C<*> which have no whitespace 207between them). 208 209=item B<-p>, B<--remove-prefix>=I<prefix> 210 211Specify a prefix which should be removed from the Perl function names, 212e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes 213the prefix from functions that are autoloaded via the C<constant()> 214mechanism. 215 216=item B<-s>, B<--const-subs>=I<sub1,sub2> 217 218Create a perl subroutine for the specified macros rather than autoload 219with the constant() subroutine. These macros are assumed to have a 220return type of B<char *>, e.g., 221S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. 222 223=item B<-t>, B<--default-type>=I<type> 224 225Specify the internal type that the constant() mechanism uses for macros. 226The default is IV (signed integer). Currently all macros found during the 227header scanning process will be assumed to have this type. Future versions 228of C<h2xs> may gain the ability to make educated guesses. 229 230=item B<--use-new-tests> 231 232When B<--compat-version> (B<-b>) is present the generated tests will use 233C<Test::More> rather than C<Test> which is the default for versions before 2345.7.2 . C<Test::More> will be added to PREREQ_PM in the generated 235C<Makefile.PL>. 236 237=item B<--use-old-tests> 238 239Will force the generation of test code that uses the older C<Test> module. 240 241=item B<--skip-exporter> 242 243Do not use C<Exporter> and/or export any symbol. 244 245=item B<--skip-ppport> 246 247Do not use C<Devel::PPPort>: no portability to older version. 248 249=item B<--skip-autoloader> 250 251Do not use the module C<AutoLoader>; but keep the constant() function 252and C<sub AUTOLOAD> for constants. 253 254=item B<--skip-strict> 255 256Do not use the pragma C<strict>. 257 258=item B<--skip-warnings> 259 260Do not use the pragma C<warnings>. 261 262=item B<-v>, B<--version>=I<version> 263 264Specify a version number for this extension. This version number is added 265to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified. 266The version specified should be numeric. 267 268=item B<-x>, B<--autogen-xsubs> 269 270Automatically generate XSUBs basing on function declarations in the 271header file. The package C<C::Scan> should be installed. If this 272option is specified, the name of the header file may look like 273C<NAME1,NAME2>. In this case NAME1 is used instead of the specified 274string, but XSUBs are emitted only for the declarations included from 275file NAME2. 276 277Note that some types of arguments/return-values for functions may 278result in XSUB-declarations/typemap-entries which need 279hand-editing. Such may be objects which cannot be converted from/to a 280pointer (like C<long long>), pointers to functions, or arrays. See 281also the section on L<LIMITATIONS of B<-x>>. 282 283=back 284 285=head1 EXAMPLES 286 287 288 # Default behavior, extension is Rusers 289 h2xs rpcsvc/rusers 290 291 # Same, but extension is RUSERS 292 h2xs -n RUSERS rpcsvc/rusers 293 294 # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h> 295 h2xs rpcsvc::rusers 296 297 # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h> 298 h2xs -n ONC::RPC rpcsvc/rusers 299 300 # Without constant() or AUTOLOAD 301 h2xs -c rpcsvc/rusers 302 303 # Creates templates for an extension named RPC 304 h2xs -cfn RPC 305 306 # Extension is ONC::RPC. 307 h2xs -cfn ONC::RPC 308 309 # Extension is Lib::Foo which works at least with Perl5.005_03. 310 # Constants are created for all #defines and enums h2xs can find 311 # in foo.h. 312 h2xs -b 5.5.3 -n Lib::Foo foo.h 313 314 # Extension is Lib::Foo which works at least with Perl5.005_03. 315 # Constants are created for all #defines but only for enums 316 # whose names do not start with 'bar_'. 317 h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h 318 319 # Makefile.PL will look for library -lrpc in 320 # additional directory /opt/net/lib 321 h2xs rpcsvc/rusers -L/opt/net/lib -lrpc 322 323 # Extension is DCE::rgynbase 324 # prefix "sec_rgy_" is dropped from perl function names 325 h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase 326 327 # Extension is DCE::rgynbase 328 # prefix "sec_rgy_" is dropped from perl function names 329 # subroutines are created for sec_rgy_wildcard_name and 330 # sec_rgy_wildcard_sid 331 h2xs -n DCE::rgynbase -p sec_rgy_ \ 332 -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase 333 334 # Make XS without defines in perl.h, but with function declarations 335 # visible from perl.h. Name of the extension is perl1. 336 # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= 337 # Extra backslashes below because the string is passed to shell. 338 # Note that a directory with perl header files would 339 # be added automatically to include path. 340 h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h 341 342 # Same with function declaration in proto.h as visible from perl.h. 343 h2xs -xAn perl2 perl.h,proto.h 344 345 # Same but select only functions which match /^av_/ 346 h2xs -M '^av_' -xAn perl2 perl.h,proto.h 347 348 # Same but treat SV* etc as "opaque" types 349 h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h 350 351=head2 Extension based on F<.h> and F<.c> files 352 353Suppose that you have some C files implementing some functionality, 354and the corresponding header files. How to create an extension which 355makes this functionality accessable in Perl? The example below 356assumes that the header files are F<interface_simple.h> and 357I<interface_hairy.h>, and you want the perl module be named as 358C<Ext::Ension>. If you need some preprocessor directives and/or 359linking with external libraries, see the flags C<-F>, C<-L> and C<-l> 360in L<"OPTIONS">. 361 362=over 363 364=item Find the directory name 365 366Start with a dummy run of h2xs: 367 368 h2xs -Afn Ext::Ension 369 370The only purpose of this step is to create the needed directories, and 371let you know the names of these directories. From the output you can 372see that the directory for the extension is F<Ext/Ension>. 373 374=item Copy C files 375 376Copy your header files and C files to this directory F<Ext/Ension>. 377 378=item Create the extension 379 380Run h2xs, overwriting older autogenerated files: 381 382 h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h 383 384h2xs looks for header files I<after> changing to the extension 385directory, so it will find your header files OK. 386 387=item Archive and test 388 389As usual, run 390 391 cd Ext/Ension 392 perl Makefile.PL 393 make dist 394 make 395 make test 396 397=item Hints 398 399It is important to do C<make dist> as early as possible. This way you 400can easily merge(1) your changes to autogenerated files if you decide 401to edit your C<.h> files and rerun h2xs. 402 403Do not forget to edit the documentation in the generated F<.pm> file. 404 405Consider the autogenerated files as skeletons only, you may invent 406better interfaces than what h2xs could guess. 407 408Consider this section as a guideline only, some other options of h2xs 409may better suit your needs. 410 411=back 412 413=head1 ENVIRONMENT 414 415No environment variables are used. 416 417=head1 AUTHOR 418 419Larry Wall and others 420 421=head1 SEE ALSO 422 423L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. 424 425=head1 DIAGNOSTICS 426 427The usual warnings if it cannot read or write the files involved. 428 429=head1 LIMITATIONS of B<-x> 430 431F<h2xs> would not distinguish whether an argument to a C function 432which is of the form, say, C<int *>, is an input, output, or 433input/output parameter. In particular, argument declarations of the 434form 435 436 int 437 foo(n) 438 int *n 439 440should be better rewritten as 441 442 int 443 foo(n) 444 int &n 445 446if C<n> is an input parameter. 447 448Additionally, F<h2xs> has no facilities to intuit that a function 449 450 int 451 foo(addr,l) 452 char *addr 453 int l 454 455takes a pair of address and length of data at this address, so it is better 456to rewrite this function as 457 458 int 459 foo(sv) 460 SV *addr 461 PREINIT: 462 STRLEN len; 463 char *s; 464 CODE: 465 s = SvPV(sv,len); 466 RETVAL = foo(s, len); 467 OUTPUT: 468 RETVAL 469 470or alternately 471 472 static int 473 my_foo(SV *sv) 474 { 475 STRLEN len; 476 char *s = SvPV(sv,len); 477 478 return foo(s, len); 479 } 480 481 MODULE = foo PACKAGE = foo PREFIX = my_ 482 483 int 484 foo(sv) 485 SV *sv 486 487See L<perlxs> and L<perlxstut> for additional details. 488 489=cut 490 491# ' # Grr 492use strict; 493 494 495my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/; 496my $TEMPLATE_VERSION = '0.01'; 497my @ARGS = @ARGV; 498my $compat_version = $]; 499 500use Getopt::Long; 501use Config; 502use Text::Wrap; 503$Text::Wrap::huge = 'overflow'; 504$Text::Wrap::columns = 80; 505use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload); 506use File::Compare; 507use File::Path; 508 509sub usage { 510 warn "@_\n" if @_; 511 die <<EOFUSAGE; 512h2xs [OPTIONS ... ] [headerfile [extra_libraries]] 513version: $H2XS_VERSION 514OPTIONS: 515 -A, --omit-autoload Omit all autoloading facilities (implies -c). 516 -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v). 517 -C, --omit-changes Omit creating the Changes file, add HISTORY heading 518 to stub POD. 519 -F, --cpp-flags Additional flags for C preprocessor/compile. 520 -M, --func-mask Mask to select C functions/macros 521 (default is select all). 522 -O, --overwrite-ok Allow overwriting of a pre-existing extension directory. 523 -P, --omit-pod Omit the stub POD section. 524 -X, --omit-XS Omit the XS portion (implies both -c and -f). 525 -a, --gen-accessors Generate get/set accessors for struct and union members (used with -x). 526 -b, --compat-version Specify a perl version to be backwards compatibile with 527 -c, --omit-constant Omit the constant() function and specialised AUTOLOAD 528 from the XS file. 529 -d, --debugging Turn on debugging messages. 530 -e, --omit-enums Omit constants from enums in the constant() function. 531 If a pattern is given, only the matching enums are 532 ignored. 533 -f, --force Force creation of the extension even if the C header 534 does not exist. 535 -g, --global Include code for safely storing static data in the .xs file. 536 -h, -?, --help Display this help message 537 -k, --omit-const-func Omit 'const' attribute on function arguments 538 (used with -x). 539 -m, --gen-tied-var Generate tied variables for access to declared 540 variables. 541 -n, --name Specify a name to use for the extension (recommended). 542 -o, --opaque-re Regular expression for \"opaque\" types. 543 -p, --remove-prefix Specify a prefix which should be removed from the 544 Perl function names. 545 -s, --const-subs Create subroutines for specified macros. 546 -t, --default-type Default type for autoloaded constants (default is IV) 547 --use-new-tests Use Test::More in backward compatible modules 548 --use-old-tests Use the module Test rather than Test::More 549 --skip-exporter Do not export symbols 550 --skip-ppport Do not use portability layer 551 --skip-autoloader Do not use the module C<AutoLoader> 552 --skip-strict Do not use the pragma C<strict> 553 --skip-warnings Do not use the pragma C<warnings> 554 -v, --version Specify a version number for this extension. 555 -x, --autogen-xsubs Autogenerate XSUBs using C::Scan. 556 557extra_libraries 558 are any libraries that might be needed for loading the 559 extension, e.g. -lm would try to link in the math library. 560EOFUSAGE 561} 562 563my ($opt_A, 564 $opt_B, 565 $opt_C, 566 $opt_F, 567 $opt_M, 568 $opt_O, 569 $opt_P, 570 $opt_X, 571 $opt_a, 572 $opt_c, 573 $opt_d, 574 $opt_e, 575 $opt_f, 576 $opt_g, 577 $opt_h, 578 $opt_k, 579 $opt_m, 580 $opt_n, 581 $opt_o, 582 $opt_p, 583 $opt_s, 584 $opt_v, 585 $opt_x, 586 $opt_b, 587 $opt_t, 588 $new_test, 589 $old_test, 590 $skip_exporter, 591 $skip_ppport, 592 $skip_autoloader, 593 $skip_strict, 594 $skip_warnings, 595 ); 596 597Getopt::Long::Configure('bundling'); 598Getopt::Long::Configure('pass_through'); 599 600my %options = ( 601 'omit-autoload|A' => \$opt_A, 602 'beta-version|B' => \$opt_B, 603 'omit-changes|C' => \$opt_C, 604 'cpp-flags|F=s' => \$opt_F, 605 'func-mask|M=s' => \$opt_M, 606 'overwrite_ok|O' => \$opt_O, 607 'omit-pod|P' => \$opt_P, 608 'omit-XS|X' => \$opt_X, 609 'gen-accessors|a' => \$opt_a, 610 'compat-version|b=s' => \$opt_b, 611 'omit-constant|c' => \$opt_c, 612 'debugging|d' => \$opt_d, 613 'omit-enums|e:s' => \$opt_e, 614 'force|f' => \$opt_f, 615 'global|g' => \$opt_g, 616 'help|h|?' => \$opt_h, 617 'omit-const-func|k' => \$opt_k, 618 'gen-tied-var|m' => \$opt_m, 619 'name|n=s' => \$opt_n, 620 'opaque-re|o=s' => \$opt_o, 621 'remove-prefix|p=s' => \$opt_p, 622 'const-subs|s=s' => \$opt_s, 623 'default-type|t=s' => \$opt_t, 624 'version|v=s' => \$opt_v, 625 'autogen-xsubs|x' => \$opt_x, 626 'use-new-tests' => \$new_test, 627 'use-old-tests' => \$old_test, 628 'skip-exporter' => \$skip_exporter, 629 'skip-ppport' => \$skip_ppport, 630 'skip-autoloader' => \$skip_autoloader, 631 'skip-warnings' => \$skip_warnings, 632 'skip-strict' => \$skip_strict, 633 ); 634 635GetOptions(%options) || usage; 636 637usage if $opt_h; 638 639if( $opt_b ){ 640 usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); 641 $opt_b =~ /^\d+\.\d+\.\d+/ || 642 usage "You must provide the backwards compatibility version in X.Y.Z form. " 643 . "(i.e. 5.5.0)\n"; 644 my ($maj,$min,$sub) = split(/\./,$opt_b,3); 645 if ($maj < 5 || ($maj == 5 && $min < 6)) { 646 $compat_version = 647 $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) : 648 sprintf("%d.%03d", $maj,$min); 649 } else { 650 $compat_version = 651 $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) : 652 sprintf("%d.%03d", $maj,$min); 653 } 654} else { 655 my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/; 656 $sub ||= 0; 657 warn sprintf <<'EOF', $maj,$min,$sub; 658Defaulting to backwards compatibility with perl %d.%d.%d 659If you intend this module to be compatible with earlier perl versions, please 660specify a minimum perl version with the -b option. 661 662EOF 663} 664 665if( $opt_B ){ 666 $TEMPLATE_VERSION = '0.00_01'; 667} 668 669if( $opt_v ){ 670 $TEMPLATE_VERSION = $opt_v; 671 672 # check if it is numeric 673 my $temp_version = $TEMPLATE_VERSION; 674 my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/; 675 my $notnum; 676 { 677 local $SIG{__WARN__} = sub { $notnum = 1 }; 678 use warnings 'numeric'; 679 $temp_version = 0+$temp_version; 680 } 681 682 if ($notnum) { 683 my $module = $opt_n || 'Your::Module'; 684 warn <<"EOF"; 685You have specified a non-numeric version. Unless you supply an 686appropriate VERSION class method, users may not be able to specify a 687minimum required version with C<use $module versionnum>. 688 689EOF 690 } 691 else { 692 $opt_B = $beta_version; 693 } 694} 695 696# -A implies -c. 697$skip_autoloader = $opt_c = 1 if $opt_A; 698 699# -X implies -c and -f 700$opt_c = $opt_f = 1 if $opt_X; 701 702$opt_t ||= 'IV'; 703 704my %const_xsub; 705%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; 706 707my $extralibs = ''; 708 709my @path_h; 710 711while (my $arg = shift) { 712 if ($arg =~ /^-l/i) { 713 $extralibs .= "$arg "; 714 next; 715 } 716 last if $extralibs; 717 push(@path_h, $arg); 718} 719 720usage "Must supply header file or module name\n" 721 unless (@path_h or $opt_n); 722 723my $fmask; 724my $tmask; 725 726$fmask = qr{$opt_M} if defined $opt_M; 727$tmask = qr{$opt_o} if defined $opt_o; 728my $tmask_all = $tmask && $opt_o eq '.'; 729 730if ($opt_x) { 731 eval {require C::Scan; 1} 732 or die <<EOD; 733C::Scan required if you use -x option. 734To install C::Scan, execute 735 perl -MCPAN -e "install C::Scan" 736EOD 737 unless ($tmask_all) { 738 $C::Scan::VERSION >= 0.70 739 or die <<EOD; 740C::Scan v. 0.70 or later required unless you use -o . option. 741You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. 742To install C::Scan, execute 743 perl -MCPAN -e "install C::Scan" 744EOD 745 } 746 if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) { 747 die <<EOD; 748C::Scan v. 0.73 or later required to use -m or -a options. 749You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. 750To install C::Scan, execute 751 perl -MCPAN -e "install C::Scan" 752EOD 753 } 754} 755elsif ($opt_o or $opt_F) { 756 warn <<EOD if $opt_o; 757Option -o does not make sense without -x. 758EOD 759 warn <<EOD if $opt_F and $opt_X ; 760Option -F does not make sense with -X. 761EOD 762} 763 764my @path_h_ini = @path_h; 765my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); 766 767my $module = $opt_n; 768 769if( @path_h ){ 770 use File::Spec; 771 my @paths; 772 my $pre_sub_tri_graphs = 1; 773 if ($^O eq 'VMS') { # Consider overrides of default location 774 # XXXX This is not equivalent to what the older version did: 775 # it was looking at $hadsys header-file per header-file... 776 my($hadsys) = grep s!^sys/!!i , @path_h; 777 @paths = qw( Sys$Library VAXC$Include ); 778 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); 779 push @paths, qw( DECC$Library_Include DECC$System_Include ); 780 } 781 else { 782 @paths = (File::Spec->curdir(), $Config{usrinc}, 783 (split ' ', $Config{locincpth}), '/usr/include'); 784 } 785 foreach my $path_h (@path_h) { 786 $name ||= $path_h; 787 $module ||= do { 788 $name =~ s/\.h$//; 789 if ( $name !~ /::/ ) { 790 $name =~ s#^.*/##; 791 $name = "\u$name"; 792 } 793 $name; 794 }; 795 796 if( $path_h =~ s#::#/#g && $opt_n ){ 797 warn "Nesting of headerfile ignored with -n\n"; 798 } 799 $path_h .= ".h" unless $path_h =~ /\.h$/; 800 my $fullpath = $path_h; 801 $path_h =~ s/,.*$// if $opt_x; 802 $fullpath{$path_h} = $fullpath; 803 804 # Minor trickery: we can't chdir() before we processed the headers 805 # (so know the name of the extension), but the header may be in the 806 # extension directory... 807 my $tmp_path_h = $path_h; 808 my $rel_path_h = $path_h; 809 my @dirs = @paths; 810 if (not -f $path_h) { 811 my $found; 812 for my $dir (@paths) { 813 $found++, last 814 if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); 815 } 816 if ($found) { 817 $rel_path_h = $path_h; 818 $fullpath{$path_h} = $fullpath; 819 } else { 820 (my $epath = $module) =~ s,::,/,g; 821 $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; 822 $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); 823 $path_h = $tmp_path_h; # Used during -x 824 push @dirs, $epath; 825 } 826 } 827 828 if (!$opt_c) { 829 die "Can't find $tmp_path_h in @dirs\n" 830 if ( ! $opt_f && ! -f "$rel_path_h" ); 831 # Scan the header file (we should deal with nested header files) 832 # Record the names of simple #define constants into const_names 833 # Function prototypes are processed below. 834 open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; 835 defines: 836 while (<CH>) { 837 if ($pre_sub_tri_graphs) { 838 # Preprocess all tri-graphs 839 # including things stuck in quoted string constants. 840 s/\?\?=/#/g; # | ??=| #| 841 s/\?\?\!/|/g; # | ??!| || 842 s/\?\?'/^/g; # | ??'| ^| 843 s/\?\?\(/[/g; # | ??(| [| 844 s/\?\?\)/]/g; # | ??)| ]| 845 s/\?\?\-/~/g; # | ??-| ~| 846 s/\?\?\//\\/g; # | ??/| \| 847 s/\?\?</{/g; # | ??<| {| 848 s/\?\?>/}/g; # | ??>| }| 849 } 850 if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) { 851 my $def = $1; 852 my $rest = $2; 853 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments 854 $rest =~ s/^\s+//; 855 $rest =~ s/\s+$//; 856 # Cannot do: (-1) and ((LHANDLE)3) are OK: 857 #print("Skip non-wordy $def => $rest\n"), 858 # next defines if $rest =~ /[^\w\$]/; 859 if ($rest =~ /"/) { 860 print("Skip stringy $def => $rest\n") if $opt_d; 861 next defines; 862 } 863 print "Matched $_ ($def)\n" if $opt_d; 864 $seen_define{$def} = $rest; 865 $_ = $def; 866 next if /^_.*_h_*$/i; # special case, but for what? 867 if (defined $opt_p) { 868 if (!/^$opt_p(\d)/) { 869 ++$prefix{$_} if s/^$opt_p//; 870 } 871 else { 872 warn "can't remove $opt_p prefix from '$_'!\n"; 873 } 874 } 875 $prefixless{$def} = $_; 876 if (!$fmask or /$fmask/) { 877 print "... Passes mask of -M.\n" if $opt_d and $fmask; 878 $const_names{$_}++; 879 } 880 } 881 } 882 if (defined $opt_e and !$opt_e) { 883 close(CH); 884 } 885 else { 886 # Work from miniperl too - on "normal" systems 887 my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0; 888 seek CH, 0, $SEEK_SET; 889 my $src = do { local $/; <CH> }; 890 close CH; 891 no warnings 'uninitialized'; 892 893 # Remove C and C++ comments 894 $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs; 895 896 while ($src =~ /(\benum\s*([\w_]*)\s*\{\s([\s\w=,]+)\})/gsc) { 897 my ($enum_name, $enum_body) = 898 $1 =~ /enum\s*([\w_]*)\s*\{\s([\s\w=,]+)\}/gs; 899 # skip enums matching $opt_e 900 next if $opt_e && $enum_name =~ /$opt_e/; 901 my $val = 0; 902 for my $item (split /,/, $enum_body) { 903 my ($key, $declared_val) = $item =~ /(\w*)\s*=\s*(.*)/; 904 $val = length($declared_val) ? $declared_val : 1 + $val; 905 $seen_define{$key} = $declared_val; 906 $const_names{$key}++; 907 } 908 } # while (...) 909 } # if (!defined $opt_e or $opt_e) 910 } 911 } 912} 913 914# Save current directory so that C::Scan can use it 915my $cwd = File::Spec->rel2abs( File::Spec->curdir ); 916 917# As Ilya suggested, use a name that contains - and then it can't clash with 918# the names of any packages. A directory 'fallback' will clash with any 919# new pragmata down the fallback:: tree, but that seems unlikely. 920my $constscfname = 'const-c.inc'; 921my $constsxsfname = 'const-xs.inc'; 922my $fallbackdirname = 'fallback'; 923 924my $ext = chdir 'ext' ? 'ext/' : ''; 925 926my @modparts = split(/::/,$module); 927my $modpname = join('-', @modparts); 928my $modfname = pop @modparts; 929my $modpmdir = join '/', 'lib', @modparts; 930my $modpmname = join '/', $modpmdir, $modfname.'.pm'; 931 932if ($opt_O) { 933 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; 934} 935else { 936 die "Won't overwrite existing $ext$modpname\n" if -e $modpname; 937} 938-d "$modpname" || mkpath([$modpname], 0, 0775); 939chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; 940 941my %types_seen; 942my %std_types; 943my $fdecls = []; 944my $fdecls_parsed = []; 945my $typedef_rex; 946my %typedefs_pre; 947my %known_fnames; 948my %structs; 949 950my @fnames; 951my @fnames_no_prefix; 952my %vdecl_hash; 953my @vdecls; 954 955if( ! $opt_X ){ # use XS, unless it was disabled 956 unless ($skip_ppport) { 957 require Devel::PPPort; 958 warn "Writing $ext$modpname/ppport.h\n"; 959 Devel::PPPort::WriteFile('ppport.h') 960 || die "Can't create $ext$modpname/ppport.h: $!\n"; 961 } 962 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; 963 if ($opt_x) { 964 warn "Scanning typemaps...\n"; 965 get_typemap(); 966 my @td; 967 my @good_td; 968 my $addflags = $opt_F || ''; 969 970 foreach my $filename (@path_h) { 971 my $c; 972 my $filter; 973 974 if ($fullpath{$filename} =~ /,/) { 975 $filename = $`; 976 $filter = $'; 977 } 978 warn "Scanning $filename for functions...\n"; 979 my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X); 980 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, 981 'add_cppflags' => $addflags, 'c_styles' => \@styles; 982 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]); 983 984 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; 985 push(@$fdecls, @{$c->get('fdecls')}); 986 987 push @td, @{$c->get('typedefs_maybe')}; 988 if ($opt_a) { 989 my $structs = $c->get('typedef_structs'); 990 @structs{keys %$structs} = values %$structs; 991 } 992 993 if ($opt_m) { 994 %vdecl_hash = %{ $c->get('vdecl_hash') }; 995 @vdecls = sort keys %vdecl_hash; 996 for (local $_ = 0; $_ < @vdecls; ++$_) { 997 my $var = $vdecls[$_]; 998 my($type, $post) = @{ $vdecl_hash{$var} }; 999 if (defined $post) { 1000 warn "Can't handle variable '$type $var $post', skipping.\n"; 1001 splice @vdecls, $_, 1; 1002 redo; 1003 } 1004 $type = normalize_type($type); 1005 $vdecl_hash{$var} = $type; 1006 } 1007 } 1008 1009 unless ($tmask_all) { 1010 warn "Scanning $filename for typedefs...\n"; 1011 my $td = $c->get('typedef_hash'); 1012 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; 1013 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; 1014 push @good_td, @f_good_td; 1015 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; 1016 } 1017 } 1018 { local $" = '|'; 1019 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td; 1020 } 1021 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT 1022 if ($fmask) { 1023 my @good; 1024 for my $i (0..$#$fdecls_parsed) { 1025 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME 1026 push @good, $i; 1027 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" 1028 if $opt_d; 1029 } 1030 $fdecls = [@$fdecls[@good]]; 1031 $fdecls_parsed = [@$fdecls_parsed[@good]]; 1032 } 1033 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME 1034 # Sort declarations: 1035 { 1036 my %h = map( ($_->[1], $_), @$fdecls_parsed); 1037 $fdecls_parsed = [ @h{@fnames} ]; 1038 } 1039 @fnames_no_prefix = @fnames; 1040 @fnames_no_prefix 1041 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix 1042 if defined $opt_p; 1043 # Remove macros which expand to typedefs 1044 print "Typedefs are @td.\n" if $opt_d; 1045 my %td = map {($_, $_)} @td; 1046 # Add some other possible but meaningless values for macros 1047 for my $k (qw(char double float int long short unsigned signed void)) { 1048 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); 1049 } 1050 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; 1051 my $n = 0; 1052 my %bad_macs; 1053 while (keys %td > $n) { 1054 $n = keys %td; 1055 my ($k, $v); 1056 while (($k, $v) = each %seen_define) { 1057 # print("found '$k'=>'$v'\n"), 1058 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; 1059 } 1060 } 1061 # Now %bad_macs contains names of bad macros 1062 for my $k (keys %bad_macs) { 1063 delete $const_names{$prefixless{$k}}; 1064 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; 1065 } 1066 } 1067} 1068my @const_names = sort keys %const_names; 1069 1070-d $modpmdir || mkpath([$modpmdir], 0, 0775); 1071open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n"; 1072 1073$" = "\n\t"; 1074warn "Writing $ext$modpname/$modpmname\n"; 1075 1076print PM <<"END"; 1077package $module; 1078 1079use $compat_version; 1080END 1081 1082print PM <<"END" unless $skip_strict; 1083use strict; 1084END 1085 1086print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006; 1087 1088unless( $opt_X || $opt_c || $opt_A ){ 1089 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and 1090 # will want Carp. 1091 print PM <<'END'; 1092use Carp; 1093END 1094} 1095 1096print PM <<'END' unless $skip_exporter; 1097 1098require Exporter; 1099END 1100 1101my $use_Dyna = (not $opt_X and $compat_version < 5.006); 1102print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled 1103require DynaLoader; 1104END 1105 1106 1107# Are we using AutoLoader or not? 1108unless ($skip_autoloader) { # no autoloader whatsoever. 1109 unless ($opt_c) { # we're doing the AUTOLOAD 1110 print PM "use AutoLoader;\n"; 1111 } 1112 else { 1113 print PM "use AutoLoader qw(AUTOLOAD);\n" 1114 } 1115} 1116 1117if ( $compat_version < 5.006 ) { 1118 my $vars = '$VERSION @ISA'; 1119 $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter; 1120 $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A; 1121 $vars .= ' $XS_VERSION' if $opt_B && !$opt_X; 1122 print PM "use vars qw($vars);"; 1123} 1124 1125# Determine @ISA. 1126my @modISA; 1127push @modISA, 'Exporter' unless $skip_exporter; 1128push @modISA, 'DynaLoader' if $use_Dyna; # no XS 1129my $myISA = "our \@ISA = qw(@modISA);"; 1130$myISA =~ s/^our // if $compat_version < 5.006; 1131 1132print PM "\n$myISA\n\n"; 1133 1134my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); 1135 1136my $tmp=''; 1137$tmp .= <<"END" unless $skip_exporter; 1138# Items to export into callers namespace by default. Note: do not export 1139# names by default without a very good reason. Use EXPORT_OK instead. 1140# Do not simply export all your public functions/methods/constants. 1141 1142# This allows declaration use $module ':all'; 1143# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK 1144# will save memory. 1145our %EXPORT_TAGS = ( 'all' => [ qw( 1146 @exported_names 1147) ] ); 1148 1149our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); 1150 1151our \@EXPORT = qw( 1152 @const_names 1153); 1154 1155END 1156 1157$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n"; 1158if ($opt_B) { 1159 $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X; 1160 $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n"; 1161} 1162$tmp .= "\n"; 1163 1164$tmp =~ s/^our //mg if $compat_version < 5.006; 1165print PM $tmp; 1166 1167if (@vdecls) { 1168 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; 1169} 1170 1171 1172print PM autoload ($module, $compat_version) unless $opt_c or $opt_X; 1173 1174if( ! $opt_X ){ # print bootstrap, unless XS is disabled 1175 if ($use_Dyna) { 1176 $tmp = <<"END"; 1177bootstrap $module \$VERSION; 1178END 1179 } else { 1180 $tmp = <<"END"; 1181require XSLoader; 1182XSLoader::load('$module', \$VERSION); 1183END 1184 } 1185 $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B; 1186 print PM $tmp; 1187} 1188 1189# tying the variables can happen only after bootstrap 1190if (@vdecls) { 1191 printf PM <<END; 1192{ 1193@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]} 1194} 1195 1196END 1197} 1198 1199my $after; 1200if( $opt_P ){ # if POD is disabled 1201 $after = '__END__'; 1202} 1203else { 1204 $after = '=cut'; 1205} 1206 1207print PM <<"END"; 1208 1209# Preloaded methods go here. 1210END 1211 1212print PM <<"END" unless $opt_A; 1213 1214# Autoload methods go after $after, and are processed by the autosplit program. 1215END 1216 1217print PM <<"END"; 1218 12191; 1220__END__ 1221END 1222 1223my ($email,$author,$licence); 1224 1225eval { 1226 my $username; 1227 ($username,$author) = (getpwuid($>))[0,6]; 1228 if (defined $username && defined $author) { 1229 $author =~ s/,.*$//; # in case of sub fields 1230 my $domain = $Config{'mydomain'}; 1231 $domain =~ s/^\.//; 1232 $email = "$username\@$domain"; 1233 } 1234 }; 1235 1236$author ||= "A. U. Thor"; 1237$email ||= 'a.u.thor@a.galaxy.far.far.away'; 1238 1239$licence = sprintf << "DEFAULT", $^V; 1240Copyright (C) ${\(1900 + (localtime) [5])} by $author 1241 1242This library is free software; you can redistribute it and/or modify 1243it under the same terms as Perl itself, either Perl version %vd or, 1244at your option, any later version of Perl 5 you may have available. 1245DEFAULT 1246 1247my $revhist = ''; 1248$revhist = <<EOT if $opt_C; 1249# 1250#=head1 HISTORY 1251# 1252#=over 8 1253# 1254#=item $TEMPLATE_VERSION 1255# 1256#Original version; created by h2xs $H2XS_VERSION with options 1257# 1258# @ARGS 1259# 1260#=back 1261# 1262EOT 1263 1264my $exp_doc = $skip_exporter ? '' : <<EOD; 1265# 1266#=head2 EXPORT 1267# 1268#None by default. 1269# 1270EOD 1271 1272if (@const_names and not $opt_P) { 1273 $exp_doc .= <<EOD unless $skip_exporter; 1274#=head2 Exportable constants 1275# 1276# @{[join "\n ", @const_names]} 1277# 1278EOD 1279} 1280 1281if (defined $fdecls and @$fdecls and not $opt_P) { 1282 $exp_doc .= <<EOD unless $skip_exporter; 1283#=head2 Exportable functions 1284# 1285EOD 1286 1287# $exp_doc .= <<EOD if $opt_p; 1288#When accessing these functions from Perl, prefix C<$opt_p> should be removed. 1289# 1290#EOD 1291 $exp_doc .= <<EOD unless $skip_exporter; 1292# @{[join "\n ", @known_fnames{@fnames}]} 1293# 1294EOD 1295} 1296 1297my $meth_doc = ''; 1298 1299if ($opt_x && $opt_a) { 1300 my($name, $struct); 1301 $meth_doc .= accessor_docs($name, $struct) 1302 while ($name, $struct) = each %structs; 1303} 1304 1305# Prefix the default licence with hash symbols. 1306# Is this just cargo cult - it seems that the first thing that happens to this 1307# block is that all the hashes are then s///g out. 1308my $licence_hash = $licence; 1309$licence_hash =~ s/^/#/gm; 1310 1311my $pod; 1312$pod = <<"END" unless $opt_P; 1313## Below is stub documentation for your module. You'd better edit it! 1314# 1315#=head1 NAME 1316# 1317#$module - Perl extension for blah blah blah 1318# 1319#=head1 SYNOPSIS 1320# 1321# use $module; 1322# blah blah blah 1323# 1324#=head1 DESCRIPTION 1325# 1326#Stub documentation for $module, created by h2xs. It looks like the 1327#author of the extension was negligent enough to leave the stub 1328#unedited. 1329# 1330#Blah blah blah. 1331$exp_doc$meth_doc$revhist 1332# 1333#=head1 SEE ALSO 1334# 1335#Mention other useful documentation such as the documentation of 1336#related modules or operating system documentation (such as man pages 1337#in UNIX), or any relevant external documentation such as RFCs or 1338#standards. 1339# 1340#If you have a mailing list set up for your module, mention it here. 1341# 1342#If you have a web site set up for your module, mention it here. 1343# 1344#=head1 AUTHOR 1345# 1346#$author, E<lt>${email}E<gt> 1347# 1348#=head1 COPYRIGHT AND LICENSE 1349# 1350$licence_hash 1351# 1352#=cut 1353END 1354 1355$pod =~ s/^\#//gm unless $opt_P; 1356print PM $pod unless $opt_P; 1357 1358close PM; 1359 1360 1361if( ! $opt_X ){ # print XS, unless it is disabled 1362warn "Writing $ext$modpname/$modfname.xs\n"; 1363 1364print XS <<"END"; 1365#include "EXTERN.h" 1366#include "perl.h" 1367#include "XSUB.h" 1368 1369END 1370 1371print XS <<"END" unless $skip_ppport; 1372#include "ppport.h" 1373 1374END 1375 1376if( @path_h ){ 1377 foreach my $path_h (@path_h_ini) { 1378 my($h) = $path_h; 1379 $h =~ s#^/usr/include/##; 1380 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } 1381 print XS qq{#include <$h>\n}; 1382 } 1383 print XS "\n"; 1384} 1385 1386print XS <<"END" if $opt_g; 1387 1388/* Global Data */ 1389 1390#define MY_CXT_KEY "${module}::_guts" XS_VERSION 1391 1392typedef struct { 1393 /* Put Global Data in here */ 1394 int dummy; /* you can access this elsewhere as MY_CXT.dummy */ 1395} my_cxt_t; 1396 1397START_MY_CXT 1398 1399END 1400 1401my %pointer_typedefs; 1402my %struct_typedefs; 1403 1404sub td_is_pointer { 1405 my $type = shift; 1406 my $out = $pointer_typedefs{$type}; 1407 return $out if defined $out; 1408 my $otype = $type; 1409 $out = ($type =~ /\*$/); 1410 # This converts only the guys which do not have trailing part in the typedef 1411 if (not $out 1412 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1413 $type = normalize_type($type); 1414 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" 1415 if $opt_d; 1416 $out = td_is_pointer($type); 1417 } 1418 return ($pointer_typedefs{$otype} = $out); 1419} 1420 1421sub td_is_struct { 1422 my $type = shift; 1423 my $out = $struct_typedefs{$type}; 1424 return $out if defined $out; 1425 my $otype = $type; 1426 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); 1427 # This converts only the guys which do not have trailing part in the typedef 1428 if (not $out 1429 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1430 $type = normalize_type($type); 1431 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" 1432 if $opt_d; 1433 $out = td_is_struct($type); 1434 } 1435 return ($struct_typedefs{$otype} = $out); 1436} 1437 1438print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; 1439 1440if( ! $opt_c ) { 1441 # We write the "sample" files used when this module is built by perl without 1442 # ExtUtils::Constant. 1443 # h2xs will later check that these are the same as those generated by the 1444 # code embedded into Makefile.PL 1445 unless (-d $fallbackdirname) { 1446 mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n"; 1447 } 1448 warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n"; 1449 warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n"; 1450 my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname); 1451 my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname); 1452 WriteConstants ( C_FILE => $cfallback, 1453 XS_FILE => $xsfallback, 1454 DEFAULT_TYPE => $opt_t, 1455 NAME => $module, 1456 NAMES => \@const_names, 1457 ); 1458 print XS "#include \"$constscfname\"\n"; 1459} 1460 1461 1462my $prefix = defined $opt_p ? "PREFIX = $opt_p" : ''; 1463 1464# Now switch from C to XS by issuing the first MODULE declaration: 1465print XS <<"END"; 1466 1467MODULE = $module PACKAGE = $module $prefix 1468 1469END 1470 1471# If a constant() function was #included then output a corresponding 1472# XS declaration: 1473print XS "INCLUDE: $constsxsfname\n" unless $opt_c; 1474 1475print XS <<"END" if $opt_g; 1476 1477BOOT: 1478{ 1479 MY_CXT_INIT; 1480 /* If any of the fields in the my_cxt_t struct need 1481 to be initialised, do it here. 1482 */ 1483} 1484 1485END 1486 1487foreach (sort keys %const_xsub) { 1488 print XS <<"END"; 1489char * 1490$_() 1491 1492 CODE: 1493#ifdef $_ 1494 RETVAL = $_; 1495#else 1496 croak("Your vendor has not defined the $module macro $_"); 1497#endif 1498 1499 OUTPUT: 1500 RETVAL 1501 1502END 1503} 1504 1505my %seen_decl; 1506my %typemap; 1507 1508sub print_decl { 1509 my $fh = shift; 1510 my $decl = shift; 1511 my ($type, $name, $args) = @$decl; 1512 return if $seen_decl{$name}++; # Need to do the same for docs as well? 1513 1514 my @argnames = map {$_->[1]} @$args; 1515 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; 1516 if ($opt_k) { 1517 s/^\s*const\b\s*// for @argtypes; 1518 } 1519 my @argarrays = map { $_->[4] || '' } @$args; 1520 my $numargs = @$args; 1521 if ($numargs and $argtypes[-1] eq '...') { 1522 $numargs--; 1523 $argnames[-1] = '...'; 1524 } 1525 local $" = ', '; 1526 $type = normalize_type($type, 1); 1527 1528 print $fh <<"EOP"; 1529 1530$type 1531$name(@argnames) 1532EOP 1533 1534 for my $arg (0 .. $numargs - 1) { 1535 print $fh <<"EOP"; 1536 $argtypes[$arg] $argnames[$arg]$argarrays[$arg] 1537EOP 1538 } 1539} 1540 1541sub print_tievar_subs { 1542 my($fh, $name, $type) = @_; 1543 print $fh <<END; 1544I32 1545_get_$name(IV index, SV *sv) { 1546 dSP; 1547 PUSHMARK(SP); 1548 XPUSHs(sv); 1549 PUTBACK; 1550 (void)call_pv("$module\::_get_$name", G_DISCARD); 1551 return (I32)0; 1552} 1553 1554I32 1555_set_$name(IV index, SV *sv) { 1556 dSP; 1557 PUSHMARK(SP); 1558 XPUSHs(sv); 1559 PUTBACK; 1560 (void)call_pv("$module\::_set_$name", G_DISCARD); 1561 return (I32)0; 1562} 1563 1564END 1565} 1566 1567sub print_tievar_xsubs { 1568 my($fh, $name, $type) = @_; 1569 print $fh <<END; 1570void 1571_tievar_$name(sv) 1572 SV* sv 1573 PREINIT: 1574 struct ufuncs uf; 1575 CODE: 1576 uf.uf_val = &_get_$name; 1577 uf.uf_set = &_set_$name; 1578 uf.uf_index = (IV)&_get_$name; 1579 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); 1580 1581void 1582_get_$name(THIS) 1583 $type THIS = NO_INIT 1584 CODE: 1585 THIS = $name; 1586 OUTPUT: 1587 SETMAGIC: DISABLE 1588 THIS 1589 1590void 1591_set_$name(THIS) 1592 $type THIS 1593 CODE: 1594 $name = THIS; 1595 1596END 1597} 1598 1599sub print_accessors { 1600 my($fh, $name, $struct) = @_; 1601 return unless defined $struct && $name !~ /\s|_ANON/; 1602 $name = normalize_type($name); 1603 my $ptrname = normalize_type("$name *"); 1604 print $fh <<"EOF"; 1605 1606MODULE = $module PACKAGE = ${name} $prefix 1607 1608$name * 1609_to_ptr(THIS) 1610 $name THIS = NO_INIT 1611 PROTOTYPE: \$ 1612 CODE: 1613 if (sv_derived_from(ST(0), "$name")) { 1614 STRLEN len; 1615 char *s = SvPV((SV*)SvRV(ST(0)), len); 1616 if (len != sizeof(THIS)) 1617 croak("Size \%d of packed data != expected \%d", 1618 len, sizeof(THIS)); 1619 RETVAL = ($name *)s; 1620 } 1621 else 1622 croak("THIS is not of type $name"); 1623 OUTPUT: 1624 RETVAL 1625 1626$name 1627new(CLASS) 1628 char *CLASS = NO_INIT 1629 PROTOTYPE: \$ 1630 CODE: 1631 Zero((void*)&RETVAL, sizeof(RETVAL), char); 1632 OUTPUT: 1633 RETVAL 1634 1635MODULE = $module PACKAGE = ${name}Ptr $prefix 1636 1637EOF 1638 my @items = @$struct; 1639 while (@items) { 1640 my $item = shift @items; 1641 if ($item->[0] =~ /_ANON/) { 1642 if (defined $item->[2]) { 1643 push @items, map [ 1644 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", 1645 ], @{ $structs{$item->[0]} }; 1646 } else { 1647 push @items, @{ $structs{$item->[0]} }; 1648 } 1649 } else { 1650 my $type = normalize_type($item->[0]); 1651 my $ttype = $structs{$type} ? normalize_type("$type *") : $type; 1652 print $fh <<"EOF"; 1653$ttype 1654$item->[2](THIS, __value = NO_INIT) 1655 $ptrname THIS 1656 $type __value 1657 PROTOTYPE: \$;\$ 1658 CODE: 1659 if (items > 1) 1660 THIS->$item->[-1] = __value; 1661 RETVAL = @{[ 1662 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" 1663 ]}; 1664 OUTPUT: 1665 RETVAL 1666 1667EOF 1668 } 1669 } 1670} 1671 1672sub accessor_docs { 1673 my($name, $struct) = @_; 1674 return unless defined $struct && $name !~ /\s|_ANON/; 1675 $name = normalize_type($name); 1676 my $ptrname = $name . 'Ptr'; 1677 my @items = @$struct; 1678 my @list; 1679 while (@items) { 1680 my $item = shift @items; 1681 if ($item->[0] =~ /_ANON/) { 1682 if (defined $item->[2]) { 1683 push @items, map [ 1684 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", 1685 ], @{ $structs{$item->[0]} }; 1686 } else { 1687 push @items, @{ $structs{$item->[0]} }; 1688 } 1689 } else { 1690 push @list, $item->[2]; 1691 } 1692 } 1693 my $methods = (join '(...)>, C<', @list) . '(...)'; 1694 1695 my $pod = <<"EOF"; 1696# 1697#=head2 Object and class methods for C<$name>/C<$ptrname> 1698# 1699#The principal Perl representation of a C object of type C<$name> is an 1700#object of class C<$ptrname> which is a reference to an integer 1701#representation of a C pointer. To create such an object, one may use 1702#a combination 1703# 1704# my \$buffer = $name->new(); 1705# my \$obj = \$buffer->_to_ptr(); 1706# 1707#This exersizes the following two methods, and an additional class 1708#C<$name>, the internal representation of which is a reference to a 1709#packed string with the C structure. Keep in mind that \$buffer should 1710#better survive longer than \$obj. 1711# 1712#=over 1713# 1714#=item C<\$object_of_type_$name-E<gt>_to_ptr()> 1715# 1716#Converts an object of type C<$name> to an object of type C<$ptrname>. 1717# 1718#=item C<$name-E<gt>new()> 1719# 1720#Creates an empty object of type C<$name>. The corresponding packed 1721#string is zeroed out. 1722# 1723#=item C<$methods> 1724# 1725#return the current value of the corresponding element if called 1726#without additional arguments. Set the element to the supplied value 1727#(and return the new value) if called with an additional argument. 1728# 1729#Applicable to objects of type C<$ptrname>. 1730# 1731#=back 1732# 1733EOF 1734 $pod =~ s/^\#//gm; 1735 return $pod; 1736} 1737 1738# Should be called before any actual call to normalize_type(). 1739sub get_typemap { 1740 # We do not want to read ./typemap by obvios reasons. 1741 my @tm = qw(../../../typemap ../../typemap ../typemap); 1742 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; 1743 unshift @tm, $stdtypemap; 1744 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; 1745 1746 # Start with useful default values 1747 $typemap{float} = 'T_NV'; 1748 1749 foreach my $typemap (@tm) { 1750 next unless -e $typemap ; 1751 # skip directories, binary files etc. 1752 warn " Scanning $typemap\n"; 1753 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 1754 unless -T $typemap ; 1755 open(TYPEMAP, $typemap) 1756 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; 1757 my $mode = 'Typemap'; 1758 while (<TYPEMAP>) { 1759 next if /^\s*\#/; 1760 if (/^INPUT\s*$/) { $mode = 'Input'; next; } 1761 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } 1762 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } 1763 elsif ($mode eq 'Typemap') { 1764 next if /^\s*($|\#)/ ; 1765 my ($type, $image); 1766 if ( ($type, $image) = 1767 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o 1768 # This may reference undefined functions: 1769 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { 1770 $typemap{normalize_type($type)} = $image; 1771 } 1772 } 1773 } 1774 close(TYPEMAP) or die "Cannot close $typemap: $!"; 1775 } 1776 %std_types = %types_seen; 1777 %types_seen = (); 1778} 1779 1780 1781sub normalize_type { # Second arg: do not strip const's before \* 1782 my $type = shift; 1783 my $do_keep_deep_const = shift; 1784 # If $do_keep_deep_const this is heuristical only 1785 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); 1786 my $ignore_mods 1787 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; 1788 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! 1789 $type =~ s/$ignore_mods//go; 1790 } 1791 else { 1792 $type =~ s/$ignore_mods//go; 1793 } 1794 $type =~ s/([^\s\w])/ $1 /g; 1795 $type =~ s/\s+$//; 1796 $type =~ s/^\s+//; 1797 $type =~ s/\s+/ /g; 1798 $type =~ s/\* (?=\*)/*/g; 1799 $type =~ s/\. \. \./.../g; 1800 $type =~ s/ ,/,/g; 1801 $types_seen{$type}++ 1802 unless $type eq '...' or $type eq 'void' or $std_types{$type}; 1803 $type; 1804} 1805 1806my $need_opaque; 1807 1808sub assign_typemap_entry { 1809 my $type = shift; 1810 my $otype = $type; 1811 my $entry; 1812 if ($tmask and $type =~ /$tmask/) { 1813 print "Type $type matches -o mask\n" if $opt_d; 1814 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); 1815 } 1816 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1817 $type = normalize_type $type; 1818 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; 1819 $entry = assign_typemap_entry($type); 1820 } 1821 # XXX good do better if our UV happens to be long long 1822 return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/; 1823 $entry ||= $typemap{$otype} 1824 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); 1825 $typemap{$otype} = $entry; 1826 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; 1827 return $entry; 1828} 1829 1830for (@vdecls) { 1831 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); 1832} 1833 1834if ($opt_x) { 1835 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } 1836 if ($opt_a) { 1837 while (my($name, $struct) = each %structs) { 1838 print_accessors(\*XS, $name, $struct); 1839 } 1840 } 1841} 1842 1843close XS; 1844 1845if (%types_seen) { 1846 my $type; 1847 warn "Writing $ext$modpname/typemap\n"; 1848 open TM, ">typemap" or die "Cannot open typemap file for write: $!"; 1849 1850 for $type (sort keys %types_seen) { 1851 my $entry = assign_typemap_entry $type; 1852 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" 1853 } 1854 1855 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry 1856############################################################################# 1857INPUT 1858T_OPAQUE_STRUCT 1859 if (sv_derived_from($arg, \"${ntype}\")) { 1860 STRLEN len; 1861 char *s = SvPV((SV*)SvRV($arg), len); 1862 1863 if (len != sizeof($var)) 1864 croak(\"Size %d of packed data != expected %d\", 1865 len, sizeof($var)); 1866 $var = *($type *)s; 1867 } 1868 else 1869 croak(\"$var is not of type ${ntype}\") 1870############################################################################# 1871OUTPUT 1872T_OPAQUE_STRUCT 1873 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); 1874EOP 1875 1876 close TM or die "Cannot close typemap file for write: $!"; 1877} 1878 1879} # if( ! $opt_X ) 1880 1881warn "Writing $ext$modpname/Makefile.PL\n"; 1882open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; 1883 1884my $prereq_pm; 1885 1886if ( $compat_version < 5.00702 and $new_test ) 1887{ 1888 $prereq_pm = q%'Test::More' => 0%; 1889} 1890else 1891{ 1892 $prereq_pm = ''; 1893} 1894 1895print PL <<"END"; 1896use $compat_version; 1897use ExtUtils::MakeMaker; 1898# See lib/ExtUtils/MakeMaker.pm for details of how to influence 1899# the contents of the Makefile that is written. 1900WriteMakefile( 1901 NAME => '$module', 1902 VERSION_FROM => '$modpmname', # finds \$VERSION 1903 PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1 1904 (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 1905 (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module 1906 AUTHOR => '$author <$email>') : ()), 1907END 1908if (!$opt_X) { # print C stuff, unless XS is disabled 1909 $opt_F = '' unless defined $opt_F; 1910 my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); 1911 my $Ihelp = ($I ? '-I. ' : ''); 1912 my $Icomment = ($I ? '' : <<EOC); 1913 # Insert -I. if you add *.h files later: 1914EOC 1915 1916 print PL <<END; 1917 LIBS => ['$extralibs'], # e.g., '-lm' 1918 DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING' 1919$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other' 1920END 1921 1922 my $C = grep {$_ ne "$modfname.c"} 1923 (glob '*.c'), (glob '*.cc'), (glob '*.C'); 1924 my $Cpre = ($C ? '' : '# '); 1925 my $Ccomment = ($C ? '' : <<EOC); 1926 # Un-comment this if you add C files to link with later: 1927EOC 1928 1929 print PL <<END; 1930$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too 1931END 1932} # ' # Grr 1933print PL ");\n"; 1934if (!$opt_c) { 1935 my $generate_code = 1936 WriteMakefileSnippet ( C_FILE => $constscfname, 1937 XS_FILE => $constsxsfname, 1938 DEFAULT_TYPE => $opt_t, 1939 NAME => $module, 1940 NAMES => \@const_names, 1941 ); 1942 print PL <<"END"; 1943if (eval {require ExtUtils::Constant; 1}) { 1944 # If you edit these definitions to change the constants used by this module, 1945 # you will need to use the generated $constscfname and $constsxsfname 1946 # files to replace their "fallback" counterparts before distributing your 1947 # changes. 1948$generate_code 1949} 1950else { 1951 use File::Copy; 1952 use File::Spec; 1953 foreach my \$file ('$constscfname', '$constsxsfname') { 1954 my \$fallback = File::Spec->catfile('$fallbackdirname', \$file); 1955 copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!"; 1956 } 1957} 1958END 1959 1960 eval $generate_code; 1961 if ($@) { 1962 warn <<"EOM"; 1963Attempting to test constant code in $ext$modpname/Makefile.PL: 1964$generate_code 1965__END__ 1966gave unexpected error $@ 1967Please report the circumstances of this bug in h2xs version $H2XS_VERSION 1968using the perlbug script. 1969EOM 1970 } else { 1971 my $fail; 1972 1973 foreach my $file ($constscfname, $constsxsfname) { 1974 my $fallback = File::Spec->catfile($fallbackdirname, $file); 1975 if (compare($file, $fallback)) { 1976 warn << "EOM"; 1977Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ. 1978EOM 1979 $fail++; 1980 } 1981 } 1982 if ($fail) { 1983 warn fill ('','', <<"EOM") . "\n"; 1984It appears that the code in $ext$modpname/Makefile.PL does not autogenerate 1985the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname 1986correctly. 1987 1988Please report the circumstances of this bug in h2xs version $H2XS_VERSION 1989using the perlbug script. 1990EOM 1991 } else { 1992 unlink $constscfname, $constsxsfname; 1993 } 1994 } 1995} 1996close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; 1997 1998# Create a simple README since this is a CPAN requirement 1999# and it doesnt hurt to have one 2000warn "Writing $ext$modpname/README\n"; 2001open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; 2002my $thisyear = (gmtime)[5] + 1900; 2003my $rmhead = "$modpname version $TEMPLATE_VERSION"; 2004my $rmheadeq = "=" x length($rmhead); 2005 2006my $rm_prereq; 2007 2008if ( $compat_version < 5.00702 and $new_test ) 2009{ 2010 $rm_prereq = 'Test::More'; 2011} 2012else 2013{ 2014 $rm_prereq = 'blah blah blah'; 2015} 2016 2017print RM <<_RMEND_; 2018$rmhead 2019$rmheadeq 2020 2021The README is used to introduce the module and provide instructions on 2022how to install the module, any machine dependencies it may have (for 2023example C compilers and installed libraries) and any other information 2024that should be provided before the module is installed. 2025 2026A README file is required for CPAN modules since CPAN extracts the 2027README file from a module distribution so that people browsing the 2028archive can use it get an idea of the modules uses. It is usually a 2029good idea to provide version information here so that people can 2030decide whether fixes for the module are worth downloading. 2031 2032INSTALLATION 2033 2034To install this module type the following: 2035 2036 perl Makefile.PL 2037 make 2038 make test 2039 make install 2040 2041DEPENDENCIES 2042 2043This module requires these other modules and libraries: 2044 2045 $rm_prereq 2046 2047COPYRIGHT AND LICENCE 2048 2049Put the correct copyright and licence information here. 2050 2051$licence 2052 2053_RMEND_ 2054close(RM) || die "Can't close $ext$modpname/README: $!\n"; 2055 2056my $testdir = "t"; 2057my $testfile = "$testdir/$modpname.t"; 2058unless (-d "$testdir") { 2059 mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n"; 2060} 2061warn "Writing $ext$modpname/$testfile\n"; 2062my $tests = @const_names ? 2 : 1; 2063 2064open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n"; 2065 2066print EX <<_END_; 2067# Before `make install' is performed this script should be runnable with 2068# `make test'. After `make install' it should work as `perl $modpname.t' 2069 2070######################### 2071 2072# change 'tests => $tests' to 'tests => last_test_to_print'; 2073 2074_END_ 2075 2076my $test_mod = 'Test::More'; 2077 2078if ( $old_test or ($compat_version < 5.007 and not $new_test )) 2079{ 2080 my $test_mod = 'Test'; 2081 2082 print EX <<_END_; 2083use Test; 2084BEGIN { plan tests => $tests }; 2085use $module; 2086ok(1); # If we made it this far, we're ok. 2087 2088_END_ 2089 2090 if (@const_names) { 2091 my $const_names = join " ", @const_names; 2092 print EX <<'_END_'; 2093 2094my $fail; 2095foreach my $constname (qw( 2096_END_ 2097 2098 print EX wrap ("\t", "\t", $const_names); 2099 print EX (")) {\n"); 2100 2101 print EX <<_END_; 2102 next if (eval "my \\\$a = \$constname; 1"); 2103 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { 2104 print "# pass: \$\@"; 2105 } else { 2106 print "# fail: \$\@"; 2107 \$fail = 1; 2108 } 2109} 2110if (\$fail) { 2111 print "not ok 2\\n"; 2112} else { 2113 print "ok 2\\n"; 2114} 2115 2116_END_ 2117 } 2118} 2119else 2120{ 2121 print EX <<_END_; 2122use Test::More tests => $tests; 2123BEGIN { use_ok('$module') }; 2124 2125_END_ 2126 2127 if (@const_names) { 2128 my $const_names = join " ", @const_names; 2129 print EX <<'_END_'; 2130 2131my $fail = 0; 2132foreach my $constname (qw( 2133_END_ 2134 2135 print EX wrap ("\t", "\t", $const_names); 2136 print EX (")) {\n"); 2137 2138 print EX <<_END_; 2139 next if (eval "my \\\$a = \$constname; 1"); 2140 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { 2141 print "# pass: \$\@"; 2142 } else { 2143 print "# fail: \$\@"; 2144 \$fail = 1; 2145 } 2146 2147} 2148 2149ok( \$fail == 0 , 'Constants' ); 2150_END_ 2151 } 2152} 2153 2154print EX <<_END_; 2155######################### 2156 2157# Insert your test code below, the $test_mod module is use()ed here so read 2158# its man page ( perldoc $test_mod ) for help writing this test script. 2159 2160_END_ 2161 2162close(EX) || die "Can't close $ext$modpname/$testfile: $!\n"; 2163 2164unless ($opt_C) { 2165 warn "Writing $ext$modpname/Changes\n"; 2166 $" = ' '; 2167 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; 2168 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; 2169 print EX <<EOP; 2170Revision history for Perl extension $module. 2171 2172$TEMPLATE_VERSION @{[scalar localtime]} 2173\t- original version; created by h2xs $H2XS_VERSION with options 2174\t\t@ARGS 2175 2176EOP 2177 close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; 2178} 2179 2180warn "Writing $ext$modpname/MANIFEST\n"; 2181open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; 2182my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>); 2183if (!@files) { 2184 eval {opendir(D,'.');}; 2185 unless ($@) { @files = readdir(D); closedir(D); } 2186} 2187if (!@files) { @files = map {chomp && $_} `ls`; } 2188if ($^O eq 'VMS') { 2189 foreach (@files) { 2190 # Clip trailing '.' for portability -- non-VMS OSs don't expect it 2191 s%\.$%%; 2192 # Fix up for case-sensitive file systems 2193 s/$modfname/$modfname/i && next; 2194 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; 2195 $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; 2196 } 2197} 2198print MANI join("\n",@files), "\n"; 2199close MANI; 2200!NO!SUBS! 2201 2202close OUT or die "Can't close $file: $!"; 2203chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 2204exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 2205chdir $origdir; 2206