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