Context Navigation

source: trunk/third/perl/utils/h2xs.PL @ 14545

Visit:

Revision 14545, 39.6 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.

Line
1	#!/usr/local/bin/perl
2
3	use Config;
4	use File::Basename qw(&basename &dirname);
5	use Cwd;
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.
16	$origdir = cwd;
17	chdir dirname($0);
18	$file = basename($0, '.PL');
19	$file .= '.com' if $^O eq 'VMS';
20
21	open OUT,">$file" or die "Can't create $file: $!";
22
23	print "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
28	print OUT <<"!GROK!THIS!";
29	$Config{startperl}
30	eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31	if \$running_under_some_shell;
32	!GROK!THIS!
33
34	# In the following, perl variables are not expanded during extraction.
35
36	print OUT <<'!NO!SUBS!';
37
38	=head1 NAME
39
40	h2xs - convert .h C header files to Perl extensions
41
42	=head1 SYNOPSIS
43
44	B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
45
46	B<h2xs> B<-h>
47
48	=head1 DESCRIPTION
49
50	I<h2xs> builds a Perl extension from C header files. The extension
51	will include functions which can be used to retrieve the value of any
52	#define statement which was in the C header files.
53
54	The I<module_name> will be used for the name of the extension. If
55	module_name is not supplied then the name of the first header file
56	will be used, with the first character capitalized.
57
58	If the extension might need extra libraries, they should be included
59	here. The extension Makefile.PL will take care of checking whether
60	the libraries actually exist and how they should be loaded.
61	The extra libraries should be specified in the form -lm -lposix, etc,
62	just as on the cc command line. By default, the Makefile.PL will
63	search through the library path determined by Configure. That path
64	can be augmented by including arguments of the form B<-L/another/library/path>
65	in the extra-libraries argument.
66
67	=head1 OPTIONS
68
69	=over 5
70
71	=item B<-A>
72
73	Omit all autoload facilities. This is the same as B<-c> but also removes the
74	S<C<use AutoLoader>> statement from the .pm file.
75
76	=item B<-C>
77
78	Omits creation of the F<Changes> file, and adds a HISTORY section to
79	the POD template.
80
81	=item B<-F>
82
83	Additional flags to specify to C preprocessor when scanning header for
84	function declarations. Should not be used without B<-x>.
85
86	=item B<-M> I<regular expression>
87
88	selects functions/macros to process.
89
90	=item B<-O>
91
92	Allows a pre-existing extension directory to be overwritten.
93
94	=item B<-P>
95
96	Omit the autogenerated stub POD section.
97
98	=item B<-X>
99
100	Omit the XS portion. Used to generate templates for a module which is not
101	XS-based. C<-c> and C<-f> are implicitly enabled.
102
103	=item B<-a>
104
105	Generate an accessor method for each element of structs and unions. The
106	generated methods are named after the element name; will return the current
107	value of the element if called without additional arguments; and will set
108	the element to the supplied value (and return the new value) if called with
109	an additional argument. Embedded structures and unions are returned as a
110	pointer rather than the complete structure, to facilitate chained calls.
111
112	These methods all apply to the Ptr type for the structure; additionally
113	two methods are constructed for the structure type itself, C<_to_ptr>
114	which returns a Ptr type pointing to the same structure, and a C<new>
115	method to construct and return a new structure, initialised to zeroes.
116
117	=item B<-c>
118
119	Omit C<constant()> from the .xs file and corresponding specialised
120	C<AUTOLOAD> from the .pm file.
121
122	=item B<-d>
123
124	Turn on debugging messages.
125
126	=item B<-f>
127
128	Allows an extension to be created for a header even if that header is
129	not found in standard include directories.
130
131	=item B<-h>
132
133	Print the usage, help and version for this h2xs and exit.
134
135	=item B<-k>
136
137	For function arguments declared as C<const>, omit the const attribute in the
138	generated XS code.
139
140	=item B<-m>
141
142	B<Experimental>: for each variable declared in the header file(s), declare
143	a perl variable of the same name magically tied to the C variable.
144
145	=item B<-n> I<module_name>
146
147	Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
148
149	=item B<-o> I<regular expression>
150
151	Use "opaque" data type for the C types matched by the regular
152	expression, even if these types are C<typedef>-equivalent to types
153	from typemaps. Should not be used without B<-x>.
154
155	This may be useful since, say, types which are C<typedef>-equivalent
156	to integers may represent OS-related handles, and one may want to work
157	with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
158	Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
159
160	The type-to-match is whitewashed (except for commas, which have no
161	whitespace before them, and multiple C<*> which have no whitespace
162	between them).
163
164	=item B<-p> I<prefix>
165
166	Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
167	This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
168	autoloaded via the C<constant()> mechanism.
169
170	=item B<-s> I<sub1,sub2>
171
172	Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
173	These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
174
175	=item B<-v> I<version>
176
177	Specify a version number for this extension. This version number is added
178	to the templates. The default is 0.01.
179
180	=item B<-x>
181
182	Automatically generate XSUBs basing on function declarations in the
183	header file. The package C<C::Scan> should be installed. If this
184	option is specified, the name of the header file may look like
185	C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
186	but XSUBs are emitted only for the declarations included from file NAME2.
187
188	Note that some types of arguments/return-values for functions may
189	result in XSUB-declarations/typemap-entries which need
190	hand-editing. Such may be objects which cannot be converted from/to a
191	pointer (like C<long long>), pointers to functions, or arrays. See
192	also the section on L<LIMITATIONS of B<-x>>.
193
194	=back
195
196	=head1 EXAMPLES
197
198
199	# Default behavior, extension is Rusers
200	h2xs rpcsvc/rusers
201
202	# Same, but extension is RUSERS
203	h2xs -n RUSERS rpcsvc/rusers
204
205	# Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
206	h2xs rpcsvc::rusers
207
208	# Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
209	h2xs -n ONC::RPC rpcsvc/rusers
210
211	# Without constant() or AUTOLOAD
212	h2xs -c rpcsvc/rusers
213
214	# Creates templates for an extension named RPC
215	h2xs -cfn RPC
216
217	# Extension is ONC::RPC.
218	h2xs -cfn ONC::RPC
219
220	# Makefile.PL will look for library -lrpc in
221	# additional directory /opt/net/lib
222	h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
223
224	# Extension is DCE::rgynbase
225	# prefix "sec_rgy_" is dropped from perl function names
226	h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
227
228	# Extension is DCE::rgynbase
229	# prefix "sec_rgy_" is dropped from perl function names
230	# subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
231	h2xs -n DCE::rgynbase -p sec_rgy_ \
232	-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
233
234	# Make XS without defines in perl.h, but with function declarations
235	# visible from perl.h. Name of the extension is perl1.
236	# When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
237	# Extra backslashes below because the string is passed to shell.
238	# Note that a directory with perl header files would
239	# be added automatically to include path.
240	h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
241
242	# Same with function declaration in proto.h as visible from perl.h.
243	h2xs -xAn perl2 perl.h,proto.h
244
245	# Same but select only functions which match /^av_/
246	h2xs -M '^av_' -xAn perl2 perl.h,proto.h
247
248	# Same but treat SV* etc as "opaque" types
249	h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
250
251	=head1 ENVIRONMENT
252
253	No environment variables are used.
254
255	=head1 AUTHOR
256
257	Larry Wall and others
258
259	=head1 SEE ALSO
260
261	L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
262
263	=head1 DIAGNOSTICS
264
265	The usual warnings if it cannot read or write the files involved.
266
267	=head1 LIMITATIONS of B<-x>
268
269	F<h2xs> would not distinguish whether an argument to a C function
270	which is of the form, say, C<int *>, is an input, output, or
271	input/output parameter. In particular, argument declarations of the
272	form
273
274	int
275	foo(n)
276	int *n
277
278	should be better rewritten as
279
280	int
281	foo(n)
282	int &n
283
284	if C<n> is an input parameter.
285
286	Additionally, F<h2xs> has no facilities to intuit that a function
287
288	int
289	foo(addr,l)
290	char *addr
291	int l
292
293	takes a pair of address and length of data at this address, so it is better
294	to rewrite this function as
295
296	int
297	foo(sv)
298	SV *addr
299	PREINIT:
300	STRLEN len;
301	char *s;
302	CODE:
303	s = SvPV(sv,len);
304	RETVAL = foo(s, len);
305	OUTPUT:
306	RETVAL
307
308	or alternately
309
310	static int
311	my_foo(SV *sv)
312	{
313	STRLEN len;
314	char *s = SvPV(sv,len);
315
316	return foo(s, len);
317	}
318
319	MODULE = foo PACKAGE = foo PREFIX = my_
320
321	int
322	foo(sv)
323	SV *sv
324
325	See L<perlxs> and L<perlxstut> for additional details.
326
327	=cut
328
329	use strict;
330
331
332	my( $H2XS_VERSION ) = ' $Revision: 1.1.1.2 $ ' =~ /\$Revision:\s+([^\s]+)/;
333	my $TEMPLATE_VERSION = '0.01';
334	my @ARGS = @ARGV;
335
336	use Getopt::Std;
337
338	sub usage{
339	warn "@_\n" if @_;
340	die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
341	version: $H2XS_VERSION
342	-A Omit all autoloading facilities (implies -c).
343	-C Omit creating the Changes file, add HISTORY heading to stub POD.
344	-F Additional flags for C preprocessor (used with -x).
345	-M Mask to select C functions/macros (default is select all).
346	-O Allow overwriting of a pre-existing extension directory.
347	-P Omit the stub POD section.
348	-X Omit the XS portion (implies both -c and -f).
349	-a Generate get/set accessors for struct and union members (used with -x).
350	-c Omit the constant() function and specialised AUTOLOAD from the XS file.
351	-d Turn on debugging messages.
352	-f Force creation of the extension even if the C header does not exist.
353	-h Display this help message
354	-k Omit 'const' attribute on function arguments (used with -x).
355	-m Generate tied variables for access to declared variables.
356	-n Specify a name to use for the extension (recommended).
357	-o Regular expression for \"opaque\" types.
358	-p Specify a prefix which should be removed from the Perl function names.
359	-s Create subroutines for specified macros.
360	-v Specify a version number for this extension.
361	-x Autogenerate XSUBs using C::Scan.
362	extra_libraries
363	are any libraries that might be needed for loading the
364	extension, e.g. -lm would try to link in the math library.
365	";
366	}
367
368
369	getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") \|\| usage;
370	use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
371	$opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
372
373	usage if $opt_h;
374
375	if( $opt_v ){
376	$TEMPLATE_VERSION = $opt_v;
377	}
378
379	# -A implies -c.
380	$opt_c = 1 if $opt_A;
381
382	# -X implies -c and -f
383	$opt_c = $opt_f = 1 if $opt_X;
384
385	my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
386	my $extralibs;
387	my @path_h;
388
389	while (my $arg = shift) {
390	if ($arg =~ /^-l/i) {
391	$extralibs = "$arg @ARGV";
392	last;
393	}
394	push(@path_h, $arg);
395	}
396
397	usage "Must supply header file or module name\n"
398	unless (@path_h or $opt_n);
399
400	my $fmask;
401	my $tmask;
402
403	$fmask = qr{$opt_M} if defined $opt_M;
404	$tmask = qr{$opt_o} if defined $opt_o;
405	my $tmask_all = $tmask && $opt_o eq '.';
406
407	if ($opt_x) {
408	eval {require C::Scan; 1}
409	or die <<EOD;
410	C::Scan required if you use -x option.
411	To install C::Scan, execute
412	perl -MCPAN -e "install C::Scan"
413	EOD
414	unless ($tmask_all) {
415	$C::Scan::VERSION >= 0.70
416	or die <<EOD;
417	C::Scan v. 0.70 or later required unless you use -o . option.
418	You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
419	To install C::Scan, execute
420	perl -MCPAN -e "install C::Scan"
421	EOD
422	}
423	if (($opt_m \|\| $opt_a) && $C::Scan::VERSION < 0.73) {
424	die <<EOD;
425	C::Scan v. 0.73 or later required to use -m or -a options.
426	You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
427	To install C::Scan, execute
428	perl -MCPAN -e "install C::Scan"
429	EOD
430	}
431	}
432	elsif ($opt_o or $opt_F) {
433	warn <<EOD;
434	Options -o and -F do not make sense without -x.
435	EOD
436	}
437
438	my @path_h_ini = @path_h;
439	my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
440
441	if( @path_h ){
442	use Config;
443	use File::Spec;
444	my @paths;
445	if ($^O eq 'VMS') { # Consider overrides of default location
446	# XXXX This is not equivalent to what the older version did:
447	# it was looking at $hadsys header-file per header-file...
448	my($hadsys) = grep s!^sys/!!i , @path_h;
449	@paths = qw( Sys$Library VAXC$Include );
450	push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
451	push @paths, qw( DECC$Library_Include DECC$System_Include );
452	}
453	else {
454	@paths = (File::Spec->curdir(), $Config{usrinc},
455	(split ' ', $Config{locincpth}), '/usr/include');
456	}
457	foreach my $path_h (@path_h) {
458	$name \|\|= $path_h;
459	if( $path_h =~ s#::#/#g && $opt_n ){
460	warn "Nesting of headerfile ignored with -n\n";
461	}
462	$path_h .= ".h" unless $path_h =~ /\.h$/;
463	my $fullpath = $path_h;
464	$path_h =~ s/,.*$// if $opt_x;
465	$fullpath{$path_h} = $fullpath;
466
467	if (not -f $path_h) {
468	my $tmp_path_h = $path_h;
469	for my $dir (@paths) {
470	last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
471	}
472	}
473
474	if (!$opt_c) {
475	die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
476	# Scan the header file (we should deal with nested header files)
477	# Record the names of simple #define constants into const_names
478	# Function prototypes are processed below.
479	open(CH, "<$path_h") \|\| die "Can't open $path_h: $!\n";
480	defines:
481	while (<CH>) {
482	if (/^[ \t]#[ \t]define\s+([\$\w]+)\b(?!\()\s(?=[^" \t])(.)/) {
483	my $def = $1;
484	my $rest = $2;
485	$rest =~ s!/\.?(\/\|\n)\|//.!!g; # Remove comments
486	$rest =~ s/^\s+//;
487	$rest =~ s/\s+$//;
488	# Cannot do: (-1) and ((LHANDLE)3) are OK:
489	#print("Skip non-wordy $def => $rest\n"),
490	# next defines if $rest =~ /[^\w\$]/;
491	if ($rest =~ /"/) {
492	print("Skip stringy $def => $rest\n") if $opt_d;
493	next defines;
494	}
495	print "Matched $_ ($def)\n" if $opt_d;
496	$seen_define{$def} = $rest;
497	$_ = $def;
498	next if /^_._h_$/i; # special case, but for what?
499	if (defined $opt_p) {
500	if (!/^$opt_p(\d)/) {
501	++$prefix{$_} if s/^$opt_p//;
502	}
503	else {
504	warn "can't remove $opt_p prefix from '$_'!\n";
505	}
506	}
507	$prefixless{$def} = $_;
508	if (!$fmask or /$fmask/) {
509	print "... Passes mask of -M.\n" if $opt_d and $fmask;
510	$const_names{$_}++;
511	}
512	}
513	}
514	close(CH);
515	}
516	}
517	}
518
519
520	my $module = $opt_n \|\| do {
521	$name =~ s/\.h$//;
522	if( $name !~ /::/ ){
523	$name =~ s#^.*/##;
524	$name = "\u$name";
525	}
526	$name;
527	};
528
529	my ($ext, $nested, @modparts, $modfname, $modpname);
530	(chdir 'ext', $ext = 'ext/') if -d 'ext';
531
532	if( $module =~ /::/ ){
533	$nested = 1;
534	@modparts = split(/::/,$module);
535	$modfname = $modparts[-1];
536	$modpname = join('/',@modparts);
537	}
538	else {
539	$nested = 0;
540	@modparts = ();
541	$modfname = $modpname = $module;
542	}
543
544
545	if ($opt_O) {
546	warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
547	}
548	else {
549	die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
550	}
551	if( $nested ){
552	my $modpath = "";
553	foreach (@modparts){
554	mkdir("$modpath$_", 0777);
555	$modpath .= "$_/";
556	}
557	}
558	mkdir($modpname, 0777);
559	chdir($modpname) \|\| die "Can't chdir $ext$modpname: $!\n";
560
561	my %types_seen;
562	my %std_types;
563	my $fdecls = [];
564	my $fdecls_parsed = [];
565	my $typedef_rex;
566	my %typedefs_pre;
567	my %known_fnames;
568	my %structs;
569
570	my @fnames;
571	my @fnames_no_prefix;
572	my %vdecl_hash;
573	my @vdecls;
574
575	if( ! $opt_X ){ # use XS, unless it was disabled
576	open(XS, ">$modfname.xs") \|\| die "Can't create $ext$modpname/$modfname.xs: $!\n";
577	if ($opt_x) {
578	require Config; # Run-time directive
579	warn "Scanning typemaps...\n";
580	get_typemap();
581	my @td;
582	my @good_td;
583	my $addflags = $opt_F \|\| '';
584
585	foreach my $filename (@path_h) {
586	my $c;
587	my $filter;
588
589	if ($fullpath{$filename} =~ /,/) {
590	$filename = $`;
591	$filter = $';
592	}
593	warn "Scanning $filename for functions...\n";
594	$c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
595	'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
596	$c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
597
598	push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
599	push(@$fdecls, @{$c->get('fdecls')});
600
601	push @td, @{$c->get('typedefs_maybe')};
602	if ($opt_a) {
603	my $structs = $c->get('typedef_structs');
604	@structs{keys %$structs} = values %$structs;
605	}
606
607	if ($opt_m) {
608	%vdecl_hash = %{ $c->get('vdecl_hash') };
609	@vdecls = sort keys %vdecl_hash;
610	for (local $_ = 0; $_ < @vdecls; ++$_) {
611	my $var = $vdecls[$_];
612	my($type, $post) = @{ $vdecl_hash{$var} };
613	if (defined $post) {
614	warn "Can't handle variable '$type $var $post', skipping.\n";
615	splice @vdecls, $_, 1;
616	redo;
617	}
618	$type = normalize_type($type);
619	$vdecl_hash{$var} = $type;
620	}
621	}
622
623	unless ($tmask_all) {
624	warn "Scanning $filename for typedefs...\n";
625	my $td = $c->get('typedef_hash');
626	# eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
627	my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
628	push @good_td, @f_good_td;
629	@typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
630	}
631	}
632	{ local $" = '\|';
633	$typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
634	}
635	%known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
636	if ($fmask) {
637	my @good;
638	for my $i (0..$#$fdecls_parsed) {
639	next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
640	push @good, $i;
641	print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
642	if $opt_d;
643	}
644	$fdecls = [@$fdecls[@good]];
645	$fdecls_parsed = [@$fdecls_parsed[@good]];
646	}
647	@fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
648	# Sort declarations:
649	{
650	my %h = map( ($_->[1], $_), @$fdecls_parsed);
651	$fdecls_parsed = [ @h{@fnames} ];
652	}
653	@fnames_no_prefix = @fnames;
654	@fnames_no_prefix
655	= sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
656	# Remove macros which expand to typedefs
657	print "Typedefs are @td.\n" if $opt_d;
658	my %td = map {($_, $_)} @td;
659	# Add some other possible but meaningless values for macros
660	for my $k (qw(char double float int long short unsigned signed void)) {
661	$td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
662	}
663	# eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
664	my $n = 0;
665	my %bad_macs;
666	while (keys %td > $n) {
667	$n = keys %td;
668	my ($k, $v);
669	while (($k, $v) = each %seen_define) {
670	# print("found '$k'=>'$v'\n"),
671	$bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
672	}
673	}
674	# Now %bad_macs contains names of bad macros
675	for my $k (keys %bad_macs) {
676	delete $const_names{$prefixless{$k}};
677	print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
678	}
679	}
680	}
681	my @const_names = sort keys %const_names;
682
683	open(PM, ">$modfname.pm") \|\| die "Can't create $ext$modpname/$modfname.pm: $!\n";
684
685	$" = "\n\t";
686	warn "Writing $ext$modpname/$modfname.pm\n";
687
688	print PM <<"END";
689	package $module;
690
691	require 5.005_62;
692	use strict;
693	use warnings;
694	END
695
696	unless( $opt_X \|\| $opt_c \|\| $opt_A ){
697	# we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
698	# will want Carp.
699	print PM <<'END';
700	use Carp;
701	END
702	}
703
704	print PM <<'END';
705
706	require Exporter;
707	END
708
709	print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
710	require DynaLoader;
711	END
712
713
714	# Are we using AutoLoader or not?
715	unless ($opt_A) { # no autoloader whatsoever.
716	unless ($opt_c) { # we're doing the AUTOLOAD
717	print PM "use AutoLoader;\n";
718	}
719	else {
720	print PM "use AutoLoader qw(AUTOLOAD);\n"
721	}
722	}
723
724	# Determine @ISA.
725	my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this.
726	$myISA .= ' DynaLoader' unless $opt_X; # no XS
727	$myISA .= ');';
728	print PM "\n$myISA\n\n";
729
730	my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
731
732	print PM<<"END";
733	# Items to export into callers namespace by default. Note: do not export
734	# names by default without a very good reason. Use EXPORT_OK instead.
735	# Do not simply export all your public functions/methods/constants.
736
737	# This allows declaration use $module ':all';
738	# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
739	# will save memory.
740	our %EXPORT_TAGS = ( 'all' => [ qw(
741	@exported_names
742	) ] );
743
744	our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
745
746	our \@EXPORT = qw(
747	@const_names
748	);
749	our \$VERSION = '$TEMPLATE_VERSION';
750
751	END
752
753	if (@vdecls) {
754	printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
755	}
756
757	print PM <<"END" unless $opt_c or $opt_X;
758	sub AUTOLOAD {
759	# This AUTOLOAD is used to 'autoload' constants from the constant()
760	# XS function. If a constant is not found then control is passed
761	# to the AUTOLOAD in AutoLoader.
762
763	my \$constname;
764	our \$AUTOLOAD;
765	(\$constname = \$AUTOLOAD) =~ s/.*:://;
766	croak "&$module::constant not defined" if \$constname eq 'constant';
767	my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
768	if (\$! != 0) {
769	if (\$! =~ /Invalid/ \|\| \$!{EINVAL}) {
770	\$AutoLoader::AUTOLOAD = \$AUTOLOAD;
771	goto &AutoLoader::AUTOLOAD;
772	}
773	else {
774	croak "Your vendor has not defined $module macro \$constname";
775	}
776	}
777	{
778	no strict 'refs';
779	# Fixed between 5.005_53 and 5.005_61
780	if (\$] >= 5.00561) {
781	*\$AUTOLOAD = sub () { \$val };
782	}
783	else {
784	*\$AUTOLOAD = sub { \$val };
785	}
786	}
787	goto &\$AUTOLOAD;
788	}
789
790	END
791
792	if( ! $opt_X ){ # print bootstrap, unless XS is disabled
793	print PM <<"END";
794	bootstrap $module \$VERSION;
795	END
796	}
797
798	# tying the variables can happen only after bootstrap
799	if (@vdecls) {
800	printf PM <<END;
801	{
802	@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
803	}
804
805	END
806	}
807
808	my $after;
809	if( $opt_P ){ # if POD is disabled
810	$after = '__END__';
811	}
812	else {
813	$after = '=cut';
814	}
815
816	print PM <<"END";
817
818	# Preloaded methods go here.
819	END
820
821	print PM <<"END" unless $opt_A;
822
823	# Autoload methods go after $after, and are processed by the autosplit program.
824	END
825
826	print PM <<"END";
827
828	1;
829	__END__
830	END
831
832	my $author = "A. U. Thor";
833	my $email = 'a.u.thor@a.galaxy.far.far.away';
834
835	my $revhist = '';
836	$revhist = <<EOT if $opt_C;
837
838	=head1 HISTORY
839
840	=over 8
841
842	=item $TEMPLATE_VERSION
843
844	Original version; created by h2xs $H2XS_VERSION with options
845
846	@ARGS
847
848	=back
849
850	EOT
851
852	my $exp_doc = <<EOD;
853
854	=head2 EXPORT
855
856	None by default.
857
858	EOD
859	if (@const_names and not $opt_P) {
860	$exp_doc .= <<EOD;
861	=head2 Exportable constants
862
863	@{[join "\n ", @const_names]}
864
865	EOD
866	}
867	if (defined $fdecls and @$fdecls and not $opt_P) {
868	$exp_doc .= <<EOD;
869	=head2 Exportable functions
870
871	EOD
872	$exp_doc .= <<EOD if $opt_p;
873	When accessing these functions from Perl, prefix C<$opt_p> should be removed.
874
875	EOD
876	$exp_doc .= <<EOD;
877	@{[join "\n ", @known_fnames{@fnames}]}
878
879	EOD
880	}
881
882	my $pod = <<"END" unless $opt_P;
883	## Below is stub documentation for your module. You better edit it!
884	#
885	#=head1 NAME
886	#
887	#$module - Perl extension for blah blah blah
888	#
889	#=head1 SYNOPSIS
890	#
891	# use $module;
892	# blah blah blah
893	#
894	#=head1 DESCRIPTION
895	#
896	#Stub documentation for $module, created by h2xs. It looks like the
897	#author of the extension was negligent enough to leave the stub
898	#unedited.
899	#
900	#Blah blah blah.
901	#$exp_doc$revhist
902	#=head1 AUTHOR
903	#
904	#$author, $email
905	#
906	#=head1 SEE ALSO
907	#
908	#perl(1).
909	#
910	#=cut
911	END
912
913	$pod =~ s/^\#//gm unless $opt_P;
914	print PM $pod unless $opt_P;
915
916	close PM;
917
918
919	if( ! $opt_X ){ # print XS, unless it is disabled
920	warn "Writing $ext$modpname/$modfname.xs\n";
921
922	print XS <<"END";
923	#include "EXTERN.h"
924	#include "perl.h"
925	#include "XSUB.h"
926
927	END
928	if( @path_h ){
929	foreach my $path_h (@path_h_ini) {
930	my($h) = $path_h;
931	$h =~ s#^/usr/include/##;
932	if ($^O eq 'VMS') { $h =~ s#.vms\]#sys/# or $h =~ s#.[:>\]]##; }
933	print XS qq{#include <$h>\n};
934	}
935	print XS "\n";
936	}
937
938	my %pointer_typedefs;
939	my %struct_typedefs;
940
941	sub td_is_pointer {
942	my $type = shift;
943	my $out = $pointer_typedefs{$type};
944	return $out if defined $out;
945	my $otype = $type;
946	$out = ($type =~ /\*$/);
947	# This converts only the guys which do not have trailing part in the typedef
948	if (not $out
949	and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
950	$type = normalize_type($type);
951	print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
952	if $opt_d;
953	$out = td_is_pointer($type);
954	}
955	return ($pointer_typedefs{$otype} = $out);
956	}
957
958	sub td_is_struct {
959	my $type = shift;
960	my $out = $struct_typedefs{$type};
961	return $out if defined $out;
962	my $otype = $type;
963	$out = ($type =~ /^(struct\|union)\b/) && !td_is_pointer($type);
964	# This converts only the guys which do not have trailing part in the typedef
965	if (not $out
966	and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
967	$type = normalize_type($type);
968	print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
969	if $opt_d;
970	$out = td_is_struct($type);
971	}
972	return ($struct_typedefs{$otype} = $out);
973	}
974
975	# Some macros will bomb if you try to return them from a double-returning func.
976	# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
977	# Fortunately, we can detect both these cases...
978	sub protect_convert_to_double {
979	my $in = shift;
980	my $val;
981	return '' unless defined ($val = $seen_define{$in});
982	return '(IV)' if $known_fnames{$val};
983	# OUT_t of ((OUT_t)-1):
984	return '' unless $val =~ /^\s(\(\s)?\(\s([^()]?)\s*\)/;
985	td_is_pointer($2) ? '(IV)' : '';
986	}
987
988	# For each of the generated functions, length($pref) leading
989	# letters are already checked. Moreover, it is recommended that
990	# the generated functions uses switch on letter at offset at least
991	# $off + length($pref).
992	#
993	# The given list has length($pref) chars removed at front, it is
994	# guarantied that $off leading chars in the rest are the same for all
995	# elts of the list.
996	#
997	# Returns: how at which offset it was decided to make a switch, or -1 if none.
998
999	sub write_const;
1000
1001	sub write_const {
1002	my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
1003	my %leading;
1004	my $offarg = length $pref;
1005
1006	if (@$list == 0) { # Can happen on the initial iteration only
1007	print $fh <<"END";
1008	static double
1009	constant(char *name, int len, int arg)
1010	{
1011	errno = EINVAL;
1012	return 0;
1013	}
1014	END
1015	return -1;
1016	}
1017
1018	if (@$list == 1) { # Can happen on the initial iteration only
1019	my $protect = protect_convert_to_double("$pref$list->[0]");
1020
1021	print $fh <<"END";
1022	static double
1023	constant(char *name, int len, int arg)
1024	{
1025	errno = 0;
1026	if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
1027	#ifdef $pref$list->[0]
1028	return $protect$pref$list->[0];
1029	#else
1030	errno = ENOENT;
1031	return 0;
1032	#endif
1033	}
1034	errno = EINVAL;
1035	return 0;
1036	}
1037	END
1038	return -1;
1039	}
1040
1041	for my $n (@$list) {
1042	my $c = substr $n, $off, 1;
1043	$leading{$c} = [] unless exists $leading{$c};
1044	push @{$leading{$c}}, substr $n, $off + 1;
1045	}
1046
1047	if (keys(%leading) == 1) {
1048	return 1 + write_const $fh, $pref, $off + 1, $list;
1049	}
1050
1051	my $leader = substr $list->[0], 0, $off;
1052	foreach my $letter (keys %leading) {
1053	write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
1054	if @{$leading{$letter}} > 1;
1055	}
1056
1057	my $npref = "_$pref";
1058	$npref = '' if $pref eq '';
1059
1060	print $fh <<"END";
1061	static double
1062	constant$npref(char *name, int len, int arg)
1063	{
1064	END
1065
1066	print $fh <<"END" if $npref eq '';
1067	errno = 0;
1068	END
1069
1070	print $fh <<"END" if $off;
1071	if ($offarg + $off >= len ) {
1072	errno = EINVAL;
1073	return 0;
1074	}
1075	END
1076
1077	print $fh <<"END";
1078	switch (name[$offarg + $off]) {
1079	END
1080
1081	foreach my $letter (sort keys %leading) {
1082	my $let = $letter;
1083	$let = '\0' if $letter eq '';
1084
1085	print $fh <<EOP;
1086	case '$let':
1087	EOP
1088	if (@{$leading{$letter}} > 1) {
1089	# It makes sense to call a function
1090	if ($off) {
1091	print $fh <<EOP;
1092	if (!strnEQ(name + $offarg,"$leader", $off))
1093	break;
1094	EOP
1095	}
1096	print $fh <<EOP;
1097	return constant_$pref$leader$letter(name, len, arg);
1098	EOP
1099	}
1100	else {
1101	# Do it ourselves
1102	my $protect
1103	= protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1104
1105	print $fh <<EOP;
1106	if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
1107	#ifdef $pref$leader$letter$leading{$letter}[0]
1108	return $protect$pref$leader$letter$leading{$letter}[0];
1109	#else
1110	goto not_there;
1111	#endif
1112	}
1113	EOP
1114	}
1115	}
1116	print $fh <<"END";
1117	}
1118	errno = EINVAL;
1119	return 0;
1120
1121	not_there:
1122	errno = ENOENT;
1123	return 0;
1124	}
1125
1126	END
1127
1128	}
1129
1130	if( ! $opt_c ) {
1131	print XS <<"END";
1132	static int
1133	not_here(char *s)
1134	{
1135	croak("$module::%s not implemented on this architecture", s);
1136	return -1;
1137	}
1138
1139	END
1140
1141	write_const(\*XS, '', 0, \@const_names);
1142	}
1143
1144	print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1145
1146	my $prefix;
1147	$prefix = "PREFIX = $opt_p" if defined $opt_p;
1148
1149	# Now switch from C to XS by issuing the first MODULE declaration:
1150	print XS <<"END";
1151
1152	MODULE = $module PACKAGE = $module $prefix
1153
1154	END
1155
1156	foreach (sort keys %const_xsub) {
1157	print XS <<"END";
1158	char *
1159	$_()
1160
1161	CODE:
1162	#ifdef $_
1163	RETVAL = $_;
1164	#else
1165	croak("Your vendor has not defined the $module macro $_");
1166	#endif
1167
1168	OUTPUT:
1169	RETVAL
1170
1171	END
1172	}
1173
1174	# If a constant() function was written then output a corresponding
1175	# XS declaration:
1176	print XS <<"END" unless $opt_c;
1177
1178	double
1179	constant(sv,arg)
1180	PREINIT:
1181	STRLEN len;
1182	INPUT:
1183	SV * sv
1184	char * s = SvPV(sv, len);
1185	int arg
1186	CODE:
1187	RETVAL = constant(s,len,arg);
1188	OUTPUT:
1189	RETVAL
1190
1191	END
1192
1193	my %seen_decl;
1194	my %typemap;
1195
1196	sub print_decl {
1197	my $fh = shift;
1198	my $decl = shift;
1199	my ($type, $name, $args) = @$decl;
1200	return if $seen_decl{$name}++; # Need to do the same for docs as well?
1201
1202	my @argnames = map {$_->[1]} @$args;
1203	my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1204	if ($opt_k) {
1205	s/^\sconst\b\s// for @argtypes;
1206	}
1207	my @argarrays = map { $_->[4] \|\| '' } @$args;
1208	my $numargs = @$args;
1209	if ($numargs and $argtypes[-1] eq '...') {
1210	$numargs--;
1211	$argnames[-1] = '...';
1212	}
1213	local $" = ', ';
1214	$type = normalize_type($type, 1);
1215
1216	print $fh <<"EOP";
1217
1218	$type
1219	$name(@argnames)
1220	EOP
1221
1222	for my $arg (0 .. $numargs - 1) {
1223	print $fh <<"EOP";
1224	$argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1225	EOP
1226	}
1227	}
1228
1229	sub print_tievar_subs {
1230	my($fh, $name, $type) = @_;
1231	print $fh <<END;
1232	I32
1233	_get_$name(IV index, SV *sv) {
1234	dSP;
1235	PUSHMARK(SP);
1236	XPUSHs(sv);
1237	PUTBACK;
1238	(void)call_pv("$module\::_get_$name", G_DISCARD);
1239	return (I32)0;
1240	}
1241
1242	I32
1243	_set_$name(IV index, SV *sv) {
1244	dSP;
1245	PUSHMARK(SP);
1246	XPUSHs(sv);
1247	PUTBACK;
1248	(void)call_pv("$module\::_set_$name", G_DISCARD);
1249	return (I32)0;
1250	}
1251
1252	END
1253	}
1254
1255	sub print_tievar_xsubs {
1256	my($fh, $name, $type) = @_;
1257	print $fh <<END;
1258	void
1259	_tievar_$name(sv)
1260	SV* sv
1261	PREINIT:
1262	struct ufuncs uf;
1263	CODE:
1264	uf.uf_val = &_get_$name;
1265	uf.uf_set = &_set_$name;
1266	uf.uf_index = (IV)&_get_$name;
1267	sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1268
1269	void
1270	_get_$name(THIS)
1271	$type THIS = NO_INIT
1272	CODE:
1273	THIS = $name;
1274	OUTPUT:
1275	SETMAGIC: DISABLE
1276	THIS
1277
1278	void
1279	_set_$name(THIS)
1280	$type THIS
1281	CODE:
1282	$name = THIS;
1283
1284	END
1285	}
1286
1287	sub print_accessors {
1288	my($fh, $name, $struct) = @_;
1289	return unless defined $struct && $name !~ /\s\|_ANON/;
1290	$name = normalize_type($name);
1291	my $ptrname = normalize_type("$name *");
1292	print $fh <<"EOF";
1293
1294	MODULE = $module PACKAGE = ${name} $prefix
1295
1296	$name *
1297	_to_ptr(THIS)
1298	$name THIS = NO_INIT
1299	PROTOTYPE: \$
1300	CODE:
1301	if (sv_derived_from(ST(0), "$name")) {
1302	STRLEN len;
1303	char s = SvPV((SV)SvRV(ST(0)), len);
1304	if (len != sizeof(THIS))
1305	croak("Size \%d of packed data != expected \%d",
1306	len, sizeof(THIS));
1307	RETVAL = ($name *)s;
1308	}
1309	else
1310	croak("THIS is not of type $name");
1311	OUTPUT:
1312	RETVAL
1313
1314	$name
1315	new(CLASS)
1316	char *CLASS = NO_INIT
1317	PROTOTYPE: \$
1318	CODE:
1319	Zero((void*)&RETVAL, sizeof(RETVAL), char);
1320	OUTPUT:
1321	RETVAL
1322
1323	MODULE = $module PACKAGE = ${name}Ptr $prefix
1324
1325	EOF
1326	my @items = @$struct;
1327	while (@items) {
1328	my $item = shift @items;
1329	if ($item->[0] =~ /_ANON/) {
1330	if (defined $item->[2]) {
1331	push @items, map [
1332	@$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1333	], @{ $structs{$item->[0]} };
1334	} else {
1335	push @items, @{ $structs{$item->[0]} };
1336	}
1337	} else {
1338	my $type = normalize_type($item->[0]);
1339	my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1340	print $fh <<"EOF";
1341	$ttype
1342	$item->[2](THIS, __value = NO_INIT)
1343	$ptrname THIS
1344	$type __value
1345	PROTOTYPE: \$;\$
1346	CODE:
1347	if (items > 1)
1348	THIS->$item->[-1] = __value;
1349	RETVAL = @{[
1350	$type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1351	]};
1352	OUTPUT:
1353	RETVAL
1354
1355	EOF
1356	}
1357	}
1358	}
1359
1360	# Should be called before any actual call to normalize_type().
1361	sub get_typemap {
1362	# We do not want to read ./typemap by obvios reasons.
1363	my @tm = qw(../../../typemap ../../typemap ../typemap);
1364	my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1365	unshift @tm, $stdtypemap;
1366	my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1367
1368	# Start with useful default values
1369	$typemap{float} = 'T_DOUBLE';
1370
1371	foreach my $typemap (@tm) {
1372	next unless -e $typemap ;
1373	# skip directories, binary files etc.
1374	warn " Scanning $typemap\n";
1375	warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1376	unless -T $typemap ;
1377	open(TYPEMAP, $typemap)
1378	or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1379	my $mode = 'Typemap';
1380	while (<TYPEMAP>) {
1381	next if /^\s*\#/;
1382	if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1383	elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1384	elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1385	elsif ($mode eq 'Typemap') {
1386	next if /^\s*($\|\#)/ ;
1387	my ($type, $image);
1388	if ( ($type, $image) =
1389	/^\s(.?\S)\s+(\S+)\s($proto_re)\s*$/o
1390	# This may reference undefined functions:
1391	and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1392	$typemap{normalize_type($type)} = $image;
1393	}
1394	}
1395	}
1396	close(TYPEMAP) or die "Cannot close $typemap: $!";
1397	}
1398	%std_types = %types_seen;
1399	%types_seen = ();
1400	}
1401
1402
1403	sub normalize_type { # Second arg: do not strip const's before \*
1404	my $type = shift;
1405	my $do_keep_deep_const = shift;
1406	# If $do_keep_deep_const this is heuristical only
1407	my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]\)' : '');
1408	my $ignore_mods
1409	= "(?:\\b(?:(?:__const__\|const)$keep_deep_const\|static\|inline\|__inline__)\\b\\s)";
1410	if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1411	$type =~ s/$ignore_mods//go;
1412	}
1413	else {
1414	$type =~ s/$ignore_mods//go;
1415	}
1416	$type =~ s/([^\s\w])/ \1 /g;
1417	$type =~ s/\s+$//;
1418	$type =~ s/^\s+//;
1419	$type =~ s/\s+/ /g;
1420	$type =~ s/\* (?=\)//g;
1421	$type =~ s/\. \. \./.../g;
1422	$type =~ s/ ,/,/g;
1423	$types_seen{$type}++
1424	unless $type eq '...' or $type eq 'void' or $std_types{$type};
1425	$type;
1426	}
1427
1428	my $need_opaque;
1429
1430	sub assign_typemap_entry {
1431	my $type = shift;
1432	my $otype = $type;
1433	my $entry;
1434	if ($tmask and $type =~ /$tmask/) {
1435	print "Type $type matches -o mask\n" if $opt_d;
1436	$entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1437	}
1438	elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1439	$type = normalize_type $type;
1440	print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1441	$entry = assign_typemap_entry($type);
1442	}
1443	$entry \|\|= $typemap{$otype}
1444	\|\| (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1445	$typemap{$otype} = $entry;
1446	$need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1447	return $entry;
1448	}
1449
1450	for (@vdecls) {
1451	print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1452	}
1453
1454	if ($opt_x) {
1455	for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1456	if ($opt_a) {
1457	while (my($name, $struct) = each %structs) {
1458	print_accessors(\*XS, $name, $struct);
1459	}
1460	}
1461	}
1462
1463	close XS;
1464
1465	if (%types_seen) {
1466	my $type;
1467	warn "Writing $ext$modpname/typemap\n";
1468	open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1469
1470	for $type (sort keys %types_seen) {
1471	my $entry = assign_typemap_entry $type;
1472	print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1473	}
1474
1475	print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1476	#############################################################################
1477	INPUT
1478	T_OPAQUE_STRUCT
1479	if (sv_derived_from($arg, \"${ntype}\")) {
1480	STRLEN len;
1481	char s = SvPV((SV)SvRV($arg), len);
1482
1483	if (len != sizeof($var))
1484	croak(\"Size %d of packed data != expected %d\",
1485	len, sizeof($var));
1486	$var = ($type )s;
1487	}
1488	else
1489	croak(\"$var is not of type ${ntype}\")
1490	#############################################################################
1491	OUTPUT
1492	T_OPAQUE_STRUCT
1493	sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1494	EOP
1495
1496	close TM or die "Cannot close typemap file for write: $!";
1497	}
1498
1499	} # if( ! $opt_X )
1500
1501	warn "Writing $ext$modpname/Makefile.PL\n";
1502	open(PL, ">Makefile.PL") \|\| die "Can't create $ext$modpname/Makefile.PL: $!\n";
1503
1504	print PL <<END;
1505	use ExtUtils::MakeMaker;
1506	# See lib/ExtUtils/MakeMaker.pm for details of how to influence
1507	# the contents of the Makefile that is written.
1508	WriteMakefile(
1509	'NAME' => '$module',
1510	'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
1511	'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
1512	END
1513	if (!$opt_X) { # print C stuff, unless XS is disabled
1514	$opt_F = '' unless defined $opt_F;
1515	print PL <<END;
1516	'LIBS' => ['$extralibs'], # e.g., '-lm'
1517	'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1518	'INC' => '', # e.g., '-I/usr/include/other'
1519	END
1520	}
1521	print PL ");\n";
1522	close(PL) \|\| die "Can't close $ext$modpname/Makefile.PL: $!\n";
1523
1524	warn "Writing $ext$modpname/test.pl\n";
1525	open(EX, ">test.pl") \|\| die "Can't create $ext$modpname/test.pl: $!\n";
1526	print EX <<'_END_';
1527	# Before `make install' is performed this script should be runnable with
1528	# `make test'. After `make install' it should work as `perl test.pl'
1529
1530	######################### We start with some black magic to print on failure.
1531
1532	# Change 1..1 below to 1..last_test_to_print .
1533	# (It may become useful if the test is moved to ./t subdirectory.)
1534
1535	BEGIN { $\| = 1; print "1..1\n"; }
1536	END {print "not ok 1\n" unless $loaded;}
1537	_END_
1538	print EX <<_END_;
1539	use $module;
1540	_END_
1541	print EX <<'_END_';
1542	$loaded = 1;
1543	print "ok 1\n";
1544
1545	######################### End of black magic.
1546
1547	# Insert your test code below (better if it prints "ok 13"
1548	# (correspondingly "not ok 13") depending on the success of chunk 13
1549	# of the test code):
1550
1551	_END_
1552	close(EX) \|\| die "Can't close $ext$modpname/test.pl: $!\n";
1553
1554	unless ($opt_C) {
1555	warn "Writing $ext$modpname/Changes\n";
1556	$" = ' ';
1557	open(EX, ">Changes") \|\| die "Can't create $ext$modpname/Changes: $!\n";
1558	@ARGS = map {/[\s\"\'\`\$*?^\|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1559	print EX <<EOP;
1560	Revision history for Perl extension $module.
1561
1562	$TEMPLATE_VERSION @{[scalar localtime]}
1563	\t- original version; created by h2xs $H2XS_VERSION with options
1564	\t\t@ARGS
1565
1566	EOP
1567	close(EX) \|\| die "Can't close $ext$modpname/Changes: $!\n";
1568	}
1569
1570	warn "Writing $ext$modpname/MANIFEST\n";
1571	open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1572	my @files = <*>;
1573	if (!@files) {
1574	eval {opendir(D,'.');};
1575	unless ($@) { @files = readdir(D); closedir(D); }
1576	}
1577	if (!@files) { @files = map {chomp && $_} `ls`; }
1578	if ($^O eq 'VMS') {
1579	foreach (@files) {
1580	# Clip trailing '.' for portability -- non-VMS OSs don't expect it
1581	s%\.$%%;
1582	# Fix up for case-sensitive file systems
1583	s/$modfname/$modfname/i && next;
1584	$_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1585	$_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1586	}
1587	}
1588	print MANI join("\n",@files), "\n";
1589	close MANI;
1590	!NO!SUBS!
1591
1592	close OUT or die "Can't close $file: $!";
1593	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1594	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1595	chdir $origdir;

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

Download in other formats: