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