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 accessible 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.10 $ ' =~ /\$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 526 (used with -x). 527 -b, --compat-version Specify a perl version to be backwards compatibile with. 528 -c, --omit-constant Omit the constant() function and specialised AUTOLOAD 529 from the XS file. 530 -d, --debugging Turn on debugging messages. 531 -e, --omit-enums Omit constants from enums in the constant() function. 532 If a pattern is given, only the matching enums are 533 ignored. 534 -f, --force Force creation of the extension even if the C header 535 does not exist. 536 -g, --global Include code for safely storing static data in the .xs file. 537 -h, -?, --help Display this help message. 538 -k, --omit-const-func Omit 'const' attribute on function arguments 539 (used with -x). 540 -m, --gen-tied-var Generate tied variables for access to declared 541 variables. 542 -n, --name Specify a name to use for the extension (recommended). 543 -o, --opaque-re Regular expression for \"opaque\" types. 544 -p, --remove-prefix Specify a prefix which should be removed from the 545 Perl function names. 546 -s, --const-subs Create subroutines for specified macros. 547 -t, --default-type Default type for autoloaded constants (default is IV). 548 --use-new-tests Use Test::More in backward compatible modules. 549 --use-old-tests Use the module Test rather than Test::More. 550 --skip-exporter Do not export symbols. 551 --skip-ppport Do not use portability layer. 552 --skip-autoloader Do not use the module C<AutoLoader>. 553 --skip-strict Do not use the pragma C<strict>. 554 --skip-warnings Do not use the pragma C<warnings>. 555 -v, --version Specify a version number for this extension. 556 -x, --autogen-xsubs Autogenerate XSUBs using C::Scan. 557 --use-xsloader Use XSLoader in backward compatible modules (ignored 558 when used with -X). 559 560extra_libraries 561 are any libraries that might be needed for loading the 562 extension, e.g. -lm would try to link in the math library. 563EOFUSAGE 564} 565 566my ($opt_A, 567 $opt_B, 568 $opt_C, 569 $opt_F, 570 $opt_M, 571 $opt_O, 572 $opt_P, 573 $opt_X, 574 $opt_a, 575 $opt_c, 576 $opt_d, 577 $opt_e, 578 $opt_f, 579 $opt_g, 580 $opt_h, 581 $opt_k, 582 $opt_m, 583 $opt_n, 584 $opt_o, 585 $opt_p, 586 $opt_s, 587 $opt_v, 588 $opt_x, 589 $opt_b, 590 $opt_t, 591 $new_test, 592 $old_test, 593 $skip_exporter, 594 $skip_ppport, 595 $skip_autoloader, 596 $skip_strict, 597 $skip_warnings, 598 $use_xsloader 599 ); 600 601Getopt::Long::Configure('bundling'); 602Getopt::Long::Configure('pass_through'); 603 604my %options = ( 605 'omit-autoload|A' => \$opt_A, 606 'beta-version|B' => \$opt_B, 607 'omit-changes|C' => \$opt_C, 608 'cpp-flags|F=s' => \$opt_F, 609 'func-mask|M=s' => \$opt_M, 610 'overwrite_ok|O' => \$opt_O, 611 'omit-pod|P' => \$opt_P, 612 'omit-XS|X' => \$opt_X, 613 'gen-accessors|a' => \$opt_a, 614 'compat-version|b=s' => \$opt_b, 615 'omit-constant|c' => \$opt_c, 616 'debugging|d' => \$opt_d, 617 'omit-enums|e:s' => \$opt_e, 618 'force|f' => \$opt_f, 619 'global|g' => \$opt_g, 620 'help|h|?' => \$opt_h, 621 'omit-const-func|k' => \$opt_k, 622 'gen-tied-var|m' => \$opt_m, 623 'name|n=s' => \$opt_n, 624 'opaque-re|o=s' => \$opt_o, 625 'remove-prefix|p=s' => \$opt_p, 626 'const-subs|s=s' => \$opt_s, 627 'default-type|t=s' => \$opt_t, 628 'version|v=s' => \$opt_v, 629 'autogen-xsubs|x' => \$opt_x, 630 'use-new-tests' => \$new_test, 631 'use-old-tests' => \$old_test, 632 'skip-exporter' => \$skip_exporter, 633 'skip-ppport' => \$skip_ppport, 634 'skip-autoloader' => \$skip_autoloader, 635 'skip-warnings' => \$skip_warnings, 636 'skip-strict' => \$skip_strict, 637 'use-xsloader' => \$use_xsloader, 638 ); 639 640GetOptions(%options) || usage; 641 642usage if $opt_h; 643 644if( $opt_b ){ 645 usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); 646 $opt_b =~ /^\d+\.\d+\.\d+/ || 647 usage "You must provide the backwards compatibility version in X.Y.Z form. " 648 . "(i.e. 5.5.0)\n"; 649 my ($maj,$min,$sub) = split(/\./,$opt_b,3); 650 if ($maj < 5 || ($maj == 5 && $min < 6)) { 651 $compat_version = 652 $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) : 653 sprintf("%d.%03d", $maj,$min); 654 } else { 655 $compat_version = 656 $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) : 657 sprintf("%d.%03d", $maj,$min); 658 } 659} else { 660 my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/; 661 $sub ||= 0; 662 warn sprintf <<'EOF', $maj,$min,$sub; 663Defaulting to backwards compatibility with perl %d.%d.%d 664If you intend this module to be compatible with earlier perl versions, please 665specify a minimum perl version with the -b option. 666 667EOF 668} 669 670if( $opt_B ){ 671 $TEMPLATE_VERSION = '0.00_01'; 672} 673 674if( $opt_v ){ 675 $TEMPLATE_VERSION = $opt_v; 676 677 # check if it is numeric 678 my $temp_version = $TEMPLATE_VERSION; 679 my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/; 680 my $notnum; 681 { 682 local $SIG{__WARN__} = sub { $notnum = 1 }; 683 use warnings 'numeric'; 684 $temp_version = 0+$temp_version; 685 } 686 687 if ($notnum) { 688 my $module = $opt_n || 'Your::Module'; 689 warn <<"EOF"; 690You have specified a non-numeric version. Unless you supply an 691appropriate VERSION class method, users may not be able to specify a 692minimum required version with C<use $module versionnum>. 693 694EOF 695 } 696 else { 697 $opt_B = $beta_version; 698 } 699} 700 701# -A implies -c. 702$skip_autoloader = $opt_c = 1 if $opt_A; 703 704# -X implies -c and -f 705$opt_c = $opt_f = 1 if $opt_X; 706 707$opt_t ||= 'IV'; 708 709my %const_xsub; 710%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; 711 712my $extralibs = ''; 713 714my @path_h; 715 716while (my $arg = shift) { 717 if ($arg =~ /^-l/i) { 718 $extralibs .= "$arg "; 719 next; 720 } 721 last if $extralibs; 722 push(@path_h, $arg); 723} 724 725usage "Must supply header file or module name\n" 726 unless (@path_h or $opt_n); 727 728my $fmask; 729my $tmask; 730 731$fmask = qr{$opt_M} if defined $opt_M; 732$tmask = qr{$opt_o} if defined $opt_o; 733my $tmask_all = $tmask && $opt_o eq '.'; 734 735if ($opt_x) { 736 eval {require C::Scan; 1} 737 or die <<EOD; 738C::Scan required if you use -x option. 739To install C::Scan, execute 740 perl -MCPAN -e "install C::Scan" 741EOD 742 unless ($tmask_all) { 743 $C::Scan::VERSION >= 0.70 744 or die <<EOD; 745C::Scan v. 0.70 or later required unless you use -o . option. 746You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. 747To install C::Scan, execute 748 perl -MCPAN -e "install C::Scan" 749EOD 750 } 751 if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) { 752 die <<EOD; 753C::Scan v. 0.73 or later required to use -m or -a options. 754You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. 755To install C::Scan, execute 756 perl -MCPAN -e "install C::Scan" 757EOD 758 } 759} 760elsif ($opt_o or $opt_F) { 761 warn <<EOD if $opt_o; 762Option -o does not make sense without -x. 763EOD 764 warn <<EOD if $opt_F and $opt_X ; 765Option -F does not make sense with -X. 766EOD 767} 768 769my @path_h_ini = @path_h; 770my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); 771 772my $module = $opt_n; 773 774if( @path_h ){ 775 use File::Spec; 776 my @paths; 777 my $pre_sub_tri_graphs = 1; 778 if ($^O eq 'VMS') { # Consider overrides of default location 779 # XXXX This is not equivalent to what the older version did: 780 # it was looking at $hadsys header-file per header-file... 781 my($hadsys) = grep s!^sys/!!i , @path_h; 782 @paths = qw( Sys$Library VAXC$Include ); 783 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); 784 push @paths, qw( DECC$Library_Include DECC$System_Include ); 785 } 786 else { 787 @paths = (File::Spec->curdir(), $Config{usrinc}, 788 (split ' ', $Config{locincpth}), '/usr/include'); 789 } 790 foreach my $path_h (@path_h) { 791 $name ||= $path_h; 792 $module ||= do { 793 $name =~ s/\.h$//; 794 if ( $name !~ /::/ ) { 795 $name =~ s#^.*/##; 796 $name = "\u$name"; 797 } 798 $name; 799 }; 800 801 if( $path_h =~ s#::#/#g && $opt_n ){ 802 warn "Nesting of headerfile ignored with -n\n"; 803 } 804 $path_h .= ".h" unless $path_h =~ /\.h$/; 805 my $fullpath = $path_h; 806 $path_h =~ s/,.*$// if $opt_x; 807 $fullpath{$path_h} = $fullpath; 808 809 # Minor trickery: we can't chdir() before we processed the headers 810 # (so know the name of the extension), but the header may be in the 811 # extension directory... 812 my $tmp_path_h = $path_h; 813 my $rel_path_h = $path_h; 814 my @dirs = @paths; 815 if (not -f $path_h) { 816 my $found; 817 for my $dir (@paths) { 818 $found++, last 819 if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); 820 } 821 if ($found) { 822 $rel_path_h = $path_h; 823 $fullpath{$path_h} = $fullpath; 824 } else { 825 (my $epath = $module) =~ s,::,/,g; 826 $epath = File::Spec->catdir('ext', $epath) if -d 'ext'; 827 $rel_path_h = File::Spec->catfile($epath, $tmp_path_h); 828 $path_h = $tmp_path_h; # Used during -x 829 push @dirs, $epath; 830 } 831 } 832 833 if (!$opt_c) { 834 die "Can't find $tmp_path_h in @dirs\n" 835 if ( ! $opt_f && ! -f "$rel_path_h" ); 836 # Scan the header file (we should deal with nested header files) 837 # Record the names of simple #define constants into const_names 838 # Function prototypes are processed below. 839 open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n"; 840 defines: 841 while (<CH>) { 842 if ($pre_sub_tri_graphs) { 843 # Preprocess all tri-graphs 844 # including things stuck in quoted string constants. 845 s/\?\?=/#/g; # | ??=| #| 846 s/\?\?\!/|/g; # | ??!| || 847 s/\?\?'/^/g; # | ??'| ^| 848 s/\?\?\(/[/g; # | ??(| [| 849 s/\?\?\)/]/g; # | ??)| ]| 850 s/\?\?\-/~/g; # | ??-| ~| 851 s/\?\?\//\\/g; # | ??/| \| 852 s/\?\?</{/g; # | ??<| {| 853 s/\?\?>/}/g; # | ??>| }| 854 } 855 if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) { 856 my $def = $1; 857 my $rest = $2; 858 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments 859 $rest =~ s/^\s+//; 860 $rest =~ s/\s+$//; 861 # Cannot do: (-1) and ((LHANDLE)3) are OK: 862 #print("Skip non-wordy $def => $rest\n"), 863 # next defines if $rest =~ /[^\w\$]/; 864 if ($rest =~ /"/) { 865 print("Skip stringy $def => $rest\n") if $opt_d; 866 next defines; 867 } 868 print "Matched $_ ($def)\n" if $opt_d; 869 $seen_define{$def} = $rest; 870 $_ = $def; 871 next if /^_.*_h_*$/i; # special case, but for what? 872 if (defined $opt_p) { 873 if (!/^$opt_p(\d)/) { 874 ++$prefix{$_} if s/^$opt_p//; 875 } 876 else { 877 warn "can't remove $opt_p prefix from '$_'!\n"; 878 } 879 } 880 $prefixless{$def} = $_; 881 if (!$fmask or /$fmask/) { 882 print "... Passes mask of -M.\n" if $opt_d and $fmask; 883 $const_names{$_}++; 884 } 885 } 886 } 887 if (defined $opt_e and !$opt_e) { 888 close(CH); 889 } 890 else { 891 # Work from miniperl too - on "normal" systems 892 my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0; 893 seek CH, 0, $SEEK_SET; 894 my $src = do { local $/; <CH> }; 895 close CH; 896 no warnings 'uninitialized'; 897 898 # Remove C and C++ comments 899 $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs; 900 901 while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) { 902 my ($enum_name, $enum_body) = ($1, $2); 903 # skip enums matching $opt_e 904 next if $opt_e && $enum_name =~ /$opt_e/; 905 my $val = 0; 906 for my $item (split /,/, $enum_body) { 907 my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/; 908 $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val; 909 $seen_define{$key} = $val; 910 $const_names{$key}++; 911 } 912 } # while (...) 913 } # if (!defined $opt_e or $opt_e) 914 } 915 } 916} 917 918# Save current directory so that C::Scan can use it 919my $cwd = File::Spec->rel2abs( File::Spec->curdir ); 920 921# As Ilya suggested, use a name that contains - and then it can't clash with 922# the names of any packages. A directory 'fallback' will clash with any 923# new pragmata down the fallback:: tree, but that seems unlikely. 924my $constscfname = 'const-c.inc'; 925my $constsxsfname = 'const-xs.inc'; 926my $fallbackdirname = 'fallback'; 927 928my $ext = chdir 'ext' ? 'ext/' : ''; 929 930my @modparts = split(/::/,$module); 931my $modpname = join('-', @modparts); 932my $modfname = pop @modparts; 933my $modpmdir = join '/', 'lib', @modparts; 934my $modpmname = join '/', $modpmdir, $modfname.'.pm'; 935 936if ($opt_O) { 937 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; 938} 939else { 940 die "Won't overwrite existing $ext$modpname\n" if -e $modpname; 941} 942-d "$modpname" || mkpath([$modpname], 0, 0775); 943chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; 944 945my %types_seen; 946my %std_types; 947my $fdecls = []; 948my $fdecls_parsed = []; 949my $typedef_rex; 950my %typedefs_pre; 951my %known_fnames; 952my %structs; 953 954my @fnames; 955my @fnames_no_prefix; 956my %vdecl_hash; 957my @vdecls; 958 959if( ! $opt_X ){ # use XS, unless it was disabled 960 unless ($skip_ppport) { 961 require Devel::PPPort; 962 warn "Writing $ext$modpname/ppport.h\n"; 963 Devel::PPPort::WriteFile('ppport.h') 964 || die "Can't create $ext$modpname/ppport.h: $!\n"; 965 } 966 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; 967 if ($opt_x) { 968 warn "Scanning typemaps...\n"; 969 get_typemap(); 970 my @td; 971 my @good_td; 972 my $addflags = $opt_F || ''; 973 974 foreach my $filename (@path_h) { 975 my $c; 976 my $filter; 977 978 if ($fullpath{$filename} =~ /,/) { 979 $filename = $`; 980 $filter = $'; 981 } 982 warn "Scanning $filename for functions...\n"; 983 my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X); 984 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, 985 'add_cppflags' => $addflags, 'c_styles' => \@styles; 986 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]); 987 988 $c->get('keywords')->{'__restrict'} = 1; 989 990 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; 991 push(@$fdecls, @{$c->get('fdecls')}); 992 993 push @td, @{$c->get('typedefs_maybe')}; 994 if ($opt_a) { 995 my $structs = $c->get('typedef_structs'); 996 @structs{keys %$structs} = values %$structs; 997 } 998 999 if ($opt_m) { 1000 %vdecl_hash = %{ $c->get('vdecl_hash') }; 1001 @vdecls = sort keys %vdecl_hash; 1002 for (local $_ = 0; $_ < @vdecls; ++$_) { 1003 my $var = $vdecls[$_]; 1004 my($type, $post) = @{ $vdecl_hash{$var} }; 1005 if (defined $post) { 1006 warn "Can't handle variable '$type $var $post', skipping.\n"; 1007 splice @vdecls, $_, 1; 1008 redo; 1009 } 1010 $type = normalize_type($type); 1011 $vdecl_hash{$var} = $type; 1012 } 1013 } 1014 1015 unless ($tmask_all) { 1016 warn "Scanning $filename for typedefs...\n"; 1017 my $td = $c->get('typedef_hash'); 1018 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; 1019 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; 1020 push @good_td, @f_good_td; 1021 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; 1022 } 1023 } 1024 { local $" = '|'; 1025 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td; 1026 } 1027 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT 1028 if ($fmask) { 1029 my @good; 1030 for my $i (0..$#$fdecls_parsed) { 1031 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME 1032 push @good, $i; 1033 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" 1034 if $opt_d; 1035 } 1036 $fdecls = [@$fdecls[@good]]; 1037 $fdecls_parsed = [@$fdecls_parsed[@good]]; 1038 } 1039 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME 1040 # Sort declarations: 1041 { 1042 my %h = map( ($_->[1], $_), @$fdecls_parsed); 1043 $fdecls_parsed = [ @h{@fnames} ]; 1044 } 1045 @fnames_no_prefix = @fnames; 1046 @fnames_no_prefix 1047 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix 1048 if defined $opt_p; 1049 # Remove macros which expand to typedefs 1050 print "Typedefs are @td.\n" if $opt_d; 1051 my %td = map {($_, $_)} @td; 1052 # Add some other possible but meaningless values for macros 1053 for my $k (qw(char double float int long short unsigned signed void)) { 1054 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); 1055 } 1056 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; 1057 my $n = 0; 1058 my %bad_macs; 1059 while (keys %td > $n) { 1060 $n = keys %td; 1061 my ($k, $v); 1062 while (($k, $v) = each %seen_define) { 1063 # print("found '$k'=>'$v'\n"), 1064 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; 1065 } 1066 } 1067 # Now %bad_macs contains names of bad macros 1068 for my $k (keys %bad_macs) { 1069 delete $const_names{$prefixless{$k}}; 1070 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; 1071 } 1072 } 1073} 1074my @const_names = sort keys %const_names; 1075 1076-d $modpmdir || mkpath([$modpmdir], 0, 0775); 1077open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n"; 1078 1079$" = "\n\t"; 1080warn "Writing $ext$modpname/$modpmname\n"; 1081 1082print PM <<"END"; 1083package $module; 1084 1085use $compat_version; 1086END 1087 1088print PM <<"END" unless $skip_strict; 1089use strict; 1090END 1091 1092print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006; 1093 1094unless( $opt_X || $opt_c || $opt_A ){ 1095 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and 1096 # will want Carp. 1097 print PM <<'END'; 1098use Carp; 1099END 1100} 1101 1102print PM <<'END' unless $skip_exporter; 1103 1104require Exporter; 1105END 1106 1107my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader); 1108print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled 1109require DynaLoader; 1110END 1111 1112 1113# Are we using AutoLoader or not? 1114unless ($skip_autoloader) { # no autoloader whatsoever. 1115 unless ($opt_c) { # we're doing the AUTOLOAD 1116 print PM "use AutoLoader;\n"; 1117 } 1118 else { 1119 print PM "use AutoLoader qw(AUTOLOAD);\n" 1120 } 1121} 1122 1123if ( $compat_version < 5.006 ) { 1124 my $vars = '$VERSION @ISA'; 1125 $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter; 1126 $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A; 1127 $vars .= ' $XS_VERSION' if $opt_B && !$opt_X; 1128 print PM "use vars qw($vars);"; 1129} 1130 1131# Determine @ISA. 1132my @modISA; 1133push @modISA, 'Exporter' unless $skip_exporter; 1134push @modISA, 'DynaLoader' if $use_Dyna; # no XS 1135my $myISA = "our \@ISA = qw(@modISA);"; 1136$myISA =~ s/^our // if $compat_version < 5.006; 1137 1138print PM "\n$myISA\n\n"; 1139 1140my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); 1141 1142my $tmp=''; 1143$tmp .= <<"END" unless $skip_exporter; 1144# Items to export into callers namespace by default. Note: do not export 1145# names by default without a very good reason. Use EXPORT_OK instead. 1146# Do not simply export all your public functions/methods/constants. 1147 1148# This allows declaration use $module ':all'; 1149# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK 1150# will save memory. 1151our %EXPORT_TAGS = ( 'all' => [ qw( 1152 @exported_names 1153) ] ); 1154 1155our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); 1156 1157our \@EXPORT = qw( 1158 @const_names 1159); 1160 1161END 1162 1163$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n"; 1164if ($opt_B) { 1165 $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X; 1166 $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n"; 1167} 1168$tmp .= "\n"; 1169 1170$tmp =~ s/^our //mg if $compat_version < 5.006; 1171print PM $tmp; 1172 1173if (@vdecls) { 1174 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; 1175} 1176 1177 1178print PM autoload ($module, $compat_version) unless $opt_c or $opt_X; 1179 1180if( ! $opt_X ){ # print bootstrap, unless XS is disabled 1181 if ($use_Dyna) { 1182 $tmp = <<"END"; 1183bootstrap $module \$VERSION; 1184END 1185 } else { 1186 $tmp = <<"END"; 1187require XSLoader; 1188XSLoader::load('$module', \$VERSION); 1189END 1190 } 1191 $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B; 1192 print PM $tmp; 1193} 1194 1195# tying the variables can happen only after bootstrap 1196if (@vdecls) { 1197 printf PM <<END; 1198{ 1199@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]} 1200} 1201 1202END 1203} 1204 1205my $after; 1206if( $opt_P ){ # if POD is disabled 1207 $after = '__END__'; 1208} 1209else { 1210 $after = '=cut'; 1211} 1212 1213print PM <<"END"; 1214 1215# Preloaded methods go here. 1216END 1217 1218print PM <<"END" unless $opt_A; 1219 1220# Autoload methods go after $after, and are processed by the autosplit program. 1221END 1222 1223print PM <<"END"; 1224 12251; 1226__END__ 1227END 1228 1229my ($email,$author,$licence); 1230 1231eval { 1232 my $username; 1233 ($username,$author) = (getpwuid($>))[0,6]; 1234 if (defined $username && defined $author) { 1235 $author =~ s/,.*$//; # in case of sub fields 1236 my $domain = $Config{'mydomain'}; 1237 $domain =~ s/^\.//; 1238 $email = "$username\@$domain"; 1239 } 1240 }; 1241 1242$author =~ s/'/\\'/g if defined $author; 1243$author ||= "A. U. Thor"; 1244$email ||= 'a.u.thor@a.galaxy.far.far.away'; 1245 1246$licence = sprintf << "DEFAULT", $^V; 1247Copyright (C) ${\(1900 + (localtime) [5])} by $author 1248 1249This library is free software; you can redistribute it and/or modify 1250it under the same terms as Perl itself, either Perl version %vd or, 1251at your option, any later version of Perl 5 you may have available. 1252DEFAULT 1253 1254my $revhist = ''; 1255$revhist = <<EOT if $opt_C; 1256# 1257#=head1 HISTORY 1258# 1259#=over 8 1260# 1261#=item $TEMPLATE_VERSION 1262# 1263#Original version; created by h2xs $H2XS_VERSION with options 1264# 1265# @ARGS 1266# 1267#=back 1268# 1269EOT 1270 1271my $exp_doc = $skip_exporter ? '' : <<EOD; 1272# 1273#=head2 EXPORT 1274# 1275#None by default. 1276# 1277EOD 1278 1279if (@const_names and not $opt_P) { 1280 $exp_doc .= <<EOD unless $skip_exporter; 1281#=head2 Exportable constants 1282# 1283# @{[join "\n ", @const_names]} 1284# 1285EOD 1286} 1287 1288if (defined $fdecls and @$fdecls and not $opt_P) { 1289 $exp_doc .= <<EOD unless $skip_exporter; 1290#=head2 Exportable functions 1291# 1292EOD 1293 1294# $exp_doc .= <<EOD if $opt_p; 1295#When accessing these functions from Perl, prefix C<$opt_p> should be removed. 1296# 1297#EOD 1298 $exp_doc .= <<EOD unless $skip_exporter; 1299# @{[join "\n ", @known_fnames{@fnames}]} 1300# 1301EOD 1302} 1303 1304my $meth_doc = ''; 1305 1306if ($opt_x && $opt_a) { 1307 my($name, $struct); 1308 $meth_doc .= accessor_docs($name, $struct) 1309 while ($name, $struct) = each %structs; 1310} 1311 1312# Prefix the default licence with hash symbols. 1313# Is this just cargo cult - it seems that the first thing that happens to this 1314# block is that all the hashes are then s///g out. 1315my $licence_hash = $licence; 1316$licence_hash =~ s/^/#/gm; 1317 1318my $pod; 1319$pod = <<"END" unless $opt_P; 1320## Below is stub documentation for your module. You'd better edit it! 1321# 1322#=head1 NAME 1323# 1324#$module - Perl extension for blah blah blah 1325# 1326#=head1 SYNOPSIS 1327# 1328# use $module; 1329# blah blah blah 1330# 1331#=head1 DESCRIPTION 1332# 1333#Stub documentation for $module, created by h2xs. It looks like the 1334#author of the extension was negligent enough to leave the stub 1335#unedited. 1336# 1337#Blah blah blah. 1338$exp_doc$meth_doc$revhist 1339# 1340#=head1 SEE ALSO 1341# 1342#Mention other useful documentation such as the documentation of 1343#related modules or operating system documentation (such as man pages 1344#in UNIX), or any relevant external documentation such as RFCs or 1345#standards. 1346# 1347#If you have a mailing list set up for your module, mention it here. 1348# 1349#If you have a web site set up for your module, mention it here. 1350# 1351#=head1 AUTHOR 1352# 1353#$author, E<lt>${email}E<gt> 1354# 1355#=head1 COPYRIGHT AND LICENSE 1356# 1357$licence_hash 1358# 1359#=cut 1360END 1361 1362$pod =~ s/^\#//gm unless $opt_P; 1363print PM $pod unless $opt_P; 1364 1365close PM; 1366 1367 1368if( ! $opt_X ){ # print XS, unless it is disabled 1369warn "Writing $ext$modpname/$modfname.xs\n"; 1370 1371print XS <<"END"; 1372#include "EXTERN.h" 1373#include "perl.h" 1374#include "XSUB.h" 1375 1376END 1377 1378print XS <<"END" unless $skip_ppport; 1379#include "ppport.h" 1380 1381END 1382 1383if( @path_h ){ 1384 foreach my $path_h (@path_h_ini) { 1385 my($h) = $path_h; 1386 $h =~ s#^/usr/include/##; 1387 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } 1388 print XS qq{#include <$h>\n}; 1389 } 1390 print XS "\n"; 1391} 1392 1393print XS <<"END" if $opt_g; 1394 1395/* Global Data */ 1396 1397#define MY_CXT_KEY "${module}::_guts" XS_VERSION 1398 1399typedef struct { 1400 /* Put Global Data in here */ 1401 int dummy; /* you can access this elsewhere as MY_CXT.dummy */ 1402} my_cxt_t; 1403 1404START_MY_CXT 1405 1406END 1407 1408my %pointer_typedefs; 1409my %struct_typedefs; 1410 1411sub td_is_pointer { 1412 my $type = shift; 1413 my $out = $pointer_typedefs{$type}; 1414 return $out if defined $out; 1415 my $otype = $type; 1416 $out = ($type =~ /\*$/); 1417 # This converts only the guys which do not have trailing part in the typedef 1418 if (not $out 1419 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1420 $type = normalize_type($type); 1421 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" 1422 if $opt_d; 1423 $out = td_is_pointer($type); 1424 } 1425 return ($pointer_typedefs{$otype} = $out); 1426} 1427 1428sub td_is_struct { 1429 my $type = shift; 1430 my $out = $struct_typedefs{$type}; 1431 return $out if defined $out; 1432 my $otype = $type; 1433 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); 1434 # This converts only the guys which do not have trailing part in the typedef 1435 if (not $out 1436 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1437 $type = normalize_type($type); 1438 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" 1439 if $opt_d; 1440 $out = td_is_struct($type); 1441 } 1442 return ($struct_typedefs{$otype} = $out); 1443} 1444 1445print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; 1446 1447if( ! $opt_c ) { 1448 # We write the "sample" files used when this module is built by perl without 1449 # ExtUtils::Constant. 1450 # h2xs will later check that these are the same as those generated by the 1451 # code embedded into Makefile.PL 1452 unless (-d $fallbackdirname) { 1453 mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n"; 1454 } 1455 warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n"; 1456 warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n"; 1457 my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname); 1458 my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname); 1459 WriteConstants ( C_FILE => $cfallback, 1460 XS_FILE => $xsfallback, 1461 DEFAULT_TYPE => $opt_t, 1462 NAME => $module, 1463 NAMES => \@const_names, 1464 ); 1465 print XS "#include \"$constscfname\"\n"; 1466} 1467 1468 1469my $prefix = defined $opt_p ? "PREFIX = $opt_p" : ''; 1470 1471# Now switch from C to XS by issuing the first MODULE declaration: 1472print XS <<"END"; 1473 1474MODULE = $module PACKAGE = $module $prefix 1475 1476END 1477 1478# If a constant() function was #included then output a corresponding 1479# XS declaration: 1480print XS "INCLUDE: $constsxsfname\n" unless $opt_c; 1481 1482print XS <<"END" if $opt_g; 1483 1484BOOT: 1485{ 1486 MY_CXT_INIT; 1487 /* If any of the fields in the my_cxt_t struct need 1488 to be initialised, do it here. 1489 */ 1490} 1491 1492END 1493 1494foreach (sort keys %const_xsub) { 1495 print XS <<"END"; 1496char * 1497$_() 1498 1499 CODE: 1500#ifdef $_ 1501 RETVAL = $_; 1502#else 1503 croak("Your vendor has not defined the $module macro $_"); 1504#endif 1505 1506 OUTPUT: 1507 RETVAL 1508 1509END 1510} 1511 1512my %seen_decl; 1513my %typemap; 1514 1515sub print_decl { 1516 my $fh = shift; 1517 my $decl = shift; 1518 my ($type, $name, $args) = @$decl; 1519 return if $seen_decl{$name}++; # Need to do the same for docs as well? 1520 1521 my @argnames = map {$_->[1]} @$args; 1522 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; 1523 if ($opt_k) { 1524 s/^\s*const\b\s*// for @argtypes; 1525 } 1526 my @argarrays = map { $_->[4] || '' } @$args; 1527 my $numargs = @$args; 1528 if ($numargs and $argtypes[-1] eq '...') { 1529 $numargs--; 1530 $argnames[-1] = '...'; 1531 } 1532 local $" = ', '; 1533 $type = normalize_type($type, 1); 1534 1535 print $fh <<"EOP"; 1536 1537$type 1538$name(@argnames) 1539EOP 1540 1541 for my $arg (0 .. $numargs - 1) { 1542 print $fh <<"EOP"; 1543 $argtypes[$arg] $argnames[$arg]$argarrays[$arg] 1544EOP 1545 } 1546} 1547 1548sub print_tievar_subs { 1549 my($fh, $name, $type) = @_; 1550 print $fh <<END; 1551I32 1552_get_$name(IV index, SV *sv) { 1553 dSP; 1554 PUSHMARK(SP); 1555 XPUSHs(sv); 1556 PUTBACK; 1557 (void)call_pv("$module\::_get_$name", G_DISCARD); 1558 return (I32)0; 1559} 1560 1561I32 1562_set_$name(IV index, SV *sv) { 1563 dSP; 1564 PUSHMARK(SP); 1565 XPUSHs(sv); 1566 PUTBACK; 1567 (void)call_pv("$module\::_set_$name", G_DISCARD); 1568 return (I32)0; 1569} 1570 1571END 1572} 1573 1574sub print_tievar_xsubs { 1575 my($fh, $name, $type) = @_; 1576 print $fh <<END; 1577void 1578_tievar_$name(sv) 1579 SV* sv 1580 PREINIT: 1581 struct ufuncs uf; 1582 CODE: 1583 uf.uf_val = &_get_$name; 1584 uf.uf_set = &_set_$name; 1585 uf.uf_index = (IV)&_get_$name; 1586 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); 1587 1588void 1589_get_$name(THIS) 1590 $type THIS = NO_INIT 1591 CODE: 1592 THIS = $name; 1593 OUTPUT: 1594 SETMAGIC: DISABLE 1595 THIS 1596 1597void 1598_set_$name(THIS) 1599 $type THIS 1600 CODE: 1601 $name = THIS; 1602 1603END 1604} 1605 1606sub print_accessors { 1607 my($fh, $name, $struct) = @_; 1608 return unless defined $struct && $name !~ /\s|_ANON/; 1609 $name = normalize_type($name); 1610 my $ptrname = normalize_type("$name *"); 1611 print $fh <<"EOF"; 1612 1613MODULE = $module PACKAGE = ${name} $prefix 1614 1615$name * 1616_to_ptr(THIS) 1617 $name THIS = NO_INIT 1618 PROTOTYPE: \$ 1619 CODE: 1620 if (sv_derived_from(ST(0), "$name")) { 1621 STRLEN len; 1622 char *s = SvPV((SV*)SvRV(ST(0)), len); 1623 if (len != sizeof(THIS)) 1624 croak("Size \%d of packed data != expected \%d", 1625 len, sizeof(THIS)); 1626 RETVAL = ($name *)s; 1627 } 1628 else 1629 croak("THIS is not of type $name"); 1630 OUTPUT: 1631 RETVAL 1632 1633$name 1634new(CLASS) 1635 char *CLASS = NO_INIT 1636 PROTOTYPE: \$ 1637 CODE: 1638 Zero((void*)&RETVAL, sizeof(RETVAL), char); 1639 OUTPUT: 1640 RETVAL 1641 1642MODULE = $module PACKAGE = ${name}Ptr $prefix 1643 1644EOF 1645 my @items = @$struct; 1646 while (@items) { 1647 my $item = shift @items; 1648 if ($item->[0] =~ /_ANON/) { 1649 if (defined $item->[2]) { 1650 push @items, map [ 1651 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", 1652 ], @{ $structs{$item->[0]} }; 1653 } else { 1654 push @items, @{ $structs{$item->[0]} }; 1655 } 1656 } else { 1657 my $type = normalize_type($item->[0]); 1658 my $ttype = $structs{$type} ? normalize_type("$type *") : $type; 1659 print $fh <<"EOF"; 1660$ttype 1661$item->[2](THIS, __value = NO_INIT) 1662 $ptrname THIS 1663 $type __value 1664 PROTOTYPE: \$;\$ 1665 CODE: 1666 if (items > 1) 1667 THIS->$item->[-1] = __value; 1668 RETVAL = @{[ 1669 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" 1670 ]}; 1671 OUTPUT: 1672 RETVAL 1673 1674EOF 1675 } 1676 } 1677} 1678 1679sub accessor_docs { 1680 my($name, $struct) = @_; 1681 return unless defined $struct && $name !~ /\s|_ANON/; 1682 $name = normalize_type($name); 1683 my $ptrname = $name . 'Ptr'; 1684 my @items = @$struct; 1685 my @list; 1686 while (@items) { 1687 my $item = shift @items; 1688 if ($item->[0] =~ /_ANON/) { 1689 if (defined $item->[2]) { 1690 push @items, map [ 1691 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", 1692 ], @{ $structs{$item->[0]} }; 1693 } else { 1694 push @items, @{ $structs{$item->[0]} }; 1695 } 1696 } else { 1697 push @list, $item->[2]; 1698 } 1699 } 1700 my $methods = (join '(...)>, C<', @list) . '(...)'; 1701 1702 my $pod = <<"EOF"; 1703# 1704#=head2 Object and class methods for C<$name>/C<$ptrname> 1705# 1706#The principal Perl representation of a C object of type C<$name> is an 1707#object of class C<$ptrname> which is a reference to an integer 1708#representation of a C pointer. To create such an object, one may use 1709#a combination 1710# 1711# my \$buffer = $name->new(); 1712# my \$obj = \$buffer->_to_ptr(); 1713# 1714#This exersizes the following two methods, and an additional class 1715#C<$name>, the internal representation of which is a reference to a 1716#packed string with the C structure. Keep in mind that \$buffer should 1717#better survive longer than \$obj. 1718# 1719#=over 1720# 1721#=item C<\$object_of_type_$name-E<gt>_to_ptr()> 1722# 1723#Converts an object of type C<$name> to an object of type C<$ptrname>. 1724# 1725#=item C<$name-E<gt>new()> 1726# 1727#Creates an empty object of type C<$name>. The corresponding packed 1728#string is zeroed out. 1729# 1730#=item C<$methods> 1731# 1732#return the current value of the corresponding element if called 1733#without additional arguments. Set the element to the supplied value 1734#(and return the new value) if called with an additional argument. 1735# 1736#Applicable to objects of type C<$ptrname>. 1737# 1738#=back 1739# 1740EOF 1741 $pod =~ s/^\#//gm; 1742 return $pod; 1743} 1744 1745# Should be called before any actual call to normalize_type(). 1746sub get_typemap { 1747 # We do not want to read ./typemap by obvios reasons. 1748 my @tm = qw(../../../typemap ../../typemap ../typemap); 1749 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; 1750 unshift @tm, $stdtypemap; 1751 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; 1752 1753 # Start with useful default values 1754 $typemap{float} = 'T_NV'; 1755 1756 foreach my $typemap (@tm) { 1757 next unless -e $typemap ; 1758 # skip directories, binary files etc. 1759 warn " Scanning $typemap\n"; 1760 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 1761 unless -T $typemap ; 1762 open(TYPEMAP, $typemap) 1763 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; 1764 my $mode = 'Typemap'; 1765 while (<TYPEMAP>) { 1766 next if /^\s*\#/; 1767 if (/^INPUT\s*$/) { $mode = 'Input'; next; } 1768 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } 1769 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } 1770 elsif ($mode eq 'Typemap') { 1771 next if /^\s*($|\#)/ ; 1772 my ($type, $image); 1773 if ( ($type, $image) = 1774 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o 1775 # This may reference undefined functions: 1776 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { 1777 $typemap{normalize_type($type)} = $image; 1778 } 1779 } 1780 } 1781 close(TYPEMAP) or die "Cannot close $typemap: $!"; 1782 } 1783 %std_types = %types_seen; 1784 %types_seen = (); 1785} 1786 1787 1788sub normalize_type { # Second arg: do not strip const's before \* 1789 my $type = shift; 1790 my $do_keep_deep_const = shift; 1791 # If $do_keep_deep_const this is heuristical only 1792 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); 1793 my $ignore_mods 1794 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; 1795 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! 1796 $type =~ s/$ignore_mods//go; 1797 } 1798 else { 1799 $type =~ s/$ignore_mods//go; 1800 } 1801 $type =~ s/([^\s\w])/ $1 /g; 1802 $type =~ s/\s+$//; 1803 $type =~ s/^\s+//; 1804 $type =~ s/\s+/ /g; 1805 $type =~ s/\* (?=\*)/*/g; 1806 $type =~ s/\. \. \./.../g; 1807 $type =~ s/ ,/,/g; 1808 $types_seen{$type}++ 1809 unless $type eq '...' or $type eq 'void' or $std_types{$type}; 1810 $type; 1811} 1812 1813my $need_opaque; 1814 1815sub assign_typemap_entry { 1816 my $type = shift; 1817 my $otype = $type; 1818 my $entry; 1819 if ($tmask and $type =~ /$tmask/) { 1820 print "Type $type matches -o mask\n" if $opt_d; 1821 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); 1822 } 1823 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { 1824 $type = normalize_type $type; 1825 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; 1826 $entry = assign_typemap_entry($type); 1827 } 1828 # XXX good do better if our UV happens to be long long 1829 return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/; 1830 $entry ||= $typemap{$otype} 1831 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); 1832 $typemap{$otype} = $entry; 1833 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; 1834 return $entry; 1835} 1836 1837for (@vdecls) { 1838 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); 1839} 1840 1841if ($opt_x) { 1842 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } 1843 if ($opt_a) { 1844 while (my($name, $struct) = each %structs) { 1845 print_accessors(\*XS, $name, $struct); 1846 } 1847 } 1848} 1849 1850close XS; 1851 1852if (%types_seen) { 1853 my $type; 1854 warn "Writing $ext$modpname/typemap\n"; 1855 open TM, ">typemap" or die "Cannot open typemap file for write: $!"; 1856 1857 for $type (sort keys %types_seen) { 1858 my $entry = assign_typemap_entry $type; 1859 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" 1860 } 1861 1862 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry 1863############################################################################# 1864INPUT 1865T_OPAQUE_STRUCT 1866 if (sv_derived_from($arg, \"${ntype}\")) { 1867 STRLEN len; 1868 char *s = SvPV((SV*)SvRV($arg), len); 1869 1870 if (len != sizeof($var)) 1871 croak(\"Size %d of packed data != expected %d\", 1872 len, sizeof($var)); 1873 $var = *($type *)s; 1874 } 1875 else 1876 croak(\"$var is not of type ${ntype}\") 1877############################################################################# 1878OUTPUT 1879T_OPAQUE_STRUCT 1880 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); 1881EOP 1882 1883 close TM or die "Cannot close typemap file for write: $!"; 1884} 1885 1886} # if( ! $opt_X ) 1887 1888warn "Writing $ext$modpname/Makefile.PL\n"; 1889open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; 1890 1891my $prereq_pm = ''; 1892 1893if ( $compat_version < 5.00702 and $new_test ) 1894{ 1895 $prereq_pm .= q%'Test::More' => 0, %; 1896} 1897 1898if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader) 1899{ 1900 $prereq_pm .= q%'XSLoader' => 0, %; 1901} 1902 1903print PL <<"END"; 1904use $compat_version; 1905use ExtUtils::MakeMaker; 1906# See lib/ExtUtils/MakeMaker.pm for details of how to influence 1907# the contents of the Makefile that is written. 1908WriteMakefile( 1909 NAME => '$module', 1910 VERSION_FROM => '$modpmname', # finds \$VERSION 1911 PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1 1912 (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 1913 (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module 1914 AUTHOR => '$author <$email>') : ()), 1915END 1916if (!$opt_X) { # print C stuff, unless XS is disabled 1917 $opt_F = '' unless defined $opt_F; 1918 my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : ''); 1919 my $Ihelp = ($I ? '-I. ' : ''); 1920 my $Icomment = ($I ? '' : <<EOC); 1921 # Insert -I. if you add *.h files later: 1922EOC 1923 1924 print PL <<END; 1925 LIBS => ['$extralibs'], # e.g., '-lm' 1926 DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING' 1927$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other' 1928END 1929 1930 my $C = grep {$_ ne "$modfname.c"} 1931 (glob '*.c'), (glob '*.cc'), (glob '*.C'); 1932 my $Cpre = ($C ? '' : '# '); 1933 my $Ccomment = ($C ? '' : <<EOC); 1934 # Un-comment this if you add C files to link with later: 1935EOC 1936 1937 print PL <<END; 1938$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too 1939END 1940} # ' # Grr 1941print PL ");\n"; 1942if (!$opt_c) { 1943 my $generate_code = 1944 WriteMakefileSnippet ( C_FILE => $constscfname, 1945 XS_FILE => $constsxsfname, 1946 DEFAULT_TYPE => $opt_t, 1947 NAME => $module, 1948 NAMES => \@const_names, 1949 ); 1950 print PL <<"END"; 1951if (eval {require ExtUtils::Constant; 1}) { 1952 # If you edit these definitions to change the constants used by this module, 1953 # you will need to use the generated $constscfname and $constsxsfname 1954 # files to replace their "fallback" counterparts before distributing your 1955 # changes. 1956$generate_code 1957} 1958else { 1959 use File::Copy; 1960 use File::Spec; 1961 foreach my \$file ('$constscfname', '$constsxsfname') { 1962 my \$fallback = File::Spec->catfile('$fallbackdirname', \$file); 1963 copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!"; 1964 } 1965} 1966END 1967 1968 eval $generate_code; 1969 if ($@) { 1970 warn <<"EOM"; 1971Attempting to test constant code in $ext$modpname/Makefile.PL: 1972$generate_code 1973__END__ 1974gave unexpected error $@ 1975Please report the circumstances of this bug in h2xs version $H2XS_VERSION 1976using the perlbug script. 1977EOM 1978 } else { 1979 my $fail; 1980 1981 foreach my $file ($constscfname, $constsxsfname) { 1982 my $fallback = File::Spec->catfile($fallbackdirname, $file); 1983 if (compare($file, $fallback)) { 1984 warn << "EOM"; 1985Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ. 1986EOM 1987 $fail++; 1988 } 1989 } 1990 if ($fail) { 1991 warn fill ('','', <<"EOM") . "\n"; 1992It appears that the code in $ext$modpname/Makefile.PL does not autogenerate 1993the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname 1994correctly. 1995 1996Please report the circumstances of this bug in h2xs version $H2XS_VERSION 1997using the perlbug script. 1998EOM 1999 } else { 2000 unlink $constscfname, $constsxsfname; 2001 } 2002 } 2003} 2004close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; 2005 2006# Create a simple README since this is a CPAN requirement 2007# and it doesnt hurt to have one 2008warn "Writing $ext$modpname/README\n"; 2009open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; 2010my $thisyear = (gmtime)[5] + 1900; 2011my $rmhead = "$modpname version $TEMPLATE_VERSION"; 2012my $rmheadeq = "=" x length($rmhead); 2013 2014my $rm_prereq; 2015 2016if ( $compat_version < 5.00702 and $new_test ) 2017{ 2018 $rm_prereq = 'Test::More'; 2019} 2020else 2021{ 2022 $rm_prereq = 'blah blah blah'; 2023} 2024 2025print RM <<_RMEND_; 2026$rmhead 2027$rmheadeq 2028 2029The README is used to introduce the module and provide instructions on 2030how to install the module, any machine dependencies it may have (for 2031example C compilers and installed libraries) and any other information 2032that should be provided before the module is installed. 2033 2034A README file is required for CPAN modules since CPAN extracts the 2035README file from a module distribution so that people browsing the 2036archive can use it get an idea of the modules uses. It is usually a 2037good idea to provide version information here so that people can 2038decide whether fixes for the module are worth downloading. 2039 2040INSTALLATION 2041 2042To install this module type the following: 2043 2044 perl Makefile.PL 2045 make 2046 make test 2047 make install 2048 2049DEPENDENCIES 2050 2051This module requires these other modules and libraries: 2052 2053 $rm_prereq 2054 2055COPYRIGHT AND LICENCE 2056 2057Put the correct copyright and licence information here. 2058 2059$licence 2060 2061_RMEND_ 2062close(RM) || die "Can't close $ext$modpname/README: $!\n"; 2063 2064my $testdir = "t"; 2065my $testfile = "$testdir/$modpname.t"; 2066unless (-d "$testdir") { 2067 mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n"; 2068} 2069warn "Writing $ext$modpname/$testfile\n"; 2070my $tests = @const_names ? 2 : 1; 2071 2072open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n"; 2073 2074print EX <<_END_; 2075# Before `make install' is performed this script should be runnable with 2076# `make test'. After `make install' it should work as `perl $modpname.t' 2077 2078######################### 2079 2080# change 'tests => $tests' to 'tests => last_test_to_print'; 2081 2082_END_ 2083 2084my $test_mod = 'Test::More'; 2085 2086if ( $old_test or ($compat_version < 5.007 and not $new_test )) 2087{ 2088 my $test_mod = 'Test'; 2089 2090 print EX <<_END_; 2091use Test; 2092BEGIN { plan tests => $tests }; 2093use $module; 2094ok(1); # If we made it this far, we're ok. 2095 2096_END_ 2097 2098 if (@const_names) { 2099 my $const_names = join " ", @const_names; 2100 print EX <<'_END_'; 2101 2102my $fail; 2103foreach my $constname (qw( 2104_END_ 2105 2106 print EX wrap ("\t", "\t", $const_names); 2107 print EX (")) {\n"); 2108 2109 print EX <<_END_; 2110 next if (eval "my \\\$a = \$constname; 1"); 2111 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { 2112 print "# pass: \$\@"; 2113 } else { 2114 print "# fail: \$\@"; 2115 \$fail = 1; 2116 } 2117} 2118if (\$fail) { 2119 print "not ok 2\\n"; 2120} else { 2121 print "ok 2\\n"; 2122} 2123 2124_END_ 2125 } 2126} 2127else 2128{ 2129 print EX <<_END_; 2130use Test::More tests => $tests; 2131BEGIN { use_ok('$module') }; 2132 2133_END_ 2134 2135 if (@const_names) { 2136 my $const_names = join " ", @const_names; 2137 print EX <<'_END_'; 2138 2139my $fail = 0; 2140foreach my $constname (qw( 2141_END_ 2142 2143 print EX wrap ("\t", "\t", $const_names); 2144 print EX (")) {\n"); 2145 2146 print EX <<_END_; 2147 next if (eval "my \\\$a = \$constname; 1"); 2148 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) { 2149 print "# pass: \$\@"; 2150 } else { 2151 print "# fail: \$\@"; 2152 \$fail = 1; 2153 } 2154 2155} 2156 2157ok( \$fail == 0 , 'Constants' ); 2158_END_ 2159 } 2160} 2161 2162print EX <<_END_; 2163######################### 2164 2165# Insert your test code below, the $test_mod module is use()ed here so read 2166# its man page ( perldoc $test_mod ) for help writing this test script. 2167 2168_END_ 2169 2170close(EX) || die "Can't close $ext$modpname/$testfile: $!\n"; 2171 2172unless ($opt_C) { 2173 warn "Writing $ext$modpname/Changes\n"; 2174 $" = ' '; 2175 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; 2176 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; 2177 print EX <<EOP; 2178Revision history for Perl extension $module. 2179 2180$TEMPLATE_VERSION @{[scalar localtime]} 2181\t- original version; created by h2xs $H2XS_VERSION with options 2182\t\t@ARGS 2183 2184EOP 2185 close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; 2186} 2187 2188warn "Writing $ext$modpname/MANIFEST\n"; 2189open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; 2190my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>); 2191if (!@files) { 2192 eval {opendir(D,'.');}; 2193 unless ($@) { @files = readdir(D); closedir(D); } 2194} 2195if (!@files) { @files = map {chomp && $_} `ls`; } 2196if ($^O eq 'VMS') { 2197 foreach (@files) { 2198 # Clip trailing '.' for portability -- non-VMS OSs don't expect it 2199 s%\.$%%; 2200 # Fix up for case-sensitive file systems 2201 s/$modfname/$modfname/i && next; 2202 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; 2203 $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; 2204 } 2205} 2206print MANI join("\n",@files), "\n"; 2207close MANI; 2208!NO!SUBS! 2209 2210close OUT or die "Can't close $file: $!"; 2211chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 2212exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 2213chdir $origdir; 2214