Change the perlbug address to perl.org since it's more forgiving.
[p5sagit/p5-mst-13.2.git] / utils / h2xs.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4 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.
be3174d2 16my $origdir = cwd;
44a8e56a 17chdir dirname($0);
be3174d2 18my $file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4 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!";
5f05dabc 29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
40000a8c 32!GROK!THIS!
33
4633a7c4 34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
cf35f3c1 37
3edbfbe5 38=head1 NAME
39
40h2xs - convert .h C header files to Perl extensions
41
42=head1 SYNOPSIS
43
be3174d2 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]]
f508c652 45
46B<h2xs> B<-h>
3edbfbe5 47
48=head1 DESCRIPTION
49
a887ff11 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.
3edbfbe5 53
54The I<module_name> will be used for the name of the extension. If
a887ff11 55module_name is not supplied then the name of the first header file
56will be used, with the first character capitalized.
3edbfbe5 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
f508c652 71=item B<-A>
3edbfbe5 72
f508c652 73Omit all autoload facilities. This is the same as B<-c> but also removes the
9ef261b5 74S<C<use AutoLoader>> statement from the .pm file.
3edbfbe5 75
c0f8b9cd 76=item B<-C>
77
78Omits creation of the F<Changes> file, and adds a HISTORY section to
79the POD template.
80
be3174d2 81=item B<-F> I<addflags>
b73edd97 82
83Additional flags to specify to C preprocessor when scanning header for
ddf6bed1 84function declarations. Should not be used without B<-x>.
85
86=item B<-M> I<regular expression>
87
88selects functions/macros to process.
b73edd97 89
2920c5d2 90=item B<-O>
91
92Allows a pre-existing extension directory to be overwritten.
93
f508c652 94=item B<-P>
3edbfbe5 95
f508c652 96Omit the autogenerated stub POD section.
3edbfbe5 97
b73edd97 98=item B<-X>
99
100Omit the XS portion. Used to generate templates for a module which is not
9ef261b5 101XS-based. C<-c> and C<-f> are implicitly enabled.
b73edd97 102
7c1d48a5 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
32fb2b78 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.
7c1d48a5 116
3edbfbe5 117=item B<-c>
118
119Omit C<constant()> from the .xs file and corresponding specialised
120C<AUTOLOAD> from the .pm file.
121
b73edd97 122=item B<-d>
123
124Turn on debugging messages.
125
f508c652 126=item B<-f>
3edbfbe5 127
f508c652 128Allows an extension to be created for a header even if that header is
ddf6bed1 129not found in standard include directories.
f508c652 130
131=item B<-h>
132
133Print the usage, help and version for this h2xs and exit.
134
32fb2b78 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
f508c652 145=item B<-n> I<module_name>
146
147Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
148
ddf6bed1 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
ead2a595 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
98a6f11e 168autoloaded via the C<constant()> mechanism.
ead2a595 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
f508c652 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.
3edbfbe5 179
760ac839 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,
b73edd97 186but XSUBs are emitted only for the declarations included from file NAME2.
760ac839 187
5273d82d 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
ddf6bed1 191pointer (like C<long long>), pointers to functions, or arrays. See
192also the section on L<LIMITATIONS of B<-x>>.
5273d82d 193
be3174d2 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
3edbfbe5 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
ead2a595 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
3edbfbe5 245
5273d82d 246 # Make XS without defines in perl.h, but with function declarations
760ac839 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.
5273d82d 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
760ac839 253
254 # Same with function declaration in proto.h as visible from perl.h.
5273d82d 255 h2xs -xAn perl2 perl.h,proto.h
760ac839 256
ddf6bed1 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
3edbfbe5 263=head1 ENVIRONMENT
264
265No environment variables are used.
266
267=head1 AUTHOR
268
269Larry Wall and others
270
271=head1 SEE ALSO
272
f508c652 273L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
3edbfbe5 274
275=head1 DIAGNOSTICS
276
760ac839 277The usual warnings if it cannot read or write the files involved.
3edbfbe5 278
ddf6bed1 279=head1 LIMITATIONS of B<-x>
280
281F<h2xs> would not distinguish whether an argument to a C function
282which is of the form, say, C<int *>, is an input, output, or
283input/output parameter. In particular, argument declarations of the
284form
285
286 int
287 foo(n)
288 int *n
289
290should be better rewritten as
291
292 int
293 foo(n)
294 int &n
295
296if C<n> is an input parameter.
297
298Additionally, F<h2xs> has no facilities to intuit that a function
299
300 int
301 foo(addr,l)
302 char *addr
303 int l
304
305takes a pair of address and length of data at this address, so it is better
306to rewrite this function as
307
308 int
309 foo(sv)
7aff18a2 310 SV *addr
311 PREINIT:
312 STRLEN len;
313 char *s;
314 CODE:
315 s = SvPV(sv,len);
316 RETVAL = foo(s, len);
317 OUTPUT:
318 RETVAL
ddf6bed1 319
320or alternately
321
322 static int
323 my_foo(SV *sv)
324 {
325 STRLEN len;
326 char *s = SvPV(sv,len);
327
328 return foo(s, len);
329 }
330
331 MODULE = foo PACKAGE = foo PREFIX = my_
332
333 int
334 foo(sv)
335 SV *sv
336
337See L<perlxs> and L<perlxstut> for additional details.
338
3edbfbe5 339=cut
340
3cb4da91 341use strict;
342
343
ddf6bed1 344my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
f508c652 345my $TEMPLATE_VERSION = '0.01';
ddf6bed1 346my @ARGS = @ARGV;
be3174d2 347my $compat_version = $];
a0d0e21e 348
349use Getopt::Std;
350
e1666bf5 351sub usage{
352 warn "@_\n" if @_;
be3174d2 353 die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]]
f508c652 354version: $H2XS_VERSION
3edbfbe5 355 -A Omit all autoloading facilities (implies -c).
c0f8b9cd 356 -C Omit creating the Changes file, add HISTORY heading to stub POD.
b73edd97 357 -F Additional flags for C preprocessor (used with -x).
ddf6bed1 358 -M Mask to select C functions/macros (default is select all).
2920c5d2 359 -O Allow overwriting of a pre-existing extension directory.
f508c652 360 -P Omit the stub POD section.
9ef261b5 361 -X Omit the XS portion (implies both -c and -f).
7c1d48a5 362 -a Generate get/set accessors for struct and union members (used with -x).
b73edd97 363 -c Omit the constant() function and specialised AUTOLOAD from the XS file.
364 -d Turn on debugging messages.
365 -f Force creation of the extension even if the C header does not exist.
366 -h Display this help message
32fb2b78 367 -k Omit 'const' attribute on function arguments (used with -x).
368 -m Generate tied variables for access to declared variables.
b73edd97 369 -n Specify a name to use for the extension (recommended).
ddf6bed1 370 -o Regular expression for \"opaque\" types.
b73edd97 371 -p Specify a prefix which should be removed from the Perl function names.
372 -s Create subroutines for specified macros.
f508c652 373 -v Specify a version number for this extension.
760ac839 374 -x Autogenerate XSUBs using C::Scan.
be3174d2 375 -b Specify a perl version to be backwards compatibile with
e1666bf5 376extra_libraries
377 are any libraries that might be needed for loading the
378 extension, e.g. -lm would try to link in the math library.
f508c652 379";
e1666bf5 380}
a0d0e21e 381
a0d0e21e 382
be3174d2 383getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage;
32fb2b78 384use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
be3174d2 385 $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x
386 $opt_b);
a0d0e21e 387
e1666bf5 388usage if $opt_h;
f508c652 389
be3174d2 390if( $opt_b ){
391 usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
392 $opt_b =~ /^\d+\.\d+\.\d+/ ||
393 usage "You must provide the backwards compatibility version in X.Y.Z form. " .
394 "(i.e. 5.5.0)\n";
395 my ($maj,$min,$sub) = split(/\./,$opt_b,3);
396 $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub);
397}
398
f508c652 399if( $opt_v ){
400 $TEMPLATE_VERSION = $opt_v;
401}
9ef261b5 402
403# -A implies -c.
e1666bf5 404$opt_c = 1 if $opt_A;
9ef261b5 405
406# -X implies -c and -f
407$opt_c = $opt_f = 1 if $opt_X;
408
3cb4da91 409my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
410my $extralibs;
411my @path_h;
a0d0e21e 412
a887ff11 413while (my $arg = shift) {
414 if ($arg =~ /^-l/i) {
415 $extralibs = "$arg @ARGV";
416 last;
417 }
418 push(@path_h, $arg);
419}
e1666bf5 420
421usage "Must supply header file or module name\n"
a887ff11 422 unless (@path_h or $opt_n);
e1666bf5 423
ddf6bed1 424my $fmask;
3cb4da91 425my $tmask;
ddf6bed1 426
427$fmask = qr{$opt_M} if defined $opt_M;
428$tmask = qr{$opt_o} if defined $opt_o;
429my $tmask_all = $tmask && $opt_o eq '.';
430
431if ($opt_x) {
432 eval {require C::Scan; 1}
433 or die <<EOD;
434C::Scan required if you use -x option.
435To install C::Scan, execute
436 perl -MCPAN -e "install C::Scan"
437EOD
438 unless ($tmask_all) {
439 $C::Scan::VERSION >= 0.70
440 or die <<EOD;
441C::Scan v. 0.70 or later required unless you use -o . option.
442You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
443To install C::Scan, execute
444 perl -MCPAN -e "install C::Scan"
445EOD
446 }
32fb2b78 447 if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
448 die <<EOD;
449C::Scan v. 0.73 or later required to use -m or -a options.
450You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
451To install C::Scan, execute
452 perl -MCPAN -e "install C::Scan"
453EOD
454 }
7aff18a2 455}
456elsif ($opt_o or $opt_F) {
ddf6bed1 457 warn <<EOD;
458Options -o and -F do not make sense without -x.
459EOD
460}
461
3cb4da91 462my @path_h_ini = @path_h;
463my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
a0d0e21e 464
a887ff11 465if( @path_h ){
ddf6bed1 466 use Config;
467 use File::Spec;
468 my @paths;
469 if ($^O eq 'VMS') { # Consider overrides of default location
3cb4da91 470 # XXXX This is not equivalent to what the older version did:
471 # it was looking at $hadsys header-file per header-file...
472 my($hadsys) = grep s!^sys/!!i , @path_h;
7aff18a2 473 @paths = qw( Sys$Library VAXC$Include );
ddf6bed1 474 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
475 push @paths, qw( DECC$Library_Include DECC$System_Include );
7aff18a2 476 }
477 else {
ddf6bed1 478 @paths = (File::Spec->curdir(), $Config{usrinc},
479 (split ' ', $Config{locincpth}), '/usr/include');
480 }
a887ff11 481 foreach my $path_h (@path_h) {
482 $name ||= $path_h;
e1666bf5 483 if( $path_h =~ s#::#/#g && $opt_n ){
484 warn "Nesting of headerfile ignored with -n\n";
485 }
486 $path_h .= ".h" unless $path_h =~ /\.h$/;
3cb4da91 487 my $fullpath = $path_h;
760ac839 488 $path_h =~ s/,.*$// if $opt_x;
3cb4da91 489 $fullpath{$path_h} = $fullpath;
ddf6bed1 490
491 if (not -f $path_h) {
492 my $tmp_path_h = $path_h;
493 for my $dir (@paths) {
494 last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
495 }
ead2a595 496 }
5273d82d 497
498 if (!$opt_c) {
499 die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
500 # Scan the header file (we should deal with nested header files)
501 # Record the names of simple #define constants into const_names
a887ff11 502 # Function prototypes are processed below.
5273d82d 503 open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
ddf6bed1 504 defines:
5273d82d 505 while (<CH>) {
3cb4da91 506 if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
ddf6bed1 507 my $def = $1;
508 my $rest = $2;
509 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
510 $rest =~ s/^\s+//;
511 $rest =~ s/\s+$//;
512 # Cannot do: (-1) and ((LHANDLE)3) are OK:
513 #print("Skip non-wordy $def => $rest\n"),
514 # next defines if $rest =~ /[^\w\$]/;
515 if ($rest =~ /"/) {
516 print("Skip stringy $def => $rest\n") if $opt_d;
517 next defines;
518 }
519 print "Matched $_ ($def)\n" if $opt_d;
520 $seen_define{$def} = $rest;
521 $_ = $def;
e1666bf5 522 next if /^_.*_h_*$/i; # special case, but for what?
760ac839 523 if (defined $opt_p) {
5273d82d 524 if (!/^$opt_p(\d)/) {
525 ++$prefix{$_} if s/^$opt_p//;
526 }
527 else {
528 warn "can't remove $opt_p prefix from '$_'!\n";
529 }
ead2a595 530 }
ddf6bed1 531 $prefixless{$def} = $_;
532 if (!$fmask or /$fmask/) {
533 print "... Passes mask of -M.\n" if $opt_d and $fmask;
534 $const_names{$_}++;
535 }
5273d82d 536 }
537 }
538 close(CH);
e1666bf5 539 }
a887ff11 540 }
a0d0e21e 541}
542
e1666bf5 543
3cb4da91 544my $module = $opt_n || do {
a0d0e21e 545 $name =~ s/\.h$//;
546 if( $name !~ /::/ ){
547 $name =~ s#^.*/##;
548 $name = "\u$name";
549 }
550 $name;
551};
552
3cb4da91 553my ($ext, $nested, @modparts, $modfname, $modpname);
8e07c86e 554(chdir 'ext', $ext = 'ext/') if -d 'ext';
a0d0e21e 555
556if( $module =~ /::/ ){
557 $nested = 1;
558 @modparts = split(/::/,$module);
559 $modfname = $modparts[-1];
560 $modpname = join('/',@modparts);
561}
562else {
563 $nested = 0;
564 @modparts = ();
565 $modfname = $modpname = $module;
566}
567
568
2920c5d2 569if ($opt_O) {
570 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
7aff18a2 571}
572else {
2920c5d2 573 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
574}
c07a80fd 575if( $nested ){
3cb4da91 576 my $modpath = "";
c07a80fd 577 foreach (@modparts){
578 mkdir("$modpath$_", 0777);
579 $modpath .= "$_/";
580 }
581}
a0d0e21e 582mkdir($modpname, 0777);
8e07c86e 583chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
a0d0e21e 584
5273d82d 585my %types_seen;
586my %std_types;
f4d63e4e 587my $fdecls = [];
588my $fdecls_parsed = [];
ddf6bed1 589my $typedef_rex;
590my %typedefs_pre;
591my %known_fnames;
7c1d48a5 592my %structs;
5273d82d 593
3cb4da91 594my @fnames;
595my @fnames_no_prefix;
32fb2b78 596my %vdecl_hash;
597my @vdecls;
5273d82d 598
2920c5d2 599if( ! $opt_X ){ # use XS, unless it was disabled
600 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
5273d82d 601 if ($opt_x) {
5273d82d 602 require Config; # Run-time directive
603 warn "Scanning typemaps...\n";
604 get_typemap();
3cb4da91 605 my @td;
606 my @good_td;
607 my $addflags = $opt_F || '';
608
f4d63e4e 609 foreach my $filename (@path_h) {
3cb4da91 610 my $c;
611 my $filter;
612
613 if ($fullpath{$filename} =~ /,/) {
f4d63e4e 614 $filename = $`;
615 $filter = $';
616 }
617 warn "Scanning $filename for functions...\n";
618 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
7c1d48a5 619 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
f4d63e4e 620 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
ddf6bed1 621
f4d63e4e 622 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
623 push(@$fdecls, @{$c->get('fdecls')});
3cb4da91 624
625 push @td, @{$c->get('typedefs_maybe')};
7c1d48a5 626 if ($opt_a) {
627 my $structs = $c->get('typedef_structs');
628 @structs{keys %$structs} = values %$structs;
629 }
3cb4da91 630
32fb2b78 631 if ($opt_m) {
632 %vdecl_hash = %{ $c->get('vdecl_hash') };
633 @vdecls = sort keys %vdecl_hash;
634 for (local $_ = 0; $_ < @vdecls; ++$_) {
635 my $var = $vdecls[$_];
636 my($type, $post) = @{ $vdecl_hash{$var} };
637 if (defined $post) {
638 warn "Can't handle variable '$type $var $post', skipping.\n";
639 splice @vdecls, $_, 1;
640 redo;
641 }
642 $type = normalize_type($type);
643 $vdecl_hash{$var} = $type;
644 }
645 }
646
3cb4da91 647 unless ($tmask_all) {
648 warn "Scanning $filename for typedefs...\n";
649 my $td = $c->get('typedef_hash');
650 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
651 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
652 push @good_td, @f_good_td;
653 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
654 }
655 }
656 { local $" = '|';
6542b28e 657 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
5273d82d 658 }
ddf6bed1 659 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
660 if ($fmask) {
661 my @good;
662 for my $i (0..$#$fdecls_parsed) {
663 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
664 push @good, $i;
665 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
666 if $opt_d;
667 }
668 $fdecls = [@$fdecls[@good]];
669 $fdecls_parsed = [@$fdecls_parsed[@good]];
670 }
3cb4da91 671 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
672 # Sort declarations:
673 {
674 my %h = map( ($_->[1], $_), @$fdecls_parsed);
675 $fdecls_parsed = [ @h{@fnames} ];
ddf6bed1 676 }
3cb4da91 677 @fnames_no_prefix = @fnames;
678 @fnames_no_prefix
679 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
ddf6bed1 680 # Remove macros which expand to typedefs
ddf6bed1 681 print "Typedefs are @td.\n" if $opt_d;
682 my %td = map {($_, $_)} @td;
683 # Add some other possible but meaningless values for macros
684 for my $k (qw(char double float int long short unsigned signed void)) {
685 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
686 }
687 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
688 my $n = 0;
689 my %bad_macs;
690 while (keys %td > $n) {
691 $n = keys %td;
692 my ($k, $v);
693 while (($k, $v) = each %seen_define) {
694 # print("found '$k'=>'$v'\n"),
695 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
696 }
697 }
698 # Now %bad_macs contains names of bad macros
699 for my $k (keys %bad_macs) {
700 delete $const_names{$prefixless{$k}};
701 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
5273d82d 702 }
5273d82d 703 }
2920c5d2 704}
3cb4da91 705my @const_names = sort keys %const_names;
5273d82d 706
8e07c86e 707open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
a0d0e21e 708
a0d0e21e 709$" = "\n\t";
8e07c86e 710warn "Writing $ext$modpname/$modfname.pm\n";
a0d0e21e 711
be3174d2 712if ( $compat_version < 5.006 ) {
713print PM <<"END";
714package $module;
715
716use $compat_version;
717use strict;
718END
719}
720else {
a0d0e21e 721print PM <<"END";
722package $module;
723
be573f63 724use 5.006;
2920c5d2 725use strict;
8cd79558 726use warnings;
2920c5d2 727END
be3174d2 728}
2920c5d2 729
aba05478 730unless( $opt_X || $opt_c || $opt_A ){
2920c5d2 731 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
732 # will want Carp.
733 print PM <<'END';
734use Carp;
2920c5d2 735END
736}
737
738print PM <<'END';
739
a0d0e21e 740require Exporter;
2920c5d2 741END
742
743print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
a0d0e21e 744require DynaLoader;
3edbfbe5 745END
746
e1666bf5 747
9ef261b5 748# Are we using AutoLoader or not?
749unless ($opt_A) { # no autoloader whatsoever.
750 unless ($opt_c) { # we're doing the AUTOLOAD
751 print PM "use AutoLoader;\n";
2920c5d2 752 }
9ef261b5 753 else {
754 print PM "use AutoLoader qw(AUTOLOAD);\n"
2920c5d2 755 }
3edbfbe5 756}
3edbfbe5 757
be3174d2 758if ( $compat_version < 5.006 ) {
759 if ( $opt_X || $opt_c || $opt_A ) {
760 print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
761 } else {
762 print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
763 }
764}
765
9ef261b5 766# Determine @ISA.
77ca0c92 767my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this.
9ef261b5 768$myISA .= ' DynaLoader' unless $opt_X; # no XS
769$myISA .= ');';
be3174d2 770$myISA =~ s/^our // if $compat_version < 5.006;
771
9ef261b5 772print PM "\n$myISA\n\n";
e1666bf5 773
32fb2b78 774my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
3cb4da91 775
be3174d2 776my $tmp=<<"END";
e1666bf5 777# Items to export into callers namespace by default. Note: do not export
778# names by default without a very good reason. Use EXPORT_OK instead.
779# Do not simply export all your public functions/methods/constants.
ddf6bed1 780
781# This allows declaration use $module ':all';
782# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
783# will save memory.
51fac20b 784our %EXPORT_TAGS = ( 'all' => [ qw(
3cb4da91 785 @exported_names
ddf6bed1 786) ] );
787
51fac20b 788our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
ddf6bed1 789
77ca0c92 790our \@EXPORT = qw(
e1666bf5 791 @const_names
a0d0e21e 792);
77ca0c92 793our \$VERSION = '$TEMPLATE_VERSION';
f508c652 794
e1666bf5 795END
796
be3174d2 797$tmp =~ s/^our //mg if $compat_version < 5.006;
798print PM $tmp;
799
32fb2b78 800if (@vdecls) {
801 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
802}
803
be3174d2 804
805$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" );
2920c5d2 806print PM <<"END" unless $opt_c or $opt_X;
a0d0e21e 807sub AUTOLOAD {
3edbfbe5 808 # This AUTOLOAD is used to 'autoload' constants from the constant()
809 # XS function. If a constant is not found then control is passed
810 # to the AUTOLOAD in AutoLoader.
e1666bf5 811
2920c5d2 812 my \$constname;
be3174d2 813 $tmp
a0d0e21e 814 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1d3434b8 815 croak "&$module::constant not defined" if \$constname eq 'constant';
2920c5d2 816 my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
a0d0e21e 817 if (\$! != 0) {
265f5c4a 818 if (\$! =~ /Invalid/ || \$!{EINVAL}) {
a0d0e21e 819 \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
820 goto &AutoLoader::AUTOLOAD;
821 }
822 else {
7aff18a2 823 croak "Your vendor has not defined $module macro \$constname";
a0d0e21e 824 }
825 }
7aff18a2 826 {
827 no strict 'refs';
828 # Fixed between 5.005_53 and 5.005_61
829 if (\$] >= 5.00561) {
830 *\$AUTOLOAD = sub () { \$val };
831 }
832 else {
833 *\$AUTOLOAD = sub { \$val };
834 }
ddf6bed1 835 }
a0d0e21e 836 goto &\$AUTOLOAD;
837}
838
a0d0e21e 839END
a0d0e21e 840
2920c5d2 841if( ! $opt_X ){ # print bootstrap, unless XS is disabled
842 print PM <<"END";
f508c652 843bootstrap $module \$VERSION;
2920c5d2 844END
845}
846
32fb2b78 847# tying the variables can happen only after bootstrap
848if (@vdecls) {
849 printf PM <<END;
850{
851@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
852}
853
854END
855}
856
3cb4da91 857my $after;
2920c5d2 858if( $opt_P ){ # if POD is disabled
859 $after = '__END__';
860}
861else {
862 $after = '=cut';
863}
864
865print PM <<"END";
a0d0e21e 866
e1666bf5 867# Preloaded methods go here.
9ef261b5 868END
869
870print PM <<"END" unless $opt_A;
a0d0e21e 871
2920c5d2 872# Autoload methods go after $after, and are processed by the autosplit program.
9ef261b5 873END
874
875print PM <<"END";
a0d0e21e 876
8771;
e1666bf5 878__END__
a0d0e21e 879END
a0d0e21e 880
3cb4da91 881my $author = "A. U. Thor";
882my $email = 'a.u.thor@a.galaxy.far.far.away';
f508c652 883
c0f8b9cd 884my $revhist = '';
885$revhist = <<EOT if $opt_C;
497711e7 886#
887#=head1 HISTORY
888#
889#=over 8
890#
891#=item $TEMPLATE_VERSION
892#
893#Original version; created by h2xs $H2XS_VERSION with options
894#
895# @ARGS
896#
897#=back
898#
c0f8b9cd 899EOT
900
ddf6bed1 901my $exp_doc = <<EOD;
497711e7 902#
903#=head2 EXPORT
904#
905#None by default.
906#
ddf6bed1 907EOD
5273d82d 908if (@const_names and not $opt_P) {
ddf6bed1 909 $exp_doc .= <<EOD;
497711e7 910#=head2 Exportable constants
911#
912# @{[join "\n ", @const_names]}
913#
5273d82d 914EOD
915}
916if (defined $fdecls and @$fdecls and not $opt_P) {
ddf6bed1 917 $exp_doc .= <<EOD;
497711e7 918#=head2 Exportable functions
919#
3cb4da91 920EOD
497711e7 921# $exp_doc .= <<EOD if $opt_p;
922#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
923#
3cb4da91 924EOD
925 $exp_doc .= <<EOD;
497711e7 926# @{[join "\n ", @known_fnames{@fnames}]}
927#
5273d82d 928EOD
929}
930
3cb4da91 931my $pod = <<"END" unless $opt_P;
7aff18a2 932## Below is stub documentation for your module. You better edit it!
f508c652 933#
934#=head1 NAME
935#
936#$module - Perl extension for blah blah blah
937#
938#=head1 SYNOPSIS
939#
940# use $module;
941# blah blah blah
942#
943#=head1 DESCRIPTION
944#
7aff18a2 945#Stub documentation for $module, created by h2xs. It looks like the
f508c652 946#author of the extension was negligent enough to leave the stub
947#unedited.
948#
949#Blah blah blah.
497711e7 950$exp_doc$revhist
f508c652 951#=head1 AUTHOR
952#
953#$author, $email
954#
955#=head1 SEE ALSO
956#
be573f63 957#L<perl>.
f508c652 958#
959#=cut
960END
961
962$pod =~ s/^\#//gm unless $opt_P;
963print PM $pod unless $opt_P;
964
a0d0e21e 965close PM;
966
e1666bf5 967
2920c5d2 968if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 969warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 970
a0d0e21e 971print XS <<"END";
972#include "EXTERN.h"
973#include "perl.h"
974#include "XSUB.h"
975
976END
a887ff11 977if( @path_h ){
3cb4da91 978 foreach my $path_h (@path_h_ini) {
a0d0e21e 979 my($h) = $path_h;
980 $h =~ s#^/usr/include/##;
ead2a595 981 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11 982 print XS qq{#include <$h>\n};
983 }
984 print XS "\n";
a0d0e21e 985}
986
ddf6bed1 987my %pointer_typedefs;
988my %struct_typedefs;
989
990sub td_is_pointer {
991 my $type = shift;
992 my $out = $pointer_typedefs{$type};
993 return $out if defined $out;
994 my $otype = $type;
995 $out = ($type =~ /\*$/);
996 # This converts only the guys which do not have trailing part in the typedef
997 if (not $out
998 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
999 $type = normalize_type($type);
1000 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1001 if $opt_d;
1002 $out = td_is_pointer($type);
1003 }
1004 return ($pointer_typedefs{$otype} = $out);
1005}
1006
1007sub td_is_struct {
1008 my $type = shift;
1009 my $out = $struct_typedefs{$type};
1010 return $out if defined $out;
1011 my $otype = $type;
32fb2b78 1012 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
ddf6bed1 1013 # This converts only the guys which do not have trailing part in the typedef
1014 if (not $out
1015 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1016 $type = normalize_type($type);
1017 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1018 if $opt_d;
1019 $out = td_is_struct($type);
1020 }
1021 return ($struct_typedefs{$otype} = $out);
1022}
1023
1024# Some macros will bomb if you try to return them from a double-returning func.
1025# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
1026# Fortunately, we can detect both these cases...
1027sub protect_convert_to_double {
1028 my $in = shift;
1029 my $val;
1030 return '' unless defined ($val = $seen_define{$in});
1031 return '(IV)' if $known_fnames{$val};
1032 # OUT_t of ((OUT_t)-1):
1033 return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
1034 td_is_pointer($2) ? '(IV)' : '';
a0d0e21e 1035}
1036
ddf6bed1 1037# For each of the generated functions, length($pref) leading
1038# letters are already checked. Moreover, it is recommended that
1039# the generated functions uses switch on letter at offset at least
1040# $off + length($pref).
1041#
1042# The given list has length($pref) chars removed at front, it is
1043# guarantied that $off leading chars in the rest are the same for all
1044# elts of the list.
1045#
1046# Returns: how at which offset it was decided to make a switch, or -1 if none.
1047
1048sub write_const;
1049
1050sub write_const {
1051 my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1052 my %leading;
1053 my $offarg = length $pref;
1054
1055 if (@$list == 0) { # Can happen on the initial iteration only
1056 print $fh <<"END";
a0d0e21e 1057static double
3cb4da91 1058constant(char *name, int len, int arg)
a0d0e21e 1059{
ddf6bed1 1060 errno = EINVAL;
1061 return 0;
1062}
a0d0e21e 1063END
a0d0e21e 1064 return -1;
ddf6bed1 1065 }
a0d0e21e 1066
ddf6bed1 1067 if (@$list == 1) { # Can happen on the initial iteration only
1068 my $protect = protect_convert_to_double("$pref$list->[0]");
e1666bf5 1069
ddf6bed1 1070 print $fh <<"END";
1071static double
3cb4da91 1072constant(char *name, int len, int arg)
ddf6bed1 1073{
daf40514 1074 errno = 0;
ddf6bed1 1075 if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
1076#ifdef $pref$list->[0]
1077 return $protect$pref$list->[0];
1078#else
1079 errno = ENOENT;
1080 return 0;
1081#endif
1082 }
1083 errno = EINVAL;
1084 return 0;
a0d0e21e 1085}
ddf6bed1 1086END
1087 return -1;
1088 }
a0d0e21e 1089
ddf6bed1 1090 for my $n (@$list) {
1091 my $c = substr $n, $off, 1;
1092 $leading{$c} = [] unless exists $leading{$c};
1093 push @{$leading{$c}}, substr $n, $off + 1;
1094 }
1095
1096 if (keys(%leading) == 1) {
1097 return 1 + write_const $fh, $pref, $off + 1, $list;
1098 }
1099
1100 my $leader = substr $list->[0], 0, $off;
3cb4da91 1101 foreach my $letter (keys %leading) {
ddf6bed1 1102 write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1103 if @{$leading{$letter}} > 1;
1104 }
a0d0e21e 1105
ddf6bed1 1106 my $npref = "_$pref";
1107 $npref = '' if $pref eq '';
a0d0e21e 1108
ddf6bed1 1109 print $fh <<"END";
a0d0e21e 1110static double
3cb4da91 1111constant$npref(char *name, int len, int arg)
a0d0e21e 1112{
daf40514 1113END
1114
1115 print $fh <<"END" if $npref eq '';
a0d0e21e 1116 errno = 0;
a0d0e21e 1117END
1118
3cb4da91 1119 print $fh <<"END" if $off;
1120 if ($offarg + $off >= len ) {
1121 errno = EINVAL;
1122 return 0;
1123 }
1124END
e1666bf5 1125
3cb4da91 1126 print $fh <<"END";
ddf6bed1 1127 switch (name[$offarg + $off]) {
1128END
a0d0e21e 1129
3cb4da91 1130 foreach my $letter (sort keys %leading) {
ddf6bed1 1131 my $let = $letter;
1132 $let = '\0' if $letter eq '';
a0d0e21e 1133
ddf6bed1 1134 print $fh <<EOP;
1135 case '$let':
1136EOP
1137 if (@{$leading{$letter}} > 1) {
1138 # It makes sense to call a function
1139 if ($off) {
1140 print $fh <<EOP;
1141 if (!strnEQ(name + $offarg,"$leader", $off))
1142 break;
1143EOP
1144 }
1145 print $fh <<EOP;
3cb4da91 1146 return constant_$pref$leader$letter(name, len, arg);
ddf6bed1 1147EOP
7aff18a2 1148 }
1149 else {
ddf6bed1 1150 # Do it ourselves
1151 my $protect
1152 = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1153
1154 print $fh <<EOP;
1155 if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
1156#ifdef $pref$leader$letter$leading{$letter}[0]
1157 return $protect$pref$leader$letter$leading{$letter}[0];
a0d0e21e 1158#else
1159 goto not_there;
1160#endif
ddf6bed1 1161 }
1162EOP
a0d0e21e 1163 }
ddf6bed1 1164 }
1165 print $fh <<"END";
a0d0e21e 1166 }
1167 errno = EINVAL;
1168 return 0;
1169
1170not_there:
1171 errno = ENOENT;
1172 return 0;
1173}
1174
e1666bf5 1175END
ddf6bed1 1176
e1666bf5 1177}
1178
ddf6bed1 1179if( ! $opt_c ) {
1180 print XS <<"END";
1181static int
1182not_here(char *s)
1183{
1184 croak("$module::%s not implemented on this architecture", s);
1185 return -1;
1186}
1187
1188END
1189
1190 write_const(\*XS, '', 0, \@const_names);
e1666bf5 1191}
1192
32fb2b78 1193print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1194
3cb4da91 1195my $prefix;
ead2a595 1196$prefix = "PREFIX = $opt_p" if defined $opt_p;
3cb4da91 1197
e1666bf5 1198# Now switch from C to XS by issuing the first MODULE declaration:
1199print XS <<"END";
a0d0e21e 1200
ead2a595 1201MODULE = $module PACKAGE = $module $prefix
1202
1203END
1204
1205foreach (sort keys %const_xsub) {
1206 print XS <<"END";
1207char *
1208$_()
1209
1210 CODE:
1211#ifdef $_
7aff18a2 1212 RETVAL = $_;
ead2a595 1213#else
7aff18a2 1214 croak("Your vendor has not defined the $module macro $_");
ead2a595 1215#endif
1216
1217 OUTPUT:
7aff18a2 1218 RETVAL
a0d0e21e 1219
e1666bf5 1220END
ead2a595 1221}
e1666bf5 1222
1223# If a constant() function was written then output a corresponding
1224# XS declaration:
1225print XS <<"END" unless $opt_c;
1226
a0d0e21e 1227double
3cb4da91 1228constant(sv,arg)
7aff18a2 1229 PREINIT:
3cb4da91 1230 STRLEN len;
7aff18a2 1231 INPUT:
3cb4da91 1232 SV * sv
1233 char * s = SvPV(sv, len);
a0d0e21e 1234 int arg
7aff18a2 1235 CODE:
3cb4da91 1236 RETVAL = constant(s,len,arg);
7aff18a2 1237 OUTPUT:
3cb4da91 1238 RETVAL
a0d0e21e 1239
1240END
a0d0e21e 1241
5273d82d 1242my %seen_decl;
ddf6bed1 1243my %typemap;
5273d82d 1244
ead2a595 1245sub print_decl {
1246 my $fh = shift;
1247 my $decl = shift;
1248 my ($type, $name, $args) = @$decl;
5273d82d 1249 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1250
ead2a595 1251 my @argnames = map {$_->[1]} @$args;
ddf6bed1 1252 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
32fb2b78 1253 if ($opt_k) {
1254 s/^\s*const\b\s*// for @argtypes;
1255 }
5273d82d 1256 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595 1257 my $numargs = @$args;
1258 if ($numargs and $argtypes[-1] eq '...') {
1259 $numargs--;
1260 $argnames[-1] = '...';
1261 }
1262 local $" = ', ';
ddf6bed1 1263 $type = normalize_type($type, 1);
1264
ead2a595 1265 print $fh <<"EOP";
1266
1267$type
1268$name(@argnames)
1269EOP
1270
3cb4da91 1271 for my $arg (0 .. $numargs - 1) {
ead2a595 1272 print $fh <<"EOP";
5273d82d 1273 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595 1274EOP
1275 }
1276}
1277
32fb2b78 1278sub print_tievar_subs {
1279 my($fh, $name, $type) = @_;
1280 print $fh <<END;
1281I32
1282_get_$name(IV index, SV *sv) {
1283 dSP;
1284 PUSHMARK(SP);
1285 XPUSHs(sv);
1286 PUTBACK;
1287 (void)call_pv("$module\::_get_$name", G_DISCARD);
1288 return (I32)0;
1289}
1290
1291I32
1292_set_$name(IV index, SV *sv) {
1293 dSP;
1294 PUSHMARK(SP);
1295 XPUSHs(sv);
1296 PUTBACK;
1297 (void)call_pv("$module\::_set_$name", G_DISCARD);
1298 return (I32)0;
1299}
1300
1301END
1302}
1303
1304sub print_tievar_xsubs {
1305 my($fh, $name, $type) = @_;
1306 print $fh <<END;
1307void
1308_tievar_$name(sv)
1309 SV* sv
1310 PREINIT:
1311 struct ufuncs uf;
1312 CODE:
1313 uf.uf_val = &_get_$name;
1314 uf.uf_set = &_set_$name;
1315 uf.uf_index = (IV)&_get_$name;
1316 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1317
1318void
1319_get_$name(THIS)
1320 $type THIS = NO_INIT
1321 CODE:
1322 THIS = $name;
1323 OUTPUT:
1324 SETMAGIC: DISABLE
1325 THIS
1326
1327void
1328_set_$name(THIS)
1329 $type THIS
1330 CODE:
1331 $name = THIS;
1332
1333END
1334}
1335
7c1d48a5 1336sub print_accessors {
1337 my($fh, $name, $struct) = @_;
1338 return unless defined $struct && $name !~ /\s|_ANON/;
1339 $name = normalize_type($name);
1340 my $ptrname = normalize_type("$name *");
32fb2b78 1341 print $fh <<"EOF";
1342
1343MODULE = $module PACKAGE = ${name} $prefix
1344
1345$name *
1346_to_ptr(THIS)
1347 $name THIS = NO_INIT
1348 PROTOTYPE: \$
1349 CODE:
1350 if (sv_derived_from(ST(0), "$name")) {
1351 STRLEN len;
1352 char *s = SvPV((SV*)SvRV(ST(0)), len);
1353 if (len != sizeof(THIS))
1354 croak("Size \%d of packed data != expected \%d",
1355 len, sizeof(THIS));
1356 RETVAL = ($name *)s;
1357 }
1358 else
1359 croak("THIS is not of type $name");
1360 OUTPUT:
1361 RETVAL
1362
1363$name
1364new(CLASS)
1365 char *CLASS = NO_INIT
1366 PROTOTYPE: \$
1367 CODE:
1368 Zero((void*)&RETVAL, sizeof(RETVAL), char);
1369 OUTPUT:
1370 RETVAL
7c1d48a5 1371
1372MODULE = $module PACKAGE = ${name}Ptr $prefix
1373
1374EOF
1375 my @items = @$struct;
1376 while (@items) {
1377 my $item = shift @items;
1378 if ($item->[0] =~ /_ANON/) {
32fb2b78 1379 if (defined $item->[2]) {
7c1d48a5 1380 push @items, map [
32fb2b78 1381 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
7c1d48a5 1382 ], @{ $structs{$item->[0]} };
1383 } else {
1384 push @items, @{ $structs{$item->[0]} };
1385 }
1386 } else {
1387 my $type = normalize_type($item->[0]);
32fb2b78 1388 my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
7c1d48a5 1389 print $fh <<"EOF";
32fb2b78 1390$ttype
1391$item->[2](THIS, __value = NO_INIT)
7c1d48a5 1392 $ptrname THIS
1393 $type __value
1394 PROTOTYPE: \$;\$
1395 CODE:
7c1d48a5 1396 if (items > 1)
1397 THIS->$item->[-1] = __value;
32fb2b78 1398 RETVAL = @{[
1399 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1400 ]};
7c1d48a5 1401 OUTPUT:
1402 RETVAL
1403
1404EOF
1405 }
1406 }
1407}
1408
5273d82d 1409# Should be called before any actual call to normalize_type().
1410sub get_typemap {
1411 # We do not want to read ./typemap by obvios reasons.
1412 my @tm = qw(../../../typemap ../../typemap ../typemap);
1413 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1414 unshift @tm, $stdtypemap;
1415 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
ddf6bed1 1416
1417 # Start with useful default values
1418 $typemap{float} = 'T_DOUBLE';
1419
3cb4da91 1420 foreach my $typemap (@tm) {
5273d82d 1421 next unless -e $typemap ;
1422 # skip directories, binary files etc.
1423 warn " Scanning $typemap\n";
1424 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1425 unless -T $typemap ;
1426 open(TYPEMAP, $typemap)
1427 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1428 my $mode = 'Typemap';
1429 while (<TYPEMAP>) {
1430 next if /^\s*\#/;
1431 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1432 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1433 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1434 elsif ($mode eq 'Typemap') {
1435 next if /^\s*($|\#)/ ;
3cb4da91 1436 my ($type, $image);
ddf6bed1 1437 if ( ($type, $image) =
5273d82d 1438 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1439 # This may reference undefined functions:
1440 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
ddf6bed1 1441 $typemap{normalize_type($type)} = $image;
5273d82d 1442 }
1443 }
1444 }
1445 close(TYPEMAP) or die "Cannot close $typemap: $!";
1446 }
1447 %std_types = %types_seen;
1448 %types_seen = ();
1449}
1450
ead2a595 1451
ddf6bed1 1452sub normalize_type { # Second arg: do not strip const's before \*
ead2a595 1453 my $type = shift;
3cb4da91 1454 my $do_keep_deep_const = shift;
1455 # If $do_keep_deep_const this is heuristical only
1456 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
ddf6bed1 1457 my $ignore_mods
3cb4da91 1458 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1459 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1460 $type =~ s/$ignore_mods//go;
7aff18a2 1461 }
1462 else {
3cb4da91 1463 $type =~ s/$ignore_mods//go;
1464 }
ddf6bed1 1465 $type =~ s/([^\s\w])/ \1 /g;
ead2a595 1466 $type =~ s/\s+$//;
1467 $type =~ s/^\s+//;
ddf6bed1 1468 $type =~ s/\s+/ /g;
1469 $type =~ s/\* (?=\*)/*/g;
1470 $type =~ s/\. \. \./.../g;
1471 $type =~ s/ ,/,/g;
5273d82d 1472 $types_seen{$type}++
1473 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595 1474 $type;
1475}
1476
ddf6bed1 1477my $need_opaque;
1478
1479sub assign_typemap_entry {
1480 my $type = shift;
1481 my $otype = $type;
1482 my $entry;
1483 if ($tmask and $type =~ /$tmask/) {
1484 print "Type $type matches -o mask\n" if $opt_d;
1485 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1486 }
1487 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1488 $type = normalize_type $type;
1489 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1490 $entry = assign_typemap_entry($type);
1491 }
1492 $entry ||= $typemap{$otype}
1493 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1494 $typemap{$otype} = $entry;
1495 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1496 return $entry;
1497}
1498
32fb2b78 1499for (@vdecls) {
1500 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1501}
1502
ead2a595 1503if ($opt_x) {
32fb2b78 1504 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1505 if ($opt_a) {
1506 while (my($name, $struct) = each %structs) {
1507 print_accessors(\*XS, $name, $struct);
7c1d48a5 1508 }
32fb2b78 1509 }
ead2a595 1510}
1511
a0d0e21e 1512close XS;
5273d82d 1513
1514if (%types_seen) {
1515 my $type;
1516 warn "Writing $ext$modpname/typemap\n";
1517 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1518
3cb4da91 1519 for $type (sort keys %types_seen) {
ddf6bed1 1520 my $entry = assign_typemap_entry $type;
1521 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
5273d82d 1522 }
1523
ddf6bed1 1524 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1525#############################################################################
1526INPUT
1527T_OPAQUE_STRUCT
1528 if (sv_derived_from($arg, \"${ntype}\")) {
1529 STRLEN len;
1530 char *s = SvPV((SV*)SvRV($arg), len);
1531
1532 if (len != sizeof($var))
1533 croak(\"Size %d of packed data != expected %d\",
1534 len, sizeof($var));
1535 $var = *($type *)s;
1536 }
1537 else
1538 croak(\"$var is not of type ${ntype}\")
1539#############################################################################
1540OUTPUT
1541T_OPAQUE_STRUCT
1542 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1543EOP
1544
5273d82d 1545 close TM or die "Cannot close typemap file for write: $!";
1546}
1547
2920c5d2 1548} # if( ! $opt_X )
e1666bf5 1549
8e07c86e 1550warn "Writing $ext$modpname/Makefile.PL\n";
1551open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 1552
8bc03d0d 1553print PL <<END;
a0d0e21e 1554use ExtUtils::MakeMaker;
1555# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 1556# the contents of the Makefile that is written.
8bc03d0d 1557WriteMakefile(
1558 'NAME' => '$module',
1559 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
1560 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
a0d0e21e 1561END
8bc03d0d 1562if (!$opt_X) { # print C stuff, unless XS is disabled
ddf6bed1 1563 $opt_F = '' unless defined $opt_F;
8bc03d0d 1564 print PL <<END;
1565 'LIBS' => ['$extralibs'], # e.g., '-lm'
1566 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1567 'INC' => '', # e.g., '-I/usr/include/other'
1568END
2920c5d2 1569}
a0d0e21e 1570print PL ");\n";
f508c652 1571close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1572
1573warn "Writing $ext$modpname/test.pl\n";
1574open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1575print EX <<'_END_';
1576# Before `make install' is performed this script should be runnable with
1577# `make test'. After `make install' it should work as `perl test.pl'
1578
1579######################### We start with some black magic to print on failure.
1580
1581# Change 1..1 below to 1..last_test_to_print .
1582# (It may become useful if the test is moved to ./t subdirectory.)
1583
5ae7f1db 1584BEGIN { $| = 1; print "1..1\n"; }
f508c652 1585END {print "not ok 1\n" unless $loaded;}
1586_END_
1587print EX <<_END_;
1588use $module;
1589_END_
1590print EX <<'_END_';
1591$loaded = 1;
1592print "ok 1\n";
1593
1594######################### End of black magic.
1595
1596# Insert your test code below (better if it prints "ok 13"
1597# (correspondingly "not ok 13") depending on the success of chunk 13
1598# of the test code):
e1666bf5 1599
f508c652 1600_END_
1601close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
a0d0e21e 1602
c0f8b9cd 1603unless ($opt_C) {
ddf6bed1 1604 warn "Writing $ext$modpname/Changes\n";
1605 $" = ' ';
1606 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1607 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1608 print EX <<EOP;
1609Revision history for Perl extension $module.
1610
1611$TEMPLATE_VERSION @{[scalar localtime]}
1612\t- original version; created by h2xs $H2XS_VERSION with options
1613\t\t@ARGS
1614
1615EOP
1616 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
c0f8b9cd 1617}
c07a80fd 1618
1619warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db 1620open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
3cb4da91 1621my @files = <*>;
5ae7f1db 1622if (!@files) {
1623 eval {opendir(D,'.');};
1624 unless ($@) { @files = readdir(D); closedir(D); }
1625}
1626if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff 1627if ($^O eq 'VMS') {
1628 foreach (@files) {
1629 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1630 s%\.$%%;
1631 # Fix up for case-sensitive file systems
1632 s/$modfname/$modfname/i && next;
1633 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 1634 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff 1635 }
1636}
3e3baf6d 1637print MANI join("\n",@files), "\n";
5ae7f1db 1638close MANI;
40000a8c 1639!NO!SUBS!
4633a7c4 1640
1641close OUT or die "Can't close $file: $!";
1642chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1643exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1644chdir $origdir;