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