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