This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [ID 20000930.002] perlrun nor perldelta mention -s modification
[perl5.git] / utils / h2xs.PL
CommitLineData
4633a7c4
LW
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4
LW
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
LW
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
AD
32!GROK!THIS!
33
4633a7c4
LW
34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
cf35f3c1 37
3edbfbe5
TB
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
TB
47
48=head1 DESCRIPTION
49
a887ff11
BS
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
TB
53
54The I<module_name> will be used for the name of the extension. If
a887ff11
BS
55module_name is not supplied then the name of the first header file
56will be used, with the first character capitalized.
3edbfbe5
TB
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
GS
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
IZ
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
GS
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
GS
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
TB
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
GS
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
IZ
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
LW
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
IZ
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
IZ
191pointer (like C<long long>), pointers to functions, or arrays. See
192also the section on L<LIMITATIONS of B<-x>>.
5273d82d 193
be3174d2
GS
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
TB
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
LW
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
IZ
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
LW
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
IZ
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
TB
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
TB
274
275=head1 DIAGNOSTICS
276
760ac839 277The usual warnings if it cannot read or write the files involved.
3edbfbe5 278
ddf6bed1
IZ
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
GS
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
IZ
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
TB
339=cut
340
3cb4da91
IZ
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
LW
348
349use Getopt::Std;
350
e1666bf5
TB
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
GS
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
TB
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
GS
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
GS
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
MS
402
403# -A implies -c.
e1666bf5 404$opt_c = 1 if $opt_A;
9ef261b5
MS
405
406# -X implies -c and -f
407$opt_c = $opt_f = 1 if $opt_X;
408
3cb4da91
IZ
409my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
410my $extralibs;
411my @path_h;
a0d0e21e 412
a887ff11
BS
413while (my $arg = shift) {
414 if ($arg =~ /^-l/i) {
415 $extralibs = "$arg @ARGV";
416 last;
417 }
418 push(@path_h, $arg);
419}
e1666bf5
TB
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
IZ
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
GS
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
GS
455}
456elsif ($opt_o or $opt_F) {
ddf6bed1
IZ
457 warn <<EOD;
458Options -o and -F do not make sense without -x.
459EOD
460}
461
3cb4da91
IZ
462my @path_h_ini = @path_h;
463my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
a0d0e21e 464
a887ff11 465if( @path_h ){
ddf6bed1
IZ
466 use Config;
467 use File::Spec;
468 my @paths;
469 if ($^O eq 'VMS') { # Consider overrides of default location
3cb4da91
IZ
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
IZ
474 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
475 push @paths, qw( DECC$Library_Include DECC$System_Include );
7aff18a2
GS
476 }
477 else {
ddf6bed1
IZ
478 @paths = (File::Spec->curdir(), $Config{usrinc},
479 (split ' ', $Config{locincpth}), '/usr/include');
480 }
a887ff11
BS
481 foreach my $path_h (@path_h) {
482 $name ||= $path_h;
e1666bf5
TB
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
IZ
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
IZ
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
IZ
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
IZ
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
IZ
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
IZ
536 }
537 }
538 close(CH);
e1666bf5 539 }
a887ff11 540 }
a0d0e21e
LW
541}
542
e1666bf5 543
3cb4da91 544my $module = $opt_n || do {
a0d0e21e
LW
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
LW
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
GS
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
IZ
585my %types_seen;
586my %std_types;
f4d63e4e
IZ
587my $fdecls = [];
588my $fdecls_parsed = [];
ddf6bed1
IZ
589my $typedef_rex;
590my %typedefs_pre;
591my %known_fnames;
7c1d48a5 592my %structs;
5273d82d 593
3cb4da91
IZ
594my @fnames;
595my @fnames_no_prefix;
32fb2b78
GS
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
IZ
602 require Config; # Run-time directive
603 warn "Scanning typemaps...\n";
604 get_typemap();
3cb4da91
IZ
605 my @td;
606 my @good_td;
607 my $addflags = $opt_F || '';
608
f4d63e4e 609 foreach my $filename (@path_h) {
3cb4da91
IZ
610 my $c;
611 my $filter;
612
613 if ($fullpath{$filename} =~ /,/) {
f4d63e4e
IZ
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
IZ
622 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
623 push(@$fdecls, @{$c->get('fdecls')});
3cb4da91
IZ
624
625 push @td, @{$c->get('typedefs_maybe')};
7c1d48a5
GS
626 if ($opt_a) {
627 my $structs = $c->get('typedef_structs');
628 @structs{keys %$structs} = values %$structs;
629 }
3cb4da91 630
32fb2b78
GS
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
IZ
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
IZ
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
IZ
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
IZ
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
IZ
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
GS
712if ( $compat_version < 5.006 ) {
713print PM <<"END";
714package $module;
715
716use $compat_version;
717use strict;
718END
719}
720else {
a0d0e21e
LW
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
TB
745END
746
e1666bf5 747
9ef261b5
MS
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
MS
753 else {
754 print PM "use AutoLoader qw(AUTOLOAD);\n"
2920c5d2 755 }
3edbfbe5 756}
3edbfbe5 757
be3174d2
GS
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
MS
768$myISA .= ' DynaLoader' unless $opt_X; # no XS
769$myISA .= ');';
be3174d2
GS
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
TB
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
IZ
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
IZ
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
TB
795END
796
be3174d2
GS
797$tmp =~ s/^our //mg if $compat_version < 5.006;
798print PM $tmp;
799
32fb2b78
GS
800if (@vdecls) {
801 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
802}
803
be3174d2
GS
804
805$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" );
2920c5d2 806print PM <<"END" unless $opt_c or $opt_X;
a0d0e21e 807sub AUTOLOAD {
3edbfbe5
TB
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
LW
819 \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
820 goto &AutoLoader::AUTOLOAD;
821 }
822 else {
7aff18a2 823 croak "Your vendor has not defined $module macro \$constname";
a0d0e21e
LW
824 }
825 }
7aff18a2
GS
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
LW
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
GS
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
MS
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
MS
873END
874
875print PM <<"END";
a0d0e21e
LW
876
8771;
e1666bf5 878__END__
a0d0e21e 879END
a0d0e21e 880
3cb4da91
IZ
881my $author = "A. U. Thor";
882my $email = 'a.u.thor@a.galaxy.far.far.away';
f508c652 883
c0f8b9cd
GS
884my $revhist = '';
885$revhist = <<EOT if $opt_C;
497711e7
GS
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
GS
899EOT
900
ddf6bed1 901my $exp_doc = <<EOD;
497711e7
GS
902#
903#=head2 EXPORT
904#
905#None by default.
906#
ddf6bed1 907EOD
b7d5fa84 908
5273d82d 909if (@const_names and not $opt_P) {
ddf6bed1 910 $exp_doc .= <<EOD;
497711e7
GS
911#=head2 Exportable constants
912#
913# @{[join "\n ", @const_names]}
914#
5273d82d
IZ
915EOD
916}
b7d5fa84 917
5273d82d 918if (defined $fdecls and @$fdecls and not $opt_P) {
ddf6bed1 919 $exp_doc .= <<EOD;
497711e7
GS
920#=head2 Exportable functions
921#
3cb4da91 922EOD
b7d5fa84 923
497711e7
GS
924# $exp_doc .= <<EOD if $opt_p;
925#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
926#
b7d5fa84 927#EOD
3cb4da91 928 $exp_doc .= <<EOD;
497711e7
GS
929# @{[join "\n ", @known_fnames{@fnames}]}
930#
5273d82d
IZ
931EOD
932}
933
b7d5fa84
IZ
934my $meth_doc = '';
935
936if ($opt_x && $opt_a) {
937 my($name, $struct);
938 $meth_doc .= accessor_docs($name, $struct)
939 while ($name, $struct) = each %structs;
940}
941
3cb4da91 942my $pod = <<"END" unless $opt_P;
7aff18a2 943## Below is stub documentation for your module. You better edit it!
f508c652 944#
945#=head1 NAME
946#
947#$module - Perl extension for blah blah blah
948#
949#=head1 SYNOPSIS
950#
951# use $module;
952# blah blah blah
953#
954#=head1 DESCRIPTION
955#
7aff18a2 956#Stub documentation for $module, created by h2xs. It looks like the
f508c652 957#author of the extension was negligent enough to leave the stub
958#unedited.
959#
960#Blah blah blah.
b7d5fa84 961$exp_doc$meth_doc$revhist
f508c652 962#=head1 AUTHOR
963#
964#$author, $email
965#
966#=head1 SEE ALSO
967#
be573f63 968#L<perl>.
f508c652 969#
970#=cut
971END
972
973$pod =~ s/^\#//gm unless $opt_P;
974print PM $pod unless $opt_P;
975
a0d0e21e
LW
976close PM;
977
e1666bf5 978
2920c5d2 979if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 980warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 981
a0d0e21e
LW
982print XS <<"END";
983#include "EXTERN.h"
984#include "perl.h"
985#include "XSUB.h"
986
987END
a887ff11 988if( @path_h ){
3cb4da91 989 foreach my $path_h (@path_h_ini) {
a0d0e21e
LW
990 my($h) = $path_h;
991 $h =~ s#^/usr/include/##;
ead2a595 992 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11
BS
993 print XS qq{#include <$h>\n};
994 }
995 print XS "\n";
a0d0e21e
LW
996}
997
ddf6bed1
IZ
998my %pointer_typedefs;
999my %struct_typedefs;
1000
1001sub td_is_pointer {
1002 my $type = shift;
1003 my $out = $pointer_typedefs{$type};
1004 return $out if defined $out;
1005 my $otype = $type;
1006 $out = ($type =~ /\*$/);
1007 # This converts only the guys which do not have trailing part in the typedef
1008 if (not $out
1009 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1010 $type = normalize_type($type);
1011 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1012 if $opt_d;
1013 $out = td_is_pointer($type);
1014 }
1015 return ($pointer_typedefs{$otype} = $out);
1016}
1017
1018sub td_is_struct {
1019 my $type = shift;
1020 my $out = $struct_typedefs{$type};
1021 return $out if defined $out;
1022 my $otype = $type;
32fb2b78 1023 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
ddf6bed1
IZ
1024 # This converts only the guys which do not have trailing part in the typedef
1025 if (not $out
1026 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1027 $type = normalize_type($type);
1028 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1029 if $opt_d;
1030 $out = td_is_struct($type);
1031 }
1032 return ($struct_typedefs{$otype} = $out);
1033}
1034
1035# Some macros will bomb if you try to return them from a double-returning func.
1036# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
1037# Fortunately, we can detect both these cases...
1038sub protect_convert_to_double {
1039 my $in = shift;
1040 my $val;
1041 return '' unless defined ($val = $seen_define{$in});
1042 return '(IV)' if $known_fnames{$val};
1043 # OUT_t of ((OUT_t)-1):
1044 return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
1045 td_is_pointer($2) ? '(IV)' : '';
a0d0e21e
LW
1046}
1047
ddf6bed1
IZ
1048# For each of the generated functions, length($pref) leading
1049# letters are already checked. Moreover, it is recommended that
1050# the generated functions uses switch on letter at offset at least
1051# $off + length($pref).
1052#
1053# The given list has length($pref) chars removed at front, it is
1054# guarantied that $off leading chars in the rest are the same for all
1055# elts of the list.
1056#
1057# Returns: how at which offset it was decided to make a switch, or -1 if none.
1058
1059sub write_const;
1060
1061sub write_const {
1062 my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1063 my %leading;
1064 my $offarg = length $pref;
1065
1066 if (@$list == 0) { # Can happen on the initial iteration only
1067 print $fh <<"END";
a0d0e21e 1068static double
3cb4da91 1069constant(char *name, int len, int arg)
a0d0e21e 1070{
ddf6bed1
IZ
1071 errno = EINVAL;
1072 return 0;
1073}
a0d0e21e 1074END
a0d0e21e 1075 return -1;
ddf6bed1 1076 }
a0d0e21e 1077
ddf6bed1
IZ
1078 if (@$list == 1) { # Can happen on the initial iteration only
1079 my $protect = protect_convert_to_double("$pref$list->[0]");
e1666bf5 1080
ddf6bed1
IZ
1081 print $fh <<"END";
1082static double
3cb4da91 1083constant(char *name, int len, int arg)
ddf6bed1 1084{
daf40514 1085 errno = 0;
ddf6bed1
IZ
1086 if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
1087#ifdef $pref$list->[0]
1088 return $protect$pref$list->[0];
1089#else
1090 errno = ENOENT;
1091 return 0;
1092#endif
1093 }
1094 errno = EINVAL;
1095 return 0;
a0d0e21e 1096}
ddf6bed1
IZ
1097END
1098 return -1;
1099 }
a0d0e21e 1100
ddf6bed1
IZ
1101 for my $n (@$list) {
1102 my $c = substr $n, $off, 1;
1103 $leading{$c} = [] unless exists $leading{$c};
1104 push @{$leading{$c}}, substr $n, $off + 1;
1105 }
1106
1107 if (keys(%leading) == 1) {
1108 return 1 + write_const $fh, $pref, $off + 1, $list;
1109 }
1110
1111 my $leader = substr $list->[0], 0, $off;
3cb4da91 1112 foreach my $letter (keys %leading) {
ddf6bed1
IZ
1113 write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1114 if @{$leading{$letter}} > 1;
1115 }
a0d0e21e 1116
ddf6bed1
IZ
1117 my $npref = "_$pref";
1118 $npref = '' if $pref eq '';
a0d0e21e 1119
ddf6bed1 1120 print $fh <<"END";
a0d0e21e 1121static double
3cb4da91 1122constant$npref(char *name, int len, int arg)
a0d0e21e 1123{
daf40514
IZ
1124END
1125
1126 print $fh <<"END" if $npref eq '';
a0d0e21e 1127 errno = 0;
a0d0e21e
LW
1128END
1129
3cb4da91
IZ
1130 print $fh <<"END" if $off;
1131 if ($offarg + $off >= len ) {
1132 errno = EINVAL;
1133 return 0;
1134 }
1135END
e1666bf5 1136
3cb4da91 1137 print $fh <<"END";
ddf6bed1
IZ
1138 switch (name[$offarg + $off]) {
1139END
a0d0e21e 1140
3cb4da91 1141 foreach my $letter (sort keys %leading) {
ddf6bed1
IZ
1142 my $let = $letter;
1143 $let = '\0' if $letter eq '';
a0d0e21e 1144
ddf6bed1
IZ
1145 print $fh <<EOP;
1146 case '$let':
1147EOP
1148 if (@{$leading{$letter}} > 1) {
1149 # It makes sense to call a function
1150 if ($off) {
1151 print $fh <<EOP;
1152 if (!strnEQ(name + $offarg,"$leader", $off))
1153 break;
1154EOP
1155 }
1156 print $fh <<EOP;
3cb4da91 1157 return constant_$pref$leader$letter(name, len, arg);
ddf6bed1 1158EOP
7aff18a2
GS
1159 }
1160 else {
ddf6bed1
IZ
1161 # Do it ourselves
1162 my $protect
1163 = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1164
1165 print $fh <<EOP;
1166 if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
1167#ifdef $pref$leader$letter$leading{$letter}[0]
1168 return $protect$pref$leader$letter$leading{$letter}[0];
a0d0e21e
LW
1169#else
1170 goto not_there;
1171#endif
ddf6bed1
IZ
1172 }
1173EOP
a0d0e21e 1174 }
ddf6bed1
IZ
1175 }
1176 print $fh <<"END";
a0d0e21e
LW
1177 }
1178 errno = EINVAL;
1179 return 0;
1180
1181not_there:
1182 errno = ENOENT;
1183 return 0;
1184}
1185
e1666bf5 1186END
ddf6bed1 1187
e1666bf5
TB
1188}
1189
ddf6bed1
IZ
1190if( ! $opt_c ) {
1191 print XS <<"END";
1192static int
1193not_here(char *s)
1194{
1195 croak("$module::%s not implemented on this architecture", s);
1196 return -1;
1197}
1198
1199END
1200
1201 write_const(\*XS, '', 0, \@const_names);
e1666bf5
TB
1202}
1203
32fb2b78
GS
1204print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1205
3cb4da91 1206my $prefix;
ead2a595 1207$prefix = "PREFIX = $opt_p" if defined $opt_p;
3cb4da91 1208
e1666bf5
TB
1209# Now switch from C to XS by issuing the first MODULE declaration:
1210print XS <<"END";
a0d0e21e 1211
ead2a595 1212MODULE = $module PACKAGE = $module $prefix
1213
1214END
1215
1216foreach (sort keys %const_xsub) {
1217 print XS <<"END";
1218char *
1219$_()
1220
1221 CODE:
1222#ifdef $_
7aff18a2 1223 RETVAL = $_;
ead2a595 1224#else
7aff18a2 1225 croak("Your vendor has not defined the $module macro $_");
ead2a595 1226#endif
1227
1228 OUTPUT:
7aff18a2 1229 RETVAL
a0d0e21e 1230
e1666bf5 1231END
ead2a595 1232}
e1666bf5
TB
1233
1234# If a constant() function was written then output a corresponding
1235# XS declaration:
1236print XS <<"END" unless $opt_c;
1237
a0d0e21e 1238double
3cb4da91 1239constant(sv,arg)
7aff18a2 1240 PREINIT:
3cb4da91 1241 STRLEN len;
7aff18a2 1242 INPUT:
3cb4da91
IZ
1243 SV * sv
1244 char * s = SvPV(sv, len);
a0d0e21e 1245 int arg
7aff18a2 1246 CODE:
3cb4da91 1247 RETVAL = constant(s,len,arg);
7aff18a2 1248 OUTPUT:
3cb4da91 1249 RETVAL
a0d0e21e
LW
1250
1251END
a0d0e21e 1252
5273d82d 1253my %seen_decl;
ddf6bed1 1254my %typemap;
5273d82d 1255
ead2a595 1256sub print_decl {
1257 my $fh = shift;
1258 my $decl = shift;
1259 my ($type, $name, $args) = @$decl;
5273d82d
IZ
1260 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1261
ead2a595 1262 my @argnames = map {$_->[1]} @$args;
ddf6bed1 1263 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
32fb2b78
GS
1264 if ($opt_k) {
1265 s/^\s*const\b\s*// for @argtypes;
1266 }
5273d82d 1267 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595 1268 my $numargs = @$args;
1269 if ($numargs and $argtypes[-1] eq '...') {
1270 $numargs--;
1271 $argnames[-1] = '...';
1272 }
1273 local $" = ', ';
ddf6bed1
IZ
1274 $type = normalize_type($type, 1);
1275
ead2a595 1276 print $fh <<"EOP";
1277
1278$type
1279$name(@argnames)
1280EOP
1281
3cb4da91 1282 for my $arg (0 .. $numargs - 1) {
ead2a595 1283 print $fh <<"EOP";
5273d82d 1284 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595 1285EOP
1286 }
1287}
1288
32fb2b78
GS
1289sub print_tievar_subs {
1290 my($fh, $name, $type) = @_;
1291 print $fh <<END;
1292I32
1293_get_$name(IV index, SV *sv) {
1294 dSP;
1295 PUSHMARK(SP);
1296 XPUSHs(sv);
1297 PUTBACK;
1298 (void)call_pv("$module\::_get_$name", G_DISCARD);
1299 return (I32)0;
1300}
1301
1302I32
1303_set_$name(IV index, SV *sv) {
1304 dSP;
1305 PUSHMARK(SP);
1306 XPUSHs(sv);
1307 PUTBACK;
1308 (void)call_pv("$module\::_set_$name", G_DISCARD);
1309 return (I32)0;
1310}
1311
1312END
1313}
1314
1315sub print_tievar_xsubs {
1316 my($fh, $name, $type) = @_;
1317 print $fh <<END;
1318void
1319_tievar_$name(sv)
1320 SV* sv
1321 PREINIT:
1322 struct ufuncs uf;
1323 CODE:
1324 uf.uf_val = &_get_$name;
1325 uf.uf_set = &_set_$name;
1326 uf.uf_index = (IV)&_get_$name;
1327 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1328
1329void
1330_get_$name(THIS)
1331 $type THIS = NO_INIT
1332 CODE:
1333 THIS = $name;
1334 OUTPUT:
1335 SETMAGIC: DISABLE
1336 THIS
1337
1338void
1339_set_$name(THIS)
1340 $type THIS
1341 CODE:
1342 $name = THIS;
1343
1344END
1345}
1346
7c1d48a5
GS
1347sub print_accessors {
1348 my($fh, $name, $struct) = @_;
1349 return unless defined $struct && $name !~ /\s|_ANON/;
1350 $name = normalize_type($name);
1351 my $ptrname = normalize_type("$name *");
32fb2b78
GS
1352 print $fh <<"EOF";
1353
1354MODULE = $module PACKAGE = ${name} $prefix
1355
1356$name *
1357_to_ptr(THIS)
1358 $name THIS = NO_INIT
1359 PROTOTYPE: \$
1360 CODE:
1361 if (sv_derived_from(ST(0), "$name")) {
1362 STRLEN len;
1363 char *s = SvPV((SV*)SvRV(ST(0)), len);
1364 if (len != sizeof(THIS))
1365 croak("Size \%d of packed data != expected \%d",
1366 len, sizeof(THIS));
1367 RETVAL = ($name *)s;
1368 }
1369 else
1370 croak("THIS is not of type $name");
1371 OUTPUT:
1372 RETVAL
1373
1374$name
1375new(CLASS)
1376 char *CLASS = NO_INIT
1377 PROTOTYPE: \$
1378 CODE:
1379 Zero((void*)&RETVAL, sizeof(RETVAL), char);
1380 OUTPUT:
1381 RETVAL
7c1d48a5
GS
1382
1383MODULE = $module PACKAGE = ${name}Ptr $prefix
1384
1385EOF
1386 my @items = @$struct;
1387 while (@items) {
1388 my $item = shift @items;
1389 if ($item->[0] =~ /_ANON/) {
32fb2b78 1390 if (defined $item->[2]) {
7c1d48a5 1391 push @items, map [
32fb2b78 1392 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
7c1d48a5
GS
1393 ], @{ $structs{$item->[0]} };
1394 } else {
1395 push @items, @{ $structs{$item->[0]} };
1396 }
1397 } else {
1398 my $type = normalize_type($item->[0]);
32fb2b78 1399 my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
7c1d48a5 1400 print $fh <<"EOF";
32fb2b78
GS
1401$ttype
1402$item->[2](THIS, __value = NO_INIT)
7c1d48a5
GS
1403 $ptrname THIS
1404 $type __value
1405 PROTOTYPE: \$;\$
1406 CODE:
7c1d48a5
GS
1407 if (items > 1)
1408 THIS->$item->[-1] = __value;
32fb2b78
GS
1409 RETVAL = @{[
1410 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1411 ]};
7c1d48a5
GS
1412 OUTPUT:
1413 RETVAL
1414
1415EOF
1416 }
1417 }
1418}
1419
b7d5fa84
IZ
1420sub accessor_docs {
1421 my($name, $struct) = @_;
1422 return unless defined $struct && $name !~ /\s|_ANON/;
1423 $name = normalize_type($name);
1424 my $ptrname = $name . 'Ptr';
1425 my @items = @$struct;
1426 my @list;
1427 while (@items) {
1428 my $item = shift @items;
1429 if ($item->[0] =~ /_ANON/) {
1430 if (defined $item->[2]) {
1431 push @items, map [
1432 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1433 ], @{ $structs{$item->[0]} };
1434 } else {
1435 push @items, @{ $structs{$item->[0]} };
1436 }
1437 } else {
1438 push @list, $item->[2];
1439 }
1440 }
1441 my $methods = (join '(...)>, C<', @list), '(...)';
1442
1443 return <<"EOF";
1444
1445=head2 Object and class methods for C<$name>/C<$ptrname>
1446
1447The principal Perl representation of a C object of type C<$name> is an
1448object of class C<$ptrname> which is a reference to an integer
1449representation of a C pointer. To create such an object, one may use
1450a combination
1451
1452 my $buffer = $name->new();
1453 my $obj = $buf->_to_ptr();
1454
1455This exersizes the following two methods, and an additional class
1456C<$name>, the internal representation of which is a reference to a
1457packed string with the C structure. Keep in mind that $buffer should
1458better survive longer than $obj.
1459
1460=over
1461
1462=item C<\$object_of_type_$name->_to_ptr()>
1463
1464Converts an object of type C<$name> to an object of type C<$ptrname>.
1465
1466=item C<$name->new()>
1467
1468Creates an empty object of type C<$name>. The corresponding packed
1469string is zeroed out.
1470
1471=item C<$methods>
1472
1473return the current value of the corresponding element if called
1474without additional arguments. Set the element to the supplied value
1475(and return the new value) if called with an additional argument.
1476
1477Applicable to objects of type C<$ptrname>.
1478
1479=back
1480
1481EOF
1482}
1483
5273d82d
IZ
1484# Should be called before any actual call to normalize_type().
1485sub get_typemap {
1486 # We do not want to read ./typemap by obvios reasons.
1487 my @tm = qw(../../../typemap ../../typemap ../typemap);
1488 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1489 unshift @tm, $stdtypemap;
1490 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
ddf6bed1
IZ
1491
1492 # Start with useful default values
1493 $typemap{float} = 'T_DOUBLE';
1494
3cb4da91 1495 foreach my $typemap (@tm) {
5273d82d
IZ
1496 next unless -e $typemap ;
1497 # skip directories, binary files etc.
1498 warn " Scanning $typemap\n";
1499 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1500 unless -T $typemap ;
1501 open(TYPEMAP, $typemap)
1502 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1503 my $mode = 'Typemap';
1504 while (<TYPEMAP>) {
1505 next if /^\s*\#/;
1506 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1507 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1508 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1509 elsif ($mode eq 'Typemap') {
1510 next if /^\s*($|\#)/ ;
3cb4da91 1511 my ($type, $image);
ddf6bed1 1512 if ( ($type, $image) =
5273d82d
IZ
1513 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1514 # This may reference undefined functions:
1515 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
ddf6bed1 1516 $typemap{normalize_type($type)} = $image;
5273d82d
IZ
1517 }
1518 }
1519 }
1520 close(TYPEMAP) or die "Cannot close $typemap: $!";
1521 }
1522 %std_types = %types_seen;
1523 %types_seen = ();
1524}
1525
ead2a595 1526
ddf6bed1 1527sub normalize_type { # Second arg: do not strip const's before \*
ead2a595 1528 my $type = shift;
3cb4da91
IZ
1529 my $do_keep_deep_const = shift;
1530 # If $do_keep_deep_const this is heuristical only
1531 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
ddf6bed1 1532 my $ignore_mods
3cb4da91
IZ
1533 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1534 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1535 $type =~ s/$ignore_mods//go;
7aff18a2
GS
1536 }
1537 else {
3cb4da91
IZ
1538 $type =~ s/$ignore_mods//go;
1539 }
ddf6bed1 1540 $type =~ s/([^\s\w])/ \1 /g;
ead2a595 1541 $type =~ s/\s+$//;
1542 $type =~ s/^\s+//;
ddf6bed1
IZ
1543 $type =~ s/\s+/ /g;
1544 $type =~ s/\* (?=\*)/*/g;
1545 $type =~ s/\. \. \./.../g;
1546 $type =~ s/ ,/,/g;
5273d82d
IZ
1547 $types_seen{$type}++
1548 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595 1549 $type;
1550}
1551
ddf6bed1
IZ
1552my $need_opaque;
1553
1554sub assign_typemap_entry {
1555 my $type = shift;
1556 my $otype = $type;
1557 my $entry;
1558 if ($tmask and $type =~ /$tmask/) {
1559 print "Type $type matches -o mask\n" if $opt_d;
1560 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1561 }
1562 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1563 $type = normalize_type $type;
1564 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1565 $entry = assign_typemap_entry($type);
1566 }
1567 $entry ||= $typemap{$otype}
1568 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1569 $typemap{$otype} = $entry;
1570 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1571 return $entry;
1572}
1573
32fb2b78
GS
1574for (@vdecls) {
1575 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1576}
1577
ead2a595 1578if ($opt_x) {
32fb2b78
GS
1579 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1580 if ($opt_a) {
1581 while (my($name, $struct) = each %structs) {
1582 print_accessors(\*XS, $name, $struct);
7c1d48a5 1583 }
32fb2b78 1584 }
ead2a595 1585}
1586
a0d0e21e 1587close XS;
5273d82d
IZ
1588
1589if (%types_seen) {
1590 my $type;
1591 warn "Writing $ext$modpname/typemap\n";
1592 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1593
3cb4da91 1594 for $type (sort keys %types_seen) {
ddf6bed1
IZ
1595 my $entry = assign_typemap_entry $type;
1596 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
5273d82d
IZ
1597 }
1598
ddf6bed1
IZ
1599 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1600#############################################################################
1601INPUT
1602T_OPAQUE_STRUCT
1603 if (sv_derived_from($arg, \"${ntype}\")) {
1604 STRLEN len;
1605 char *s = SvPV((SV*)SvRV($arg), len);
1606
1607 if (len != sizeof($var))
1608 croak(\"Size %d of packed data != expected %d\",
1609 len, sizeof($var));
1610 $var = *($type *)s;
1611 }
1612 else
1613 croak(\"$var is not of type ${ntype}\")
1614#############################################################################
1615OUTPUT
1616T_OPAQUE_STRUCT
1617 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1618EOP
1619
5273d82d
IZ
1620 close TM or die "Cannot close typemap file for write: $!";
1621}
1622
2920c5d2 1623} # if( ! $opt_X )
e1666bf5 1624
8e07c86e
AD
1625warn "Writing $ext$modpname/Makefile.PL\n";
1626open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 1627
8bc03d0d 1628print PL <<END;
a0d0e21e
LW
1629use ExtUtils::MakeMaker;
1630# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 1631# the contents of the Makefile that is written.
8bc03d0d
GS
1632WriteMakefile(
1633 'NAME' => '$module',
1634 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
1635 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
a0d0e21e 1636END
8bc03d0d 1637if (!$opt_X) { # print C stuff, unless XS is disabled
ddf6bed1 1638 $opt_F = '' unless defined $opt_F;
8bc03d0d
GS
1639 print PL <<END;
1640 'LIBS' => ['$extralibs'], # e.g., '-lm'
1641 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1642 'INC' => '', # e.g., '-I/usr/include/other'
1643END
2920c5d2 1644}
a0d0e21e 1645print PL ");\n";
f508c652 1646close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1647
1648warn "Writing $ext$modpname/test.pl\n";
1649open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1650print EX <<'_END_';
1651# Before `make install' is performed this script should be runnable with
1652# `make test'. After `make install' it should work as `perl test.pl'
1653
1654######################### We start with some black magic to print on failure.
1655
1656# Change 1..1 below to 1..last_test_to_print .
1657# (It may become useful if the test is moved to ./t subdirectory.)
1658
5ae7f1db 1659BEGIN { $| = 1; print "1..1\n"; }
f508c652 1660END {print "not ok 1\n" unless $loaded;}
1661_END_
1662print EX <<_END_;
1663use $module;
1664_END_
1665print EX <<'_END_';
1666$loaded = 1;
1667print "ok 1\n";
1668
1669######################### End of black magic.
1670
1671# Insert your test code below (better if it prints "ok 13"
1672# (correspondingly "not ok 13") depending on the success of chunk 13
1673# of the test code):
e1666bf5 1674
f508c652 1675_END_
1676close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
a0d0e21e 1677
c0f8b9cd 1678unless ($opt_C) {
ddf6bed1
IZ
1679 warn "Writing $ext$modpname/Changes\n";
1680 $" = ' ';
1681 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1682 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1683 print EX <<EOP;
1684Revision history for Perl extension $module.
1685
1686$TEMPLATE_VERSION @{[scalar localtime]}
1687\t- original version; created by h2xs $H2XS_VERSION with options
1688\t\t@ARGS
1689
1690EOP
1691 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
c0f8b9cd 1692}
c07a80fd 1693
1694warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db 1695open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
3cb4da91 1696my @files = <*>;
5ae7f1db 1697if (!@files) {
1698 eval {opendir(D,'.');};
1699 unless ($@) { @files = readdir(D); closedir(D); }
1700}
1701if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff 1702if ($^O eq 'VMS') {
1703 foreach (@files) {
1704 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1705 s%\.$%%;
1706 # Fix up for case-sensitive file systems
1707 s/$modfname/$modfname/i && next;
1708 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 1709 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff 1710 }
1711}
3e3baf6d 1712print MANI join("\n",@files), "\n";
5ae7f1db 1713close MANI;
40000a8c 1714!NO!SUBS!
4633a7c4
LW
1715
1716close OUT or die "Can't close $file: $!";
1717chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1718exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1719chdir $origdir;