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