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