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