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