Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

source: for-distributions/trunk/bin/windows/perl/bin/h2xs.bat@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago
upgrading to perl 5.8
File size: 59.0 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: