Codebase list libextutils-parsexs-perl / 2bcb2bb
Imported Upstream version 3.030000 Harlan Lieberman-Berg 12 years ago
59 changed file(s) with 6587 addition(s) and 2413 deletion(s). Raw diff Collapse all Expand all
+65
-1
Changes less more
00 Revision history for Perl extension ExtUtils::ParseXS.
1
2 3.03 - Thu Aug 11 08:24:00 CET 2011
3
4 - Test fix: Try all @INC-derived typemap locations. (CPAN RT #70047)
5 [Mike Sheldrake]
6
7 3.02 - Thu Aug 4 18:19:00 CET 2011
8
9 - Test fix: Use File::Spec->catfile instead of catdir where appropriate.
10
11 3.01 - Thu Aug 4 17:51:00 CET 2011
12
13 - No significant changes form 3.00_05.
14
15 3.00_05 - Wed Jul 27 22:54:00 CET 2011
16
17 - Define PERL_UNUSED_ARG for pre-3.8.9 perls.
18 This should fix the tests on those perls.
19
20 3.00_04 - Wed Jul 27 22:22:00 CET 2011
21
22 - Require perl 5.8.1.
23
24 - Patches from CPAN RT #53938, #61908
25 Both of these are attempts to fix win32 problems:
26 Bug #61908 for ExtUtils-ParseXS: MSWin compilers and back-slashed paths
27 Bug #53938 for ExtUtils-ParseXS: MinGW Broken after 2.21
28
29 3.00_03 - Fri Jul 22 20:13:00 CET 2011
30
31 - Add some diagnostics when xsubpp fails to load a current-enough
32 version of ExtUtils::ParseXS. [Steffen Mueller]
33
34 - Add a check to Makefile.PL that scans @INC to determine whether
35 the new xsubpp will be shadowed by another, existing xsubpp
36 and warn the user vehemently. [Steffen Mueller]
37
38 3.00_02 - Thu Jul 14 18:00:00 CET 2011
39
40 - Move script/xsubpp back to lib/ExtUtils/xsubpp
41 The original move caused old xsubpp's to be used.
42
43 3.00_01 - Tue Jul 12 22:00:00 CET 2011
44
45 - Major refactoring of the whole code base.
46 It finally runs under 'use strict' for the first time!
47 [James Keenan, Steffen Mueller]
48
49 - Typemaps can now be embedded into XS code using a here-doc
50 like syntax and the new "TYPEMAP:" XS keyword.
51 [Steffen Mueller]
52
53 - Move typemap handling code to ExtUtils::Typemaps
54 with full object-oriented goodness. [Steffen Mueller]
55
56 - Check API compatibility when loading xs modules.
57 If on a new-enough perl, add the XS_APIVERSION_BOOTCHECK macro to
58 the _boot function of every XS module to compare it against the API
59 version the module has been compiled against. If the versions do
60 not match, an exception is thrown. [Florian Ragwitz]
61
62 - Fixed compiler warnings in XS. [Zefram]
63
64 - Spell-check [Peter J. Acklam]
165
266 2.2206 - Sun Jul 4 15:43:21 EDT 2010
367
229293
230294 - On Win32, there was a DLL file we create during testing that we
231295 couldn't delete unless we closed it first, so testing failed when
232 the deletiong was attempted. This should now work (provided the
296 the deletion was attempted. This should now work (provided the
233297 version of perl is high enough to have DynaLoader::dl_unload_file()
234298 - I'm not sure what will happen otherwise). [Steve Hay]
235299
+45
-9
MANIFEST less more
00 Changes
11 INSTALL
22 lib/ExtUtils/ParseXS.pm
3 lib/ExtUtils/ParseXS.pod
4 lib/ExtUtils/ParseXS/Constants.pm
5 lib/ExtUtils/ParseXS/CountLines.pm
6 lib/ExtUtils/ParseXS/Utilities.pm
7 lib/ExtUtils/Typemaps.pm
8 lib/ExtUtils/Typemaps/InputMap.pm
9 lib/ExtUtils/Typemaps/OutputMap.pm
10 lib/ExtUtils/Typemaps/Type.pm
311 lib/ExtUtils/xsubpp
412 Makefile.PL
5 MANIFEST
6 META.yml Module meta-data (added by MakeMaker)
13 MANIFEST This list of files
14 META.yml
715 README
8 t/basic.t
9 t/bugs/RT48104.xs
10 t/bugs/typemap
11 t/include/nscore.h
12 t/include/nsUniversalDetector.h
16 t/001-basic.t
17 t/002-more.t
18 t/003-usage.t
19 t/004-nolinenumbers.t
20 t/101-standard_typemap_locations.t
21 t/102-trim_whitespace.t
22 t/103-tidy_type.t
23 t/104-map_type.t
24 t/105-valid_proto_string.t
25 t/106-process_typemaps.t
26 t/107-make_targetable.t
27 t/108-map_type.t
28 t/109-standard_XS_defs.t
29 t/110-assign_func_args.t
30 t/111-analyze_preprocessor_statements.t
31 t/112-set_cond.t
32 t/113-check_cond_preproc_statements.t
33 t/114-blurt_death_Warn.t
34 t/501-t-compile.t
35 t/510-t-bare.t
36 t/511-t-whitespace.t
37 t/512-t-file.t
38 t/513-t-merge.t
39 t/600-t-compat.t
40 t/data/b.typemap
41 t/data/combined.typemap
42 t/data/confl_repl.typemap
43 t/data/confl_skip.typemap
44 t/data/conflicting.typemap
45 t/data/other.typemap
46 t/data/perl.typemap
47 t/data/simple.typemap
1348 t/lib/IncludeTester.pm
14 t/more.t
49 t/lib/PrimitiveCapture.pm
50 t/pseudotypemap1
1551 t/typemap
16 t/usage.t
1752 t/XSInclude.xsh
1853 t/XSMore.xs
1954 t/XSTest.pm
2055 t/XSTest.xs
2156 t/XSUsage.pm
2257 t/XSUsage.xs
58 META.json Module JSON meta-data (added by MakeMaker)
+49
-0
META.json less more
0 {
1 "abstract" : "converts Perl XS code into C code",
2 "author" : [
3 "Ken Williams <ken@mathforum.org>"
4 ],
5 "dynamic_config" : 1,
6 "generated_by" : "ExtUtils::MakeMaker version 6.58, CPAN::Meta::Converter version 2.110930",
7 "license" : [
8 "unknown"
9 ],
10 "meta-spec" : {
11 "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
12 "version" : "2"
13 },
14 "name" : "ExtUtils-ParseXS",
15 "no_index" : {
16 "directory" : [
17 "t",
18 "inc"
19 ]
20 },
21 "prereqs" : {
22 "build" : {
23 "requires" : {
24 "ExtUtils::MakeMaker" : 0
25 }
26 },
27 "configure" : {
28 "requires" : {
29 "ExtUtils::MakeMaker" : 0
30 }
31 },
32 "runtime" : {
33 "requires" : {
34 "Carp" : 0,
35 "Cwd" : 0,
36 "DynaLoader" : 0,
37 "Exporter" : 0,
38 "ExtUtils::CBuilder" : 0,
39 "File::Basename" : 0,
40 "File::Spec" : 0,
41 "Symbol" : 0,
42 "Test::More" : "0.47"
43 }
44 }
45 },
46 "release_status" : "stable",
47 "version" : "3.03"
48 }
+16
-18
META.yml less more
00 ---
11 abstract: 'converts Perl XS code into C code'
22 author:
3 - 'Ken Williams, <ken@mathforum.org>'
4 - 'David Golden, <dagolden@cpan.org>'
3 - 'Ken Williams <ken@mathforum.org>'
54 build_requires:
6 Carp: 0
7 DynaLoader: 0
8 ExtUtils::CBuilder: 0
9 Test::More: 0.47
10 generated_by: 'Module::Build version 0.3603'
11 license: perl
5 ExtUtils::MakeMaker: 0
6 configure_requires:
7 ExtUtils::MakeMaker: 0
8 dynamic_config: 1
9 generated_by: 'ExtUtils::MakeMaker version 6.58, CPAN::Meta::Converter version 2.110930'
10 license: unknown
1211 meta-spec:
1312 url: http://module-build.sourceforge.net/META-spec-v1.4.html
1413 version: 1.4
1514 name: ExtUtils-ParseXS
16 provides:
17 ExtUtils::ParseXS:
18 file: lib/ExtUtils/ParseXS.pm
19 version: 2.2206
15 no_index:
16 directory:
17 - t
18 - inc
2019 requires:
20 Carp: 0
2121 Cwd: 0
22 DynaLoader: 0
2223 Exporter: 0
24 ExtUtils::CBuilder: 0
2325 File::Basename: 0
2426 File::Spec: 0
2527 Symbol: 0
26 resources:
27 MailingList: mailto:perl5-porters@perl.org
28 bugtracker: http://rt.cpan.org/Dist/Display.html?Queue=ExtUtils-ParseXS
29 license: http://dev.perl.org/licenses/
30 repository: git://github.com/dagolden/extutils-parsexs.git
31 version: 2.2206
28 Test::More: 0.47
29 version: 3.03
+79
-21
Makefile.PL less more
0 # Note: this file was auto-generated by Module::Build::Compat version 0.3603
0 use 5.008001;
1 use strict;
2 use warnings;
13 use ExtUtils::MakeMaker;
2 WriteMakefile
3 (
4 'NAME' => 'ExtUtils::ParseXS',
5 'VERSION_FROM' => 'lib/ExtUtils/ParseXS.pm',
6 'PREREQ_PM' => {
7 'Carp' => 0,
8 'Cwd' => 0,
9 'DynaLoader' => 0,
10 'Exporter' => 0,
11 'ExtUtils::CBuilder' => 0,
12 'File::Basename' => 0,
13 'File::Spec' => 0,
14 'Symbol' => 0,
15 'Test::More' => '0.47'
16 },
17 'INSTALLDIRS' => ($] < 5.008009 ? 'site' : 'perl'),
18 'EXE_FILES' => [],
19 'PL_FILES' => {}
20 )
21 ;
4
5 use Config '%Config';
6 use File::Spec;
7
8 # It's a weirdness in ExtUtils::MakeMaker that, when searching for xsubpp,
9 # it searches @INC for $path/ExtUtils/xsubpp instead of looking for an
10 # executable in the $PATH or whatever.
11 # EU::MM will pick up whatever xsubpp is found first in @INC.
12 # Thus, we must at least warn the user when we're about to install a new
13 # xsubpp to a location that may be shadowed by an old one.
14
15 my $whereto = ($] > 5.010001 ? 'site' : 'perl');
16 my $instdir = $whereto eq 'site' ? $Config{installsitelib} : $Config{installprivlib};
17 $instdir = File::Spec->canonpath($instdir);
18
19 my $target_xsubpp = File::Spec->catfile($instdir, 'ExtUtils', 'xsubpp');
20 my @shadowing_xsubpps;
21 foreach my $dir (grep !ref, @INC) {
22 my $cpath = File::Spec->canonpath($dir);
23 my $test_xsubpp = File::Spec->catdir($cpath, 'ExtUtils', 'xsubpp');
24 last if $cpath eq $instdir or $target_xsubpp eq $test_xsubpp;
25 if (-r $test_xsubpp) {
26 push @shadowing_xsubpps, $test_xsubpp;
27 }
28 }
29 if (@shadowing_xsubpps) {
30 my $problems = join("\n ", @shadowing_xsubpps);
31 warn <<HERE;
32
33 ==========================================================
34 WARNING WARNING WARNING WARNING WARNING WARNING WARNING
35 ==========================================================
36 I detected that an old version of 'xsubpp' will shadow the
37 new, to-be-installed 'xsubpp' (which you need to install
38 XS modules) after installation.
39 This is likely because an old version was installed
40 wrongly or because your vendor patched your perl. You can
41 continue with the installation but afterwards, you may
42 have to remove all copies of 'xsubpp' that shadow this
43 one for future module installations. Failure to do so may
44 result in your being unable to install XS modules.
45 But as long as you keep this in mind, nothing is going to
46 break your system if you do nothing.
47
48 Problematic copies of 'xsubpp' found:
49 $problems
50
51 ==========================================================
52 WARNING WARNING WARNING WARNING WARNING WARNING WARNING
53 ==========================================================
54
55 HERE
56 sleep 2;
57 }
58
59 WriteMakefile(
60 'NAME' => 'ExtUtils::ParseXS',
61 'VERSION_FROM' => 'lib/ExtUtils/ParseXS.pm',
62 'PREREQ_PM' => {
63 'Carp' => 0,
64 'Cwd' => 0,
65 'DynaLoader' => 0,
66 'Exporter' => 0,
67 'ExtUtils::CBuilder' => 0,
68 'File::Basename' => 0,
69 'File::Spec' => 0,
70 'Symbol' => 0,
71 'Test::More' => '0.47'
72 },
73 ($] >= 5.005 ? ## Add these new keywords supported since 5.005
74 (ABSTRACT_FROM => 'lib/ExtUtils/ParseXS.pod',
75 AUTHOR => 'Ken Williams <ken@mathforum.org>') : ()),
76 'INSTALLDIRS' => $whereto,
77 'EXE_FILES' => ['lib/ExtUtils/xsubpp'],
78 'PL_FILES' => {}
79 );
+0
-113
README less more
0 NAME
1 ExtUtils::ParseXS - converts Perl XS code into C code
2
3 SYNOPSIS
4 use ExtUtils::ParseXS qw(process_file);
5
6 process_file( filename => 'foo.xs' );
7
8 process_file( filename => 'foo.xs',
9 output => 'bar.c',
10 'C++' => 1,
11 typemap => 'path/to/typemap',
12 hiertype => 1,
13 except => 1,
14 prototypes => 1,
15 versioncheck => 1,
16 linenumbers => 1,
17 optimize => 1,
18 prototypes => 1,
19 );
20 =head1 DESCRIPTION
21
22 "ExtUtils::ParseXS" will compile XS code into C code by embedding the
23 constructs necessary to let C functions manipulate Perl values and
24 creates the glue necessary to let Perl access those functions. The
25 compiler uses typemaps to determine how to map C function parameters and
26 variables to Perl values.
27
28 The compiler will search for typemap files called *typemap*. It will use
29 the following search path to find default typemaps, with the rightmost
30 typemap taking precedence.
31
32 ../../../typemap:../../typemap:../typemap:typemap
33
34 EXPORT
35 None by default. "process_file()" may be exported upon request.
36
37 FUNCTIONS
38 process_xs()
39 This function processes an XS file and sends output to a C file.
40 Named parameters control how the processing is done. The following
41 parameters are accepted:
42
43 C++ Adds "extern "C"" to the C code. Default is false.
44
45 hiertype
46 Retains "::" in type names so that C++ hierachical types can be
47 mapped. Default is false.
48
49 except
50 Adds exception handling stubs to the C code. Default is false.
51
52 typemap
53 Indicates that a user-supplied typemap should take precedence
54 over the default typemaps. A single typemap may be specified as
55 a string, or multiple typemaps can be specified in an array
56 reference, with the last typemap having the highest precedence.
57
58 prototypes
59 Generates prototype code for all xsubs. Default is false.
60
61 versioncheck
62 Makes sure at run time that the object file (derived from the
63 ".xs" file) and the ".pm" files have the same version number.
64 Default is true.
65
66 linenumbers
67 Adds "#line" directives to the C output so error messages will
68 look like they came from the original XS file. Default is true.
69
70 optimize
71 Enables certain optimizations. The only optimization that is
72 currently affected is the use of *target*s by the output C code
73 (see perlguts). Not optimizing may significantly slow down the
74 generated code, but this is the way xsubpp of 5.005 and earlier
75 operated. Default is to optimize.
76
77 inout
78 Enable recognition of "IN", "OUT_LIST" and "INOUT_LIST"
79 declarations. Default is true.
80
81 argtypes
82 Enable recognition of ANSI-like descriptions of function
83 signature. Default is true.
84
85 s I have no clue what this does. Strips function prefixes?
86
87 errors()
88 This function returns the number of [a certain kind of] errors
89 encountered during processing of the XS file.
90
91 AUTHOR
92 Based on xsubpp code, written by Larry Wall.
93
94 Maintained by:
95
96 * Ken Williams, <ken@mathforum.org>
97
98 * David Golden, <dagolden@cpan.org>
99
100 COPYRIGHT
101 Copyright 2002-2009 by Ken Williams, David Golden and other
102 contributors. All rights reserved.
103
104 This library is free software; you can redistribute it and/or modify it
105 under the same terms as Perl itself.
106
107 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5 Porters,
108 which was released under the same license terms.
109
110 SEE ALSO
111 perl, ExtUtils::xsubpp, ExtUtils::MakeMaker, perlxs, perlxstut.
112
+39
-0
lib/ExtUtils/ParseXS/Constants.pm less more
0 package ExtUtils::ParseXS::Constants;
1 use strict;
2 use warnings;
3 use Symbol;
4
5 =head1 NAME
6
7 ExtUtils::ParseXS::Constants - Initialization values for some globals
8
9 =head1 SYNOPSIS
10
11 use ExtUtils::ParseXS::Constants ();
12
13 $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp;
14
15 =head1 DESCRIPTION
16
17 Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its
18 supporting packages has been moved into this package so that those values can
19 be defined exactly once and then re-used in any package.
20
21 Nothing is exported. Use fully qualified variable names.
22
23 =cut
24
25 # FIXME: THESE ARE NOT CONSTANTS!
26 our @InitFileCode;
27
28 # Note that to reduce maintenance, $PrototypeRegexp is used
29 # by ExtUtils::Typemaps, too!
30 our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]";
31 our @XSKeywords = qw(
32 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
33 OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
34 VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
35 INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
36 );
37
38 1;
+50
-0
lib/ExtUtils/ParseXS/CountLines.pm less more
0 package ExtUtils::ParseXS::CountLines;
1 use strict;
2 our $SECTION_END_MARKER;
3
4 sub TIEHANDLE {
5 my ($class, $cfile, $fh) = @_;
6 $cfile =~ s/\\/\\\\/g;
7 $SECTION_END_MARKER = qq{#line --- "$cfile"};
8
9 return bless {
10 buffer => '',
11 fh => $fh,
12 line_no => 1,
13 }, $class;
14 }
15
16 sub PRINT {
17 my $self = shift;
18 for (@_) {
19 $self->{buffer} .= $_;
20 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
21 my $line = $1;
22 ++$self->{line_no};
23 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
24 print {$self->{fh}} $line;
25 }
26 }
27 }
28
29 sub PRINTF {
30 my $self = shift;
31 my $fmt = shift;
32 $self->PRINT(sprintf($fmt, @_));
33 }
34
35 sub DESTROY {
36 # Not necessary if we're careful to end with a "\n"
37 my $self = shift;
38 print {$self->{fh}} $self->{buffer};
39 }
40
41 sub UNTIE {
42 # This sub does nothing, but is necessary for references to be released.
43 }
44
45 sub end_marker {
46 return $SECTION_END_MARKER;
47 }
48
49 1;
+757
-0
lib/ExtUtils/ParseXS/Utilities.pm less more
0 package ExtUtils::ParseXS::Utilities;
1 use strict;
2 use warnings;
3 use Exporter;
4 use File::Spec;
5 use lib qw( lib );
6 use ExtUtils::ParseXS::Constants ();
7
8 our (@ISA, @EXPORT_OK);
9 @ISA = qw(Exporter);
10 @EXPORT_OK = qw(
11 standard_typemap_locations
12 trim_whitespace
13 tidy_type
14 C_string
15 valid_proto_string
16 process_typemaps
17 make_targetable
18 map_type
19 standard_XS_defs
20 assign_func_args
21 analyze_preprocessor_statements
22 set_cond
23 Warn
24 current_line_number
25 blurt
26 death
27 check_conditional_preprocessor_statements
28 );
29
30 =head1 NAME
31
32 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
33
34 =head1 SYNOPSIS
35
36 use ExtUtils::ParseXS::Utilities qw(
37 standard_typemap_locations
38 trim_whitespace
39 tidy_type
40 C_string
41 valid_proto_string
42 process_typemaps
43 make_targetable
44 map_type
45 standard_XS_defs
46 assign_func_args
47 analyze_preprocessor_statements
48 set_cond
49 Warn
50 blurt
51 death
52 check_conditional_preprocessor_statements
53 );
54
55 =head1 SUBROUTINES
56
57 The following functions are not considered to be part of the public interface.
58 They are documented here for the benefit of future maintainers of this module.
59
60 =head2 C<standard_typemap_locations()>
61
62 =over 4
63
64 =item * Purpose
65
66 Provide a list of filepaths where F<typemap> files may be found. The
67 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
68
69 The highest priority is to look in the current directory.
70
71 'typemap'
72
73 The second and third highest priorities are to look in the parent of the
74 current directory and a directory called F<lib/ExtUtils> underneath the parent
75 directory.
76
77 '../typemap',
78 '../lib/ExtUtils/typemap',
79
80 The fourth through ninth highest priorities are to look in the corresponding
81 grandparent, great-grandparent and great-great-grandparent directories.
82
83 '../../typemap',
84 '../../lib/ExtUtils/typemap',
85 '../../../typemap',
86 '../../../lib/ExtUtils/typemap',
87 '../../../../typemap',
88 '../../../../lib/ExtUtils/typemap',
89
90 The tenth and subsequent priorities are to look in directories named
91 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
92 I<provided> a file named F<typemap> actually exists in such a directory.
93 Example:
94
95 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
96
97 However, these filepaths appear in the list returned by
98 C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
99
100 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
101 '../../../../lib/ExtUtils/typemap',
102 '../../../../typemap',
103 '../../../lib/ExtUtils/typemap',
104 '../../../typemap',
105 '../../lib/ExtUtils/typemap',
106 '../../typemap',
107 '../lib/ExtUtils/typemap',
108 '../typemap',
109 'typemap'
110
111 =item * Arguments
112
113 my @stl = standard_typemap_locations( \@INC );
114
115 Reference to C<@INC>.
116
117 =item * Return Value
118
119 Array holding list of directories to be searched for F<typemap> files.
120
121 =back
122
123 =cut
124
125 sub standard_typemap_locations {
126 my $include_ref = shift;
127 my @tm = qw(typemap);
128
129 my $updir = File::Spec->updir();
130 foreach my $dir (
131 File::Spec->catdir(($updir) x 1),
132 File::Spec->catdir(($updir) x 2),
133 File::Spec->catdir(($updir) x 3),
134 File::Spec->catdir(($updir) x 4),
135 ) {
136 unshift @tm, File::Spec->catfile($dir, 'typemap');
137 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
138 }
139 foreach my $dir (@{ $include_ref}) {
140 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
141 unshift @tm, $file if -e $file;
142 }
143 return @tm;
144 }
145
146 =head2 C<trim_whitespace()>
147
148 =over 4
149
150 =item * Purpose
151
152 Perform an in-place trimming of leading and trailing whitespace from the
153 first argument provided to the function.
154
155 =item * Argument
156
157 trim_whitespace($arg);
158
159 =item * Return Value
160
161 None. Remember: this is an I<in-place> modification of the argument.
162
163 =back
164
165 =cut
166
167 sub trim_whitespace {
168 $_[0] =~ s/^\s+|\s+$//go;
169 }
170
171 =head2 C<tidy_type()>
172
173 =over 4
174
175 =item * Purpose
176
177 Rationalize any asterisks (C<*>) by joining them into bunches, removing
178 interior whitespace, then trimming leading and trailing whitespace.
179
180 =item * Arguments
181
182 ($ret_type) = tidy_type($_);
183
184 String to be cleaned up.
185
186 =item * Return Value
187
188 String cleaned up.
189
190 =back
191
192 =cut
193
194 sub tidy_type {
195 local ($_) = @_;
196
197 # rationalise any '*' by joining them into bunches and removing whitespace
198 s#\s*(\*+)\s*#$1#g;
199 s#(\*+)# $1 #g;
200
201 # change multiple whitespace into a single space
202 s/\s+/ /g;
203
204 # trim leading & trailing whitespace
205 trim_whitespace($_);
206
207 $_;
208 }
209
210 =head2 C<C_string()>
211
212 =over 4
213
214 =item * Purpose
215
216 Escape backslashes (C<\>) in prototype strings.
217
218 =item * Arguments
219
220 $ProtoThisXSUB = C_string($_);
221
222 String needing escaping.
223
224 =item * Return Value
225
226 Properly escaped string.
227
228 =back
229
230 =cut
231
232 sub C_string {
233 my($string) = @_;
234
235 $string =~ s[\\][\\\\]g;
236 $string;
237 }
238
239 =head2 C<valid_proto_string()>
240
241 =over 4
242
243 =item * Purpose
244
245 Validate prototype string.
246
247 =item * Arguments
248
249 String needing checking.
250
251 =item * Return Value
252
253 Upon success, returns the same string passed as argument.
254
255 Upon failure, returns C<0>.
256
257 =back
258
259 =cut
260
261 sub valid_proto_string {
262 my($string) = @_;
263
264 if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
265 return $string;
266 }
267
268 return 0;
269 }
270
271 =head2 C<process_typemaps()>
272
273 =over 4
274
275 =item * Purpose
276
277 Process all typemap files.
278
279 =item * Arguments
280
281 my $typemaps_object = process_typemaps( $args{typemap}, $pwd );
282
283 List of two elements: C<typemap> element from C<%args>; current working
284 directory.
285
286 =item * Return Value
287
288 Upon success, returns an L<ExtUtils::Typemaps> object.
289
290 =back
291
292 =cut
293
294 sub process_typemaps {
295 my ($tmap, $pwd) = @_;
296
297 my @tm = ref $tmap ? @{$tmap} : ($tmap);
298
299 foreach my $typemap (@tm) {
300 die "Can't find $typemap in $pwd\n" unless -r $typemap;
301 }
302
303 push @tm, standard_typemap_locations( \@INC );
304
305 require ExtUtils::Typemaps;
306 my $typemap = ExtUtils::Typemaps->new;
307 foreach my $typemap_loc (@tm) {
308 next unless -f $typemap_loc;
309 # skip directories, binary files etc.
310 warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
311 unless -T $typemap_loc;
312
313 $typemap->merge(file => $typemap_loc, replace => 1);
314 }
315
316 return $typemap;
317 }
318
319 =head2 C<make_targetable()>
320
321 =over 4
322
323 =item * Purpose
324
325 Populate C<%targetable>. This constitutes a refinement of the output of
326 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
327
328 =item * Arguments
329
330 %targetable = make_targetable($output_expr_ref);
331
332 Single hash reference: the fourth such ref returned by C<process_typemaps()>.
333
334 =item * Return Value
335
336 Hash.
337
338 =back
339
340 =cut
341
342 sub make_targetable {
343 my $output_expr_ref = shift;
344
345 our $bal; # ()-balanced
346 $bal = qr[
347 (?:
348 (?>[^()]+)
349 |
350 \( (??{ $bal }) \)
351 )*
352 ]x;
353
354 # matches variations on (SV*)
355 my $sv_cast = qr[
356 (?:
357 \( \s* SV \s* \* \s* \) \s*
358 )?
359 ]x;
360
361 my $size = qr[ # Third arg (to setpvn)
362 , \s* (??{ $bal })
363 ]x;
364
365 my %targetable;
366 foreach my $key (keys %{ $output_expr_ref }) {
367 # We can still bootstrap compile 're', because in code re.pm is
368 # available to miniperl, and does not attempt to load the XS code.
369 use re 'eval';
370
371 my ($type, $with_size, $arg, $sarg) =
372 ($output_expr_ref->{$key} =~
373 m[^
374 \s+
375 sv_set([iunp])v(n)? # Type, is_setpvn
376 \s*
377 \( \s*
378 $sv_cast \$arg \s* , \s*
379 ( (??{ $bal }) ) # Set from
380 ( (??{ $size }) )? # Possible sizeof set-from
381 \) \s* ; \s* $
382 ]x
383 );
384 $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
385 }
386 return %targetable;
387 }
388
389 =head2 C<map_type()>
390
391 =over 4
392
393 =item * Purpose
394
395 Performs a mapping at several places inside C<PARAGRAPH> loop.
396
397 =item * Arguments
398
399 $type = map_type($self, $type, $varname);
400
401 List of three arguments.
402
403 =item * Return Value
404
405 String holding augmented version of second argument.
406
407 =back
408
409 =cut
410
411 sub map_type {
412 my ($self, $type, $varname) = @_;
413
414 # C++ has :: in types too so skip this
415 $type =~ tr/:/_/ unless $self->{hiertype};
416 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
417 if ($varname) {
418 if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
419 (substr $type, pos $type, 0) = " $varname ";
420 }
421 else {
422 $type .= "\t$varname";
423 }
424 }
425 return $type;
426 }
427
428 =head2 C<standard_XS_defs()>
429
430 =over 4
431
432 =item * Purpose
433
434 Writes to the C<.c> output file certain preprocessor directives and function
435 headers needed in all such files.
436
437 =item * Arguments
438
439 None.
440
441 =item * Return Value
442
443 Returns true.
444
445 =back
446
447 =cut
448
449 sub standard_XS_defs {
450 print <<"EOF";
451 #ifndef PERL_UNUSED_VAR
452 # define PERL_UNUSED_VAR(var) if (0) var = var
453 #endif
454
455 EOF
456
457 print <<"EOF";
458 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
459 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
460
461 /* prototype to pass -Wmissing-prototypes */
462 STATIC void
463 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
464
465 STATIC void
466 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
467 {
468 const GV *const gv = CvGV(cv);
469
470 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
471
472 if (gv) {
473 const char *const gvname = GvNAME(gv);
474 const HV *const stash = GvSTASH(gv);
475 const char *const hvname = stash ? HvNAME(stash) : NULL;
476
477 if (hvname)
478 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
479 else
480 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
481 } else {
482 /* Pants. I don't think that it should be possible to get here. */
483 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
484 }
485 }
486 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
487
488 #ifdef PERL_IMPLICIT_CONTEXT
489 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
490 #else
491 #define croak_xs_usage S_croak_xs_usage
492 #endif
493
494 #endif
495
496 /* NOTE: the prototype of newXSproto() is different in versions of perls,
497 * so we define a portable version of newXSproto()
498 */
499 #ifdef newXS_flags
500 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
501 #else
502 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
503 #endif /* !defined(newXS_flags) */
504
505 EOF
506 return 1;
507 }
508
509 =head2 C<assign_func_args()>
510
511 =over 4
512
513 =item * Purpose
514
515 Perform assignment to the C<func_args> attribute.
516
517 =item * Arguments
518
519 $string = assign_func_args($self, $argsref, $class);
520
521 List of three elements. Second is an array reference; third is a string.
522
523 =item * Return Value
524
525 String.
526
527 =back
528
529 =cut
530
531 sub assign_func_args {
532 my ($self, $argsref, $class) = @_;
533 my @func_args = @{$argsref};
534 shift @func_args if defined($class);
535
536 for my $arg (@func_args) {
537 $arg =~ s/^/&/ if $self->{in_out}->{$arg};
538 }
539 return join(", ", @func_args);
540 }
541
542 =head2 C<analyze_preprocessor_statements()>
543
544 =over 4
545
546 =item * Purpose
547
548 Within each function inside each Xsub, print to the F<.c> output file certain
549 preprocessor statements.
550
551 =item * Arguments
552
553 ( $self, $XSS_work_idx, $BootCode_ref ) =
554 analyze_preprocessor_statements(
555 $self, $statement, $XSS_work_idx, $BootCode_ref
556 );
557
558 List of four elements.
559
560 =item * Return Value
561
562 Modifed values of three of the arguments passed to the function. In
563 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
564
565 =back
566
567 =cut
568
569 sub analyze_preprocessor_statements {
570 my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
571
572 if ($statement eq 'if') {
573 $XSS_work_idx = @{ $self->{XSStack} };
574 push(@{ $self->{XSStack} }, {type => 'if'});
575 }
576 else {
577 $self->death("Error: `$statement' with no matching `if'")
578 if $self->{XSStack}->[-1]{type} ne 'if';
579 if ($self->{XSStack}->[-1]{varname}) {
580 push(@{ $self->{InitFileCode} }, "#endif\n");
581 push(@{ $BootCode_ref }, "#endif");
582 }
583
584 my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
585 if ($statement ne 'endif') {
586 # Hide the functions defined in other #if branches, and reset.
587 @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
588 @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
589 }
590 else {
591 my($tmp) = pop(@{ $self->{XSStack} });
592 0 while (--$XSS_work_idx
593 && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
594 # Keep all new defined functions
595 push(@fns, keys %{$tmp->{other_functions}});
596 @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
597 }
598 }
599 return ($self, $XSS_work_idx, $BootCode_ref);
600 }
601
602 =head2 C<set_cond()>
603
604 =over 4
605
606 =item * Purpose
607
608 =item * Arguments
609
610 =item * Return Value
611
612 =back
613
614 =cut
615
616 sub set_cond {
617 my ($ellipsis, $min_args, $num_args) = @_;
618 my $cond;
619 if ($ellipsis) {
620 $cond = ($min_args ? qq(items < $min_args) : 0);
621 }
622 elsif ($min_args == $num_args) {
623 $cond = qq(items != $min_args);
624 }
625 else {
626 $cond = qq(items < $min_args || items > $num_args);
627 }
628 return $cond;
629 }
630
631 =head2 C<current_line_number()>
632
633 =over 4
634
635 =item * Purpose
636
637 Figures out the current line number in the XS file.
638
639 =item * Arguments
640
641 C<$self>
642
643 =item * Return Value
644
645 The current line number.
646
647 =back
648
649 =cut
650
651 sub current_line_number {
652 my $self = shift;
653 my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
654 return $line_number;
655 }
656
657 =head2 C<Warn()>
658
659 =over 4
660
661 =item * Purpose
662
663 =item * Arguments
664
665 =item * Return Value
666
667 =back
668
669 =cut
670
671 sub Warn {
672 my $self = shift;
673 my $warn_line_number = $self->current_line_number();
674 print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
675 }
676
677 =head2 C<blurt()>
678
679 =over 4
680
681 =item * Purpose
682
683 =item * Arguments
684
685 =item * Return Value
686
687 =back
688
689 =cut
690
691 sub blurt {
692 my $self = shift;
693 $self->Warn(@_);
694 $self->{errors}++
695 }
696
697 =head2 C<death()>
698
699 =over 4
700
701 =item * Purpose
702
703 =item * Arguments
704
705 =item * Return Value
706
707 =back
708
709 =cut
710
711 sub death {
712 my $self = shift;
713 $self->Warn(@_);
714 exit 1;
715 }
716
717 =head2 C<check_conditional_preprocessor_statements()>
718
719 =over 4
720
721 =item * Purpose
722
723 =item * Arguments
724
725 =item * Return Value
726
727 =back
728
729 =cut
730
731 sub check_conditional_preprocessor_statements {
732 my ($self) = @_;
733 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
734 if (@cpp) {
735 my $cpplevel;
736 for my $cpp (@cpp) {
737 if ($cpp =~ /^\#\s*if/) {
738 $cpplevel++;
739 }
740 elsif (!$cpplevel) {
741 $self->Warn("Warning: #else/elif/endif without #if in this function");
742 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
743 if $self->{XSStack}->[-1]{type} eq 'if';
744 return;
745 }
746 elsif ($cpp =~ /^\#\s*endif/) {
747 $cpplevel--;
748 }
749 }
750 $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
751 }
752 }
753
754 1;
755
756 # vim: ts=2 sw=2 et:
+1461
-1709
lib/ExtUtils/ParseXS.pm less more
00 package ExtUtils::ParseXS;
1
2 use 5.006; # We use /??{}/ in regexes
1 use strict;
2
3 use 5.008001; # We use /??{}/ in regexes
34 use Cwd;
45 use Config;
6 use Exporter;
57 use File::Basename;
68 use File::Spec;
79 use Symbol;
8
9 require Exporter;
10
11 @ISA = qw(Exporter);
12 @EXPORT_OK = qw(process_file);
13
14 # use strict; # One of these days...
15
16 my(@XSStack); # Stack of conditionals and INCLUDEs
17 my($XSS_work_idx, $cpp_next_tmp);
18
19 use vars qw($VERSION);
20 $VERSION = '2.2206';
10 use ExtUtils::ParseXS::Constants ();
11 use ExtUtils::ParseXS::CountLines;
12 use ExtUtils::ParseXS::Utilities qw(
13 standard_typemap_locations
14 trim_whitespace
15 tidy_type
16 C_string
17 valid_proto_string
18 process_typemaps
19 make_targetable
20 map_type
21 standard_XS_defs
22 assign_func_args
23 analyze_preprocessor_statements
24 set_cond
25 Warn
26 current_line_number
27 blurt
28 death
29 check_conditional_preprocessor_statements
30 );
31
32 our @ISA = qw(Exporter);
33 our @EXPORT_OK = qw(
34 process_file
35 report_error_count
36 );
37 our $VERSION = '3.03';
2138 $VERSION = eval $VERSION if $VERSION =~ /_/;
2239
23 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
24 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
25 $WantOptimize $process_inout $process_argtypes @tm
26 $dir $filename $filepathname %IncludedFiles
27 %type_kind %proto_letter
28 %targetable $BLOCK_re $lastline $lastline_no
29 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
30 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
31 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
32 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
33 @line_no $ret_type $func_header $orig_args
34 ); # Add these just to get compilation to happen.
35
40 # The scalars in the line below remain as 'our' variables because pulling
41 # them into $self led to build problems. In most cases, strings being
42 # 'eval'-ed contain the variables' names hard-coded.
43 our (
44 $Package, $func_name, $Full_func_name, $pname, $ALIAS,
45 );
46
47 our $self = bless {} => __PACKAGE__;
3648
3749 sub process_file {
38
50
3951 # Allow for $package->process_file(%hash) in the future
40 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
41
42 $ProtoUsed = exists $args{prototypes};
43
52 my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_);
53
54 $self->{ProtoUsed} = exists $options{prototypes};
55
4456 # Set defaults.
45 %args = (
46 # 'C++' => 0, # Doesn't seem to *do* anything...
47 hiertype => 0,
48 except => 0,
49 prototypes => 0,
50 versioncheck => 1,
51 linenumbers => 1,
52 optimize => 1,
53 prototypes => 0,
54 inout => 1,
55 argtypes => 1,
56 typemap => [],
57 output => \*STDOUT,
58 csuffix => '.c',
59 %args,
60 );
57 my %args = (
58 argtypes => 1,
59 csuffix => '.c',
60 except => 0,
61 hiertype => 0,
62 inout => 1,
63 linenumbers => 1,
64 optimize => 1,
65 output => \*STDOUT,
66 prototypes => 0,
67 typemap => [],
68 versioncheck => 1,
69 FH => Symbol::gensym(),
70 %options,
71 );
72 $args{except} = $args{except} ? ' TRY' : '';
6173
6274 # Global Constants
63
75
6476 my ($Is_VMS, $SymSet);
6577 if ($^O eq 'VMS') {
6678 $Is_VMS = 1;
6779 # Establish set of global symbols with max length 28, since xsubpp
6880 # will later add the 'XS_' prefix.
6981 require ExtUtils::XSSymSet;
70 $SymSet = new ExtUtils::XSSymSet 28;
71 }
72 @XSStack = ({type => 'none'});
73 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
74 @InitFileCode = ();
75 $FH = Symbol::gensym();
76 $proto_re = "[" . quotemeta('\$%&*@;[]_') . "]" ;
77 $Overload = 0;
78 $errors = 0;
79 $Fallback = '&PL_sv_undef';
82 $SymSet = ExtUtils::XSSymSet->new(28);
83 }
84 @{ $self->{XSStack} } = ({type => 'none'});
85 $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
86 $self->{Overload} = 0;
87 $self->{errors} = 0;
88 $self->{Fallback} = '&PL_sv_undef';
8089
8190 # Most of the 1500 lines below uses these globals. We'll have to
8291 # clean this up sometime, probably. For now, we just pull them out
8392 # of %args. -Ken
84
85 $cplusplus = $args{'C++'};
86 $hiertype = $args{hiertype};
87 $WantPrototypes = $args{prototypes};
88 $WantVersionChk = $args{versioncheck};
89 $except = $args{except} ? ' TRY' : '';
90 $WantLineNumbers = $args{linenumbers};
91 $WantOptimize = $args{optimize};
92 $process_inout = $args{inout};
93 $process_argtypes = $args{argtypes};
94 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
95
96 for ($args{filename}) {
97 die "Missing required parameter 'filename'" unless $_;
98 $filepathname = $_;
99 ($dir, $filename) = (dirname($_), basename($_));
100 $filepathname =~ s/\\/\\\\/g;
101 $IncludedFiles{$_}++;
102 }
103
104 # Open the input file
105 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
93
94 $self->{hiertype} = $args{hiertype};
95 $self->{WantPrototypes} = $args{prototypes};
96 $self->{WantVersionChk} = $args{versioncheck};
97 $self->{WantLineNumbers} = $args{linenumbers};
98 $self->{IncludedFiles} = {};
99
100 die "Missing required parameter 'filename'" unless $args{filename};
101 $self->{filepathname} = $args{filename};
102 ($self->{dir}, $self->{filename}) =
103 (dirname($args{filename}), basename($args{filename}));
104 $self->{filepathname} =~ s/\\/\\\\/g;
105 $self->{IncludedFiles}->{$args{filename}}++;
106106
107107 # Open the output file if given as a string. If they provide some
108108 # other kind of reference, trust them that we can print to it.
113113 }
114114
115115 # Really, we shouldn't have to chdir() or select() in the first
116 # place. For now, just save & restore.
116 # place. For now, just save and restore.
117117 my $orig_cwd = cwd();
118118 my $orig_fh = select();
119
120 chdir($dir);
119
120 chdir($self->{dir});
121121 my $pwd = cwd();
122122 my $csuffix = $args{csuffix};
123
124 if ($WantLineNumbers) {
123
124 if ($self->{WantLineNumbers}) {
125125 my $cfile;
126126 if ( $args{outfile} ) {
127127 $cfile = $args{outfile};
128 } else {
128 }
129 else {
129130 $cfile = $args{filename};
130131 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
131132 }
132133 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
133134 select PSEUDO_STDOUT;
134 } else {
135 }
136 else {
135137 select $args{output};
136138 }
137139
138 foreach my $typemap (@tm) {
139 die "Can't find $typemap in $pwd\n" unless -r $typemap;
140 }
141
142 push @tm, standard_typemap_locations();
143
144 foreach my $typemap (@tm) {
145 next unless -f $typemap ;
146 # skip directories, binary files etc.
147 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
148 unless -T $typemap ;
149 open(TYPEMAP, $typemap)
150 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
151 my $mode = 'Typemap';
152 my $junk = "" ;
153 my $current = \$junk;
154 while (<TYPEMAP>) {
155 next if /^\s* #/;
156 my $line_no = $. + 1;
157 if (/^INPUT\s*$/) {
158 $mode = 'Input'; $current = \$junk; next;
159 }
160 if (/^OUTPUT\s*$/) {
161 $mode = 'Output'; $current = \$junk; next;
162 }
163 if (/^TYPEMAP\s*$/) {
164 $mode = 'Typemap'; $current = \$junk; next;
165 }
166 if ($mode eq 'Typemap') {
167 chomp;
168 my $line = $_ ;
169 TrimWhitespace($_) ;
170 # skip blank lines and comment lines
171 next if /^$/ or /^#/ ;
172 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
173 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
174 $type = TidyType($type) ;
175 $type_kind{$type} = $kind ;
176 # prototype defaults to '$'
177 $proto = "\$" unless $proto ;
178 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
179 unless ValidProtoString($proto) ;
180 $proto_letter{$type} = C_string($proto) ;
181 } elsif (/^\s/) {
182 $$current .= $_;
183 } elsif ($mode eq 'Input') {
184 s/\s+$//;
185 $input_expr{$_} = '';
186 $current = \$input_expr{$_};
187 } else {
188 s/\s+$//;
189 $output_expr{$_} = '';
190 $current = \$output_expr{$_};
191 }
192 }
193 close(TYPEMAP);
194 }
195
196 foreach my $value (values %input_expr) {
197 $value =~ s/;*\s+\z//;
198 # Move C pre-processor instructions to column 1 to be strictly ANSI
199 # conformant. Some pre-processors are fussy about this.
200 $value =~ s/^\s+#/#/mg;
201 }
202 foreach my $value (values %output_expr) {
203 # And again.
204 $value =~ s/^\s+#/#/mg;
205 }
206
207 my ($cast, $size);
208 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
209 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
210 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
211
212 foreach my $key (keys %output_expr) {
213 # We can still bootstrap compile 're', because in code re.pm is
214 # available to miniperl, and does not attempt to load the XS code.
215 use re 'eval';
216
217 my ($t, $with_size, $arg, $sarg) =
218 ($output_expr{$key} =~
219 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
220 \s* \( \s* $cast \$arg \s* ,
221 \s* ( (??{ $bal }) ) # Set from
222 ( (??{ $size }) )? # Possible sizeof set-from
223 \) \s* ; \s* $
224 ]x);
225 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
226 }
227
228 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
140 $self->{typemap} = process_typemaps( $args{typemap}, $pwd );
141
142 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
229143
230144 # Match an XS keyword
231 $BLOCK_re= '\s*(' . join('|', qw(
232 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
233 OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
234 VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
235 INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
236 )) . "|$END)\\s*:";
237
238
145 $self->{BLOCK_re} = '\s*(' .
146 join('|' => @ExtUtils::ParseXS::Constants::XSKeywords) .
147 "|$END)\\s*:";
148
239149 our ($C_group_rex, $C_arg);
240150 # Group in C (no support for comments or literals)
241151 $C_group_rex = qr/ [({\[]
242 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
243 [)}\]] /x ;
152 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
153 [)}\]] /x;
244154 # Chunk in C without comma at toplevel (no comments):
245155 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
246 | (??{ $C_group_rex })
247 | " (?: (?> [^\\"]+ )
248 | \\.
249 )* " # String literal
250 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
251 )* /xs;
252
156 | (??{ $C_group_rex })
157 | " (?: (?> [^\\"]+ )
158 | \\.
159 )* " # String literal
160 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
161 )* /xs;
162
163 # Since at this point we're ready to begin printing to the output file and
164 # reading from the input file, I want to get as much data as possible into
165 # the proto-object $self. That means assigning to $self and elements of
166 # %args referenced below this point.
167 # HOWEVER: This resulted in an error when I tried:
168 # $args{'s'} ---> $self->{s}.
169 # Use of uninitialized value in quotemeta at
170 # .../blib/lib/ExtUtils/ParseXS.pm line 733
171
172 foreach my $datum ( qw| argtypes except inout optimize | ) {
173 $self->{$datum} = $args{$datum};
174 }
175
253176 # Identify the version of xsubpp used
254 print <<EOM ;
177 print <<EOM;
255178 /*
256179 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
257 * contents of $filename. Do not edit this file, edit $filename instead.
180 * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead.
258181 *
259 * ANY CHANGES MADE HERE WILL BE LOST!
182 * ANY CHANGES MADE HERE WILL BE LOST!
260183 *
261184 */
262185
263186 EOM
264187
265188
266 print("#line 1 \"$filepathname\"\n")
267 if $WantLineNumbers;
189 print("#line 1 \"$self->{filepathname}\"\n")
190 if $self->{WantLineNumbers};
191
192 # Open the input file (using $self->{filename} which
193 # is a basename'd $args{filename} due to chdir above)
194 open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n";
268195
269196 firstmodule:
270 while (<$FH>) {
197 while (readline($self->{FH})) {
271198 if (/^=/) {
272199 my $podstartline = $.;
273200 do {
274 if (/^=cut\s*$/) {
275 # We can't just write out a /* */ comment, as our embedded
276 # POD might itself be in a comment. We can't put a /**/
277 # comment inside #if 0, as the C standard says that the source
278 # file is decomposed into preprocessing characters in the stage
279 # before preprocessing commands are executed.
280 # I don't want to leave the text as barewords, because the spec
281 # isn't clear whether macros are expanded before or after
282 # preprocessing commands are executed, and someone pathological
283 # may just have defined one of the 3 words as a macro that does
284 # something strange. Multiline strings are illegal in C, so
285 # the "" we write must be a string literal. And they aren't
286 # concatenated until 2 steps later, so we are safe.
287 # - Nicholas Clark
288 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
289 printf("#line %d \"$filepathname\"\n", $. + 1)
290 if $WantLineNumbers;
291 next firstmodule
292 }
293
294 } while (<$FH>);
201 if (/^=cut\s*$/) {
202 # We can't just write out a /* */ comment, as our embedded
203 # POD might itself be in a comment. We can't put a /**/
204 # comment inside #if 0, as the C standard says that the source
205 # file is decomposed into preprocessing characters in the stage
206 # before preprocessing commands are executed.
207 # I don't want to leave the text as barewords, because the spec
208 # isn't clear whether macros are expanded before or after
209 # preprocessing commands are executed, and someone pathological
210 # may just have defined one of the 3 words as a macro that does
211 # something strange. Multiline strings are illegal in C, so
212 # the "" we write must be a string literal. And they aren't
213 # concatenated until 2 steps later, so we are safe.
214 # - Nicholas Clark
215 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
216 printf("#line %d \"$self->{filepathname}\"\n", $. + 1)
217 if $self->{WantLineNumbers};
218 next firstmodule
219 }
220
221 } while (readline($self->{FH}));
295222 # At this point $. is at end of file so die won't state the start
296223 # of the problem, and as we haven't yet read any lines &death won't
297224 # show the correct line in the message either.
298 die ("Error: Unterminated pod in $filename, line $podstartline\n")
299 unless $lastline;
300 }
301 last if ($Package, $Prefix) =
225 die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n")
226 unless $self->{lastline};
227 }
228 last if ($Package, $self->{Prefix}) =
302229 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
303
230
304231 print $_;
305232 }
306233 unless (defined $_) {
308235 exit 0; # Not a fatal error for the caller process
309236 }
310237
311 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
312
313 print <<"EOF";
314 #ifndef PERL_UNUSED_VAR
315 # define PERL_UNUSED_VAR(var) if (0) var = var
316 #endif
317
318 EOF
319
320 print <<"EOF";
321 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
322 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
323
324 /* prototype to pass -Wmissing-prototypes */
325 STATIC void
326 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
327
328 STATIC void
329 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
330 {
331 const GV *const gv = CvGV(cv);
332
333 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
334
335 if (gv) {
336 const char *const gvname = GvNAME(gv);
337 const HV *const stash = GvSTASH(gv);
338 const char *const hvname = stash ? HvNAME(stash) : NULL;
339
340 if (hvname)
341 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
342 else
343 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
344 } else {
345 /* Pants. I don't think that it should be possible to get here. */
346 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
347 }
348 }
349 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
350
351 #ifdef PERL_IMPLICIT_CONTEXT
352 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
353 #else
354 #define croak_xs_usage S_croak_xs_usage
355 #endif
356
357 #endif
358
359 /* NOTE: the prototype of newXSproto() is different in versions of perls,
360 * so we define a portable version of newXSproto()
361 */
362 #ifdef newXS_flags
363 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
364 #else
365 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
366 #endif /* !defined(newXS_flags) */
367
368 EOF
369
370 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
371
372 $lastline = $_;
373 $lastline_no = $.;
374
238 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
239
240 standard_XS_defs();
241
242 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
243
244 $self->{lastline} = $_;
245 $self->{lastline_no} = $.;
246
247 my $BootCode_ref = [];
248 my $XSS_work_idx = 0;
249 my $cpp_next_tmp = 'XSubPPtmpAAAA';
375250 PARAGRAPH:
376 while (fetch_para()) {
251 while ($self->fetch_para()) {
252 my $outlist_ref = [];
377253 # Print initial preprocessor statements and blank lines
378 while (@line && $line[0] !~ /^[^\#]/) {
379 my $line = shift(@line);
380 print $line, "\n";
381 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
254 while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) {
255 my $ln = shift(@{ $self->{line} });
256 print $ln, "\n";
257 next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
382258 my $statement = $+;
383 if ($statement eq 'if') {
384 $XSS_work_idx = @XSStack;
385 push(@XSStack, {type => 'if'});
386 } else {
387 death ("Error: `$statement' with no matching `if'")
388 if $XSStack[-1]{type} ne 'if';
389 if ($XSStack[-1]{varname}) {
390 push(@InitFileCode, "#endif\n");
391 push(@BootCode, "#endif");
392 }
393
394 my(@fns) = keys %{$XSStack[-1]{functions}};
395 if ($statement ne 'endif') {
396 # Hide the functions defined in other #if branches, and reset.
397 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
398 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
399 } else {
400 my($tmp) = pop(@XSStack);
401 0 while (--$XSS_work_idx
402 && $XSStack[$XSS_work_idx]{type} ne 'if');
403 # Keep all new defined functions
404 push(@fns, keys %{$tmp->{other_functions}});
405 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
406 }
407 }
408 }
409
410 next PARAGRAPH unless @line;
411
412 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
259 ( $self, $XSS_work_idx, $BootCode_ref ) =
260 analyze_preprocessor_statements(
261 $self, $statement, $XSS_work_idx, $BootCode_ref
262 );
263 }
264
265 next PARAGRAPH unless @{ $self->{line} };
266
267 if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) {
413268 # We are inside an #if, but have not yet #defined its xsubpp variable.
414269 print "#define $cpp_next_tmp 1\n\n";
415 push(@InitFileCode, "#if $cpp_next_tmp\n");
416 push(@BootCode, "#if $cpp_next_tmp");
417 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
418 }
419
420 death ("Code is not inside a function"
421 ." (maybe last function was ended by a blank line "
422 ." followed by a statement on column one?)")
423 if $line[0] =~ /^\s/;
424
425 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
426 my (@fake_INPUT_pre); # For length(s) generated variables
427 my (@fake_INPUT);
428
270 push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n");
271 push(@{ $BootCode_ref }, "#if $cpp_next_tmp");
272 $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++;
273 }
274
275 $self->death(
276 "Code is not inside a function"
277 ." (maybe last function was ended by a blank line "
278 ." followed by a statement on column one?)")
279 if $self->{line}->[0] =~ /^\s/;
280
429281 # initialize info arrays
430 undef(%args_match);
431 undef(%var_types);
432 undef(%defaults);
433 undef(%arg_list) ;
434 undef(@proto_arg) ;
435 undef($processing_arg_with_types) ;
436 undef(%argtype_seen) ;
437 undef(@outlist) ;
438 undef(%in_out) ;
439 undef(%lengthof) ;
440 undef($proto_in_this_xsub) ;
441 undef($scope_in_this_xsub) ;
442 undef($interface);
443 undef($prepush_done);
444 $interface_macro = 'XSINTERFACE_FUNC' ;
445 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
446 $ProtoThisXSUB = $WantPrototypes ;
447 $ScopeThisXSUB = 0;
448 $xsreturn = 0;
449
450 $_ = shift(@line);
451 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
452 &{"${kwd}_handler"}() ;
453 next PARAGRAPH unless @line ;
454 $_ = shift(@line);
455 }
456
457 if (check_keyword("BOOT")) {
458 &check_cpp;
459 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
460 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
461 push (@BootCode, @line, "") ;
462 next PARAGRAPH ;
463 }
464
282 foreach my $member (qw(args_match var_types defaults arg_list
283 argtype_seen in_out lengthof))
284 {
285 $self->{$member} = {};
286 }
287 $self->{proto_arg} = [];
288 $self->{processing_arg_with_types} = undef;
289 $self->{proto_in_this_xsub} = undef;
290 $self->{scope_in_this_xsub} = undef;
291 $self->{interface} = undef;
292 $self->{interface_macro} = 'XSINTERFACE_FUNC';
293 $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
294 $self->{ProtoThisXSUB} = $self->{WantPrototypes};
295 $self->{ScopeThisXSUB} = 0;
296
297 my $xsreturn = 0;
298
299 $_ = shift(@{ $self->{line} });
300 while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
301 my $method = $kwd . "_handler";
302 $self->$method($_);
303 next PARAGRAPH unless @{ $self->{line} };
304 $_ = shift(@{ $self->{line} });
305 }
306
307 if ($self->check_keyword("BOOT")) {
308 check_conditional_preprocessor_statements($self);
309 push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"$self->{filepathname}\"")
310 if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/;
311 push (@{ $BootCode_ref }, @{ $self->{line} }, "");
312 next PARAGRAPH;
313 }
465314
466315 # extract return type, function name and arguments
467 ($ret_type) = TidyType($_);
468 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
316 ($self->{ret_type}) = tidy_type($_);
317 my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
469318
470319 # Allow one-line ANSI-like declaration
471 unshift @line, $2
472 if $process_argtypes
473 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
320 unshift @{ $self->{line} }, $2
321 if $self->{argtypes}
322 and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
474323
475324 # a function definition needs at least 2 lines
476 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
477 unless @line ;
478
479 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
480 $static = 1 if $ret_type =~ s/^static\s+//;
481
482 $func_header = shift(@line);
483 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
325 $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
326 unless @{ $self->{line} };
327
328 my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
329 my $static = 1 if $self->{ret_type} =~ s/^static\s+//;
330
331 my $func_header = shift(@{ $self->{line} });
332 $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
484333 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
485334
486 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
335 my ($class, $orig_args);
336 ($class, $func_name, $orig_args) = ($1, $2, $3);
487337 $class = "$4 $class" if $4;
488 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
489 ($clean_func_name = $func_name) =~ s/^$Prefix//;
490 $Full_func_name = "${Packid}_$clean_func_name";
338 ($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/;
339 my $clean_func_name;
340 ($clean_func_name = $func_name) =~ s/^$self->{Prefix}//;
341 $Full_func_name = "$self->{Packid}_$clean_func_name";
491342 if ($Is_VMS) {
492343 $Full_func_name = $SymSet->addsym($Full_func_name);
493344 }
494345
495346 # Check for duplicate function definition
496 for my $tmp (@XSStack) {
347 for my $tmp (@{ $self->{XSStack} }) {
497348 next unless defined $tmp->{functions}{$Full_func_name};
498 Warn("Warning: duplicate function definition '$clean_func_name' detected");
349 Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected");
499350 last;
500351 }
501 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
502 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
503 $DoSetMagic = 1;
504
505 $orig_args =~ s/\\\s*/ /g; # process line continuations
352 $self->{XSStack}->[$XSS_work_idx]{functions}{$Full_func_name}++;
353 %{ $self->{XsubAliases} } = ();
354 %{ $self->{XsubAliasValues} } = ();
355 %{ $self->{Interfaces} } = ();
356 @{ $self->{Attributes} } = ();
357 $self->{DoSetMagic} = 1;
358
359 $orig_args =~ s/\\\s*/ /g; # process line continuations
506360 my @args;
507361
508 my %only_C_inlist; # Not in the signature of Perl function
509 if ($process_argtypes and $orig_args =~ /\S/) {
362 my (@fake_INPUT_pre); # For length(s) generated variables
363 my (@fake_INPUT);
364 my $only_C_inlist_ref = {}; # Not in the signature of Perl function
365 if ($self->{argtypes} and $orig_args =~ /\S/) {
510366 my $args = "$orig_args ,";
511367 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
512 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
513 for ( @args ) {
514 s/^\s+//;
515 s/\s+$//;
516 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
517 my ($pre, $name) = ($arg =~ /(.*?) \s*
518 \b ( \w+ | length\( \s*\w+\s* \) )
519 \s* $ /x);
520 next unless defined($pre) && length($pre);
521 my $out_type = '';
522 my $inout_var;
523 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
524 my $type = $1;
525 $out_type = $type if $type ne 'IN';
526 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
527 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
528 }
529 my $islength;
530 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
531 $name = "XSauto_length_of_$1";
532 $islength = 1;
533 die "Default value on length() argument: `$_'"
534 if length $default;
535 }
536 if (length $pre or $islength) { # Has a type
537 if ($islength) {
538 push @fake_INPUT_pre, $arg;
539 } else {
540 push @fake_INPUT, $arg;
541 }
542 # warn "pushing '$arg'\n";
543 $argtype_seen{$name}++;
544 $_ = "$name$default"; # Assigns to @args
545 }
546 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
547 push @outlist, $name if $out_type =~ /OUTLIST$/;
548 $in_out{$name} = $out_type if $out_type;
549 }
550 } else {
551 @args = split(/\s*,\s*/, $orig_args);
552 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
553 }
554 } else {
368 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
369 for ( @args ) {
370 s/^\s+//;
371 s/\s+$//;
372 my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x);
373 my ($pre, $len_name) = ($arg =~ /(.*?) \s*
374 \b ( \w+ | length\( \s*\w+\s* \) )
375 \s* $ /x);
376 next unless defined($pre) && length($pre);
377 my $out_type = '';
378 my $inout_var;
379 if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
380 my $type = $1;
381 $out_type = $type if $type ne 'IN';
382 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
383 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
384 }
385 my $islength;
386 if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) {
387 $len_name = "XSauto_length_of_$1";
388 $islength = 1;
389 die "Default value on length() argument: `$_'"
390 if length $default;
391 }
392 if (length $pre or $islength) { # Has a type
393 if ($islength) {
394 push @fake_INPUT_pre, $arg;
395 }
396 else {
397 push @fake_INPUT, $arg;
398 }
399 # warn "pushing '$arg'\n";
400 $self->{argtype_seen}->{$len_name}++;
401 $_ = "$len_name$default"; # Assigns to @args
402 }
403 $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength;
404 push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/;
405 $self->{in_out}->{$len_name} = $out_type if $out_type;
406 }
407 }
408 else {
409 @args = split(/\s*,\s*/, $orig_args);
410 Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split");
411 }
412 }
413 else {
555414 @args = split(/\s*,\s*/, $orig_args);
556415 for (@args) {
557 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
558 my $out_type = $1;
559 next if $out_type eq 'IN';
560 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
561 push @outlist, $name if $out_type =~ /OUTLIST$/;
562 $in_out{$_} = $out_type;
563 }
416 if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
417 my $out_type = $1;
418 next if $out_type eq 'IN';
419 $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST";
420 if ($out_type =~ /OUTLIST$/) {
421 push @{ $outlist_ref }, undef;
422 }
423 $self->{in_out}->{$_} = $out_type;
424 }
564425 }
565426 }
566427 if (defined($class)) {
567428 my $arg0 = ((defined($static) or $func_name eq 'new')
568 ? "CLASS" : "THIS");
429 ? "CLASS" : "THIS");
569430 unshift(@args, $arg0);
570431 }
571432 my $extra_args = 0;
572 @args_num = ();
573 $num_args = 0;
433 my @args_num = ();
434 my $num_args = 0;
574435 my $report_args = '';
436 my $ellipsis;
575437 foreach my $i (0 .. $#args) {
576438 if ($args[$i] =~ s/\.\.\.//) {
577 $ellipsis = 1;
578 if ($args[$i] eq '' && $i == $#args) {
579 $report_args .= ", ...";
580 pop(@args);
581 last;
582 }
583 }
584 if ($only_C_inlist{$args[$i]}) {
585 push @args_num, undef;
586 } else {
587 push @args_num, ++$num_args;
588 $report_args .= ", $args[$i]";
439 $ellipsis = 1;
440 if ($args[$i] eq '' && $i == $#args) {
441 $report_args .= ", ...";
442 pop(@args);
443 last;
444 }
445 }
446 if ($only_C_inlist_ref->{$args[$i]}) {
447 push @args_num, undef;
448 }
449 else {
450 push @args_num, ++$num_args;
451 $report_args .= ", $args[$i]";
589452 }
590453 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
591 $extra_args++;
592 $args[$i] = $1;
593 $defaults{$args[$i]} = $2;
594 $defaults{$args[$i]} =~ s/"/\\"/g;
595 }
596 $proto_arg[$i+1] = '$' ;
597 }
598 $min_args = $num_args - $extra_args;
454 $extra_args++;
455 $args[$i] = $1;
456 $self->{defaults}->{$args[$i]} = $2;
457 $self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
458 }
459 $self->{proto_arg}->[$i+1] = '$';
460 }
461 my $min_args = $num_args - $extra_args;
599462 $report_args =~ s/"/\\"/g;
600463 $report_args =~ s/^,\s+//;
601 my @func_args = @args;
602 shift @func_args if defined($class);
603
604 for (@func_args) {
605 s/^/&/ if $in_out{$_};
606 }
607 $func_args = join(", ", @func_args);
608 @args_match{@args} = @args_num;
609
610 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
611 $CODE = grep(/^\s*CODE\s*:/, @line);
464 $self->{func_args} = assign_func_args($self, \@args, $class);
465 @{ $self->{args_match} }{@args} = @args_num;
466
467 my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} });
468 my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} });
612469 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
613 # to set explicit return values.
614 $EXPLICIT_RETURN = ($CODE &&
615 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
616 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
617 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
470 # to set explicit return values.
471 my $EXPLICIT_RETURN = ($CODE &&
472 ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
473
474 # The $ALIAS which follows is only explicitly called within the scope of
475 # process_file(). In principle, it ought to be a lexical, i.e., 'my
476 # $ALIAS' like the other nearby variables. However, implementing that
477 # change produced a slight difference in the resulting .c output in at
478 # least two distributions: B/BD/BDFOY/Crypt-Rijndael and
479 # G/GF/GFUJI/Hash-FieldHash. The difference is, arguably, an improvement
480 # in the resulting C code. Example:
481 # 388c388
482 # < GvNAME(CvGV(cv)),
483 # ---
484 # > "Crypt::Rijndael::encrypt",
485 # But at this point we're committed to generating the *same* C code that
486 # the current version of ParseXS.pm does. So we're declaring it as 'our'.
487 $ALIAS = grep(/^\s*ALIAS\s*:/, @{ $self->{line} });
488
489 my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} });
618490
619491 $xsreturn = 1 if $EXPLICIT_RETURN;
620492
632504 # dXSARGS;
633505 ##endif
634506 EOF
635 print Q(<<"EOF") if $ALIAS ;
507 print Q(<<"EOF") if $ALIAS;
636508 # dXSI32;
637509 EOF
638 print Q(<<"EOF") if $INTERFACE ;
639 # dXSFUNCTION($ret_type);
640 EOF
641 if ($ellipsis) {
642 $cond = ($min_args ? qq(items < $min_args) : 0);
643 } elsif ($min_args == $num_args) {
644 $cond = qq(items != $min_args);
645 } else {
646 $cond = qq(items < $min_args || items > $num_args);
647 }
648
649 print Q(<<"EOF") if $except;
510 print Q(<<"EOF") if $INTERFACE;
511 # dXSFUNCTION($self->{ret_type});
512 EOF
513
514 $self->{cond} = set_cond($ellipsis, $min_args, $num_args);
515
516 print Q(<<"EOF") if $self->{except};
650517 # char errbuf[1024];
651518 # *errbuf = '\0';
652519 EOF
653520
654 if($cond) {
655 print Q(<<"EOF");
656 # if ($cond)
521 if($self->{cond}) {
522 print Q(<<"EOF");
523 # if ($self->{cond})
657524 # croak_xs_usage(cv, "$report_args");
658525 EOF
659 } else {
526 }
527 else {
660528 # cv likely to be unused
661529 print Q(<<"EOF");
662530 # PERL_UNUSED_VAR(cv); /* -W */
678546
679547 # Now do a block of some sort.
680548
681 $condnum = 0;
682 $cond = ''; # last CASE: condidional
683 push(@line, "$END:");
684 push(@line_no, $line_no[-1]);
549 $self->{condnum} = 0;
550 $self->{cond} = ''; # last CASE: conditional
551 push(@{ $self->{line} }, "$END:");
552 push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
685553 $_ = '';
686 &check_cpp;
687 while (@line) {
688 &CASE_handler if check_keyword("CASE");
554 check_conditional_preprocessor_statements();
555 while (@{ $self->{line} }) {
556 $self->CASE_handler($_) if $self->check_keyword("CASE");
689557 print Q(<<"EOF");
690 # $except [[
558 # $self->{except} [[
691559 EOF
692560
693561 # do initialization of input variables
694 $thisdone = 0;
695 $retvaldone = 0;
696 $deferred = "";
697 %arg_list = () ;
698 $gotRETVAL = 0;
699
700 INPUT_handler() ;
701 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
702
703 print Q(<<"EOF") if $ScopeThisXSUB;
562 $self->{thisdone} = 0;
563 $self->{retvaldone} = 0;
564 $self->{deferred} = "";
565 %{ $self->{arg_list} } = ();
566 $self->{gotRETVAL} = 0;
567
568 $self->INPUT_handler($_);
569 $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
570
571 print Q(<<"EOF") if $self->{ScopeThisXSUB};
704572 # ENTER;
705573 # [[
706574 EOF
707
708 if (!$thisdone && defined($class)) {
709 if (defined($static) or $func_name eq 'new') {
710 print "\tchar *";
711 $var_types{"CLASS"} = "char *";
712 &generate_init("char *", 1, "CLASS");
713 }
714 else {
715 print "\t$class *";
716 $var_types{"THIS"} = "$class *";
717 &generate_init("$class *", 1, "THIS");
718 }
719 }
720
575
576 if (!$self->{thisdone} && defined($class)) {
577 if (defined($static) or $func_name eq 'new') {
578 print "\tchar *";
579 $self->{var_types}->{"CLASS"} = "char *";
580 generate_init( {
581 type => "char *",
582 num => 1,
583 var => "CLASS",
584 printed_name => undef,
585 } );
586 }
587 else {
588 print "\t$class *";
589 $self->{var_types}->{"THIS"} = "$class *";
590 generate_init( {
591 type => "$class *",
592 num => 1,
593 var => "THIS",
594 printed_name => undef,
595 } );
596 }
597 }
598
599 my ($wantRETVAL);
721600 # do code
722601 if (/^\s*NOT_IMPLEMENTED_YET/) {
723 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
724 $_ = '' ;
725 } else {
726 if ($ret_type ne "void") {
727 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
728 if !$retvaldone;
729 $args_match{"RETVAL"} = 0;
730 $var_types{"RETVAL"} = $ret_type;
731 print "\tdXSTARG;\n"
732 if $WantOptimize and $targetable{$type_kind{$ret_type}};
733 }
734
735 if (@fake_INPUT or @fake_INPUT_pre) {
736 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
737 $_ = "";
738 $processing_arg_with_types = 1;
739 INPUT_handler() ;
740 }
741 print $deferred;
742
743 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
744
745 if (check_keyword("PPCODE")) {
746 print_section();
747 death ("PPCODE must be last thing") if @line;
748 print "\tLEAVE;\n" if $ScopeThisXSUB;
749 print "\tPUTBACK;\n\treturn;\n";
750 } elsif (check_keyword("CODE")) {
751 print_section() ;
752 } elsif (defined($class) and $func_name eq "DESTROY") {
753 print "\n\t";
754 print "delete THIS;\n";
755 } else {
756 print "\n\t";
757 if ($ret_type ne "void") {
758 print "RETVAL = ";
759 $wantRETVAL = 1;
760 }
761 if (defined($static)) {
762 if ($func_name eq 'new') {
763 $func_name = "$class";
764 } else {
765 print "${class}::";
766 }
767 } elsif (defined($class)) {
768 if ($func_name eq 'new') {
769 $func_name .= " $class";
770 } else {
771 print "THIS->";
772 }
773 }
774 $func_name =~ s/^\Q$args{'s'}//
775 if exists $args{'s'};
776 $func_name = 'XSFUNCTION' if $interface;
777 print "$func_name($func_args);\n";
778 }
779 }
780
602 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
603 $_ = '';
604 }
605 else {
606 if ($self->{ret_type} ne "void") {
607 print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n"
608 if !$self->{retvaldone};
609 $self->{args_match}->{"RETVAL"} = 0;
610 $self->{var_types}->{"RETVAL"} = $self->{ret_type};
611 my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
612 print "\tdXSTARG;\n"
613 if $self->{optimize} and $outputmap and $outputmap->targetable;
614 }
615
616 if (@fake_INPUT or @fake_INPUT_pre) {
617 unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_;
618 $_ = "";
619 $self->{processing_arg_with_types} = 1;
620 $self->INPUT_handler($_);
621 }
622 print $self->{deferred};
623
624 $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
625
626 if ($self->check_keyword("PPCODE")) {
627 $self->print_section();
628 $self->death("PPCODE must be last thing") if @{ $self->{line} };
629 print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
630 print "\tPUTBACK;\n\treturn;\n";
631 }
632 elsif ($self->check_keyword("CODE")) {
633 $self->print_section();
634 }
635 elsif (defined($class) and $func_name eq "DESTROY") {
636 print "\n\t";
637 print "delete THIS;\n";
638 }
639 else {
640 print "\n\t";
641 if ($self->{ret_type} ne "void") {
642 print "RETVAL = ";
643 $wantRETVAL = 1;
644 }
645 if (defined($static)) {
646 if ($func_name eq 'new') {
647 $func_name = "$class";
648 }
649 else {
650 print "${class}::";
651 }
652 }
653 elsif (defined($class)) {
654 if ($func_name eq 'new') {
655 $func_name .= " $class";
656 }
657 else {
658 print "THIS->";
659 }
660 }
661 $func_name =~ s/^\Q$args{'s'}//
662 if exists $args{'s'};
663 $func_name = 'XSFUNCTION' if $self->{interface};
664 print "$func_name($self->{func_args});\n";
665 }
666 }
667
781668 # do output variables
782 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
783 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
669 $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section;
670 undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section);
784671 # $wantRETVAL set if 'RETVAL =' autogenerated
785 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
786 undef %outargs ;
787 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
788
789 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
790 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
791
672 ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
673 undef %{ $self->{outargs} };
674 $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
675
676 generate_output( {
677 type => $self->{var_types}->{$_},
678 num => $self->{args_match}->{$_},
679 var => $_,
680 do_setmagic => $self->{DoSetMagic},
681 do_push => undef,
682 } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} };
683
684 my $prepush_done;
792685 # all OUTPUT done, so now push the return value on the stack
793 if ($gotRETVAL && $RETVAL_code) {
794 print "\t$RETVAL_code\n";
795 } elsif ($gotRETVAL || $wantRETVAL) {
796 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
797 my $var = 'RETVAL';
798 my $type = $ret_type;
799
800 # 0: type, 1: with_size, 2: how, 3: how_size
801 if ($t and not $t->[1] and $t->[0] eq 'p') {
802 # PUSHp corresponds to setpvn. Treate setpv directly
803 my $what = eval qq("$t->[2]");
804 warn $@ if $@;
805
806 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
807 $prepush_done = 1;
808 }
809 elsif ($t) {
810 my $what = eval qq("$t->[2]");
811 warn $@ if $@;
812
813 my $size = $t->[3];
814 $size = '' unless defined $size;
815 $size = eval qq("$size");
816 warn $@ if $@;
817 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
818 $prepush_done = 1;
819 }
820 else {
821 # RETVAL almost never needs SvSETMAGIC()
822 &generate_output($ret_type, 0, 'RETVAL', 0);
823 }
824 }
825
826 $xsreturn = 1 if $ret_type ne "void";
686 if ($self->{gotRETVAL} && $self->{RETVAL_code}) {
687 print "\t$self->{RETVAL_code}\n";
688 }
689 elsif ($self->{gotRETVAL} || $wantRETVAL) {
690 my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
691 my $t = $self->{optimize} && $outputmap && $outputmap->targetable;
692 # Although the '$var' declared in the next line is never explicitly
693 # used within this 'elsif' block, commenting it out leads to
694 # disaster, starting with the first 'eval qq' inside the 'elsif' block
695 # below.
696 # It appears that this is related to the fact that at this point the
697 # value of $t is a reference to an array whose [2] element includes
698 # '$var' as a substring:
699 # <i> <> <(IV)$var>
700 my $var = 'RETVAL';
701 my $type = $self->{ret_type};
702
703 if ($t and not $t->{with_size} and $t->{type} eq 'p') {
704 # PUSHp corresponds to setpvn. Treat setpv directly
705 my $what = eval qq("$t->{what}");
706 warn $@ if $@;
707
708 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
709 $prepush_done = 1;
710 }
711 elsif ($t) {
712 my $what = eval qq("$t->{what}");
713 warn $@ if $@;
714
715 my $tsize = $t->{what_size};
716 $tsize = '' unless defined $tsize;
717 $tsize = eval qq("$tsize");
718 warn $@ if $@;
719 print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n";
720 $prepush_done = 1;
721 }
722 else {
723 # RETVAL almost never needs SvSETMAGIC()
724 generate_output( {
725 type => $self->{ret_type},
726 num => 0,
727 var => 'RETVAL',
728 do_setmagic => 0,
729 do_push => undef,
730 } );
731 }
732 }
733
734 $xsreturn = 1 if $self->{ret_type} ne "void";
827735 my $num = $xsreturn;
828 my $c = @outlist;
736 my $c = @{ $outlist_ref };
829737 print "\tXSprePUSH;" if $c and not $prepush_done;
830738 print "\tEXTEND(SP,$c);\n" if $c;
831739 $xsreturn += $c;
832 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
833
740 generate_output( {
741 type => $self->{var_types}->{$_},
742 num => $num++,
743 var => $_,
744 do_setmagic => 0,
745 do_push => 1,
746 } ) for @{ $outlist_ref };
747
834748 # do cleanup
835 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
836
837 print Q(<<"EOF") if $ScopeThisXSUB;
749 $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
750
751 print Q(<<"EOF") if $self->{ScopeThisXSUB};
838752 # ]]
839753 EOF
840 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
754 print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE;
841755 # LEAVE;
842756 EOF
843
757
844758 # print function trailer
845759 print Q(<<"EOF");
846760 # ]]
847761 EOF
848 print Q(<<"EOF") if $except;
762 print Q(<<"EOF") if $self->{except};
849763 # BEGHANDLERS
850764 # CATCHALL
851 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
765 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
852766 # ENDHANDLERS
853767 EOF
854 if (check_keyword("CASE")) {
855 blurt ("Error: No `CASE:' at top of function")
856 unless $condnum;
857 $_ = "CASE: $_"; # Restore CASE: label
858 next;
768 if ($self->check_keyword("CASE")) {
769 $self->blurt("Error: No `CASE:' at top of function")
770 unless $self->{condnum};
771 $_ = "CASE: $_"; # Restore CASE: label
772 next;
859773 }
860774 last if $_ eq "$END:";
861 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
862 }
863
864 print Q(<<"EOF") if $except;
775 $self->death(/^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
776 }
777
778 print Q(<<"EOF") if $self->{except};
865779 # if (errbuf[0])
866 # Perl_croak(aTHX_ errbuf);
867 EOF
868
780 # Perl_croak(aTHX_ errbuf);
781 EOF
782
869783 if ($xsreturn) {
870784 print Q(<<"EOF") unless $PPCODE;
871785 # XSRETURN($xsreturn);
872786 EOF
873 } else {
787 }
788 else {
874789 print Q(<<"EOF") unless $PPCODE;
875790 # XSRETURN_EMPTY;
876791 EOF
881796 #
882797 EOF
883798
884 our $newXS = "newXS" ;
885 our $proto = "" ;
886
799 $self->{newXS} = "newXS";
800 $self->{proto} = "";
801
887802 # Build the prototype string for the xsub
888 if ($ProtoThisXSUB) {
889 $newXS = "newXSproto_portable";
890
891 if ($ProtoThisXSUB eq 2) {
892 # User has specified empty prototype
893 }
894 elsif ($ProtoThisXSUB eq 1) {
895 my $s = ';';
896 if ($min_args < $num_args) {
897 $s = '';
898 $proto_arg[$min_args] .= ";" ;
899 }
900 push @proto_arg, "$s\@"
901 if $ellipsis ;
902
903 $proto = join ("", grep defined, @proto_arg);
803 if ($self->{ProtoThisXSUB}) {
804 $self->{newXS} = "newXSproto_portable";
805
806 if ($self->{ProtoThisXSUB} eq 2) {
807 # User has specified empty prototype
808 }
809 elsif ($self->{ProtoThisXSUB} eq 1) {
810 my $s = ';';
811 if ($min_args < $num_args) {
812 $s = '';
813 $self->{proto_arg}->[$min_args] .= ";";
814 }
815 push @{ $self->{proto_arg} }, "$s\@"
816 if $ellipsis;
817
818 $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } );
904819 }
905820 else {
906 # User has specified a prototype
907 $proto = $ProtoThisXSUB;
908 }
909 $proto = qq{, "$proto"};
910 }
911
912 if (%XsubAliases) {
913 $XsubAliases{$pname} = 0
914 unless defined $XsubAliases{$pname} ;
915 while ( ($name, $value) = each %XsubAliases) {
916 push(@InitFileCode, Q(<<"EOF"));
917 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
918 # XSANY.any_i32 = $value ;
919 EOF
920 }
921 }
922 elsif (@Attributes) {
923 push(@InitFileCode, Q(<<"EOF"));
924 # cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
925 # apply_attrs_string("$Package", cv, "@Attributes", 0);
926 EOF
927 }
928 elsif ($interface) {
929 while ( ($name, $value) = each %Interfaces) {
930 $name = "$Package\::$name" unless $name =~ /::/;
931 push(@InitFileCode, Q(<<"EOF"));
932 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
933 # $interface_macro_set(cv,$value) ;
934 EOF
935 }
936 }
937 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
938 push(@InitFileCode,
939 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
821 # User has specified a prototype
822 $self->{proto} = $self->{ProtoThisXSUB};
823 }
824 $self->{proto} = qq{, "$self->{proto}"};
825 }
826
827 if (%{ $self->{XsubAliases} }) {
828 $self->{XsubAliases}->{$pname} = 0
829 unless defined $self->{XsubAliases}->{$pname};
830 while ( my ($xname, $value) = each %{ $self->{XsubAliases} }) {
831 push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
832 # cv = $self->{newXS}(\"$xname\", XS_$Full_func_name, file$self->{proto});
833 # XSANY.any_i32 = $value;
834 EOF
835 }
836 }
837 elsif (@{ $self->{Attributes} }) {
838 push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
839 # cv = $self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});
840 # apply_attrs_string("$Package", cv, "@{ $self->{Attributes} }", 0);
841 EOF
842 }
843 elsif ($self->{interface}) {
844 while ( my ($yname, $value) = each %{ $self->{Interfaces} }) {
845 $yname = "$Package\::$yname" unless $yname =~ /::/;
846 push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
847 # cv = $self->{newXS}(\"$yname\", XS_$Full_func_name, file$self->{proto});
848 # $self->{interface_macro_set}(cv,$value);
849 EOF
850 }
851 }
852 elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro
853 push(@{ $self->{InitFileCode} },
854 " $self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});\n");
940855 }
941856 else {
942 push(@InitFileCode,
943 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
944 }
945 }
946
947 if ($Overload) # make it findable with fetchmethod
948 {
857 push(@{ $self->{InitFileCode} },
858 " (void)$self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});\n");
859 }
860 } # END 'PARAGRAPH' 'while' loop
861
862 if ($self->{Overload}) { # make it findable with fetchmethod
949863 print Q(<<"EOF");
950 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
951 #XS(XS_${Packid}_nil)
864 #XS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
865 #XS(XS_$self->{Packid}_nil)
952866 #{
953867 # dXSARGS;
954868 # XSRETURN_EMPTY;
955869 #}
956870 #
957871 EOF
958 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
872 unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK");
959873 /* Making a sub named "${Package}::()" allows the package */
960874 /* to be findable via fetchmethod(), and causes */
961875 /* overload::Overloaded("${Package}") to return true. */
962 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
876 (void)$self->{newXS}("${Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
963877 MAKE_FETCHMETHOD_WORK
964878 }
965879
972886 EOF
973887
974888 print Q(<<"EOF");
975 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
976 #XS(boot_$Module_cname)
889 #XS(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
890 #XS(boot_$self->{Module_cname})
977891 EOF
978892
979893 print Q(<<"EOF");
1003917 print Q(<<"EOF");
1004918 # PERL_UNUSED_VAR(cv); /* -W */
1005919 # PERL_UNUSED_VAR(items); /* -W */
1006 EOF
1007
1008 print Q(<<"EOF") if $WantVersionChk ;
1009 # XS_VERSION_BOOTCHECK ;
920 ##ifdef XS_APIVERSION_BOOTCHECK
921 # XS_APIVERSION_BOOTCHECK;
922 ##endif
923 EOF
924
925 print Q(<<"EOF") if $self->{WantVersionChk};
926 # XS_VERSION_BOOTCHECK;
1010927 #
1011928 EOF
1012929
1013 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
930 print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces};
1014931 # {
1015 # CV * cv ;
932 # CV * cv;
1016933 #
1017934 EOF
1018935
1019 print Q(<<"EOF") if ($Overload);
936 print Q(<<"EOF") if ($self->{Overload});
1020937 # /* register the overloading (type 'A') magic */
1021938 # PL_amagic_generation++;
1022939 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1024941 # /* the "fallback" status. */
1025942 # sv_setsv(
1026943 # get_sv( "${Package}::()", TRUE ),
1027 # $Fallback
944 # $self->{Fallback}
1028945 # );
1029946 EOF
1030947
1031 print @InitFileCode;
1032
1033 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
948 print @{ $self->{InitFileCode} };
949
950 print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces};
1034951 # }
1035952 EOF
1036953
1037 if (@BootCode)
1038 {
1039 print "\n /* Initialisation Section */\n\n" ;
1040 @line = @BootCode;
1041 print_section();
1042 print "\n /* End of Initialisation Section */\n\n" ;
954 if (@{ $BootCode_ref }) {
955 print "\n /* Initialisation Section */\n\n";
956 @{ $self->{line} } = @{ $BootCode_ref };
957 $self->print_section();
958 print "\n /* End of Initialisation Section */\n\n";
1043959 }
1044960
1045961 print Q(<<'EOF');
1055971 #
1056972 EOF
1057973
1058 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1059 unless $ProtoUsed ;
974 warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n")
975 unless $self->{ProtoUsed};
1060976
1061977 chdir($orig_cwd);
1062978 select($orig_fh);
1063979 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1064 close $FH;
980 close $self->{FH};
1065981
1066982 return 1;
1067983 }
1068984
1069 sub errors { $errors }
1070
1071 sub standard_typemap_locations {
1072 # Add all the default typemap locations to the search path
1073 my @tm = qw(typemap);
1074
1075 my $updir = File::Spec->updir;
1076 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1077 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1078
1079 unshift @tm, File::Spec->catfile($dir, 'typemap');
1080 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1081 }
1082 foreach my $dir (@INC) {
1083 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1084 unshift @tm, $file if -e $file;
1085 }
1086 return @tm;
1087 }
1088
1089 sub TrimWhitespace
1090 {
1091 $_[0] =~ s/^\s+|\s+$//go ;
1092 }
1093
1094 sub TidyType
1095 {
1096 local ($_) = @_ ;
1097
1098 # rationalise any '*' by joining them into bunches and removing whitespace
1099 s#\s*(\*+)\s*#$1#g;
1100 s#(\*+)# $1 #g ;
1101
1102 # change multiple whitespace into a single space
1103 s/\s+/ /g ;
1104
1105 # trim leading & trailing whitespace
1106 TrimWhitespace($_) ;
1107
1108 $_ ;
1109 }
1110
1111 # Input: ($_, @line) == unparsed input.
1112 # Output: ($_, @line) == (rest of line, following lines).
985 sub report_error_count { $self->{errors} }
986
987 # Input: ($self, $_, @{ $self->{line} }) == unparsed input.
988 # Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
1113989 # Return: the matched keyword if found, otherwise 0
1114990 sub check_keyword {
1115 $_ = shift(@line) while !/\S/ && @line;
1116 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
991 my $self = shift;
992 $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} };
993 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1117994 }
1118995
1119996 sub print_section {
1120 # the "do" is required for right semantics
1121 do { $_ = shift(@line) } while !/\S/ && @line;
1122
1123 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1124 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1125 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1126 print "$_\n";
1127 }
1128 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
997 my $self = shift;
998
999 # the "do" is required for right semantics
1000 do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} };
1001
1002 print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"$self->{filepathname}\"\n")
1003 if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1004 for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
1005 print "$_\n";
1006 }
1007 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
11291008 }
11301009
11311010 sub merge_section {
1132 my $in = '';
1133
1134 while (!/\S/ && @line) {
1135 $_ = shift(@line);
1136 }
1137
1138 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1139 $in .= "$_\n";
1140 }
1141 chomp $in;
1142 return $in;
1143 }
1144
1145 sub process_keyword($)
1146 {
1147 my($pattern) = @_ ;
1148 my $kwd ;
1149
1150 &{"${kwd}_handler"}()
1151 while $kwd = check_keyword($pattern) ;
1152 }
1011 my $self = shift;
1012 my $in = '';
1013
1014 while (!/\S/ && @{ $self->{line} }) {
1015 $_ = shift(@{ $self->{line} });
1016 }
1017
1018 for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
1019 $in .= "$_\n";
1020 }
1021 chomp $in;
1022 return $in;
1023 }
1024
1025 sub process_keyword {
1026 my($self, $pattern) = @_;
1027
1028 while (my $kwd = $self->check_keyword($pattern)) {
1029 my $method = $kwd . "_handler";
1030 $self->$method($_);
1031 }
1032 }
11531033
11541034 sub CASE_handler {
1155 blurt ("Error: `CASE:' after unconditional `CASE:'")
1156 if $condnum && $cond eq '';
1157 $cond = $_;
1158 TrimWhitespace($cond);
1159 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1160 $_ = '' ;
1035 my $self = shift;
1036 $_ = shift;
1037 $self->blurt("Error: `CASE:' after unconditional `CASE:'")
1038 if $self->{condnum} && $self->{cond} eq '';
1039 $self->{cond} = $_;
1040 trim_whitespace($self->{cond});
1041 print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n");
1042 $_ = '';
11611043 }
11621044
11631045 sub INPUT_handler {
1164 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1046 my $self = shift;
1047 $_ = shift;
1048 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
11651049 last if /^\s*NOT_IMPLEMENTED_YET/;
1166 next unless /\S/; # skip blank lines
1167
1168 TrimWhitespace($_) ;
1169 my $line = $_ ;
1050 next unless /\S/; # skip blank lines
1051
1052 trim_whitespace($_);
1053 my $ln = $_;
11701054
11711055 # remove trailing semicolon if no initialisation
1172 s/\s*;$//g unless /[=;+].*\S/ ;
1056 s/\s*;$//g unless /[=;+].*\S/;
11731057
11741058 # Process the length(foo) declarations
11751059 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
11761060 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1177 $lengthof{$2} = $name;
1178 # $islengthof{$name} = $1;
1179 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
1061 $self->{lengthof}->{$2} = undef;
1062 $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
11801063 }
11811064
11821065 # check for optional initialisation code
1183 my $var_init = '' ;
1184 $var_init = $1 if s/\s*([=;+].*)$//s ;
1066 my $var_init = '';
1067 $var_init = $1 if s/\s*([=;+].*)$//s;
11851068 $var_init =~ s/"/\\"/g;
11861069
11871070 s/\s+/ /g;
11881071 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1189 or blurt("Error: invalid argument declaration '$line'"), next;
1072 or $self->blurt("Error: invalid argument declaration '$ln'"), next;
11901073
11911074 # Check for duplicate definitions
1192 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1193 if $arg_list{$var_name}++
1194 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1195
1196 $thisdone |= $var_name eq "THIS";
1197 $retvaldone |= $var_name eq "RETVAL";
1198 $var_types{$var_name} = $var_type;
1075 $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next
1076 if $self->{arg_list}->{$var_name}++
1077 or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types};
1078
1079 $self->{thisdone} |= $var_name eq "THIS";
1080 $self->{retvaldone} |= $var_name eq "RETVAL";
1081 $self->{var_types}->{$var_name} = $var_type;
11991082 # XXXX This check is a safeguard against the unfinished conversion of
12001083 # generate_init(). When generate_init() is fixed,
12011084 # one can use 2-args map_type() unconditionally.
1085 my $printed_name;
12021086 if ($var_type =~ / \( \s* \* \s* \) /x) {
1203 # Function pointers are not yet supported with &output_init!
1204 print "\t" . &map_type($var_type, $var_name);
1205 $name_printed = 1;
1206 } else {
1207 print "\t" . &map_type($var_type);
1208 $name_printed = 0;
1209 }
1210 $var_num = $args_match{$var_name};
1211
1212 $proto_arg[$var_num] = ProtoString($var_type)
1213 if $var_num ;
1214 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1087 # Function pointers are not yet supported with output_init()!
1088 print "\t" . map_type($self, $var_type, $var_name);
1089 $printed_name = 1;
1090 }
1091 else {
1092 print "\t" . map_type($self, $var_type, undef);
1093 $printed_name = 0;
1094 }
1095 $self->{var_num} = $self->{args_match}->{$var_name};
1096
1097 if ($self->{var_num}) {
1098 my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
1099 $self->death("Could not find a typemap for C type '$var_type'")
1100 if not $typemap;
1101 $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
1102 }
1103 $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
12151104 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1216 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1217 and $var_init !~ /\S/) {
1218 if ($name_printed) {
1219 print ";\n";
1220 } else {
1221 print "\t$var_name;\n";
1222 }
1223 } elsif ($var_init =~ /\S/) {
1224 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1225 } elsif ($var_num) {
1226 # generate initialization code
1227 &generate_init($var_type, $var_num, $var_name, $name_printed);
1228 } else {
1105 or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/
1106 and $var_init !~ /\S/) {
1107 if ($printed_name) {
1108 print ";\n";
1109 }
1110 else {
1111 print "\t$var_name;\n";
1112 }
1113 }
1114 elsif ($var_init =~ /\S/) {
1115 output_init( {
1116 type => $var_type,
1117 num => $self->{var_num},
1118 var => $var_name,
1119 init => $var_init,
1120 printed_name => $printed_name,
1121 } );
1122 }
1123 elsif ($self->{var_num}) {
1124 generate_init( {
1125 type => $var_type,
1126 num => $self->{var_num},
1127 var => $var_name,
1128 printed_name => $printed_name,
1129 } );
1130 }
1131 else {
12291132 print ";\n";
12301133 }
12311134 }
12321135 }
12331136
12341137 sub OUTPUT_handler {
1235 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1138 my $self = shift;
1139 $_ = shift;
1140 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
12361141 next unless /\S/;
12371142 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1238 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1143 $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0);
12391144 next;
12401145 }
1241 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1242 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1243 if $outargs{$outarg} ++ ;
1244 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1146 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
1147 $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1148 if $self->{outargs}->{$outarg}++;
1149 if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') {
12451150 # deal with RETVAL last
1246 $RETVAL_code = $outcode ;
1247 $gotRETVAL = 1 ;
1248 next ;
1249 }
1250 blurt ("Error: OUTPUT $outarg not an argument"), next
1251 unless defined($args_match{$outarg});
1252 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1253 unless defined $var_types{$outarg} ;
1254 $var_num = $args_match{$outarg};
1151 $self->{RETVAL_code} = $outcode;
1152 $self->{gotRETVAL} = 1;
1153 next;
1154 }
1155 $self->blurt("Error: OUTPUT $outarg not an argument"), next
1156 unless defined($self->{args_match}->{$outarg});
1157 $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1158 unless defined $self->{var_types}->{$outarg};
1159 $self->{var_num} = $self->{args_match}->{$outarg};
12551160 if ($outcode) {
12561161 print "\t$outcode\n";
1257 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1258 } else {
1259 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1260 }
1261 delete $in_out{$outarg} # No need to auto-OUTPUT
1262 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1263 }
1264 }
1265
1266 sub C_ARGS_handler() {
1267 my $in = merge_section();
1268
1269 TrimWhitespace($in);
1270 $func_args = $in;
1271 }
1272
1273 sub INTERFACE_MACRO_handler() {
1274 my $in = merge_section();
1275
1276 TrimWhitespace($in);
1277 if ($in =~ /\s/) { # two
1278 ($interface_macro, $interface_macro_set) = split ' ', $in;
1279 } else {
1280 $interface_macro = $in;
1281 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1282 }
1283 $interface = 1; # local
1284 $Interfaces = 1; # global
1285 }
1286
1287 sub INTERFACE_handler() {
1288 my $in = merge_section();
1289
1290 TrimWhitespace($in);
1162 print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic};
1163 }
1164 else {
1165 generate_output( {
1166 type => $self->{var_types}->{$outarg},
1167 num => $self->{var_num},
1168 var => $outarg,
1169 do_setmagic => $self->{DoSetMagic},
1170 do_push => undef,
1171 } );
1172 }
1173 delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT
1174 if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/;
1175 }
1176 }
1177
1178 sub C_ARGS_handler {
1179 my $self = shift;
1180 $_ = shift;
1181 my $in = $self->merge_section();
1182
1183 trim_whitespace($in);
1184 $self->{func_args} = $in;
1185 }
1186
1187 sub INTERFACE_MACRO_handler {
1188 my $self = shift;
1189 $_ = shift;
1190 my $in = $self->merge_section();
1191
1192 trim_whitespace($in);
1193 if ($in =~ /\s/) { # two
1194 ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in;
1195 }
1196 else {
1197 $self->{interface_macro} = $in;
1198 $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later
1199 }
1200 $self->{interface} = 1; # local
1201 $self->{interfaces} = 1; # global
1202 }
1203
1204 sub INTERFACE_handler {
1205 my $self = shift;
1206 $_ = shift;
1207 my $in = $self->merge_section();
1208
1209 trim_whitespace($in);
12911210
12921211 foreach (split /[\s,]+/, $in) {
1293 my $name = $_;
1294 $name =~ s/^$Prefix//;
1295 $Interfaces{$name} = $_;
1212 my $iface_name = $_;
1213 $iface_name =~ s/^$self->{Prefix}//;
1214 $self->{Interfaces}->{$iface_name} = $_;
12961215 }
12971216 print Q(<<"EOF");
1298 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1299 EOF
1300 $interface = 1; # local
1301 $Interfaces = 1; # global
1302 }
1303
1304 sub CLEANUP_handler() { print_section() }
1305 sub PREINIT_handler() { print_section() }
1306 sub POSTCALL_handler() { print_section() }
1307 sub INIT_handler() { print_section() }
1308
1309 sub GetAliases
1310 {
1311 my ($line) = @_ ;
1312 my ($orig) = $line ;
1313 my ($alias) ;
1314 my ($value) ;
1315
1316 # Parse alias definitions
1317 # format is
1318 # alias = value alias = value ...
1319
1320 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1321 $alias = $1 ;
1322 $orig_alias = $alias ;
1323 $value = $2 ;
1324
1325 # check for optional package definition in the alias
1326 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1327
1328 # check for duplicate alias name & duplicate value
1329 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1330 if defined $XsubAliases{$alias} ;
1331
1332 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1333 if $XsubAliasValues{$value} ;
1334
1335 $XsubAliases = 1;
1336 $XsubAliases{$alias} = $value ;
1337 $XsubAliasValues{$value} = $orig_alias ;
1338 }
1339
1340 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1341 if $line ;
1342 }
1343
1344 sub ATTRS_handler ()
1345 {
1346 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1347 next unless /\S/;
1348 TrimWhitespace($_) ;
1349 push @Attributes, $_;
1350 }
1351 }
1352
1353 sub ALIAS_handler ()
1354 {
1355 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1356 next unless /\S/;
1357 TrimWhitespace($_) ;
1358 GetAliases($_) if $_ ;
1359 }
1360 }
1361
1362 sub OVERLOAD_handler()
1363 {
1364 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1217 # XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr);
1218 EOF
1219 $self->{interface} = 1; # local
1220 $self->{interfaces} = 1; # global
1221 }
1222
1223 sub CLEANUP_handler {
1224 my $self = shift;
1225 $self->print_section();
1226 }
1227
1228 sub PREINIT_handler {
1229 my $self = shift;
1230 $self->print_section();
1231 }
1232
1233 sub POSTCALL_handler {
1234 my $self = shift;
1235 $self->print_section();
1236 }
1237
1238 sub INIT_handler {
1239 my $self = shift;
1240 $self->print_section();
1241 }
1242
1243 sub get_aliases {
1244 my $self = shift;
1245 my ($line) = @_;
1246 my ($orig) = $line;
1247
1248 # Parse alias definitions
1249 # format is
1250 # alias = value alias = value ...
1251
1252 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1253 my ($alias, $value) = ($1, $2);
1254 my $orig_alias = $alias;
1255
1256 # check for optional package definition in the alias
1257 $alias = $self->{Packprefix} . $alias if $alias !~ /::/;
1258
1259 # check for duplicate alias name & duplicate value
1260 Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
1261 if defined $self->{XsubAliases}->{$alias};
1262
1263 Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
1264 if $self->{XsubAliasValues}->{$value};
1265
1266 $self->{xsubaliases} = 1;
1267 $self->{XsubAliases}->{$alias} = $value;
1268 $self->{XsubAliasValues}->{$value} = $orig_alias;
1269 }
1270
1271 blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")
1272 if $line;
1273 }
1274
1275 sub ATTRS_handler {
1276 my $self = shift;
1277 $_ = shift;
1278
1279 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
13651280 next unless /\S/;
1366 TrimWhitespace($_) ;
1281 trim_whitespace($_);
1282 push @{ $self->{Attributes} }, $_;
1283 }
1284 }
1285
1286 sub ALIAS_handler {
1287 my $self = shift;
1288 $_ = shift;
1289
1290 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
1291 next unless /\S/;
1292 trim_whitespace($_);
1293 $self->get_aliases($_) if $_;
1294 }
1295 }
1296
1297 sub OVERLOAD_handler {
1298 my $self = shift;
1299 $_ = shift;
1300
1301 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
1302 next unless /\S/;
1303 trim_whitespace($_);
13671304 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1368 $Overload = 1 unless $Overload;
1369 my $overload = "$Package\::(".$1 ;
1370 push(@InitFileCode,
1371 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
1372 }
1373 }
1374 }
1375
1376 sub FALLBACK_handler()
1377 {
1378 # the rest of the current line should contain either TRUE,
1305 $self->{Overload} = 1 unless $self->{Overload};
1306 my $overload = "$Package\::(".$1;
1307 push(@{ $self->{InitFileCode} },
1308 " (void)$self->{newXS}(\"$overload\", XS_$Full_func_name, file$self->{proto});\n");
1309 }
1310 }
1311 }
1312
1313 sub FALLBACK_handler {
1314 my $self = shift;
1315 $_ = shift;
1316
1317 # the rest of the current line should contain either TRUE,
13791318 # FALSE or UNDEF
1380
1381 TrimWhitespace($_) ;
1319
1320 trim_whitespace($_);
13821321 my %map = (
1383 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1384 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1385 UNDEF => "&PL_sv_undef",
1386 ) ;
1387
1322 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1323 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1324 UNDEF => "&PL_sv_undef",
1325 );
1326
13881327 # check for valid FALLBACK value
1389 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1390
1391 $Fallback = $map{uc $_} ;
1392 }
1393
1394
1395 sub REQUIRE_handler ()
1396 {
1397 # the rest of the current line should contain a version number
1398 my ($Ver) = $_ ;
1399
1400 TrimWhitespace($Ver) ;
1401
1402 death ("Error: REQUIRE expects a version number")
1403 unless $Ver ;
1404
1405 # check that the version number is of the form n.n
1406 death ("Error: REQUIRE: expected a number, got '$Ver'")
1407 unless $Ver =~ /^\d+(\.\d*)?/ ;
1408
1409 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1410 unless $VERSION >= $Ver ;
1411 }
1412
1413 sub VERSIONCHECK_handler ()
1414 {
1415 # the rest of the current line should contain either ENABLE or
1416 # DISABLE
1417
1418 TrimWhitespace($_) ;
1419
1420 # check for ENABLE/DISABLE
1421 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1422 unless /^(ENABLE|DISABLE)/i ;
1423
1424 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1425 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1426
1427 }
1428
1429 sub PROTOTYPE_handler ()
1430 {
1431 my $specified ;
1432
1433 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1434 if $proto_in_this_xsub ++ ;
1435
1436 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1437 next unless /\S/;
1438 $specified = 1 ;
1439 TrimWhitespace($_) ;
1440 if ($_ eq 'DISABLE') {
1441 $ProtoThisXSUB = 0
1442 } elsif ($_ eq 'ENABLE') {
1443 $ProtoThisXSUB = 1
1444 } else {
1445 # remove any whitespace
1446 s/\s+//g ;
1447 death("Error: Invalid prototype '$_'")
1448 unless ValidProtoString($_) ;
1449 $ProtoThisXSUB = C_string($_) ;
1450 }
1451 }
1452
1453 # If no prototype specified, then assume empty prototype ""
1454 $ProtoThisXSUB = 2 unless $specified ;
1455
1456 $ProtoUsed = 1 ;
1457
1458 }
1459
1460 sub SCOPE_handler ()
1461 {
1462 death("Error: Only 1 SCOPE declaration allowed per xsub")
1463 if $scope_in_this_xsub ++ ;
1464
1465 TrimWhitespace($_);
1466 death ("Error: SCOPE: ENABLE/DISABLE")
1467 unless /^(ENABLE|DISABLE)\b/i;
1468 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1469 }
1470
1471 sub PROTOTYPES_handler ()
1472 {
1473 # the rest of the current line should contain either ENABLE or
1474 # DISABLE
1475
1476 TrimWhitespace($_) ;
1477
1478 # check for ENABLE/DISABLE
1479 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1480 unless /^(ENABLE|DISABLE)/i ;
1481
1482 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1483 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1484 $ProtoUsed = 1 ;
1485
1486 }
1487
1488 sub PushXSStack
1489 {
1490 my %args = @_;
1491 # Save the current file context.
1492 push(@XSStack, {
1493 type => 'file',
1494 LastLine => $lastline,
1495 LastLineNo => $lastline_no,
1496 Line => \@line,
1497 LineNo => \@line_no,
1498 Filename => $filename,
1499 Filepathname => $filepathname,
1500 Handle => $FH,
1501 IsPipe => scalar($filename =~ /\|\s*$/),
1502 %args,
1503 }) ;
1504
1505 }
1506
1507 sub INCLUDE_handler ()
1508 {
1509 # the rest of the current line should contain a valid filename
1510
1511 TrimWhitespace($_) ;
1512
1513 death("INCLUDE: filename missing")
1514 unless $_ ;
1515
1516 death("INCLUDE: output pipe is illegal")
1517 if /^\s*\|/ ;
1518
1519 # simple minded recursion detector
1520 death("INCLUDE loop detected")
1521 if $IncludedFiles{$_} ;
1522
1523 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1524
1525 if (/\|\s*$/ && /^\s*perl\s/) {
1526 Warn("The INCLUDE directive with a command is discouraged." .
1527 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1528 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1529 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1530 " the use of \$^X as the currently running perl, see" .
1531 " 'perldoc perlxs' for details.");
1532 }
1533
1534 PushXSStack();
1535
1536 $FH = Symbol::gensym();
1537
1538 # open the new file
1539 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1540
1541 print Q(<<"EOF");
1328 $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
1329
1330 $self->{Fallback} = $map{uc $_};
1331 }
1332
1333
1334 sub REQUIRE_handler {
1335 my $self = shift;
1336 # the rest of the current line should contain a version number
1337 my $Ver = shift;
1338
1339 trim_whitespace($Ver);
1340
1341 $self->death("Error: REQUIRE expects a version number")
1342 unless $Ver;
1343
1344 # check that the version number is of the form n.n
1345 $self->death("Error: REQUIRE: expected a number, got '$Ver'")
1346 unless $Ver =~ /^\d+(\.\d*)?/;
1347
1348 $self->death("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1349 unless $VERSION >= $Ver;
1350 }
1351
1352 sub VERSIONCHECK_handler {
1353 my $self = shift;
1354 $_ = shift;
1355
1356 # the rest of the current line should contain either ENABLE or
1357 # DISABLE
1358
1359 trim_whitespace($_);
1360
1361 # check for ENABLE/DISABLE
1362 $self->death("Error: VERSIONCHECK: ENABLE/DISABLE")
1363 unless /^(ENABLE|DISABLE)/i;
1364
1365 $self->{WantVersionChk} = 1 if $1 eq 'ENABLE';
1366 $self->{WantVersionChk} = 0 if $1 eq 'DISABLE';
1367
1368 }
1369
1370 sub PROTOTYPE_handler {
1371 my $self = shift;
1372 $_ = shift;
1373
1374 my $specified;
1375
1376 $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1377 if $self->{proto_in_this_xsub}++;
1378
1379 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
1380 next unless /\S/;
1381 $specified = 1;
1382 trim_whitespace($_);
1383 if ($_ eq 'DISABLE') {
1384 $self->{ProtoThisXSUB} = 0;
1385 }
1386 elsif ($_ eq 'ENABLE') {
1387 $self->{ProtoThisXSUB} = 1;
1388 }
1389 else {
1390 # remove any whitespace
1391 s/\s+//g;
1392 $self->death("Error: Invalid prototype '$_'")
1393 unless valid_proto_string($_);
1394 $self->{ProtoThisXSUB} = C_string($_);
1395 }
1396 }
1397
1398 # If no prototype specified, then assume empty prototype ""
1399 $self->{ProtoThisXSUB} = 2 unless $specified;
1400
1401 $self->{ProtoUsed} = 1;
1402 }
1403
1404 sub SCOPE_handler {
1405 my $self = shift;
1406 $_ = shift;
1407
1408 $self->death("Error: Only 1 SCOPE declaration allowed per xsub")
1409 if $self->{scope_in_this_xsub}++;
1410
1411 trim_whitespace($_);
1412 $self->death("Error: SCOPE: ENABLE/DISABLE")
1413 unless /^(ENABLE|DISABLE)\b/i;
1414 $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' );
1415 }
1416
1417 sub PROTOTYPES_handler {
1418 my $self = shift;
1419 $_ = shift;
1420
1421 # the rest of the current line should contain either ENABLE or
1422 # DISABLE
1423
1424 trim_whitespace($_);
1425
1426 # check for ENABLE/DISABLE
1427 $self->death("Error: PROTOTYPES: ENABLE/DISABLE")
1428 unless /^(ENABLE|DISABLE)/i;
1429
1430 $self->{WantPrototypes} = 1 if $1 eq 'ENABLE';
1431 $self->{WantPrototypes} = 0 if $1 eq 'DISABLE';
1432 $self->{ProtoUsed} = 1;
1433 }
1434
1435 sub PushXSStack {
1436 my $self = shift;
1437 my %args = @_;
1438 # Save the current file context.
1439 push(@{ $self->{XSStack} }, {
1440 type => 'file',
1441 LastLine => $self->{lastline},
1442 LastLineNo => $self->{lastline_no},
1443 Line => $self->{line},
1444 LineNo => $self->{line_no},
1445 Filename => $self->{filename},
1446 Filepathname => $self->{filepathname},
1447 Handle => $self->{FH},
1448 IsPipe => scalar($self->{filename} =~ /\|\s*$/),
1449 %args,
1450 });
1451
1452 }
1453
1454 sub INCLUDE_handler {
1455 my $self = shift;
1456 $_ = shift;
1457 # the rest of the current line should contain a valid filename
1458
1459 trim_whitespace($_);
1460
1461 $self->death("INCLUDE: filename missing")
1462 unless $_;
1463
1464 $self->death("INCLUDE: output pipe is illegal")
1465 if /^\s*\|/;
1466
1467 # simple minded recursion detector
1468 $self->death("INCLUDE loop detected")
1469 if $self->{IncludedFiles}->{$_};
1470
1471 ++$self->{IncludedFiles}->{$_} unless /\|\s*$/;
1472
1473 if (/\|\s*$/ && /^\s*perl\s/) {
1474 Warn( $self, "The INCLUDE directive with a command is discouraged." .
1475 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1476 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1477 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1478 " the use of \$^X as the currently running perl, see" .
1479 " 'perldoc perlxs' for details.");
1480 }
1481
1482 $self->PushXSStack();
1483
1484 $self->{FH} = Symbol::gensym();
1485
1486 # open the new file
1487 open ($self->{FH}, '<', $_) or $self->death("Cannot open '$_': $!");
1488
1489 print Q(<<"EOF");
15421490 #
1543 #/* INCLUDE: Including '$_' from '$filename' */
1491 #/* INCLUDE: Including '$_' from '$self->{filename}' */
15441492 #
15451493 EOF
15461494
1547 $filename = $_ ;
1548 $filepathname = File::Spec->catfile($dir, $filename);
1549
1550 # Prime the pump by reading the first
1551 # non-blank line
1552
1553 # skip leading blank lines
1554 while (<$FH>) {
1555 last unless /^\s*$/ ;
1556 }
1557
1558 $lastline = $_ ;
1559 $lastline_no = $. ;
1560 }
1495 $self->{filename} = $_;
1496 $self->{filepathname} = ( $^O =~ /^mswin/i )
1497 ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32?
1498 : File::Spec->catfile($self->{dir}, $self->{filename});
1499
1500 # Prime the pump by reading the first
1501 # non-blank line
1502
1503 # skip leading blank lines
1504 while (readline($self->{FH})) {
1505 last unless /^\s*$/;
1506 }
1507
1508 $self->{lastline} = $_;
1509 $self->{lastline_no} = $.;
1510 }
15611511
15621512 sub QuoteArgs {
1563 my $cmd = shift;
1564 my @args = split /\s+/, $cmd;
1565 $cmd = shift @args;
1566 for (@args) {
1567 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1568 }
1569 return join (' ', ($cmd, @args));
1570 }
1571
1572 sub INCLUDE_COMMAND_handler ()
1573 {
1574 # the rest of the current line should contain a valid command
1575
1576 TrimWhitespace($_) ;
1577
1578 $_ = QuoteArgs($_) if $^O eq 'VMS';
1579
1580 death("INCLUDE_COMMAND: command missing")
1581 unless $_ ;
1582
1583 death("INCLUDE_COMMAND: pipes are illegal")
1584 if /^\s*\|/ or /\|\s*$/ ;
1585
1586 PushXSStack( IsPipe => 1 );
1587
1588 $FH = Symbol::gensym();
1589
1590 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1591 # the same perl interpreter as we're currently running
1592 s/^\s*\$\^X/$^X/;
1593
1594 # open the new file
1595 open ($FH, "-|", "$_")
1596 or death("Cannot run command '$_' to include its output: $!") ;
1597
1598 print Q(<<"EOF");
1513 my $cmd = shift;
1514 my @args = split /\s+/, $cmd;
1515 $cmd = shift @args;
1516 for (@args) {
1517 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1518 }
1519 return join (' ', ($cmd, @args));
1520 }
1521
1522 sub INCLUDE_COMMAND_handler {
1523 my $self = shift;
1524 $_ = shift;
1525 # the rest of the current line should contain a valid command
1526
1527 trim_whitespace($_);
1528
1529 $_ = QuoteArgs($_) if $^O eq 'VMS';
1530
1531 $self->death("INCLUDE_COMMAND: command missing")
1532 unless $_;
1533
1534 $self->death("INCLUDE_COMMAND: pipes are illegal")
1535 if /^\s*\|/ or /\|\s*$/;
1536
1537 $self->PushXSStack( IsPipe => 1 );
1538
1539 $self->{FH} = Symbol::gensym();
1540
1541 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1542 # the same perl interpreter as we're currently running
1543 s/^\s*\$\^X/$^X/;
1544
1545 # open the new file
1546 open ($self->{FH}, "-|", $_)
1547 or $self->death( $self, "Cannot run command '$_' to include its output: $!");
1548
1549 print Q(<<"EOF");
15991550 #
1600 #/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1551 #/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */
16011552 #
16021553 EOF
16031554
1604 $filename = $_ ;
1605 $filepathname = $filename;
1606 $filepathname =~ s/\"/\\"/g;
1607
1608 # Prime the pump by reading the first
1609 # non-blank line
1610
1611 # skip leading blank lines
1612 while (<$FH>) {
1613 last unless /^\s*$/ ;
1614 }
1615
1616 $lastline = $_ ;
1617 $lastline_no = $. ;
1618 }
1619
1620 sub PopFile()
1621 {
1622 return 0 unless $XSStack[-1]{type} eq 'file' ;
1623
1624 my $data = pop @XSStack ;
1625 my $ThisFile = $filename ;
1626 my $isPipe = $data->{IsPipe};
1627
1628 -- $IncludedFiles{$filename}
1629 unless $isPipe ;
1630
1631 close $FH ;
1632
1633 $FH = $data->{Handle} ;
1634 # $filename is the leafname, which for some reason isused for diagnostic
1635 # messages, whereas $filepathname is the full pathname, and is used for
1636 # #line directives.
1637 $filename = $data->{Filename} ;
1638 $filepathname = $data->{Filepathname} ;
1639 $lastline = $data->{LastLine} ;
1640 $lastline_no = $data->{LastLineNo} ;
1641 @line = @{ $data->{Line} } ;
1642 @line_no = @{ $data->{LineNo} } ;
1643
1644 if ($isPipe and $? ) {
1645 -- $lastline_no ;
1646 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1647 exit 1 ;
1648 }
1649
1650 print Q(<<"EOF");
1555 $self->{filename} = $_;
1556 $self->{filepathname} = $self->{filename};
1557 #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21
1558 $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938
1559
1560 # Prime the pump by reading the first
1561 # non-blank line
1562
1563 # skip leading blank lines
1564 while (readline($self->{FH})) {
1565 last unless /^\s*$/;
1566 }
1567
1568 $self->{lastline} = $_;
1569 $self->{lastline_no} = $.;
1570 }
1571
1572 sub PopFile {
1573 my $self = shift;
1574
1575 return 0 unless $self->{XSStack}->[-1]{type} eq 'file';
1576
1577 my $data = pop @{ $self->{XSStack} };
1578 my $ThisFile = $self->{filename};
1579 my $isPipe = $data->{IsPipe};
1580
1581 --$self->{IncludedFiles}->{$self->{filename}}
1582 unless $isPipe;
1583
1584 close $self->{FH};
1585
1586 $self->{FH} = $data->{Handle};
1587 # $filename is the leafname, which for some reason isused for diagnostic
1588 # messages, whereas $filepathname is the full pathname, and is used for
1589 # #line directives.
1590 $self->{filename} = $data->{Filename};
1591 $self->{filepathname} = $data->{Filepathname};
1592 $self->{lastline} = $data->{LastLine};
1593 $self->{lastline_no} = $data->{LastLineNo};
1594 @{ $self->{line} } = @{ $data->{Line} };
1595 @{ $self->{line_no} } = @{ $data->{LineNo} };
1596
1597 if ($isPipe and $? ) {
1598 --$self->{lastline_no};
1599 print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ;
1600 exit 1;
1601 }
1602
1603 print Q(<<"EOF");
16511604 #
1652 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1605 #/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */
16531606 #
16541607 EOF
16551608
1656 return 1 ;
1657 }
1658
1659 sub ValidProtoString ($)
1660 {
1661 my($string) = @_ ;
1662
1663 if ( $string =~ /^$proto_re+$/ ) {
1664 return $string ;
1665 }
1666
1667 return 0 ;
1668 }
1669
1670 sub C_string ($)
1671 {
1672 my($string) = @_ ;
1673
1674 $string =~ s[\\][\\\\]g ;
1675 $string ;
1676 }
1677
1678 sub ProtoString ($)
1679 {
1680 my ($type) = @_ ;
1681
1682 $proto_letter{$type} or "\$" ;
1683 }
1684
1685 sub check_cpp {
1686 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1687 if (@cpp) {
1688 my ($cpp, $cpplevel);
1689 for $cpp (@cpp) {
1690 if ($cpp =~ /^\#\s*if/) {
1691 $cpplevel++;
1692 } elsif (!$cpplevel) {
1693 Warn("Warning: #else/elif/endif without #if in this function");
1694 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1695 if $XSStack[-1]{type} eq 'if';
1696 return;
1697 } elsif ($cpp =~ /^\#\s*endif/) {
1698 $cpplevel--;
1699 }
1700 }
1701 Warn("Warning: #if without #endif in this function") if $cpplevel;
1702 }
1703 }
1704
1609 return 1;
1610 }
17051611
17061612 sub Q {
17071613 my($text) = @_;
17111617 $text;
17121618 }
17131619
1714 # Read next xsub into @line from ($lastline, <$FH>).
1620 # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})).
17151621 sub fetch_para {
1622 my $self = shift;
1623
17161624 # parse paragraph
1717 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1718 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1719 @line = ();
1720 @line_no = () ;
1721 return PopFile() if !defined $lastline;
1722
1723 if ($lastline =~
1625 $self->death("Error: Unterminated `#if/#ifdef/#ifndef'")
1626 if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
1627 @{ $self->{line} } = ();
1628 @{ $self->{line_no} } = ();
1629 return $self->PopFile() if !defined $self->{lastline};
1630
1631 if ($self->{lastline} =~
17241632 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1725 $Module = $1;
1633 my $Module = $1;
17261634 $Package = defined($2) ? $2 : ''; # keep -w happy
1727 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1728 $Prefix = quotemeta $Prefix ;
1729 ($Module_cname = $Module) =~ s/\W/_/g;
1730 ($Packid = $Package) =~ tr/:/_/;
1731 $Packprefix = $Package;
1732 $Packprefix .= "::" if $Packprefix ne "";
1733 $lastline = "";
1635 $self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy
1636 $self->{Prefix} = quotemeta $self->{Prefix};
1637 ($self->{Module_cname} = $Module) =~ s/\W/_/g;
1638 ($self->{Packid} = $Package) =~ tr/:/_/;
1639 $self->{Packprefix} = $Package;
1640 $self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
1641 $self->{lastline} = "";
17341642 }
17351643
17361644 for (;;) {
17371645 # Skip embedded PODs
1738 while ($lastline =~ /^=/) {
1739 while ($lastline = <$FH>) {
1740 last if ($lastline =~ /^=cut\s*$/);
1741 }
1742 death ("Error: Unterminated pod") unless $lastline;
1743 $lastline = <$FH>;
1744 chomp $lastline;
1745 $lastline =~ s/^\s+$//;
1746 }
1747 if ($lastline !~ /^\s*#/ ||
1748 # CPP directives:
1749 # ANSI: if ifdef ifndef elif else endif define undef
1750 # line error pragma
1751 # gcc: warning include_next
1752 # obj-c: import
1753 # others: ident (gcc notes that some cpps have this one)
1754 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1755 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1756 push(@line, $lastline);
1757 push(@line_no, $lastline_no) ;
1646 while ($self->{lastline} =~ /^=/) {
1647 while ($self->{lastline} = readline($self->{FH})) {
1648 last if ($self->{lastline} =~ /^=cut\s*$/);
1649 }
1650 $self->death("Error: Unterminated pod") unless $self->{lastline};
1651 $self->{lastline} = readline($self->{FH});
1652 chomp $self->{lastline};
1653 $self->{lastline} =~ s/^\s+$//;
1654 }
1655
1656 # This chunk of code strips out (and parses) embedded TYPEMAP blocks
1657 # which support a HEREdoc-alike block syntax.
1658 # This is special cased from the usual paragraph-handler logic
1659 # due to the HEREdoc-ish syntax.
1660 if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+))\s*;?\s*$/) {
1661 my $end_marker = quotemeta(defined($1) ? $2 : $3);
1662 my @tmaplines;
1663 while (1) {
1664 $self->{lastline} = readline($self->{FH});
1665 $self->death("Error: Unterminated typemap") if not defined $self->{lastline};
1666 last if $self->{lastline} =~ /^$end_marker\s*$/;
1667 push @tmaplines, $self->{lastline};
1668 }
1669
1670 my $tmapcode = join "", @tmaplines;
1671 my $tmap = ExtUtils::Typemaps->new(
1672 string => $tmapcode,
1673 lineno_offset => $self->current_line_number()+1,
1674 fake_filename => $self->{filename},
1675 );
1676 $self->{typemap}->merge(typemap => $tmap, replace => 1);
1677
1678 last unless defined($self->{lastline} = readline($self->{FH}));
1679 next;
1680 }
1681
1682 if ($self->{lastline} !~ /^\s*#/ ||
1683 # CPP directives:
1684 # ANSI: if ifdef ifndef elif else endif define undef
1685 # line error pragma
1686 # gcc: warning include_next
1687 # obj-c: import
1688 # others: ident (gcc notes that some cpps have this one)
1689 $self->{lastline} =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1690 last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq "";
1691 push(@{ $self->{line} }, $self->{lastline});
1692 push(@{ $self->{line_no} }, $self->{lastline_no});
17581693 }
17591694
17601695 # Read next line and continuation lines
1761 last unless defined($lastline = <$FH>);
1762 $lastline_no = $.;
1696 last unless defined($self->{lastline} = readline($self->{FH}));
1697 $self->{lastline_no} = $.;
17631698 my $tmp_line;
1764 $lastline .= $tmp_line
1765 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1766
1767 chomp $lastline;
1768 $lastline =~ s/^\s+$//;
1769 }
1770 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1699 $self->{lastline} .= $tmp_line
1700 while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH})));
1701
1702 chomp $self->{lastline};
1703 $self->{lastline} =~ s/^\s+$//;
1704 }
1705 pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq "";
17711706 1;
17721707 }
17731708
17741709 sub output_init {
1775 local($type, $num, $var, $init, $name_printed) = @_;
1776 local($arg) = "ST(" . ($num - 1) . ")";
1710 my $argsref = shift;
1711 my ($type, $num, $var, $init, $printed_name) = (
1712 $argsref->{type},
1713 $argsref->{num},
1714 $argsref->{var},
1715 $argsref->{init},
1716 $argsref->{printed_name}
1717 );
1718 my $arg = "ST(" . ($num - 1) . ")";
17771719
17781720 if ( $init =~ /^=/ ) {
1779 if ($name_printed) {
1721 if ($printed_name) {
17801722 eval qq/print " $init\\n"/;
1781 } else {
1723 }
1724 else {
17821725 eval qq/print "\\t$var $init\\n"/;
17831726 }
1784 warn $@ if $@;
1785 } else {
1727 warn $@ if $@;
1728 }
1729 else {
17861730 if ( $init =~ s/^\+// && $num ) {
1787 &generate_init($type, $num, $var, $name_printed);
1788 } elsif ($name_printed) {
1731 generate_init( {
1732 type => $type,
1733 num => $num,
1734 var => $var,
1735 printed_name => $printed_name,
1736 } );
1737 }
1738 elsif ($printed_name) {
17891739 print ";\n";
17901740 $init =~ s/^;//;
1791 } else {
1741 }
1742 else {
17921743 eval qq/print "\\t$var;\\n"/;
1793 warn $@ if $@;
1744 warn $@ if $@;
17941745 $init =~ s/^;//;
17951746 }
1796 $deferred .= eval qq/"\\n\\t$init\\n"/;
1797 warn $@ if $@;
1798 }
1799 }
1800
1801 sub Warn
1802 {
1803 # work out the line number
1804 my $line_no = $line_no[@line_no - @line -1] ;
1805
1806 print STDERR "@_ in $filename, line $line_no\n" ;
1807 }
1808
1809 sub blurt
1810 {
1811 Warn @_ ;
1812 $errors ++
1813 }
1814
1815 sub death
1816 {
1817 Warn @_ ;
1818 exit 1 ;
1819 }
1747 $self->{deferred} .= eval qq/"\\n\\t$init\\n"/;
1748 warn $@ if $@;
1749 }
1750 }
18201751
18211752 sub generate_init {
1822 local($type, $num, $var) = @_;
1823 local($arg) = "ST(" . ($num - 1) . ")";
1824 local($argoff) = $num - 1;
1825 local($ntype);
1826 local($tk);
1827
1828 $type = TidyType($type) ;
1829 blurt("Error: '$type' not in typemap"), return
1830 unless defined($type_kind{$type});
1753 my $argsref = shift;
1754 my ($type, $num, $var, $printed_name) = (
1755 $argsref->{type},
1756 $argsref->{num},
1757 $argsref->{var},
1758 $argsref->{printed_name},
1759 );
1760 my $arg = "ST(" . ($num - 1) . ")";
1761 my ($argoff, $ntype);
1762 $argoff = $num - 1;
1763
1764 my $typemaps = $self->{typemap};
1765
1766 $type = tidy_type($type);
1767 $self->blurt("Error: '$type' not in typemap"), return
1768 unless $typemaps->get_typemap(ctype => $type);
18311769
18321770 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1771 my $subtype;
18331772 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1834 $tk = $type_kind{$type};
1835 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1836 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1837 print "\t$var" unless $name_printed;
1773 my $typem = $typemaps->get_typemap(ctype => $type);
1774 my $xstype = $typem->xstype;
1775 $xstype =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1776 if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
1777 print "\t$var" unless $printed_name;
18381778 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
18391779 die "default value not supported with length(NAME) supplied"
1840 if defined $defaults{$var};
1780 if defined $self->{defaults}->{$var};
18411781 return;
18421782 }
1843 $type =~ tr/:/_/ unless $hiertype;
1844 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1845 unless defined $input_expr{$tk} ;
1846 $expr = $input_expr{$tk};
1783 $type =~ tr/:/_/ unless $self->{hiertype};
1784
1785 my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
1786 $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return
1787 unless defined $inputmap;
1788
1789 my $expr = $inputmap->cleaned_code;
1790 # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
18471791 if ($expr =~ /DO_ARRAY_ELEM/) {
1848 blurt("Error: '$subtype' not in typemap"), return
1849 unless defined($type_kind{$subtype});
1850 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1851 unless defined $input_expr{$type_kind{$subtype}} ;
1852 $subexpr = $input_expr{$type_kind{$subtype}};
1792 my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
1793 $self->blurt("Error: C type '$subtype' not in typemap"), return
1794 if not $subtypemap;
1795 my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
1796 $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
1797 unless $subinputmap;
1798 my $subexpr = $subinputmap->cleaned_code;
18531799 $subexpr =~ s/\$type/\$subtype/g;
18541800 $subexpr =~ s/ntype/subtype/g;
18551801 $subexpr =~ s/\$arg/ST(ix_$var)/g;
18591805 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
18601806 }
18611807 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1862 $ScopeThisXSUB = 1;
1863 }
1864 if (defined($defaults{$var})) {
1808 $self->{ScopeThisXSUB} = 1;
1809 }
1810 if (defined($self->{defaults}->{$var})) {
18651811 $expr =~ s/(\t+)/$1 /g;
18661812 $expr =~ s/ /\t/g;
1867 if ($name_printed) {
1813 if ($printed_name) {
18681814 print ";\n";
1869 } else {
1815 }
1816 else {
18701817 eval qq/print "\\t$var;\\n"/;
1871 warn $@ if $@;
1872 }
1873 if ($defaults{$var} eq 'NO_INIT') {
1874 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1875 } else {
1876 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1877 }
1878 warn $@ if $@;
1879 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1880 if ($name_printed) {
1818 warn $@ if $@;
1819 }
1820 if ($self->{defaults}->{$var} eq 'NO_INIT') {
1821 $self->{deferred} .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1822 }
1823 else {
1824 $self->{deferred} .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1825 }
1826 warn $@ if $@;
1827 }
1828 elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) {
1829 if ($printed_name) {
18811830 print ";\n";
1882 } else {
1831 }
1832 else {
18831833 eval qq/print "\\t$var;\\n"/;
1884 warn $@ if $@;
1885 }
1886 $deferred .= eval qq/"\\n$expr;\\n"/;
1887 warn $@ if $@;
1888 } else {
1834 warn $@ if $@;
1835 }
1836 $self->{deferred} .= eval qq/"\\n$expr;\\n"/;
1837 warn $@ if $@;
1838 }
1839 else {
18891840 die "panic: do not know how to handle this branch for function pointers"
1890 if $name_printed;
1841 if $printed_name;
18911842 eval qq/print "$expr;\\n"/;
1892 warn $@ if $@;
1843 warn $@ if $@;
18931844 }
18941845 }
18951846
18961847 sub generate_output {
1897 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1898 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1899 local($argoff) = $num - 1;
1900 local($ntype);
1901
1902 $type = TidyType($type) ;
1848 my $argsref = shift;
1849 my ($type, $num, $var, $do_setmagic, $do_push) = (
1850 $argsref->{type},
1851 $argsref->{num},
1852 $argsref->{var},
1853 $argsref->{do_setmagic},
1854 $argsref->{do_push}
1855 );
1856 my $arg = "ST(" . ($num - ($num != 0)) . ")";
1857 my $ntype;
1858
1859 my $typemaps = $self->{typemap};
1860
1861 $type = tidy_type($type);
19031862 if ($type =~ /^array\(([^,]*),(.*)\)/) {
19041863 print "\t$arg = sv_newmortal();\n";
19051864 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
19061865 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1907 } else {
1908 blurt("Error: '$type' not in typemap"), return
1909 unless defined($type_kind{$type});
1910 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1911 unless defined $output_expr{$type_kind{$type}} ;
1866 }
1867 else {
1868 my $typemap = $typemaps->get_typemap(ctype => $type);
1869 $self->blurt("Could not find a typemap for C type '$type'"), return
1870 if not $typemap;
1871 my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
1872 $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return
1873 unless $outputmap;
19121874 ($ntype = $type) =~ s/\s*\*/Ptr/g;
19131875 $ntype =~ s/\(\)//g;
1876 my $subtype;
19141877 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1915 $expr = $output_expr{$type_kind{$type}};
1878
1879 my $expr = $outputmap->cleaned_code;
19161880 if ($expr =~ /DO_ARRAY_ELEM/) {
1917 blurt("Error: '$subtype' not in typemap"), return
1918 unless defined($type_kind{$subtype});
1919 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1920 unless defined $output_expr{$type_kind{$subtype}} ;
1921 $subexpr = $output_expr{$type_kind{$subtype}};
1881 my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
1882 $self->blurt("Could not find a typemap for C type '$subtype'"), return
1883 if not $subtypemap;
1884 my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
1885 $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
1886 unless $suboutputmap;
1887 my $subexpr = $suboutputmap->cleaned_code;
19221888 $subexpr =~ s/ntype/subtype/g;
19231889 $subexpr =~ s/\$arg/ST(ix_$var)/g;
19241890 $subexpr =~ s/\$var/${var}[ix_$var]/g;
19251891 $subexpr =~ s/\n\t/\n\t\t/g;
19261892 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
19271893 eval "print qq\a$expr\a";
1928 warn $@ if $@;
1894 warn $@ if $@;
19291895 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1930 } elsif ($var eq 'RETVAL') {
1896 }
1897 elsif ($var eq 'RETVAL') {
19311898 if ($expr =~ /^\t\$arg = new/) {
1932 # We expect that $arg has refcnt 1, so we need to
1933 # mortalize it.
1934 eval "print qq\a$expr\a";
1935 warn $@ if $@;
1936 print "\tsv_2mortal(ST($num));\n";
1937 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1938 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1939 # We expect that $arg has refcnt >=1, so we need
1940 # to mortalize it!
1941 eval "print qq\a$expr\a";
1942 warn $@ if $@;
1943 print "\tsv_2mortal(ST(0));\n";
1944 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1945 } else {
1946 # Just hope that the entry would safely write it
1947 # over an already mortalized value. By
1948 # coincidence, something like $arg = &sv_undef
1949 # works too.
1950 print "\tST(0) = sv_newmortal();\n";
1951 eval "print qq\a$expr\a";
1952 warn $@ if $@;
1953 # new mortals don't have set magic
1954 }
1955 } elsif ($do_push) {
1899 # We expect that $arg has refcnt 1, so we need to
1900 # mortalize it.
1901 eval "print qq\a$expr\a";
1902 warn $@ if $@;
1903 print "\tsv_2mortal(ST($num));\n";
1904 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1905 }
1906 elsif ($expr =~ /^\s*\$arg\s*=/) {
1907 # We expect that $arg has refcnt >=1, so we need
1908 # to mortalize it!
1909 eval "print qq\a$expr\a";
1910 warn $@ if $@;
1911 print "\tsv_2mortal(ST(0));\n";
1912 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1913 }
1914 else {
1915 # Just hope that the entry would safely write it
1916 # over an already mortalized value. By
1917 # coincidence, something like $arg = &sv_undef
1918 # works too.
1919 print "\tST(0) = sv_newmortal();\n";
1920 eval "print qq\a$expr\a";
1921 warn $@ if $@;
1922 # new mortals don't have set magic
1923 }
1924 }
1925 elsif ($do_push) {
19561926 print "\tPUSHs(sv_newmortal());\n";
19571927 $arg = "ST($num)";
19581928 eval "print qq\a$expr\a";
1959 warn $@ if $@;
1929 warn $@ if $@;
19601930 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1961 } elsif ($arg =~ /^ST\(\d+\)$/) {
1931 }
1932 elsif ($arg =~ /^ST\(\d+\)$/) {
19621933 eval "print qq\a$expr\a";
1963 warn $@ if $@;
1934 warn $@ if $@;
19641935 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
19651936 }
19661937 }
19671938 }
19681939
1969 sub map_type {
1970 my($type, $varname) = @_;
1971
1972 # C++ has :: in types too so skip this
1973 $type =~ tr/:/_/ unless $hiertype;
1974 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1975 if ($varname) {
1976 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1977 (substr $type, pos $type, 0) = " $varname ";
1978 } else {
1979 $type .= "\t$varname";
1980 }
1981 }
1982 $type;
1983 }
1984
1985
1986 #########################################################
1987 package
1988 ExtUtils::ParseXS::CountLines;
1989 use strict;
1990 use vars qw($SECTION_END_MARKER);
1991
1992 sub TIEHANDLE {
1993 my ($class, $cfile, $fh) = @_;
1994 $cfile =~ s/\\/\\\\/g;
1995 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1996
1997 return bless {buffer => '',
1998 fh => $fh,
1999 line_no => 1,
2000 }, $class;
2001 }
2002
2003 sub PRINT {
2004 my $self = shift;
2005 for (@_) {
2006 $self->{buffer} .= $_;
2007 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
2008 my $line = $1;
2009 ++ $self->{line_no};
2010 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
2011 print {$self->{fh}} $line;
2012 }
2013 }
2014 }
2015
2016 sub PRINTF {
2017 my $self = shift;
2018 my $fmt = shift;
2019 $self->PRINT(sprintf($fmt, @_));
2020 }
2021
2022 sub DESTROY {
2023 # Not necessary if we're careful to end with a "\n"
2024 my $self = shift;
2025 print {$self->{fh}} $self->{buffer};
2026 }
2027
2028 sub UNTIE {
2029 # This sub does nothing, but is neccessary for references to be released.
2030 }
2031
2032 sub end_marker {
2033 return $SECTION_END_MARKER;
2034 }
2035
2036
20371940 1;
2038 __END__
2039
2040 =head1 NAME
2041
2042 ExtUtils::ParseXS - converts Perl XS code into C code
2043
2044 =head1 SYNOPSIS
2045
2046 use ExtUtils::ParseXS qw(process_file);
2047
2048 process_file( filename => 'foo.xs' );
2049
2050 process_file( filename => 'foo.xs',
2051 output => 'bar.c',
2052 'C++' => 1,
2053 typemap => 'path/to/typemap',
2054 hiertype => 1,
2055 except => 1,
2056 prototypes => 1,
2057 versioncheck => 1,
2058 linenumbers => 1,
2059 optimize => 1,
2060 prototypes => 1,
2061 );
2062 =head1 DESCRIPTION
2063
2064 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
2065 necessary to let C functions manipulate Perl values and creates the glue
2066 necessary to let Perl access those functions. The compiler uses typemaps to
2067 determine how to map C function parameters and variables to Perl values.
2068
2069 The compiler will search for typemap files called I<typemap>. It will use
2070 the following search path to find default typemaps, with the rightmost
2071 typemap taking precedence.
2072
2073 ../../../typemap:../../typemap:../typemap:typemap
2074
2075 =head1 EXPORT
2076
2077 None by default. C<process_file()> may be exported upon request.
2078
2079
2080 =head1 FUNCTIONS
2081
2082 =over 4
2083
2084 =item process_xs()
2085
2086 This function processes an XS file and sends output to a C file.
2087 Named parameters control how the processing is done. The following
2088 parameters are accepted:
2089
2090 =over 4
2091
2092 =item B<C++>
2093
2094 Adds C<extern "C"> to the C code. Default is false.
2095
2096 =item B<hiertype>
2097
2098 Retains C<::> in type names so that C++ hierachical types can be
2099 mapped. Default is false.
2100
2101 =item B<except>
2102
2103 Adds exception handling stubs to the C code. Default is false.
2104
2105 =item B<typemap>
2106
2107 Indicates that a user-supplied typemap should take precedence over the
2108 default typemaps. A single typemap may be specified as a string, or
2109 multiple typemaps can be specified in an array reference, with the
2110 last typemap having the highest precedence.
2111
2112 =item B<prototypes>
2113
2114 Generates prototype code for all xsubs. Default is false.
2115
2116 =item B<versioncheck>
2117
2118 Makes sure at run time that the object file (derived from the C<.xs>
2119 file) and the C<.pm> files have the same version number. Default is
2120 true.
2121
2122 =item B<linenumbers>
2123
2124 Adds C<#line> directives to the C output so error messages will look
2125 like they came from the original XS file. Default is true.
2126
2127 =item B<optimize>
2128
2129 Enables certain optimizations. The only optimization that is currently
2130 affected is the use of I<target>s by the output C code (see L<perlguts>).
2131 Not optimizing may significantly slow down the generated code, but this is the way
2132 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2133
2134 =item B<inout>
2135
2136 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2137 declarations. Default is true.
2138
2139 =item B<argtypes>
2140
2141 Enable recognition of ANSI-like descriptions of function signature.
2142 Default is true.
2143
2144 =item B<s>
2145
2146 I have no clue what this does. Strips function prefixes?
2147
2148 =back
2149
2150 =item errors()
2151
2152 This function returns the number of [a certain kind of] errors
2153 encountered during processing of the XS file.
2154
2155 =back
2156
2157 =head1 AUTHOR
2158
2159 Based on xsubpp code, written by Larry Wall.
2160
2161 Maintained by:
2162
2163 =over 4
2164
2165 =item *
2166
2167 Ken Williams, <ken@mathforum.org>
2168
2169 =item *
2170
2171 David Golden, <dagolden@cpan.org>
2172
2173 =back
2174
2175 =head1 COPYRIGHT
2176
2177 Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All
2178 rights reserved.
2179
2180 This library is free software; you can redistribute it and/or
2181 modify it under the same terms as Perl itself.
2182
2183 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2184 Porters, which was released under the same license terms.
2185
2186 =head1 SEE ALSO
2187
2188 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.
2189
2190 =cut
1941
1942 # vim: ts=2 sw=2 et:
+161
-0
lib/ExtUtils/ParseXS.pod less more
0 =head1 NAME
1
2 ExtUtils::ParseXS - converts Perl XS code into C code
3
4 =head1 SYNOPSIS
5
6 use ExtUtils::ParseXS qw(process_file);
7
8 process_file( filename => 'foo.xs' );
9
10 process_file( filename => 'foo.xs',
11 output => 'bar.c',
12 'C++' => 1,
13 typemap => 'path/to/typemap',
14 hiertype => 1,
15 except => 1,
16 prototypes => 1,
17 versioncheck => 1,
18 linenumbers => 1,
19 optimize => 1,
20 prototypes => 1,
21 );
22
23 =head1 DESCRIPTION
24
25 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
26 necessary to let C functions manipulate Perl values and creates the glue
27 necessary to let Perl access those functions. The compiler uses typemaps to
28 determine how to map C function parameters and variables to Perl values.
29
30 The compiler will search for typemap files called I<typemap>. It will use
31 the following search path to find default typemaps, with the rightmost
32 typemap taking precedence.
33
34 ../../../typemap:../../typemap:../typemap:typemap
35
36 =head1 EXPORT
37
38 None by default. C<process_file()> may be exported upon request.
39
40 =head1 FUNCTIONS
41
42 =over 4
43
44 =item process_file()
45
46 This function processes an XS file and sends output to a C file.
47 Named parameters control how the processing is done. The following
48 parameters are accepted:
49
50 =over 4
51
52 =item B<C++>
53
54 Adds C<extern "C"> to the C code. Default is false.
55
56 =item B<hiertype>
57
58 Retains C<::> in type names so that C++ hierarchical types can be
59 mapped. Default is false.
60
61 =item B<except>
62
63 Adds exception handling stubs to the C code. Default is false.
64
65 =item B<typemap>
66
67 Indicates that a user-supplied typemap should take precedence over the
68 default typemaps. A single typemap may be specified as a string, or
69 multiple typemaps can be specified in an array reference, with the
70 last typemap having the highest precedence.
71
72 =item B<prototypes>
73
74 Generates prototype code for all xsubs. Default is false.
75
76 =item B<versioncheck>
77
78 Makes sure at run time that the object file (derived from the C<.xs>
79 file) and the C<.pm> files have the same version number. Default is
80 true.
81
82 =item B<linenumbers>
83
84 Adds C<#line> directives to the C output so error messages will look
85 like they came from the original XS file. Default is true.
86
87 =item B<optimize>
88
89 Enables certain optimizations. The only optimization that is currently
90 affected is the use of I<target>s by the output C code (see L<perlguts>).
91 Not optimizing may significantly slow down the generated code, but this is the way
92 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
93
94 =item B<inout>
95
96 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
97 declarations. Default is true.
98
99 =item B<argtypes>
100
101 Enable recognition of ANSI-like descriptions of function signature.
102 Default is true.
103
104 =item B<s>
105
106 I<Maintainer note:> I have no clue what this does. Strips function prefixes?
107
108 =back
109
110 =item errors()
111
112 This function returns the number of [a certain kind of] errors
113 encountered during processing of the XS file.
114
115 =back
116
117 =head1 AUTHOR
118
119 Based on xsubpp code, written by Larry Wall.
120
121 Maintained by:
122
123 =over 4
124
125 =item *
126
127 Ken Williams, <ken@mathforum.org>
128
129 =item *
130
131 David Golden, <dagolden@cpan.org>
132
133 =item *
134
135 James Keenan, <jkeenan@cpan.org>
136
137 =item *
138
139 Steffen Mueller, <smueller@cpan.org>
140
141 =back
142
143 =head1 COPYRIGHT
144
145 Copyright 2002-2011 by Ken Williams, David Golden and other contributors. All
146 rights reserved.
147
148 This library is free software; you can redistribute it and/or
149 modify it under the same terms as Perl itself.
150
151 Based on the C<ExtUtils::xsubpp> code by Larry Wall and the Perl 5
152 Porters, which was released under the same license terms.
153
154 =head1 SEE ALSO
155
156 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.
157
158 =cut
159
160
+116
-0
lib/ExtUtils/Typemaps/InputMap.pm less more
0 package ExtUtils::Typemaps::InputMap;
1 use 5.006001;
2 use strict;
3 use warnings;
4 #use Carp qw(croak);
5
6 =head1 NAME
7
8 ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap
9
10 =head1 SYNOPSIS
11
12 use ExtUtils::Typemaps;
13 ...
14 my $input = $typemap->get_input_map('T_NV');
15 my $code = $input->code();
16 $input->code("...");
17
18 =head1 DESCRIPTION
19
20 Refer to L<ExtUtils::Typemaps> for details.
21
22 =head1 METHODS
23
24 =cut
25
26 =head2 new
27
28 Requires C<xstype> and C<code> parameters.
29
30 =cut
31
32 sub new {
33 my $prot = shift;
34 my $class = ref($prot)||$prot;
35 my %args = @_;
36
37 if (!ref($prot)) {
38 if (not defined $args{xstype} or not defined $args{code}) {
39 die("Need xstype and code parameters");
40 }
41 }
42
43 my $self = bless(
44 (ref($prot) ? {%$prot} : {})
45 => $class
46 );
47
48 $self->{xstype} = $args{xstype} if defined $args{xstype};
49 $self->{code} = $args{code} if defined $args{code};
50 $self->{code} =~ s/^(?=\S)/\t/mg;
51
52 return $self;
53 }
54
55 =head2 code
56
57 Returns or sets the INPUT mapping code for this entry.
58
59 =cut
60
61 sub code {
62 $_[0]->{code} = $_[1] if @_ > 1;
63 return $_[0]->{code};
64 }
65
66 =head2 xstype
67
68 Returns the name of the XS type of the INPUT map.
69
70 =cut
71
72 sub xstype {
73 return $_[0]->{xstype};
74 }
75
76 =head2 cleaned_code
77
78 Returns a cleaned-up copy of the code to which certain transformations
79 have been applied to make it more ANSI compliant.
80
81 =cut
82
83 sub cleaned_code {
84 my $self = shift;
85 my $code = $self->code;
86
87 $code =~ s/;*\s+\z//;
88
89 # Move C pre-processor instructions to column 1 to be strictly ANSI
90 # conformant. Some pre-processors are fussy about this.
91 $code =~ s/^\s+#/#/mg;
92 $code =~ s/\s*\z/\n/;
93
94 return $code;
95 }
96
97 =head1 SEE ALSO
98
99 L<ExtUtils::Typemaps>
100
101 =head1 AUTHOR
102
103 Steffen Mueller C<<smueller@cpan.org>>
104
105 =head1 COPYRIGHT & LICENSE
106
107 Copyright 2009-2011 Steffen Mueller
108
109 This program is free software; you can redistribute it and/or
110 modify it under the same terms as Perl itself.
111
112 =cut
113
114 1;
115
+194
-0
lib/ExtUtils/Typemaps/OutputMap.pm less more
0 package ExtUtils::Typemaps::OutputMap;
1 use 5.006001;
2 use strict;
3 use warnings;
4 #use Carp qw(croak);
5
6 =head1 NAME
7
8 ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap
9
10 =head1 SYNOPSIS
11
12 use ExtUtils::Typemaps;
13 ...
14 my $output = $typemap->get_output_map('T_NV');
15 my $code = $output->code();
16 $output->code("...");
17
18 =head1 DESCRIPTION
19
20 Refer to L<ExtUtils::Typemaps> for details.
21
22 =head1 METHODS
23
24 =cut
25
26 =head2 new
27
28 Requires C<xstype> and C<code> parameters.
29
30 =cut
31
32 sub new {
33 my $prot = shift;
34 my $class = ref($prot)||$prot;
35 my %args = @_;
36
37 if (!ref($prot)) {
38 if (not defined $args{xstype} or not defined $args{code}) {
39 die("Need xstype and code parameters");
40 }
41 }
42
43 my $self = bless(
44 (ref($prot) ? {%$prot} : {})
45 => $class
46 );
47
48 $self->{xstype} = $args{xstype} if defined $args{xstype};
49 $self->{code} = $args{code} if defined $args{code};
50 $self->{code} =~ s/^(?=\S)/\t/mg;
51
52 return $self;
53 }
54
55 =head2 code
56
57 Returns or sets the OUTPUT mapping code for this entry.
58
59 =cut
60
61 sub code {
62 $_[0]->{code} = $_[1] if @_ > 1;
63 return $_[0]->{code};
64 }
65
66 =head2 xstype
67
68 Returns the name of the XS type of the OUTPUT map.
69
70 =cut
71
72 sub xstype {
73 return $_[0]->{xstype};
74 }
75
76 =head2 cleaned_code
77
78 Returns a cleaned-up copy of the code to which certain transformations
79 have been applied to make it more ANSI compliant.
80
81 =cut
82
83 sub cleaned_code {
84 my $self = shift;
85 my $code = $self->code;
86
87 # Move C pre-processor instructions to column 1 to be strictly ANSI
88 # conformant. Some pre-processors are fussy about this.
89 $code =~ s/^\s+#/#/mg;
90 $code =~ s/\s*\z/\n/;
91
92 return $code;
93 }
94
95 =head2 targetable
96
97 This is an obscure optimization that used to live in C<ExtUtils::ParseXS>
98 directly.
99
100 In a nutshell, this will check whether the output code
101 involves calling C<set_iv>, C<set_uv>, C<set_nv>, C<set_pv> or C<set_pvn>
102 to set the special C<$arg> placeholder to a new value
103 B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
104 eligible for using the C<TARG>-related macros to optimize this.
105 Thus the name of the method: C<targetable>.
106
107 If the optimization can not be applied, this returns undef.
108 If it can be applied, this method returns a hash reference containing
109 the following information:
110
111 type: Any of the characters i, u, n, p
112 with_size: Bool indicating whether this is the sv_setpvn variant
113 what: The code that actually evaluates to the output scalar
114 what_size: If "with_size", this has the string length (as code, not constant)
115
116 =cut
117
118 sub targetable {
119 my $self = shift;
120 return $self->{targetable} if exists $self->{targetable};
121
122 our $bal; # ()-balanced
123 $bal = qr[
124 (?:
125 (?>[^()]+)
126 |
127 \( (??{ $bal }) \)
128 )*
129 ]x;
130
131 # matches variations on (SV*)
132 my $sv_cast = qr[
133 (?:
134 \( \s* SV \s* \* \s* \) \s*
135 )?
136 ]x;
137
138 my $size = qr[ # Third arg (to setpvn)
139 , \s* (??{ $bal })
140 ]x;
141
142 my $code = $self->code;
143
144 # We can still bootstrap compile 're', because in code re.pm is
145 # available to miniperl, and does not attempt to load the XS code.
146 use re 'eval';
147
148 my ($type, $with_size, $arg, $sarg) =
149 ($code =~
150 m[^
151 \s+
152 sv_set([iunp])v(n)? # Type, is_setpvn
153 \s*
154 \( \s*
155 $sv_cast \$arg \s* , \s*
156 ( (??{ $bal }) ) # Set from
157 ( (??{ $size }) )? # Possible sizeof set-from
158 \) \s* ; \s* $
159 ]x
160 );
161
162 my $rv = undef;
163 if ($type) {
164 $rv = {
165 type => $type,
166 with_size => $with_size,
167 what => $arg,
168 what_size => $sarg,
169 };
170 }
171 $self->{targetable} = $rv;
172 return $rv;
173 }
174
175 =head1 SEE ALSO
176
177 L<ExtUtils::Typemaps>
178
179 =head1 AUTHOR
180
181 Steffen Mueller C<<smueller@cpan.org>>
182
183 =head1 COPYRIGHT & LICENSE
184
185 Copyright 2009-2011 Steffen Mueller
186
187 This program is free software; you can redistribute it and/or
188 modify it under the same terms as Perl itself.
189
190 =cut
191
192 1;
193
+121
-0
lib/ExtUtils/Typemaps/Type.pm less more
0 package ExtUtils::Typemaps::Type;
1 use 5.006001;
2 use strict;
3 use warnings;
4 our $VERSION = '0.05';
5 #use Carp qw(croak);
6 require ExtUtils::Typemaps;
7
8 =head1 NAME
9
10 ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap
11
12 =head1 SYNOPSIS
13
14 use ExtUtils::Typemaps;
15 ...
16 my $type = $typemap->get_type_map('char*');
17 my $input = $typemap->get_input_map($type->xstype);
18
19 =head1 DESCRIPTION
20
21 Refer to L<ExtUtils::Typemaps> for details.
22 Object associates C<ctype> with C<xstype>, which is the index
23 into the in- and output mapping tables.
24
25 =head1 METHODS
26
27 =cut
28
29 =head2 new
30
31 Requires C<xstype> and C<ctype> parameters.
32
33 Optionally takes C<prototype> parameter.
34
35 =cut
36
37 sub new {
38 my $prot = shift;
39 my $class = ref($prot)||$prot;
40 my %args = @_;
41
42 if (!ref($prot)) {
43 if (not defined $args{xstype} or not defined $args{ctype}) {
44 die("Need xstype and ctype parameters");
45 }
46 }
47
48 my $self = bless(
49 (ref($prot) ? {%$prot} : {proto => ''})
50 => $class
51 );
52
53 $self->{xstype} = $args{xstype} if defined $args{xstype};
54 $self->{ctype} = $args{ctype} if defined $args{ctype};
55 $self->{tidy_ctype} = ExtUtils::Typemaps::_tidy_type($self->{ctype});
56 $self->{proto} = $args{'prototype'} if defined $args{'prototype'};
57
58 return $self;
59 }
60
61 =head2 proto
62
63 Returns or sets the prototype.
64
65 =cut
66
67 sub proto {
68 $_[0]->{proto} = $_[1] if @_ > 1;
69 return $_[0]->{proto};
70 }
71
72 =head2 xstype
73
74 Returns the name of the XS type that this C type is associated to.
75
76 =cut
77
78 sub xstype {
79 return $_[0]->{xstype};
80 }
81
82 =head2 ctype
83
84 Returns the name of the C type as it was set on construction.
85
86 =cut
87
88 sub ctype {
89 return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype};
90 }
91
92 =head2 tidy_ctype
93
94 Returns the canonicalized name of the C type.
95
96 =cut
97
98 sub tidy_ctype {
99 return $_[0]->{tidy_ctype};
100 }
101
102 =head1 SEE ALSO
103
104 L<ExtUtils::Typemaps>
105
106 =head1 AUTHOR
107
108 Steffen Mueller C<<smueller@cpan.org>>
109
110 =head1 COPYRIGHT & LICENSE
111
112 Copyright 2009-2011 Steffen Mueller
113
114 This program is free software; you can redistribute it and/or
115 modify it under the same terms as Perl itself.
116
117 =cut
118
119 1;
120
+985
-0
lib/ExtUtils/Typemaps.pm less more
0 package ExtUtils::Typemaps;
1 use 5.006001;
2 use strict;
3 use warnings;
4 our $VERSION = '1.01';
5 #use Carp qw(croak);
6
7 require ExtUtils::ParseXS;
8 require ExtUtils::ParseXS::Constants;
9 require ExtUtils::Typemaps::InputMap;
10 require ExtUtils::Typemaps::OutputMap;
11 require ExtUtils::Typemaps::Type;
12
13 =head1 NAME
14
15 ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files
16
17 =head1 SYNOPSIS
18
19 # read/create file
20 my $typemap = ExtUtils::Typemaps->new(file => 'typemap');
21 # alternatively create an in-memory typemap
22 # $typemap = ExtUtils::Typemaps->new();
23 # alternatively create an in-memory typemap by parsing a string
24 # $typemap = ExtUtils::Typemaps->new(string => $sometypemap);
25
26 # add a mapping
27 $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV');
28 $typemap->add_inputmap(
29 xstype => 'T_NV', code => '$var = ($type)SvNV($arg);'
30 );
31 $typemap->add_outputmap(
32 xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);'
33 );
34 $typemap->add_string(string => $typemapstring);
35 # will be parsed and merged
36
37 # remove a mapping (same for remove_typemap and remove_outputmap...)
38 $typemap->remove_inputmap(xstype => 'SomeType');
39
40 # save a typemap to a file
41 $typemap->write(file => 'anotherfile.map');
42
43 # merge the other typemap into this one
44 $typemap->merge(typemap => $another_typemap);
45
46 =head1 DESCRIPTION
47
48 This module can read, modify, create and write Perl XS typemap files. If you don't know
49 what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals.
50
51 The module is not entirely round-trip safe: For example it currently simply strips all comments.
52 The order of entries in the maps is, however, preserved.
53
54 We check for duplicate entries in the typemap, but do not check for missing
55 C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden
56 in a different typemap.
57
58 =head1 METHODS
59
60 =cut
61
62 =head2 new
63
64 Returns a new typemap object. Takes an optional C<file> parameter.
65 If set, the given file will be read. If the file doesn't exist, an empty typemap
66 is returned.
67
68 Alternatively, if the C<string> parameter is given, the supplied
69 string will be parsed instead of a file.
70
71 =cut
72
73 sub new {
74 my $class = shift;
75 my %args = @_;
76
77 if (defined $args{file} and defined $args{string}) {
78 die("Cannot handle both 'file' and 'string' arguments to constructor");
79 }
80
81 my $self = bless {
82 file => undef,
83 %args,
84 typemap_section => [],
85 typemap_lookup => {},
86 input_section => [],
87 input_lookup => {},
88 output_section => [],
89 output_lookup => {},
90 } => $class;
91
92 $self->_init();
93
94 return $self;
95 }
96
97 sub _init {
98 my $self = shift;
99 if (defined $self->{string}) {
100 $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename});
101 delete $self->{string};
102 }
103 elsif (defined $self->{file} and -e $self->{file}) {
104 open my $fh, '<', $self->{file}
105 or die "Cannot open typemap file '"
106 . $self->{file} . "' for reading: $!";
107 local $/ = undef;
108 my $string = <$fh>;
109 $self->_parse(\$string, $self->{lineno_offset}, $self->{file});
110 }
111 }
112
113 =head2 file
114
115 Get/set the file that the typemap is written to when the
116 C<write> method is called.
117
118 =cut
119
120 sub file {
121 $_[0]->{file} = $_[1] if @_ > 1;
122 $_[0]->{file}
123 }
124
125 =head2 add_typemap
126
127 Add a C<TYPEMAP> entry to the typemap.
128
129 Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
130 and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
131
132 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
133 existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1>
134 triggers a I<"first come first serve"> logic by which new entries that conflict
135 with existing entries are silently ignored.
136
137 As an alternative to the named parameters usage, you may pass in
138 an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be
139 added to the typemap. In that case, only the C<replace> or C<skip> named parameters
140 may be used after the object. Example:
141
142 $map->add_typemap($type_obj, replace => 1);
143
144 =cut
145
146 sub add_typemap {
147 my $self = shift;
148 my $type;
149 my %args;
150
151 if ((@_ % 2) == 1) {
152 my $orig = shift;
153 $type = $orig->new();
154 %args = @_;
155 }
156 else {
157 %args = @_;
158 my $ctype = $args{ctype};
159 die("Need ctype argument") if not defined $ctype;
160 my $xstype = $args{xstype};
161 die("Need xstype argument") if not defined $xstype;
162
163 $type = ExtUtils::Typemaps::Type->new(
164 xstype => $xstype,
165 'prototype' => $args{'prototype'},
166 ctype => $ctype,
167 );
168 }
169
170 if ($args{skip} and $args{replace}) {
171 die("Cannot use both 'skip' and 'replace'");
172 }
173
174 if ($args{replace}) {
175 $self->remove_typemap(ctype => $type->ctype);
176 }
177 elsif ($args{skip}) {
178 return() if exists $self->{typemap_lookup}{$type->ctype};
179 }
180 else {
181 $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
182 }
183
184 # store
185 push @{$self->{typemap_section}}, $type;
186 # remember type for lookup, too.
187 $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
188
189 return 1;
190 }
191
192 =head2 add_inputmap
193
194 Add an C<INPUT> entry to the typemap.
195
196 Required named arguments:
197 The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
198 and the C<code> to associate with it for input.
199
200 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
201 existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1>
202 triggers a I<"first come first serve"> logic by which new entries that conflict
203 with existing entries are silently ignored.
204
205 As an alternative to the named parameters usage, you may pass in
206 an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be
207 added to the typemap. In that case, only the C<replace> or C<skip> named parameters
208 may be used after the object. Example:
209
210 $map->add_inputmap($type_obj, replace => 1);
211
212 =cut
213
214 sub add_inputmap {
215 my $self = shift;
216 my $input;
217 my %args;
218
219 if ((@_ % 2) == 1) {
220 my $orig = shift;
221 $input = $orig->new();
222 %args = @_;
223 }
224 else {
225 %args = @_;
226 my $xstype = $args{xstype};
227 die("Need xstype argument") if not defined $xstype;
228 my $code = $args{code};
229 die("Need code argument") if not defined $code;
230
231 $input = ExtUtils::Typemaps::InputMap->new(
232 xstype => $xstype,
233 code => $code,
234 );
235 }
236
237 if ($args{skip} and $args{replace}) {
238 die("Cannot use both 'skip' and 'replace'");
239 }
240
241 if ($args{replace}) {
242 $self->remove_inputmap(xstype => $input->xstype);
243 }
244 elsif ($args{skip}) {
245 return() if exists $self->{input_lookup}{$input->xstype};
246 }
247 else {
248 $self->validate(inputmap_xstype => $input->xstype);
249 }
250
251 # store
252 push @{$self->{input_section}}, $input;
253 # remember type for lookup, too.
254 $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
255
256 return 1;
257 }
258
259 =head2 add_outputmap
260
261 Add an C<OUTPUT> entry to the typemap.
262 Works exactly the same as C<add_inputmap>.
263
264 =cut
265
266 sub add_outputmap {
267 my $self = shift;
268 my $output;
269 my %args;
270
271 if ((@_ % 2) == 1) {
272 my $orig = shift;
273 $output = $orig->new();
274 %args = @_;
275 }
276 else {
277 %args = @_;
278 my $xstype = $args{xstype};
279 die("Need xstype argument") if not defined $xstype;
280 my $code = $args{code};
281 die("Need code argument") if not defined $code;
282
283 $output = ExtUtils::Typemaps::OutputMap->new(
284 xstype => $xstype,
285 code => $code,
286 );
287 }
288
289 if ($args{skip} and $args{replace}) {
290 die("Cannot use both 'skip' and 'replace'");
291 }
292
293 if ($args{replace}) {
294 $self->remove_outputmap(xstype => $output->xstype);
295 }
296 elsif ($args{skip}) {
297 return() if exists $self->{output_lookup}{$output->xstype};
298 }
299 else {
300 $self->validate(outputmap_xstype => $output->xstype);
301 }
302
303 # store
304 push @{$self->{output_section}}, $output;
305 # remember type for lookup, too.
306 $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
307
308 return 1;
309 }
310
311 =head2 add_string
312
313 Parses a string as a typemap and merge it into the typemap object.
314
315 Required named argument: C<string> to specify the string to parse.
316
317 =cut
318
319 sub add_string {
320 my $self = shift;
321 my %args = @_;
322 die("Need 'string' argument") if not defined $args{string};
323
324 # no, this is not elegant.
325 my $other = ExtUtils::Typemaps->new(string => $args{string});
326 $self->merge(typemap => $other);
327 }
328
329 =head2 remove_typemap
330
331 Removes a C<TYPEMAP> entry from the typemap.
332
333 Required named argument: C<ctype> to specify the entry to remove from the typemap.
334
335 Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
336
337 =cut
338
339 sub remove_typemap {
340 my $self = shift;
341 my $ctype;
342 if (@_ > 1) {
343 my %args = @_;
344 $ctype = $args{ctype};
345 die("Need ctype argument") if not defined $ctype;
346 $ctype = _tidy_type($ctype);
347 }
348 else {
349 $ctype = $_[0]->tidy_ctype;
350 }
351
352 return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
353 }
354
355 =head2 remove_inputmap
356
357 Removes an C<INPUT> entry from the typemap.
358
359 Required named argument: C<xstype> to specify the entry to remove from the typemap.
360
361 Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
362
363 =cut
364
365 sub remove_inputmap {
366 my $self = shift;
367 my $xstype;
368 if (@_ > 1) {
369 my %args = @_;
370 $xstype = $args{xstype};
371 die("Need xstype argument") if not defined $xstype;
372 }
373 else {
374 $xstype = $_[0]->xstype;
375 }
376
377 return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
378 }
379
380 =head2 remove_inputmap
381
382 Removes an C<OUTPUT> entry from the typemap.
383
384 Required named argument: C<xstype> to specify the entry to remove from the typemap.
385
386 Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
387
388 =cut
389
390 sub remove_outputmap {
391 my $self = shift;
392 my $xstype;
393 if (@_ > 1) {
394 my %args = @_;
395 $xstype = $args{xstype};
396 die("Need xstype argument") if not defined $xstype;
397 }
398 else {
399 $xstype = $_[0]->xstype;
400 }
401
402 return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
403 }
404
405 sub _remove {
406 my $self = shift;
407 my $rm = shift;
408 my $array = shift;
409 my $lookup = shift;
410
411 # Just fetch the index of the item from the lookup table
412 my $index = $lookup->{$rm};
413 return() if not defined $index;
414
415 # Nuke the item from storage
416 splice(@$array, $index, 1);
417
418 # Decrement the storage position of all items thereafter
419 foreach my $key (keys %$lookup) {
420 if ($lookup->{$key} > $index) {
421 $lookup->{$key}--;
422 }
423 }
424 return();
425 }
426
427 =head2 get_typemap
428
429 Fetches an entry of the TYPEMAP section of the typemap.
430
431 Mandatory named arguments: The C<ctype> of the entry.
432
433 Returns the C<ExtUtils::Typemaps::Type>
434 object for the entry if found.
435
436 =cut
437
438 sub get_typemap {
439 my $self = shift;
440 die("Need named parameters, got uneven number") if @_ % 2;
441
442 my %args = @_;
443 my $ctype = $args{ctype};
444 die("Need ctype argument") if not defined $ctype;
445 $ctype = _tidy_type($ctype);
446
447 my $index = $self->{typemap_lookup}{$ctype};
448 return() if not defined $index;
449 return $self->{typemap_section}[$index];
450 }
451
452 =head2 get_inputmap
453
454 Fetches an entry of the INPUT section of the
455 typemap.
456
457 Mandatory named arguments: The C<xstype> of the
458 entry or the C<ctype> of the typemap that can be used to find
459 the C<xstype>. To wit, the following pieces of code
460 are equivalent:
461
462 my $type = $typemap->get_typemap(ctype => $ctype)
463 my $input_map = $typemap->get_inputmap(xstype => $type->xstype);
464
465 my $input_map = $typemap->get_inputmap(ctype => $ctype);
466
467 Returns the C<ExtUtils::Typemaps::InputMap>
468 object for the entry if found.
469
470 =cut
471
472 sub get_inputmap {
473 my $self = shift;
474 die("Need named parameters, got uneven number") if @_ % 2;
475
476 my %args = @_;
477 my $xstype = $args{xstype};
478 my $ctype = $args{ctype};
479 die("Need xstype or ctype argument")
480 if not defined $xstype
481 and not defined $ctype;
482 die("Need xstype OR ctype arguments, not both")
483 if defined $xstype and defined $ctype;
484
485 if (defined $ctype) {
486 my $tm = $self->get_typemap(ctype => $ctype);
487 $xstype = $tm && $tm->xstype;
488 return() if not defined $xstype;
489 }
490
491 my $index = $self->{input_lookup}{$xstype};
492 return() if not defined $index;
493 return $self->{input_section}[$index];
494 }
495
496 =head2 get_outputmap
497
498 Fetches an entry of the OUTPUT section of the
499 typemap.
500
501 Mandatory named arguments: The C<xstype> of the
502 entry or the C<ctype> of the typemap that can be used to
503 resolve the C<xstype>. (See above for an example.)
504
505 Returns the C<ExtUtils::Typemaps::InputMap>
506 object for the entry if found.
507
508 =cut
509
510 sub get_outputmap {
511 my $self = shift;
512 die("Need named parameters, got uneven number") if @_ % 2;
513
514 my %args = @_;
515 my $xstype = $args{xstype};
516 my $ctype = $args{ctype};
517 die("Need xstype or ctype argument")
518 if not defined $xstype
519 and not defined $ctype;
520 die("Need xstype OR ctype arguments, not both")
521 if defined $xstype and defined $ctype;
522
523 if (defined $ctype) {
524 my $tm = $self->get_typemap(ctype => $ctype);
525 $xstype = $tm && $tm->xstype;
526 return() if not defined $xstype;
527 }
528
529 my $index = $self->{output_lookup}{$xstype};
530 return() if not defined $index;
531 return $self->{output_section}[$index];
532 }
533
534 =head2 write
535
536 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
537 typemap will be written to the specified file. If not, the typemap is written
538 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
539 it was read from if any).
540
541 =cut
542
543 sub write {
544 my $self = shift;
545 my %args = @_;
546 my $file = defined $args{file} ? $args{file} : $self->file();
547 die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
548 if not defined $file;
549
550 open my $fh, '>', $file
551 or die "Cannot open typemap file '$file' for writing: $!";
552 print $fh $self->as_string();
553 close $fh;
554 }
555
556 =head2 as_string
557
558 Generates and returns the string form of the typemap.
559
560 =cut
561
562 sub as_string {
563 my $self = shift;
564 my $typemap = $self->{typemap_section};
565 my @code;
566 push @code, "TYPEMAP\n";
567 foreach my $entry (@$typemap) {
568 # type kind proto
569 # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
570 push @code, $entry->ctype . "\t" . $entry->xstype
571 . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
572 }
573
574 my $input = $self->{input_section};
575 if (@$input) {
576 push @code, "\nINPUT\n";
577 foreach my $entry (@$input) {
578 push @code, $entry->xstype, "\n", $entry->code, "\n";
579 }
580 }
581
582 my $output = $self->{output_section};
583 if (@$output) {
584 push @code, "\nOUTPUT\n";
585 foreach my $entry (@$output) {
586 push @code, $entry->xstype, "\n", $entry->code, "\n";
587 }
588 }
589 return join '', @code;
590 }
591
592 =head2 merge
593
594 Merges a given typemap into the object. Note that a failed merge
595 operation leaves the object in an inconsistent state so clone it if necessary.
596
597 Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
598 or C<file =E<gt> $path_to_typemap_file> but not both.
599
600 Optional arguments: C<replace =E<gt> 1> to force replacement
601 of existing typemap entries without warning or C<skip =E<gt> 1>
602 to skip entries that exist already in the typemap.
603
604 =cut
605
606 sub merge {
607 my $self = shift;
608 my %args = @_;
609
610 if (exists $args{typemap} and exists $args{file}) {
611 die("Need {file} OR {typemap} argument. Not both!");
612 }
613 elsif (not exists $args{typemap} and not exists $args{file}) {
614 die("Need {file} or {typemap} argument!");
615 }
616
617 my @params;
618 push @params, 'replace' => $args{replace} if exists $args{replace};
619 push @params, 'skip' => $args{skip} if exists $args{skip};
620
621 my $typemap = $args{typemap};
622 if (not defined $typemap) {
623 $typemap = ref($self)->new(file => $args{file}, @params);
624 }
625
626 # FIXME breaking encapsulation. Add accessor code.
627 foreach my $entry (@{$typemap->{typemap_section}}) {
628 $self->add_typemap( $entry, @params );
629 }
630
631 foreach my $entry (@{$typemap->{input_section}}) {
632 $self->add_inputmap( $entry, @params );
633 }
634
635 foreach my $entry (@{$typemap->{output_section}}) {
636 $self->add_outputmap( $entry, @params );
637 }
638
639 return 1;
640 }
641
642 =head2 is_empty
643
644 Returns a bool indicating whether this typemap is entirely empty.
645
646 =cut
647
648 sub is_empty {
649 my $self = shift;
650
651 return @{ $self->{typemap_section} } == 0
652 && @{ $self->{input_section} } == 0
653 && @{ $self->{output_section} } == 0;
654 }
655
656 =head2 _get_typemap_hash
657
658 Returns a hash mapping the C types to the XS types:
659
660 {
661 'char **' => 'T_PACKEDARRAY',
662 'bool_t' => 'T_IV',
663 'AV *' => 'T_AVREF',
664 'InputStream' => 'T_IN',
665 'double' => 'T_DOUBLE',
666 # ...
667 }
668
669 This is documented because it is used by C<ExtUtils::ParseXS>,
670 but it's not intended for general consumption. May be removed
671 at any time.
672
673 =cut
674
675 sub _get_typemap_hash {
676 my $self = shift;
677 my $lookup = $self->{typemap_lookup};
678 my $storage = $self->{typemap_section};
679
680 my %rv;
681 foreach my $ctype (keys %$lookup) {
682 $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
683 }
684
685 return \%rv;
686 }
687
688 =head2 _get_inputmap_hash
689
690 Returns a hash mapping the XS types (identifiers) to the
691 corresponding INPUT code:
692
693 {
694 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg)
695 ',
696 'T_OUT' => ' $var = IoOFP(sv_2io($arg))
697 ',
698 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) {
699 # ...
700 }
701
702 This is documented because it is used by C<ExtUtils::ParseXS>,
703 but it's not intended for general consumption. May be removed
704 at any time.
705
706 =cut
707
708 sub _get_inputmap_hash {
709 my $self = shift;
710 my $lookup = $self->{input_lookup};
711 my $storage = $self->{input_section};
712
713 my %rv;
714 foreach my $xstype (keys %$lookup) {
715 $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
716
717 # Squash trailing whitespace to one line break
718 # This isn't strictly necessary, but makes the output more similar
719 # to the original ExtUtils::ParseXS.
720 $rv{$xstype} =~ s/\s*\z/\n/;
721 }
722
723 return \%rv;
724 }
725
726
727 =head2 _get_outputmap_hash
728
729 Returns a hash mapping the XS types (identifiers) to the
730 corresponding OUTPUT code:
731
732 {
733 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(),
734 $var.context.value().size());
735 ',
736 'T_OUT' => ' {
737 GV *gv = newGVgen("$Package");
738 if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
739 sv_setsv(
740 $arg,
741 sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))
742 );
743 else
744 $arg = &PL_sv_undef;
745 }
746 ',
747 # ...
748 }
749
750 This is documented because it is used by C<ExtUtils::ParseXS>,
751 but it's not intended for general consumption. May be removed
752 at any time.
753
754 =cut
755
756 sub _get_outputmap_hash {
757 my $self = shift;
758 my $lookup = $self->{output_lookup};
759 my $storage = $self->{output_section};
760
761 my %rv;
762 foreach my $xstype (keys %$lookup) {
763 $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
764
765 # Squash trailing whitespace to one line break
766 # This isn't strictly necessary, but makes the output more similar
767 # to the original ExtUtils::ParseXS.
768 $rv{$xstype} =~ s/\s*\z/\n/;
769 }
770
771 return \%rv;
772 }
773
774 =head2 _get_prototype_hash
775
776 Returns a hash mapping the C types of the typemap to their
777 corresponding prototypes.
778
779 {
780 'char **' => '$',
781 'bool_t' => '$',
782 'AV *' => '$',
783 'InputStream' => '$',
784 'double' => '$',
785 # ...
786 }
787
788 This is documented because it is used by C<ExtUtils::ParseXS>,
789 but it's not intended for general consumption. May be removed
790 at any time.
791
792 =cut
793
794 sub _get_prototype_hash {
795 my $self = shift;
796 my $lookup = $self->{typemap_lookup};
797 my $storage = $self->{typemap_section};
798
799 my %rv;
800 foreach my $ctype (keys %$lookup) {
801 $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
802 }
803
804 return \%rv;
805 }
806
807
808
809 # make sure that the provided types wouldn't collide with what's
810 # in the object already.
811 sub validate {
812 my $self = shift;
813 my %args = @_;
814
815 if ( exists $args{ctype}
816 and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
817 {
818 die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
819 }
820
821 if ( exists $args{inputmap_xstype}
822 and exists $self->{input_lookup}{$args{inputmap_xstype}} )
823 {
824 die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
825 }
826
827 if ( exists $args{outputmap_xstype}
828 and exists $self->{output_lookup}{$args{outputmap_xstype}} )
829 {
830 die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
831 }
832
833 return 1;
834 }
835
836 sub _parse {
837 my $self = shift;
838 my $stringref = shift;
839 my $lineno_offset = shift;
840 $lineno_offset = 0 if not defined $lineno_offset;
841 my $filename = shift;
842 $filename = '<string>' if not defined $filename;
843
844 my $replace = $self->{replace};
845 my $skip = $self->{skip};
846 die "Can only replace OR skip" if $replace and $skip;
847 my @add_params;
848 push @add_params, replace => 1 if $replace;
849 push @add_params, skip => 1 if $skip;
850
851 # TODO comments should round-trip, currently ignoring
852 # TODO order of sections, multiple sections of same type
853 # Heavily influenced by ExtUtils::ParseXS
854 my $section = 'typemap';
855 my $lineno = $lineno_offset;
856 my $junk = "";
857 my $current = \$junk;
858 my @input_expr;
859 my @output_expr;
860 while ($$stringref =~ /^(.*)$/gcm) {
861 local $_ = $1;
862 ++$lineno;
863 chomp;
864 next if /^\s*#/;
865 if (/^INPUT\s*$/) {
866 $section = 'input';
867 $current = \$junk;
868 next;
869 }
870 elsif (/^OUTPUT\s*$/) {
871 $section = 'output';
872 $current = \$junk;
873 next;
874 }
875 elsif (/^TYPEMAP\s*$/) {
876 $section = 'typemap';
877 $current = \$junk;
878 next;
879 }
880
881 if ($section eq 'typemap') {
882 my $line = $_;
883 s/^\s+//; s/\s+$//;
884 next if $_ eq '' or /^#/;
885 my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
886 or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
887 next;
888 # prototype defaults to '$'
889 $proto = '$' unless $proto;
890 warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
891 unless _valid_proto_string($proto);
892 $self->add_typemap(
893 ExtUtils::Typemaps::Type->new(
894 xstype => $kind, proto => $proto, ctype => $type
895 ),
896 @add_params
897 );
898 } elsif (/^\s/) {
899 s/\s+$//;
900 $$current .= $$current eq '' ? $_ : "\n".$_;
901 } elsif ($_ eq '') {
902 next;
903 } elsif ($section eq 'input') {
904 s/\s+$//;
905 push @input_expr, {xstype => $_, code => ''};
906 $current = \$input_expr[-1]{code};
907 } else { # output section
908 s/\s+$//;
909 push @output_expr, {xstype => $_, code => ''};
910 $current = \$output_expr[-1]{code};
911 }
912
913 } # end while lines
914
915 foreach my $inexpr (@input_expr) {
916 $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
917 }
918 foreach my $outexpr (@output_expr) {
919 $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
920 }
921
922 return 1;
923 }
924
925 # taken from ExtUtils::ParseXS
926 sub _tidy_type {
927 local $_ = shift;
928
929 # rationalise any '*' by joining them into bunches and removing whitespace
930 s#\s*(\*+)\s*#$1#g;
931 s#(\*+)# $1 #g ;
932
933 # trim leading & trailing whitespace
934 s/^\s+//; s/\s+$//;
935
936 # change multiple whitespace into a single space
937 s/\s+/ /g;
938
939 $_;
940 }
941
942
943 # taken from ExtUtils::ParseXS
944 sub _valid_proto_string {
945 my $string = shift;
946 if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
947 return $string;
948 }
949
950 return 0 ;
951 }
952
953 # taken from ExtUtils::ParseXS (C_string)
954 sub _escape_backslashes {
955 my $string = shift;
956 $string =~ s[\\][\\\\]g;
957 $string;
958 }
959
960 =head1 CAVEATS
961
962 Inherits some evil code from C<ExtUtils::ParseXS>.
963
964 =head1 SEE ALSO
965
966 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
967
968 For details on typemaps: L<perlxstut>, L<perlxs>.
969
970 =head1 AUTHOR
971
972 Steffen Mueller C<<smueller@cpan.org>>
973
974 =head1 COPYRIGHT & LICENSE
975
976 Copyright 2009-2011 Steffen Mueller
977
978 This program is free software; you can redistribute it and/or
979 modify it under the same terms as Perl itself.
980
981 =cut
982
983 1;
984
+22
-5
lib/ExtUtils/xsubpp less more
0 #!./miniperl
0 #!perl
1 use 5.006;
2 use strict;
3 eval {
4 require ExtUtils::ParseXS;
5 ExtUtils::ParseXS->import(
6 qw(
7 process_file
8 report_error_count
9 )
10 );
11 1;
12 }
13 or do {
14 my $err = $@ || 'Zombie error';
15 my $v = $ExtUtils::ParseXS::VERSION;
16 $v = '<undef>' if not defined $v;
17 die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err";
18 };
119
2 require 5.002;
3 use ExtUtils::ParseXS qw(process_file);
420 use Getopt::Long;
521
622 my %args = ();
3753 $args{filename} = shift @ARGV;
3854
3955 process_file(%args);
40 exit( ExtUtils::ParseXS::errors() ? 1 : 0 );
56 exit( report_error_count() ? 1 : 0 );
4157
4258 __END__
4359
5167
5268 =head1 DESCRIPTION
5369
54 This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>.
70 This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>
71 or by L<Module::Build> or other Perl module build tools.
5572
5673 I<xsubpp> will compile XS code into C code by embedding the constructs
5774 necessary to let C functions manipulate Perl values and creates the glue
+89
-0
t/001-basic.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More tests => 11;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7
8 my ($source_file, $obj_file, $lib_file);
9
10 require_ok( 'ExtUtils::ParseXS' );
11 ExtUtils::ParseXS->import('process_file');
12
13 chdir 't' or die "Can't chdir to t/, $!";
14
15 use Carp; $SIG{__WARN__} = \&Carp::cluck;
16
17 #########################
18
19 # Try sending to filehandle
20 tie *FH, 'Foo';
21 process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 );
22 like tied(*FH)->content, '/is_even/', "Test that output contains some text";
23
24 $source_file = 'XSTest.c';
25
26 # Try sending to file
27 process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0);
28 ok -e $source_file, "Create an output file";
29
30 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
31 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
32
33 SKIP: {
34 skip "no compiler available", 2
35 if ! $b->have_compiler;
36 $obj_file = $b->compile( source => $source_file );
37 ok $obj_file, "ExtUtils::CBuilder::compile() returned true value";
38 ok -e $obj_file, "Make sure $obj_file exists";
39 }
40
41 SKIP: {
42 skip "no dynamic loading", 5
43 if !$b->have_compiler || !$Config{usedl};
44 my $module = 'XSTest';
45 $lib_file = $b->link( objects => $obj_file, module_name => $module );
46 ok $lib_file, "ExtUtils::CBuilder::link() returned true value";
47 ok -e $lib_file, "Make sure $lib_file exists";
48
49 eval {require XSTest};
50 is $@, '', "No error message recorded, as expected";
51 ok XSTest::is_even(8),
52 "Function created thru XS returned expected true value";
53 ok !XSTest::is_even(9),
54 "Function created thru XS returned expected false value";
55
56 # Win32 needs to close the DLL before it can unlink it, but unfortunately
57 # dl_unload_file was missing on Win32 prior to perl change #24679!
58 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
59 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
60 if ($DynaLoader::dl_modules[$i] eq $module) {
61 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
62 last;
63 }
64 }
65 }
66 }
67
68 my $seen = 0;
69 open my $IN, '<', $source_file
70 or die "Unable to open $source_file: $!";
71 while (my $l = <$IN>) {
72 $seen++ if $l =~ m/#line\s1\s/;
73 }
74 close $IN or die "Unable to close $source_file: $!";
75 is( $seen, 1, "Linenumbers created in output file, as intended" );
76
77 unless ($ENV{PERL_NO_CLEANUP}) {
78 for ( $obj_file, $lib_file, $source_file) {
79 next unless defined $_;
80 1 while unlink $_;
81 }
82 }
83
84 #####################################################################
85
86 sub Foo::TIEHANDLE { bless {}, 'Foo' }
87 sub Foo::PRINT { shift->{buf} .= join '', @_ }
88 sub Foo::content { shift->{buf} }
+116
-0
t/002-more.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5 use Config;
6 use DynaLoader;
7 use ExtUtils::CBuilder;
8 use attributes;
9 use overload;
10
11 plan tests => 28;
12
13 my ($source_file, $obj_file, $lib_file);
14
15 require_ok( 'ExtUtils::ParseXS' );
16 ExtUtils::ParseXS->import('process_file');
17
18 chdir 't' or die "Can't chdir to t/, $!";
19
20 use Carp; $SIG{__WARN__} = \&Carp::cluck;
21
22 #########################
23
24 $source_file = 'XSMore.c';
25
26 # Try sending to file
27 ExtUtils::ParseXS->process_file(
28 filename => 'XSMore.xs',
29 output => $source_file,
30 );
31 ok -e $source_file, "Create an output file";
32
33 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
34 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
35
36 SKIP: {
37 skip "no compiler available", 2
38 if ! $b->have_compiler;
39 $obj_file = $b->compile( source => $source_file );
40 ok $obj_file, "ExtUtils::CBuilder::compile() returned true value";
41 ok -e $obj_file, "Make sure $obj_file exists";
42 }
43
44 SKIP: {
45 skip "no dynamic loading", 24
46 if !$b->have_compiler || !$Config{usedl};
47 my $module = 'XSMore';
48 $lib_file = $b->link( objects => $obj_file, module_name => $module );
49 ok $lib_file, "ExtUtils::CBuilder::link() returned true value";
50 ok -e $lib_file, "Make sure $lib_file exists";
51
52 eval{
53 package XSMore;
54 our $VERSION = 42;
55 our $boot_ok;
56 DynaLoader::bootstrap_inherit(__PACKAGE__, $VERSION); # VERSIONCHECK disabled
57
58 sub new{ bless {}, shift }
59 };
60 is $@, '', "No error message recorded, as expected";
61 is ExtUtils::ParseXS::report_error_count(), 0, 'ExtUtils::ParseXS::errors()';
62
63 is $XSMore::boot_ok, 100, 'the BOOT keyword';
64
65 ok XSMore::include_ok(), 'the INCLUDE keyword';
66 is prototype(\&XSMore::include_ok), "", 'the PROTOTYPES keyword';
67
68 is prototype(\&XSMore::prototype_ssa), '$$@', 'the PROTOTYPE keyword';
69
70 is_deeply [attributes::get(\&XSMore::attr_method)], [qw(method)], 'the ATTRS keyword';
71 is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype';
72
73 is XSMore::return_1(), 1, 'the CASE keyword (1)';
74 is XSMore::return_2(), 2, 'the CASE keyword (2)';
75 is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)';
76 is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)';
77
78 is XSMore::arg_init(200), 200, 'argument init';
79
80 ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword';
81 is abs(XSMore->new), 42, 'the OVERLOAD keyword';
82
83 my @a;
84 XSMore::hook(\@a);
85 is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords';
86
87 is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword';
88
89 is XSMore::len("foo"), 3, 'the length keyword';
90
91 is XSMore::sum(5, 9), 14, 'the INCLUDE_COMMAND directive';
92
93 # Tests for embedded typemaps
94 is XSMore::typemaptest1(), 42, 'Simple embedded typemap works';
95 is XSMore::typemaptest2(), 42, 'Simple embedded typemap works with funny end marker';
96 is XSMore::typemaptest3(12), 12, 'Simple embedded typemap works for input, too';
97
98 # Win32 needs to close the DLL before it can unlink it, but unfortunately
99 # dl_unload_file was missing on Win32 prior to perl change #24679!
100 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
101 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
102 if ($DynaLoader::dl_modules[$i] eq $module) {
103 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
104 last;
105 }
106 }
107 }
108 }
109
110 unless ($ENV{PERL_NO_CLEANUP}) {
111 for ( $obj_file, $lib_file, $source_file) {
112 next unless defined $_;
113 1 while unlink $_;
114 }
115 }
+117
-0
t/003-usage.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7
8 if ( $] < 5.008 ) {
9 plan skip_all => "INTERFACE keyword support broken before 5.8";
10 }
11 else {
12 plan tests => 24;
13 }
14
15 my ($source_file, $obj_file, $lib_file, $module);
16
17 require_ok( 'ExtUtils::ParseXS' );
18 ExtUtils::ParseXS->import('process_file');
19
20 chdir 't' or die "Can't chdir to t/, $!";
21
22 use Carp; $SIG{__WARN__} = \&Carp::cluck;
23
24 #########################
25
26 $source_file = 'XSUsage.c';
27
28 # Try sending to file
29 process_file(filename => 'XSUsage.xs', output => $source_file);
30 ok -e $source_file, "Create an output file";
31
32 # TEST doesn't like extraneous output
33 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
34
35 # Try to compile the file! Don't get too fancy, though.
36 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
37
38 SKIP: {
39 skip "no compiler available", 2
40 if ! $b->have_compiler;
41 $module = 'XSUsage';
42
43 $obj_file = $b->compile( source => $source_file );
44 ok $obj_file;
45 ok -e $obj_file, "Make sure $obj_file exists";
46 }
47 SKIP: {
48 skip "no dynamic loading", 20
49 if !$b->have_compiler || !$Config{usedl};
50
51 $lib_file = $b->link( objects => $obj_file, module_name => $module );
52 ok $lib_file;
53 ok -e $lib_file, "Make sure $lib_file exists";
54
55 eval {require XSUsage};
56 is $@, '';
57
58 # The real tests here - for each way of calling the functions, call with the
59 # wrong number of arguments and check the Usage line is what we expect
60
61 eval { XSUsage::one(1) };
62 ok $@;
63 ok $@ =~ /^Usage: XSUsage::one/;
64
65 eval { XSUsage::two(1) };
66 ok $@;
67 ok $@ =~ /^Usage: XSUsage::two/;
68
69 eval { XSUsage::two_x(1) };
70 ok $@;
71 ok $@ =~ /^Usage: XSUsage::two_x/;
72
73 eval { FOO::two(1) };
74 ok $@;
75 ok $@ =~ /^Usage: FOO::two/;
76
77 eval { XSUsage::three(1) };
78 ok $@;
79 ok $@ =~ /^Usage: XSUsage::three/;
80
81 eval { XSUsage::four(1) };
82 ok !$@;
83
84 eval { XSUsage::five() };
85 ok $@;
86 ok $@ =~ /^Usage: XSUsage::five/;
87
88 eval { XSUsage::six() };
89 ok !$@;
90
91 eval { XSUsage::six(1) };
92 ok !$@;
93
94 eval { XSUsage::six(1,2) };
95 ok $@;
96 ok $@ =~ /^Usage: XSUsage::six/;
97
98 # Win32 needs to close the DLL before it can unlink it, but unfortunately
99 # dl_unload_file was missing on Win32 prior to perl change #24679!
100 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
101 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
102 if ($DynaLoader::dl_modules[$i] eq $module) {
103 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
104 last;
105 }
106 }
107 }
108 }
109
110 unless ($ENV{PERL_NO_CLEANUP}) {
111 for ( $obj_file, $lib_file, $source_file) {
112 next unless defined $_;
113 1 while unlink $_;
114 }
115 }
116
+100
-0
t/004-nolinenumbers.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More tests => 11;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7
8 my ($source_file, $obj_file, $lib_file);
9
10 require_ok( 'ExtUtils::ParseXS' );
11 ExtUtils::ParseXS->import('process_file');
12
13 chdir 't' or die "Can't chdir to t/, $!";
14
15 use Carp; $SIG{__WARN__} = \&Carp::cluck;
16
17 #########################
18
19 # Try sending to filehandle
20 tie *FH, 'Foo';
21 process_file(
22 filename => 'XSTest.xs',
23 output => \*FH,
24 prototypes => 1,
25 linenumbers => 0,
26 );
27 like tied(*FH)->content, '/is_even/', "Test that output contains some text";
28
29 $source_file = 'XSTest.c';
30
31 # Try sending to file
32 process_file(
33 filename => 'XSTest.xs',
34 output => $source_file,
35 prototypes => 0,
36 linenumbers => 0,
37 );
38 ok -e $source_file, "Create an output file";
39
40 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
41 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
42
43 SKIP: {
44 skip "no compiler available", 2
45 if ! $b->have_compiler;
46 $obj_file = $b->compile( source => $source_file );
47 ok $obj_file, "ExtUtils::CBuilder::compile() returned true value";
48 ok -e $obj_file, "Make sure $obj_file exists";
49 }
50
51 SKIP: {
52 skip "no dynamic loading", 5
53 if !$b->have_compiler || !$Config{usedl};
54 my $module = 'XSTest';
55 $lib_file = $b->link( objects => $obj_file, module_name => $module );
56 ok $lib_file, "ExtUtils::CBuilder::link() returned true value";
57 ok -e $lib_file, "Make sure $lib_file exists";
58
59 eval {require XSTest};
60 is $@, '', "No error message recorded, as expected";
61 ok XSTest::is_even(8),
62 "Function created thru XS returned expected true value";
63 ok !XSTest::is_even(9),
64 "Function created thru XS returned expected false value";
65
66 # Win32 needs to close the DLL before it can unlink it, but unfortunately
67 # dl_unload_file was missing on Win32 prior to perl change #24679!
68 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
69 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
70 if ($DynaLoader::dl_modules[$i] eq $module) {
71 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
72 last;
73 }
74 }
75 }
76 }
77
78 my $seen = 0;
79 open my $IN, '<', $source_file
80 or die "Unable to open $source_file: $!";
81 while (my $l = <$IN>) {
82 $seen++ if $l =~ m/#line\s1\s/;
83 }
84 close $IN or die "Unable to close $source_file: $!";
85 is( $seen, 0, "No linenumbers created in output file, as intended" );
86
87
88 unless ($ENV{PERL_NO_CLEANUP}) {
89 for ( $obj_file, $lib_file, $source_file) {
90 next unless defined $_;
91 1 while unlink $_;
92 }
93 }
94
95 #####################################################################
96
97 sub Foo::TIEHANDLE { bless {}, 'Foo' }
98 sub Foo::PRINT { shift->{buf} .= join '', @_ }
99 sub Foo::content { shift->{buf} }
+38
-0
t/101-standard_typemap_locations.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Test::More tests => 3;
4 use lib qw( lib );
5 use ExtUtils::ParseXS::Utilities qw(
6 standard_typemap_locations
7 );
8
9 {
10 local @INC = @INC;
11 my @stl = standard_typemap_locations( \@INC );
12 ok( @stl >= 9, "At least 9 entries in typemap locations list" );
13 is( $stl[$#stl], 'typemap',
14 "Last element is typemap in current directory");
15 SKIP: {
16 skip "No lib/ExtUtils/ directories under directories in \@INC",
17 1
18 unless @stl > 9;
19
20 # We check only as many location entries from the start of the array
21 # (where the @INC-related entries are) as there are entries from @INC.
22 # We manage to do that by stopping when we find the "updir" related
23 # entries, which we assume is never contained in a default @INC entry.
24 my $updir = File::Spec->updir;
25 my $max = $#INC;
26 $max = $#stl if $#stl < $max;
27 foreach my $i (0.. $max) {
28 $max = $i, last if $stl[$i] =~ /\Q$updir\E/;
29 }
30
31 ok(
32 ( 0 < (grep -f $_, @stl[0..$max]) ),
33 "At least one typemap file exists underneath \@INC directories"
34 );
35 }
36 }
37
+30
-0
t/102-trim_whitespace.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Test::More tests => 5;
4 use lib qw( lib );
5 use ExtUtils::ParseXS::Utilities qw(
6 trim_whitespace
7 );
8
9 my $str;
10
11 $str = 'overworked';
12 trim_whitespace($str);
13 is( $str, 'overworked', "Got expected value" );
14
15 $str = ' overworked';
16 trim_whitespace($str);
17 is( $str, 'overworked', "Got expected value" );
18
19 $str = 'overworked ';
20 trim_whitespace($str);
21 is( $str, 'overworked', "Got expected value" );
22
23 $str = ' overworked ';
24 trim_whitespace($str);
25 is( $str, 'overworked', "Got expected value" );
26
27 $str = "\toverworked";
28 trim_whitespace($str);
29 is( $str, 'overworked', "Got expected value" );
+23
-0
t/103-tidy_type.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Test::More tests => 3;
4 use lib qw( lib );
5 use ExtUtils::ParseXS::Utilities qw(
6 tidy_type
7 );
8
9 my $input;
10
11 $input = ' * ** ';
12 is( tidy_type($input), '***',
13 "Got expected value for '$input'" );
14
15 $input = ' * ** ';
16 is( tidy_type($input), '***',
17 "Got expected value for '$input'" );
18
19 $input = ' * ** foobar * ';
20 is( tidy_type($input), '*** foobar *',
21 "Got expected value for '$input'" );
22
+67
-0
t/104-map_type.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Test::More tests => 7;
4 use lib qw( lib );
5 use ExtUtils::ParseXS::Utilities qw(
6 map_type
7 );
8
9 my ($self, $type, $varname);
10 my ($result, $expected);
11
12 $type = 'struct DATA *';
13 $varname = 'RETVAL';
14 $self->{hiertype} = 0;
15 $expected = "$type\t$varname";
16 $result = map_type($self, $type, $varname);
17 is( $result, $expected,
18 "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
19
20 $type = 'Crypt::Shark';
21 $varname = undef;
22 $self->{hiertype} = 0;
23 $expected = 'Crypt__Shark';
24 $result = map_type($self, $type, $varname);
25 is( $result, $expected,
26 "Got expected map_type for <$type>, undef, <$self->{hiertype}>" );
27
28 $type = 'Crypt::Shark';
29 $varname = undef;
30 $self->{hiertype} = 1;
31 $expected = 'Crypt::Shark';
32 $result = map_type($self, $type, $varname);
33 is( $result, $expected,
34 "Got expected map_type for <$type>, undef, <$self->{hiertype}>" );
35
36 $type = 'Crypt::TC18';
37 $varname = 'RETVAL';
38 $self->{hiertype} = 0;
39 $expected = "Crypt__TC18\t$varname";
40 $result = map_type($self, $type, $varname);
41 is( $result, $expected,
42 "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
43
44 $type = 'Crypt::TC18';
45 $varname = 'RETVAL';
46 $self->{hiertype} = 1;
47 $expected = "Crypt::TC18\t$varname";
48 $result = map_type($self, $type, $varname);
49 is( $result, $expected,
50 "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
51
52 $type = 'array(alpha,beta) gamma';
53 $varname = 'RETVAL';
54 $self->{hiertype} = 0;
55 $expected = "alpha *\t$varname";
56 $result = map_type($self, $type, $varname);
57 is( $result, $expected,
58 "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
59
60 $type = '(*)';
61 $varname = 'RETVAL';
62 $self->{hiertype} = 0;
63 $expected = "(* $varname )";
64 $result = map_type($self, $type, $varname);
65 is( $result, $expected,
66 "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
+35
-0
t/105-valid_proto_string.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Test::More tests => 6;
4 use lib qw( lib );
5 use ExtUtils::ParseXS::Utilities qw(
6 valid_proto_string
7 );
8
9 my ($input, $output);
10
11 $input = '[\$]';
12 $output = valid_proto_string($input);
13 is( $output, $input, "Got expected value for <$input>" );
14
15 $input = '[$]';
16 $output = valid_proto_string($input);
17 is( $output, $input, "Got expected value for <$input>" );
18
19 $input = '[\$\@]';
20 $output = valid_proto_string($input);
21 is( $output, $input, "Got expected value for <$input>" );
22
23 $input = '[\$alpha]';
24 $output = valid_proto_string($input);
25 is( $output, 0, "Got expected value for <$input>" );
26
27 $input = '[alpha]';
28 $output = valid_proto_string($input);
29 is( $output, 0, "Got expected value for <$input>" );
30
31 $input = '[_]';
32 $output = valid_proto_string($input);
33 is( $output, $input, "Got expected value for <$input>" );
34
+45
-0
t/106-process_typemaps.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More tests => 2;
8 use lib qw( lib );
9 use ExtUtils::ParseXS::Utilities qw(
10 process_typemaps
11 );
12
13 my $startdir = cwd();
14 {
15 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
16 my $typemap = 'typemap';
17 my $tdir = tempdir( CLEANUP => 1 );
18 chdir $tdir or croak "Unable to change to tempdir for testing";
19 eval {
20 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
21 = process_typemaps( $typemap, $tdir );
22 };
23 like( $@, qr/Can't find \Q$typemap\E in \Q$tdir\E/, #'
24 "Got expected result for no typemap in current directory" );
25 chdir $startdir;
26 }
27
28 {
29 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
30 my $typemap = [ qw( pseudo typemap ) ];
31 my $tdir = tempdir( CLEANUP => 1 );
32 chdir $tdir or croak "Unable to change to tempdir for testing";
33 open my $IN, '>', 'typemap' or croak "Cannot open for writing";
34 print $IN "\n";
35 close $IN or croak "Cannot close after writing";
36 eval {
37 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
38 = process_typemaps( $typemap, $tdir );
39 };
40 like( $@, qr/Can't find pseudo in \Q$tdir\E/, #'
41 "Got expected result for no typemap in current directory" );
42 chdir $startdir;
43 }
44
+146
-0
t/107-make_targetable.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More qw(no_plan); # tests => 7;
8 use lib qw( lib );
9 use ExtUtils::ParseXS::Utilities qw(
10 make_targetable
11 );
12
13 my $output_expr_ref = {
14 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(),
15 $var.context.value().size());
16 ',
17 'T_OUT' => ' {
18 GV *gv = newGVgen("$Package");
19 if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
20 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
21 else
22 $arg = &PL_sv_undef;
23 }
24 ',
25 'T_REF_IV_PTR' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
26 ',
27 'T_U_LONG' => ' sv_setuv($arg, (UV)$var);
28 ',
29 'T_U_CHAR' => ' sv_setuv($arg, (UV)$var);
30 ',
31 'T_U_INT' => ' sv_setuv($arg, (UV)$var);
32 ',
33 'T_ARRAY' => ' {
34 U32 ix_$var;
35 EXTEND(SP,size_$var);
36 for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
37 ST(ix_$var) = sv_newmortal();
38 DO_ARRAY_ELEM
39 }
40 }
41 ',
42 'T_NV' => ' sv_setnv($arg, (NV)$var);
43 ',
44 'T_SHORT' => ' sv_setiv($arg, (IV)$var);
45 ',
46 'T_OPAQUE' => ' sv_setpvn($arg, (char *)&$var, sizeof($var));
47 ',
48 'T_PTROBJ' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
49 ',
50 'T_HVREF' => ' $arg = newRV((SV*)$var);
51 ',
52 'T_PACKEDARRAY' => ' XS_pack_$ntype($arg, $var, count_$ntype);
53 ',
54 'T_INT' => ' sv_setiv($arg, (IV)$var);
55 ',
56 'T_OPAQUEPTR' => ' sv_setpvn($arg, (char *)$var, sizeof(*$var));
57 ',
58 'T_BOOL' => ' $arg = boolSV($var);
59 ',
60 'T_REFREF' => ' NOT_IMPLEMENTED
61 ',
62 'T_REF_IV_REF' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var));
63 ',
64 'T_STDIO' => ' {
65 GV *gv = newGVgen("$Package");
66 PerlIO *fp = PerlIO_importFILE($var,0);
67 if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
68 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
69 else
70 $arg = &PL_sv_undef;
71 }
72 ',
73 'T_FLOAT' => ' sv_setnv($arg, (double)$var);
74 ',
75 'T_IN' => ' {
76 GV *gv = newGVgen("$Package");
77 if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
78 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
79 else
80 $arg = &PL_sv_undef;
81 }
82 ',
83 'T_PV' => ' sv_setpv((SV*)$arg, $var);
84 ',
85 'T_INOUT' => ' {
86 GV *gv = newGVgen("$Package");
87 if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
88 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
89 else
90 $arg = &PL_sv_undef;
91 }
92 ',
93 'T_CHAR' => ' sv_setpvn($arg, (char *)&$var, 1);
94 ',
95 'T_LONG' => ' sv_setiv($arg, (IV)$var);
96 ',
97 'T_DOUBLE' => ' sv_setnv($arg, (double)$var);
98 ',
99 'T_PTR' => ' sv_setiv($arg, PTR2IV($var));
100 ',
101 'T_AVREF' => ' $arg = newRV((SV*)$var);
102 ',
103 'T_SV' => ' $arg = $var;
104 ',
105 'T_ENUM' => ' sv_setiv($arg, (IV)$var);
106 ',
107 'T_REFOBJ' => ' NOT IMPLEMENTED
108 ',
109 'T_CVREF' => ' $arg = newRV((SV*)$var);
110 ',
111 'T_UV' => ' sv_setuv($arg, (UV)$var);
112 ',
113 'T_PACKED' => ' XS_pack_$ntype($arg, $var);
114 ',
115 'T_SYSRET' => ' if ($var != -1) {
116 if ($var == 0)
117 sv_setpvn($arg, "0 but true", 10);
118 else
119 sv_setiv($arg, (IV)$var);
120 }
121 ',
122 'T_IV' => ' sv_setiv($arg, (IV)$var);
123 ',
124 'T_PTRDESC' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var));
125 ',
126 'T_DATAUNIT' => ' sv_setpvn($arg, $var.chp(), $var.size());
127 ',
128 'T_U_SHORT' => ' sv_setuv($arg, (UV)$var);
129 ',
130 'T_SVREF' => ' $arg = newRV((SV*)$var);
131 ',
132 'T_PTRREF' => ' sv_setref_pv($arg, Nullch, (void*)$var);
133 ',
134 };
135
136 my %targetable;
137 %targetable = make_targetable($output_expr_ref);
138
139 ok(! exists $targetable{'T_AVREF'},
140 "Element found in 'output_expr' not found in \%targetable: not an 'sv_set'" );
141
142 ok(exists $targetable{'T_CALLBACK'},
143 "Element found in 'output_expr' found in \%targetable as expected" );
144
145 pass("Passed all tests in $0");
+18
-0
t/108-map_type.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More qw(no_plan); # tests => 7;
8 use lib qw( lib );
9 use ExtUtils::ParseXS::Utilities qw(
10 map_type
11 );
12
13 #print "\t" . map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n"
14 #print "\t" . map_type($var_type, $var_name, $self->{hiertype});
15 #print "\t" . map_type($var_type, undef, $self->{hiertype});
16
17 pass("Passed all tests in $0");
+27
-0
t/109-standard_XS_defs.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 $| = 1;
4 use Test::More tests => 5;
5 use lib qw( lib t/lib );
6 use ExtUtils::ParseXS::Utilities qw(
7 standard_XS_defs
8 );
9 use PrimitiveCapture;
10
11 my @statements = (
12 '#ifndef PERL_UNUSED_VAR',
13 '#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE',
14 '#ifdef PERL_IMPLICIT_CONTEXT',
15 '#ifdef newXS_flags',
16 );
17
18 my $stdout = PrimitiveCapture::capture_stdout(sub {
19 standard_XS_defs();
20 });
21
22 foreach my $s (@statements) {
23 like( $stdout, qr/$s/s, "Printed <$s>" );
24 }
25
26 pass("Passed all tests in $0");
+52
-0
t/110-assign_func_args.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More qw(no_plan); # tests => 7;
8 use lib qw( lib );
9 use ExtUtils::ParseXS::Utilities qw(
10 assign_func_args
11 );
12
13 #sub assign_func_args {
14 # my ($self, $argsref, $class) = @_;
15 # return join(", ", @func_args);
16
17 my ($self, @args, $class);
18 my ($func_args, $expected);
19
20 @args = qw( alpha beta gamma );
21 $self->{in_out}->{alpha} = 'OUT';
22 $expected = q|&alpha, beta, gamma|;
23 $func_args = assign_func_args($self, \@args, $class);
24 is( $func_args, $expected,
25 "Got expected func_args: in_out true; class undefined" );
26
27 @args = ( 'My::Class', qw( beta gamma ) );
28 $self->{in_out}->{beta} = 'OUT';
29 $class = 'My::Class';
30 $expected = q|&beta, gamma|;
31 $func_args = assign_func_args($self, \@args, $class);
32 is( $func_args, $expected,
33 "Got expected func_args: in_out true; class defined" );
34
35 @args = ( 'My::Class', qw( beta gamma ) );
36 $self->{in_out}->{beta} = '';
37 $class = 'My::Class';
38 $expected = q|beta, gamma|;
39 $func_args = assign_func_args($self, \@args, $class);
40 is( $func_args, $expected,
41 "Got expected func_args: in_out false; class defined" );
42
43 @args = qw( alpha beta gamma );
44 $self->{in_out}->{alpha} = '';
45 $class = undef;
46 $expected = q|alpha, beta, gamma|;
47 $func_args = assign_func_args($self, \@args, $class);
48 is( $func_args, $expected,
49 "Got expected func_args: in_out false; class undefined" );
50
51 pass("Passed all tests in $0");
+22
-0
t/111-analyze_preprocessor_statements.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 $| = 1;
4 use Carp;
5 use Cwd;
6 use File::Spec;
7 use File::Temp qw( tempdir );
8 use Test::More qw(no_plan); # tests => 7;
9 use lib qw( lib );
10 use ExtUtils::ParseXS::Utilities qw(
11 analyze_preprocessor_statements
12 );
13
14 # ( $self, $XSS_work_idx, $BootCode_ref ) =
15 # analyze_preprocessor_statements(
16 # $self, $statement, $XSS_work_idx, $BootCode_ref
17 # );
18
19 pass("Passed all tests in $0");
20
21
+14
-0
t/112-set_cond.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More qw(no_plan); # tests => 7;
8 use lib qw( lib );
9 use ExtUtils::ParseXS::Utilities qw(
10 set_cond
11 );
12
13 pass("Passed all tests in $0");
+149
-0
t/113-check_cond_preproc_statements.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 use Carp;
4 use Cwd;
5 use File::Spec;
6 use File::Temp qw( tempdir );
7 use Test::More tests => 13;
8 use lib qw( lib t/lib );
9 use ExtUtils::ParseXS;
10 use ExtUtils::ParseXS::Utilities qw(
11 check_conditional_preprocessor_statements
12 );
13 use PrimitiveCapture;
14
15 my $self = bless({} => 'ExtUtils::ParseXS');
16 $self->{line} = [];
17 $self->{XSStack} = [];
18 $self->{XSStack}->[0] = {};
19
20 {
21 $self->{line} = [
22 "#if this_is_an_if_statement",
23 "Alpha this is not an if/elif/elsif/endif",
24 "#elif this_is_an_elif_statement",
25 "Beta this is not an if/elif/elsif/endif",
26 "#else this_is_an_else_statement",
27 "Gamma this is not an if/elif/elsif/endif",
28 "#endif this_is_an_endif_statement",
29 ];
30 $self->{line_no} = [ 17 .. 23 ];
31 $self->{XSStack}->[-1]{type} = 'if';
32 $self->{filename} = 'myfile1';
33
34 my $rv;
35 my $stderr = PrimitiveCapture::capture_stderr(sub {
36 $rv = check_conditional_preprocessor_statements($self);
37 });
38
39 is( $rv, 0, "Basic case: returned 0: all ifs resolved" );
40 ok( ! $stderr, "No warnings captured, as expected" );
41 }
42
43 {
44 $self->{line} = [
45 "#if this_is_an_if_statement",
46 "Alpha this is not an if/elif/elsif/endif",
47 "#if this_is_a_different_if_statement",
48 "Beta this is not an if/elif/elsif/endif",
49 "#endif this_is_a_different_endif_statement",
50 "Gamma this is not an if/elif/elsif/endif",
51 "#endif this_is_an_endif_statement",
52 ];
53 $self->{line_no} = [ 17 .. 23 ];
54 $self->{XSStack}->[-1]{type} = 'if';
55 $self->{filename} = 'myfile1';
56
57 my $rv;
58 my $stderr = PrimitiveCapture::capture_stderr(sub {
59 $rv = check_conditional_preprocessor_statements($self);
60 });
61 is( $rv, 0, "One nested if case: returned 0: all ifs resolved" );
62 ok( ! $stderr, "No warnings captured, as expected" );
63 }
64
65 {
66 $self->{line} = [
67 "Alpha this is not an if/elif/elsif/endif",
68 "#elif this_is_an_elif_statement",
69 "Beta this is not an if/elif/elsif/endif",
70 "#else this_is_an_else_statement",
71 "Gamma this is not an if/elif/elsif/endif",
72 "#endif this_is_an_endif_statement",
73 ];
74 $self->{line_no} = [ 17 .. 22 ];
75 $self->{XSStack}->[-1]{type} = 'if';
76 $self->{filename} = 'myfile1';
77
78 my $rv;
79 my $stderr = PrimitiveCapture::capture_stderr(sub {
80 $rv = check_conditional_preprocessor_statements($self);
81 });
82 is( $rv, undef,
83 "Missing 'if' case: returned undef: all ifs resolved" );
84 like( $stderr,
85 qr/Warning: #else\/elif\/endif without #if in this function/,
86 "Got expected warning: lack of #if"
87 );
88 like( $stderr,
89 qr/precede it with a blank line/s,
90 "Got expected warning: advice re blank line"
91 );
92 }
93
94 {
95 $self->{line} = [
96 "Alpha this is not an if/elif/elsif/endif",
97 "#elif this_is_an_elif_statement",
98 "Beta this is not an if/elif/elsif/endif",
99 "#else this_is_an_else_statement",
100 "Gamma this is not an if/elif/elsif/endif",
101 "#endif this_is_an_endif_statement",
102 ];
103 $self->{line_no} = [ 17 .. 22 ];
104 $self->{XSStack}->[-1]{type} = 'file';
105 $self->{filename} = 'myfile1';
106
107 my $rv;
108 my $stderr = PrimitiveCapture::capture_stderr(sub {
109 $rv = check_conditional_preprocessor_statements($self);
110 });
111 is( $rv, undef,
112 "Missing 'if' case: returned undef: all ifs resolved" );
113 like( $stderr,
114 qr/Warning: #else\/elif\/endif without #if in this function/,
115 "Got expected warning: lack of #if"
116 );
117 unlike( $stderr,
118 qr/precede it with a blank line/s,
119 "Did not get unexpected stderr"
120 );
121 }
122
123 {
124 $self->{line} = [
125 "#if this_is_an_if_statement",
126 "Alpha this is not an if/elif/elsif/endif",
127 "#elif this_is_an_elif_statement",
128 "Beta this is not an if/elif/elsif/endif",
129 "#else this_is_an_else_statement",
130 "Gamma this is not an if/elif/elsif/endif",
131 ];
132 $self->{line_no} = [ 17 .. 22 ];
133 $self->{XSStack}->[-1]{type} = 'if';
134 $self->{filename} = 'myfile1';
135
136 my $rv;
137 my $stderr = PrimitiveCapture::capture_stderr(sub {
138 $rv = check_conditional_preprocessor_statements($self);
139 });
140 isnt( $rv, 0,
141 "Missing 'endif' case: returned non-zero as expected" );
142 like( $stderr,
143 qr/Warning: #if without #endif in this function/s,
144 "Got expected warning: lack of #endif"
145 );
146 }
147
148 pass("Passed all tests in $0");
+132
-0
t/114-blurt_death_Warn.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3 $| = 1;
4 use Carp;
5 use Cwd;
6 use File::Spec;
7 use File::Temp qw( tempdir );
8 use Test::More tests => 7;
9 use lib qw( lib t/lib );
10 use ExtUtils::ParseXS;
11 use ExtUtils::ParseXS::Utilities qw(
12 Warn
13 blurt
14 death
15 );
16 use PrimitiveCapture;
17
18 my $self = bless({} => 'ExtUtils::ParseXS');
19 $self->{line} = [];
20 $self->{line_no} = [];
21
22 {
23 $self->{line} = [
24 'Alpha',
25 'Beta',
26 'Gamma',
27 'Delta',
28 ];
29 $self->{line_no} = [ 17 .. 20 ];
30 $self->{filename} = 'myfile1';
31
32 my $message = 'Warning: Ignoring duplicate alias';
33
34 my $stderr = PrimitiveCapture::capture_stderr(sub {
35 Warn( $self, $message);
36 });
37 like( $stderr,
38 qr/$message in $self->{filename}, line 20/,
39 "Got expected Warn output",
40 );
41 }
42
43 {
44 $self->{line} = [
45 'Alpha',
46 'Beta',
47 'Gamma',
48 'Delta',
49 'Epsilon',
50 ];
51 $self->{line_no} = [ 17 .. 20 ];
52 $self->{filename} = 'myfile2';
53
54 my $message = 'Warning: Ignoring duplicate alias';
55 my $stderr = PrimitiveCapture::capture_stderr(sub {
56 Warn( $self, $message);
57 });
58 like( $stderr,
59 qr/$message in $self->{filename}, line 19/,
60 "Got expected Warn output",
61 );
62 }
63
64 {
65 $self->{line} = [
66 'Alpha',
67 'Beta',
68 'Gamma',
69 'Delta',
70 ];
71 $self->{line_no} = [ 17 .. 21 ];
72 $self->{filename} = 'myfile1';
73
74 my $message = 'Warning: Ignoring duplicate alias';
75 my $stderr = PrimitiveCapture::capture_stderr(sub {
76 Warn( $self, $message);
77 });
78 like( $stderr,
79 qr/$message in $self->{filename}, line 17/,
80 "Got expected Warn output",
81 );
82 }
83
84 {
85 $self->{line} = [
86 'Alpha',
87 'Beta',
88 'Gamma',
89 'Delta',
90 ];
91 $self->{line_no} = [ 17 .. 20 ];
92 $self->{filename} = 'myfile1';
93 $self->{errors} = 0;
94
95
96 my $message = 'Error: Cannot parse function definition';
97 my $stderr = PrimitiveCapture::capture_stderr(sub {
98 blurt( $self, $message);
99 });
100 like( $stderr,
101 qr/$message in $self->{filename}, line 20/,
102 "Got expected blurt output",
103 );
104 is( $self->{errors}, 1, "Error count incremented correctly" );
105 }
106
107 SKIP: {
108 skip "death() not testable as long as it contains hard-coded 'exit'", 1;
109
110 $self->{line} = [
111 'Alpha',
112 'Beta',
113 'Gamma',
114 'Delta',
115 ];
116 $self->{line_no} = [ 17 .. 20 ];
117 $self->{filename} = 'myfile1';
118
119 my $message = "Code is not inside a function";
120 eval {
121 my $stderr = PrimitiveCapture::capture_stderr(sub {
122 death( $self, $message);
123 });
124 like( $stderr,
125 qr/$message in $self->{filename}, line 20/,
126 "Got expected death output",
127 );
128 };
129 }
130
131 pass("Passed all tests in $0");
+14
-0
t/501-t-compile.t less more
0 #!/usr/bin/perl
1 use strict;
2 BEGIN {
3 $| = 1;
4 $^W = 1;
5 }
6
7 use Test::More tests => 2;
8
9 # Check their perl version
10 ok( $] >= 5.006001, "Your perl is new enough" );
11
12 # Does the module load
13 use_ok( 'ExtUtils::Typemaps' );
+160
-0
t/510-t-bare.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3
4 use Test::More tests => 43;
5 use ExtUtils::Typemaps;
6
7 # empty typemap
8 SCOPE: {
9 ok(ExtUtils::Typemaps->new()->is_empty(), "This is an empty typemap");
10 }
11
12 # typemap only
13 SCOPE: {
14 my $map = ExtUtils::Typemaps->new();
15 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_IV');
16 ok(!$map->is_empty(), "This is not an empty typemap");
17
18 is($map->as_string(), <<'HERE', "Simple typemap matches expectations");
19 TYPEMAP
20 unsigned int T_IV
21 HERE
22
23 my $type = $map->get_typemap(ctype => 'unsigned int');
24 isa_ok($type, 'ExtUtils::Typemaps::Type');
25 is($type->ctype, 'unsigned int');
26 is($type->xstype, 'T_IV');
27 is($type->tidy_ctype, 'unsigned int');
28
29
30 # test failure
31 ok(!$map->get_typemap(ctype => 'foo'), "Access to nonexistent typemap doesn't die");
32 ok(!$map->get_inputmap(ctype => 'foo'), "Access to nonexistent inputmap via ctype doesn't die");
33 ok(!$map->get_outputmap(ctype => 'foo'), "Access to nonexistent outputmap via ctype doesn't die");
34 ok(!$map->get_inputmap(xstype => 'foo'), "Access to nonexistent inputmap via xstype doesn't die");
35 ok(!$map->get_outputmap(xstype => 'foo'), "Access to nonexistent outputmap via xstype doesn't die");
36 ok(!eval{$map->get_typemap('foo')} && $@, "Access to typemap with positional params dies");
37 ok(!eval{$map->get_inputmap('foo')} && $@, "Access to inputmap with positional params dies");
38 ok(!eval{$map->get_outputmap('foo')} && $@, "Access to outputmap with positional params dies");
39 }
40
41 # typemap & input
42 SCOPE: {
43 my $map = ExtUtils::Typemaps->new();
44 $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);');
45 ok(!$map->is_empty(), "This is not an empty typemap");
46 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
47 is($map->as_string(), <<'HERE', "Simple typemap (with input) matches expectations");
48 TYPEMAP
49 unsigned int T_UV
50
51 INPUT
52 T_UV
53 $var = ($type)SvUV($arg);
54 HERE
55
56 my $type = $map->get_typemap(ctype => 'unsigned int');
57 isa_ok($type, 'ExtUtils::Typemaps::Type');
58 is($type->ctype, 'unsigned int');
59 is($type->xstype, 'T_UV');
60 is($type->tidy_ctype, 'unsigned int');
61
62 my $in = $map->get_inputmap(xstype => 'T_UV');
63 isa_ok($in, 'ExtUtils::Typemaps::InputMap');
64 is($in->xstype, 'T_UV');
65
66 # test fetching inputmap by ctype
67 my $in2 = $map->get_inputmap(ctype => 'unsigned int');
68 is_deeply($in2, $in, "get_inputmap returns the same typemap for ctype and xstype");
69 }
70
71
72 # typemap & output
73 SCOPE: {
74 my $map = ExtUtils::Typemaps->new();
75 $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);');
76 ok(!$map->is_empty(), "This is not an empty typemap");
77 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
78 is($map->as_string(), <<'HERE', "Simple typemap (with output) matches expectations");
79 TYPEMAP
80 unsigned int T_UV
81
82 OUTPUT
83 T_UV
84 sv_setuv($arg, (UV)$var);
85 HERE
86
87 my $type = $map->get_typemap(ctype => 'unsigned int');
88 isa_ok($type, 'ExtUtils::Typemaps::Type');
89 is($type->ctype, 'unsigned int');
90 is($type->xstype, 'T_UV');
91 is($type->tidy_ctype, 'unsigned int');
92
93 my $in = $map->get_outputmap(xstype => 'T_UV');
94 isa_ok($in, 'ExtUtils::Typemaps::OutputMap');
95 is($in->xstype, 'T_UV');
96 }
97
98 # typemap & input & output
99 SCOPE: {
100 my $map = ExtUtils::Typemaps->new();
101 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
102 $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);');
103 $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);');
104 ok(!$map->is_empty(), "This is not an empty typemap");
105 is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations");
106 TYPEMAP
107 unsigned int T_UV
108
109 INPUT
110 T_UV
111 $var = ($type)SvUV($arg);
112
113 OUTPUT
114 T_UV
115 sv_setuv($arg, (UV)$var);
116 HERE
117 }
118
119 # two typemaps & input & output
120 SCOPE: {
121 my $map = ExtUtils::Typemaps->new();
122 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
123 $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);');
124 $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);');
125
126 $map->add_typemap(ctype => 'int', xstype => 'T_IV');
127 $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);');
128 $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);');
129 is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations");
130 TYPEMAP
131 unsigned int T_UV
132 int T_IV
133
134 INPUT
135 T_UV
136 $var = ($type)SvUV($arg);
137 T_IV
138 $var = ($type)SvIV($arg);
139
140 OUTPUT
141 T_UV
142 sv_setuv($arg, (UV)$var);
143 T_IV
144 sv_setiv($arg, (IV)$var);
145 HERE
146 my $type = $map->get_typemap(ctype => 'unsigned int');
147 isa_ok($type, 'ExtUtils::Typemaps::Type');
148 is($type->ctype, 'unsigned int');
149 is($type->xstype, 'T_UV');
150 is($type->tidy_ctype, 'unsigned int');
151
152 my $in = $map->get_outputmap(xstype => 'T_UV');
153 isa_ok($in, 'ExtUtils::Typemaps::OutputMap');
154 is($in->xstype, 'T_UV');
155 $in = $map->get_outputmap(xstype => 'T_IV');
156 isa_ok($in, 'ExtUtils::Typemaps::OutputMap');
157 is($in->xstype, 'T_IV');
158 }
159
+38
-0
t/511-t-whitespace.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3
4 use Test::More tests => 2;
5 use ExtUtils::Typemaps;
6
7 SCOPE: {
8 my $map = ExtUtils::Typemaps->new();
9 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
10 $map->add_inputmap(xstype => 'T_UV', code => ' $var = ($type)SvUV($arg);');
11 is($map->as_string(), <<'HERE', "Simple typemap (with input and code including leading whitespace) matches expectations");
12 TYPEMAP
13 unsigned int T_UV
14
15 INPUT
16 T_UV
17 $var = ($type)SvUV($arg);
18 HERE
19 }
20
21
22 SCOPE: {
23 my $map = ExtUtils::Typemaps->new();
24 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
25 $map->add_inputmap(xstype => 'T_UV', code => " \$var =\n(\$type)\n SvUV(\$arg);");
26 is($map->as_string(), <<'HERE', "Simple typemap (with input and multi-line code) matches expectations");
27 TYPEMAP
28 unsigned int T_UV
29
30 INPUT
31 T_UV
32 $var =
33 ($type)
34 SvUV($arg);
35 HERE
36 }
37
+49
-0
t/512-t-file.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3
4 use Test::More tests => 6;
5 use ExtUtils::Typemaps;
6 use File::Spec;
7 use File::Temp;
8
9 my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data';
10
11 sub slurp {
12 my $file = shift;
13 open my $fh, '<', $file
14 or die "Cannot open file '$file' for reading: $!";
15 local $/ = undef;
16 return <$fh>;
17 }
18
19 my $cmp_typemap_file = File::Spec->catfile($datadir, 'simple.typemap');
20 my $cmp_typemap_str = slurp($cmp_typemap_file);
21
22 my $map = ExtUtils::Typemaps->new();
23 $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
24 $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);');
25 $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);');
26 $map->add_typemap(ctype => 'int', xstype => 'T_IV');
27 $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);');
28 $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);');
29
30 is($map->as_string(), $cmp_typemap_str, "Simple typemap matches reference file");
31
32 my $tmpdir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1);
33 my $tmpfile = File::Spec->catfile($tmpdir, 'simple.typemap');
34
35 $map->write(file => $tmpfile);
36 is($map->as_string(), slurp($tmpfile), "Simple typemap write matches as_string");
37 is(ExtUtils::Typemaps->new(file => $cmp_typemap_file)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips");
38 is(ExtUtils::Typemaps->new(file => $tmpfile)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips (2)");
39
40 SCOPE: {
41 local $map->{file} = $cmp_typemap_file;
42 is_deeply(ExtUtils::Typemaps->new(file => $cmp_typemap_file), $map, "Simple typemap roundtrips (in memory)");
43 }
44
45 # test that we can also create them from a string
46 my $map_from_str = ExtUtils::Typemaps->new(string => $map->as_string());
47 is_deeply($map_from_str, $map);
48
+116
-0
t/513-t-merge.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3
4 use Test::More tests => 19;
5 use ExtUtils::Typemaps;
6 use File::Spec;
7 use File::Temp;
8
9 my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data';
10
11 sub slurp {
12 my $file = shift;
13 open my $fh, '<', $file
14 or die "Cannot open file '$file' for reading: $!";
15 local $/ = undef;
16 return <$fh>;
17 }
18
19 my $first_typemap_file = File::Spec->catfile($datadir, 'simple.typemap');
20 my $second_typemap_file = File::Spec->catfile($datadir, 'other.typemap');
21 my $combined_typemap_file = File::Spec->catfile($datadir, 'combined.typemap');
22 my $conflicting_typemap_file = File::Spec->catfile($datadir, 'conflicting.typemap');
23 my $confl_replace_typemap_file = File::Spec->catfile($datadir, 'confl_repl.typemap');
24 my $confl_skip_typemap_file = File::Spec->catfile($datadir, 'confl_skip.typemap');
25
26 # test merging two typemaps
27 SCOPE: {
28 my $first = ExtUtils::Typemaps->new(file => $first_typemap_file);
29 isa_ok($first, 'ExtUtils::Typemaps');
30 my $second = ExtUtils::Typemaps->new(file => $second_typemap_file);
31 isa_ok($second, 'ExtUtils::Typemaps');
32
33 $first->merge(typemap => $second);
34
35 is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output");
36 }
37
38 # test merging a typemap from file
39 SCOPE: {
40 my $first = ExtUtils::Typemaps->new(file => $first_typemap_file);
41 isa_ok($first, 'ExtUtils::Typemaps');
42
43 $first->merge(file => $second_typemap_file);
44
45 is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output");
46 }
47
48
49 # test merging a typemap as string
50 SCOPE: {
51 my $first = ExtUtils::Typemaps->new(file => $first_typemap_file);
52 isa_ok($first, 'ExtUtils::Typemaps');
53 my $second_str = slurp($second_typemap_file);
54
55 $first->add_string(string => $second_str);
56
57 is($first->as_string(), slurp($combined_typemap_file), "merging (string) produces expected output");
58 }
59
60 # test merging a conflicting typemap without "replace"
61 SCOPE: {
62 my $second = ExtUtils::Typemaps->new(file => $second_typemap_file);
63 isa_ok($second, 'ExtUtils::Typemaps');
64 my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file);
65 isa_ok($conflict, 'ExtUtils::Typemaps');
66
67 ok(
68 !eval {
69 $second->merge(typemap => $conflict);
70 1;
71 },
72 "Merging conflicting typemap croaks"
73 );
74 ok(
75 $@ =~ /Multiple definition/,
76 "Conflicting typemap error as expected"
77 );
78 }
79
80 # test merging a conflicting typemap with "replace"
81 SCOPE: {
82 my $second = ExtUtils::Typemaps->new(file => $second_typemap_file);
83 isa_ok($second, 'ExtUtils::Typemaps');
84 my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file);
85 isa_ok($conflict, 'ExtUtils::Typemaps');
86
87 ok(
88 eval {
89 $second->merge(typemap => $conflict, replace => 1);
90 1;
91 },
92 "Conflicting typemap merge with 'replace' doesn't croak"
93 );
94
95 is($second->as_string(), slurp($confl_replace_typemap_file), "merging (string) produces expected output");
96 }
97
98 # test merging a conflicting typemap file with "skip"
99 SCOPE: {
100 my $second = ExtUtils::Typemaps->new(file => $second_typemap_file);
101 isa_ok($second, 'ExtUtils::Typemaps');
102 my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file);
103 isa_ok($conflict, 'ExtUtils::Typemaps');
104
105 ok(
106 eval {
107 $second->merge(typemap => $conflict, skip => 1);
108 1;
109 },
110 "Conflicting typemap merge with 'skip' doesn't croak"
111 );
112
113 is($second->as_string(), slurp($confl_skip_typemap_file), "merging (string) produces expected output");
114 }
115
+182
-0
t/600-t-compat.t less more
0 #!/usr/bin/perl
1 use strict;
2 use warnings;
3
4 use Test::More;
5
6 # This test is for making sure that the new EU::Typemaps
7 # based typemap merging produces the same result as the old
8 # EU::ParseXS code.
9
10 use ExtUtils::Typemaps;
11 use ExtUtils::ParseXS::Utilities qw(
12 C_string
13 tidy_type
14 trim_whitespace
15 process_typemaps
16 );
17 use ExtUtils::ParseXS::Constants;
18 use File::Spec;
19
20 my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data));
21
22 my @tests = (
23 {
24 name => 'Simple conflict',
25 local_maps => [
26 File::Spec->catfile($path_prefix, "conflicting.typemap"),
27 ],
28 std_maps => [
29 File::Spec->catfile($path_prefix, "other.typemap"),
30 ],
31 },
32 {
33 name => 'B',
34 local_maps => [
35 File::Spec->catfile($path_prefix, "b.typemap"),
36 ],
37 std_maps => [],
38 },
39 {
40 name => 'B and perl',
41 local_maps => [
42 File::Spec->catfile($path_prefix, "b.typemap"),
43 ],
44 std_maps => [
45 File::Spec->catfile($path_prefix, "perl.typemap"),
46 ],
47 },
48 {
49 name => 'B and perl and B again',
50 local_maps => [
51 File::Spec->catfile($path_prefix, "b.typemap"),
52 ],
53 std_maps => [
54 File::Spec->catfile($path_prefix, "perl.typemap"),
55 File::Spec->catfile($path_prefix, "b.typemap"),
56 ],
57 },
58 );
59 plan tests => scalar(@tests);
60
61 my @local_tmaps;
62 my @standard_typemap_locations;
63 SCOPE: {
64 no warnings 'redefine';
65 sub ExtUtils::ParseXS::Utilities::standard_typemap_locations {
66 @standard_typemap_locations;
67 }
68 sub standard_typemap_locations {
69 @standard_typemap_locations;
70 }
71 }
72
73 foreach my $test (@tests) {
74 @local_tmaps = @{ $test->{local_maps} };
75 @standard_typemap_locations = @{ $test->{std_maps} };
76
77 my $res = [_process_typemaps([@local_tmaps], '.')];
78 my $tm = process_typemaps([@local_tmaps], '.');
79 my $res_new = [map $tm->$_(), qw(_get_typemap_hash _get_prototype_hash _get_inputmap_hash _get_outputmap_hash) ];
80
81 # Normalize trailing whitespace. Let's be that lenient, mkay?
82 for ($res, $res_new) {
83 for ($_->[2], $_->[3]) {
84 for (values %$_) {
85 s/\s+\z//;
86 }
87 }
88 }
89 #use Data::Dumper; warn Dumper $res;
90 #use Data::Dumper; warn Dumper $res_new;
91
92 is_deeply($res_new, $res, "typemap equivalency for '$test->{name}'");
93 }
94
95
96 # The code below is a reproduction of what the pre-ExtUtils::Typemap
97 # typemap-parsing/handling code in ExtUtils::ParseXS looked like. For
98 # bug-compatibility, we want to produce the same data structures as that
99 # code as much as possible.
100 sub _process_typemaps {
101 my ($tmap, $pwd) = @_;
102
103 my @tm = ref $tmap ? @{$tmap} : ($tmap);
104
105 foreach my $typemap (@tm) {
106 die "Can't find $typemap in $pwd\n" unless -r $typemap;
107 }
108
109 push @tm, standard_typemap_locations( \@INC );
110
111 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
112 = ( {}, {}, {}, {} );
113
114 foreach my $typemap (@tm) {
115 next unless -f $typemap;
116 # skip directories, binary files etc.
117 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
118 unless -T $typemap;
119 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
120 _process_single_typemap( $typemap,
121 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
122 }
123 return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
124 }
125
126 sub _process_single_typemap {
127 my ($typemap,
128 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
129 open my $TYPEMAP, '<', $typemap
130 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
131 my $mode = 'Typemap';
132 my $junk = "";
133 my $current = \$junk;
134 while (<$TYPEMAP>) {
135 # skip comments
136 next if /^\s*#/;
137 if (/^INPUT\s*$/) {
138 $mode = 'Input'; $current = \$junk; next;
139 }
140 if (/^OUTPUT\s*$/) {
141 $mode = 'Output'; $current = \$junk; next;
142 }
143 if (/^TYPEMAP\s*$/) {
144 $mode = 'Typemap'; $current = \$junk; next;
145 }
146 if ($mode eq 'Typemap') {
147 chomp;
148 my $logged_line = $_;
149 trim_whitespace($_);
150 # skip blank lines
151 next if /^$/;
152 my($type,$kind, $proto) =
153 m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
154 or warn(
155 "Warning: File '$typemap' Line $. '$logged_line' " .
156 "TYPEMAP entry needs 2 or 3 columns\n"
157 ),
158 next;
159 $type = tidy_type($type);
160 $type_kind_ref->{$type} = $kind;
161 # prototype defaults to '$'
162 $proto = "\$" unless $proto;
163 $proto_letter_ref->{$type} = C_string($proto);
164 }
165 elsif (/^\s/) {
166 $$current .= $_;
167 }
168 elsif ($mode eq 'Input') {
169 s/\s+$//;
170 $input_expr_ref->{$_} = '';
171 $current = \$input_expr_ref->{$_};
172 }
173 else {
174 s/\s+$//;
175 $output_expr_ref->{$_} = '';
176 $current = \$output_expr_ref->{$_};
177 }
178 }
179 close $TYPEMAP;
180 return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
181 }
+71
-0
t/XSMore.xs less more
00 #include "EXTERN.h"
11 #include "perl.h"
22 #include "XSUB.h"
3
4 typedef IV MyType;
5 typedef IV MyType2;
6 typedef IV MyType3;
7 typedef IV MyType4;
8
39
410 =for testing
511
612 This parts are ignored.
713
814 =cut
15
16 /* Old perls (pre 5.8.9 or so) did not have PERL_UNUSED_ARG in XSUB.h.
17 * This is normally covered by ppport.h. */
18 #ifndef PERL_UNUSED_ARG
19 # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
20 # include <note.h>
21 # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
22 # else
23 # define PERL_UNUSED_ARG(x) ((void)x)
24 # endif
25 #endif
26 #ifndef PERL_UNUSED_VAR
27 # define PERL_UNUSED_VAR(x) ((void)x)
28 #endif
29
30
931
1032 STATIC void
1133 outlist(int* a, int* b){
1537
1638 STATIC int
1739 len(const char* const s, int const l){
40 PERL_UNUSED_ARG(s);
1841 return l;
1942 }
2043
3962 BOOT:
4063 sv_setiv(get_sv("XSMore::boot_ok", TRUE), 100);
4164
65
66 TYPEMAP: <<END
67 MyType T_IV
68 END
69
70 TYPEMAP: <<" FOO BAR BAZ";
71 MyType2 T_FOOOO
72
73 OUTPUT
74 T_FOOOO
75 sv_setiv($arg, (IV)$var);
76 FOO BAR BAZ
77
78 TYPEMAP: <<'END'
79 MyType3 T_BAAR
80 MyType4 T_BAAR
81
82 OUTPUT
83 T_BAAR
84 sv_setiv($arg, (IV)$var);
85
86 INPUT
87 T_BAAR
88 $var = ($type)SvIV($arg)
89 END
90
91
92 MyType
93 typemaptest1()
94 CODE:
95 RETVAL = 42;
96 OUTPUT:
97 RETVAL
98
99 MyType2
100 typemaptest2()
101 CODE:
102 RETVAL = 42;
103 OUTPUT:
104 RETVAL
105
106 MyType3
107 typemaptest3(MyType4 foo)
108 CODE:
109 RETVAL = foo;
110 OUTPUT:
111 RETVAL
42112
43113 void
44114 prototype_ssa()
83153 myabs(...)
84154 OVERLOAD: abs
85155 CODE:
156 PERL_UNUSED_VAR(items);
86157 RETVAL = 42;
87158 OUTPUT:
88159 RETVAL
+16
-2
t/XSUsage.xs less more
00 #include "EXTERN.h"
11 #include "perl.h"
22 #include "XSUB.h"
3
4 /* Old perls (pre 5.8.9 or so) did not have PERL_UNUSED_ARG in XSUB.h.
5 * This is normally covered by ppport.h. */
6 #ifndef PERL_UNUSED_ARG
7 # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
8 # include <note.h>
9 # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
10 # else
11 # define PERL_UNUSED_ARG(x) ((void)x)
12 # endif
13 #endif
14 #ifndef PERL_UNUSED_VAR
15 # define PERL_UNUSED_VAR(x) ((void)x)
16 #endif
317
418 int xsusage_one() { return 1; }
519 int xsusage_two() { return 2; }
620 int xsusage_three() { return 3; }
721 int xsusage_four() { return 4; }
8 int xsusage_five(int i) { return 5; }
9 int xsusage_six(int i) { return 6; }
22 int xsusage_five(int i) { PERL_UNUSED_ARG(i); return 5; }
23 int xsusage_six(int i) { PERL_UNUSED_ARG(i); return 6; }
1024
1125 MODULE = XSUsage PACKAGE = XSUsage PREFIX = xsusage_
1226
+0
-80
t/basic.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7
8 plan tests => 10;
9
10 my ($source_file, $obj_file, $lib_file);
11
12 require_ok( 'ExtUtils::ParseXS' );
13 ExtUtils::ParseXS->import('process_file');
14
15 chdir 't' or die "Can't chdir to t/, $!";
16
17 use Carp; $SIG{__WARN__} = \&Carp::cluck;
18
19 #########################
20
21 # Try sending to filehandle
22 tie *FH, 'Foo';
23 process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 );
24 like tied(*FH)->content, '/is_even/', "Test that output contains some text";
25
26 $source_file = 'XSTest.c';
27
28 # Try sending to file
29 process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0);
30 ok -e $source_file, "Create an output file";
31
32 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
33 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
34
35 SKIP: {
36 skip "no compiler available", 2
37 if ! $b->have_compiler;
38 $obj_file = $b->compile( source => $source_file );
39 ok $obj_file;
40 ok -e $obj_file, "Make sure $obj_file exists";
41 }
42
43 SKIP: {
44 skip "no dynamic loading", 5
45 if !$b->have_compiler || !$Config{usedl};
46 my $module = 'XSTest';
47 $lib_file = $b->link( objects => $obj_file, module_name => $module );
48 ok $lib_file;
49 ok -e $lib_file, "Make sure $lib_file exists";
50
51 eval {require XSTest};
52 is $@, '';
53 ok XSTest::is_even(8);
54 ok !XSTest::is_even(9);
55
56 # Win32 needs to close the DLL before it can unlink it, but unfortunately
57 # dl_unload_file was missing on Win32 prior to perl change #24679!
58 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
59 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
60 if ($DynaLoader::dl_modules[$i] eq $module) {
61 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
62 last;
63 }
64 }
65 }
66 }
67
68 unless ($ENV{PERL_NO_CLEANUP}) {
69 for ( $obj_file, $lib_file, $source_file) {
70 next unless defined $_;
71 1 while unlink $_;
72 }
73 }
74
75 #####################################################################
76
77 sub Foo::TIEHANDLE { bless {}, 'Foo' }
78 sub Foo::PRINT { shift->{buf} .= join '', @_ }
79 sub Foo::content { shift->{buf} }
+0
-115
t/bugs/RT48104.xs less more
0 // ***** BEGIN LICENSE BLOCK *****
1 // Version: MPL 1.1/GPL 2.0/LGPL 2.1
2 //
3 // The contents of this file are subject to the Mozilla Public License Version
4 // 1.1 (the "License"); you may not use this file except in compliance with
5 // the License. You may obtain a copy of the License at
6 // http://www.mozilla.org/MPL/
7 //
8 // Software distributed under the License is distributed on an "AS IS" basis,
9 // WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
10 // for the specific language governing rights and limitations under the
11 // License.
12 //
13 // The Original Code is Encode::Detect wrapper
14 //
15 // The Initial Developer of the Original Code is
16 // Proofpoint, Inc.
17 // Portions created by the Initial Developer are Copyright (C) 2005
18 // the Initial Developer. All Rights Reserved.
19 //
20 // Contributor(s):
21 //
22 // Alternatively, the contents of this file may be used under the terms of
23 // either the GNU General Public License Version 2 or later (the "GPL"), or
24 // the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
25 // in which case the provisions of the GPL or the LGPL are applicable instead
26 // of those above. If you wish to allow use of your version of this file only
27 // under the terms of either the GPL or the LGPL, and not to allow others to
28 // use your version of this file under the terms of the MPL, indicate your
29 // decision by deleting the provisions above and replace them with the notice
30 // and other provisions required by the GPL or the LGPL. If you do not delete
31 // the provisions above, a recipient may use your version of this file under
32 // the terms of any one of the MPL, the GPL or the LGPL.
33 //
34 // ***** END LICENSE BLOCK *****
35
36 extern "C" {
37 #define PERL_NO_GET_CONTEXT /* we want efficiency */
38 #include "EXTERN.h"
39 #include "perl.h"
40
41 // work around perlbug #39634
42 #if __GNUC__ == 3 && __GNUC_MINOR__ <= 3
43 #undef HASATTRIBUTE_UNUSED
44 #endif
45
46 #include "XSUB.h"
47 }
48
49 #include "nscore.h"
50 #include "nsUniversalDetector.h"
51
52 class Detector: public nsUniversalDetector {
53 public:
54 Detector() {};
55 virtual ~Detector() {}
56 const char *getresult() { return mDetectedCharset; }
57 virtual void Reset() { this->nsUniversalDetector::Reset(); }
58 protected:
59 virtual void Report(const char* aCharset) { mDetectedCharset = aCharset; }
60 };
61
62
63 MODULE = Encode::Detect::Detector PACKAGE = Encode::Detect::Detector
64 PROTOTYPES: ENABLE
65
66
67 Detector *
68 Detector::new()
69
70 void
71 Detector::DESTROY()
72
73 int
74 Detector::handle(SV *buf)
75 CODE:
76 STRLEN len;
77 char *ptr = SvPV(buf, len);
78 RETVAL = THIS->HandleData(ptr, len);
79 OUTPUT:
80 RETVAL
81
82 void
83 Detector::eof()
84 CODE:
85 THIS->DataEnd();
86
87 void
88 Detector::reset()
89 CODE:
90 THIS->Reset();
91
92 const char *
93 Detector::getresult()
94 CODE:
95 RETVAL = THIS->getresult();
96 OUTPUT:
97 RETVAL
98
99
100 const char *
101 detect(buf)
102 SV *buf
103 CODE:
104 STRLEN len;
105 char *ptr = SvPV(buf, len);
106
107 Detector *det = new Detector;
108 det->HandleData(ptr, len);
109 det->DataEnd();
110 RETVAL = det->getresult();
111 delete det;
112 OUTPUT:
113 RETVAL
114
+0
-18
t/bugs/typemap less more
0 TYPEMAP
1 Detector * O_OBJECT
2
3 INPUT
4 O_OBJECT
5 if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) {
6 $var = ($type)SvIV((SV*)SvRV( $arg ));
7 } else {
8 warn(\"${Package}::$func_name() -- $var is not a blessed SV reference\");
9 XSRETURN_UNDEF;
10 }
11
12 OUTPUT
13 # The Perl object is blessed into 'CLASS', which should be a
14 # char * having the name of the package for the blessing.
15 O_OBJECT
16 sv_setref_pv($arg, CLASS, (void*)$var);
17
+88
-0
t/data/b.typemap less more
0 TYPEMAP
1
2 B::OP T_OP_OBJ
3 B::UNOP T_OP_OBJ
4 B::BINOP T_OP_OBJ
5 B::LOGOP T_OP_OBJ
6 B::LISTOP T_OP_OBJ
7 B::PMOP T_OP_OBJ
8 B::SVOP T_OP_OBJ
9 B::PADOP T_OP_OBJ
10 B::PVOP T_OP_OBJ
11 B::LOOP T_OP_OBJ
12 B::COP T_OP_OBJ
13
14 B::SV T_SV_OBJ
15 B::PV T_SV_OBJ
16 B::IV T_SV_OBJ
17 B::NV T_SV_OBJ
18 B::PVMG T_SV_OBJ
19 B::REGEXP T_SV_OBJ
20 B::PVLV T_SV_OBJ
21 B::BM T_SV_OBJ
22 B::RV T_SV_OBJ
23 B::GV T_SV_OBJ
24 B::CV T_SV_OBJ
25 B::HV T_SV_OBJ
26 B::AV T_SV_OBJ
27 B::IO T_SV_OBJ
28 B::FM T_SV_OBJ
29
30 B::MAGIC T_MG_OBJ
31 SSize_t T_IV
32 STRLEN T_UV
33 PADOFFSET T_UV
34
35 B::HE T_HE_OBJ
36 B::RHE T_RHE_OBJ
37
38 INPUT
39 T_OP_OBJ
40 if (SvROK($arg)) {
41 IV tmp = SvIV((SV*)SvRV($arg));
42 $var = INT2PTR($type,tmp);
43 }
44 else
45 croak(\"$var is not a reference\")
46
47 T_SV_OBJ
48 if (SvROK($arg)) {
49 IV tmp = SvIV((SV*)SvRV($arg));
50 $var = INT2PTR($type,tmp);
51 }
52 else
53 croak(\"$var is not a reference\")
54
55 T_MG_OBJ
56 if (SvROK($arg)) {
57 IV tmp = SvIV((SV*)SvRV($arg));
58 $var = INT2PTR($type,tmp);
59 }
60 else
61 croak(\"$var is not a reference\")
62
63 T_HE_OBJ
64 if (SvROK($arg)) {
65 IV tmp = SvIV((SV*)SvRV($arg));
66 $var = INT2PTR($type,tmp);
67 }
68 else
69 croak(\"$var is not a reference\")
70
71 T_RHE_OBJ
72 if (SvROK($arg)) {
73 IV tmp = SvIV((SV*)SvRV($arg));
74 $var = INT2PTR($type,tmp);
75 }
76 else
77 croak(\"$var is not a reference\")
78
79 OUTPUT
80 T_MG_OBJ
81 sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
82
83 T_HE_OBJ
84 sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var));
85
86 T_RHE_OBJ
87 sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
+20
-0
t/data/combined.typemap less more
0 TYPEMAP
1 unsigned int T_UV
2 int T_IV
3 double T_NV
4
5 INPUT
6 T_UV
7 $var = ($type)SvUV($arg);
8 T_IV
9 $var = ($type)SvIV($arg);
10 T_NV
11 $var = ($type)SvNV($arg);
12
13 OUTPUT
14 T_UV
15 sv_setuv($arg, (UV)$var);
16 T_IV
17 sv_setiv($arg, (IV)$var);
18 T_NV
19 sv_setnv($arg, (NV)$var);
+12
-0
t/data/confl_repl.typemap less more
0 TYPEMAP
1 double T_DIFFERENT
2
3 INPUT
4 T_NV
5 $var = ($type)SvNV($arg);
6 T_DIFFERENT
7 $var = ($type)SvNV($arg);
8
9 OUTPUT
10 T_NV
11 sv_setnv($arg, (NV)$var);
+12
-0
t/data/confl_skip.typemap less more
0 TYPEMAP
1 double T_NV
2
3 INPUT
4 T_NV
5 $var = ($type)SvNV($arg);
6 T_DIFFERENT
7 $var = ($type)SvNV($arg);
8
9 OUTPUT
10 T_NV
11 sv_setnv($arg, (NV)$var);
+6
-0
t/data/conflicting.typemap less more
0 TYPEMAP
1 double T_DIFFERENT
2
3 INPUT
4 T_DIFFERENT
5 $var = ($type)SvNV($arg);
+10
-0
t/data/other.typemap less more
0 TYPEMAP
1 double T_NV
2
3 INPUT
4 T_NV
5 $var = ($type)SvNV($arg);
6
7 OUTPUT
8 T_NV
9 sv_setnv($arg, (NV)$var);
+360
-0
t/data/perl.typemap less more
0 # basic C types
1 int T_IV
2 unsigned T_UV
3 unsigned int T_UV
4 long T_IV
5 unsigned long T_UV
6 short T_IV
7 unsigned short T_UV
8 char T_CHAR
9 unsigned char T_U_CHAR
10 char * T_PV
11 unsigned char * T_PV
12 const char * T_PV
13 caddr_t T_PV
14 wchar_t * T_PV
15 wchar_t T_IV
16 # bool_t is defined in <rpc/rpc.h>
17 bool_t T_IV
18 size_t T_UV
19 ssize_t T_IV
20 time_t T_NV
21 unsigned long * T_OPAQUEPTR
22 char ** T_PACKEDARRAY
23 void * T_PTR
24 Time_t * T_PV
25 SV * T_SV
26 SVREF T_SVREF
27 AV * T_AVREF
28 HV * T_HVREF
29 CV * T_CVREF
30
31 IV T_IV
32 UV T_UV
33 NV T_NV
34 I32 T_IV
35 I16 T_IV
36 I8 T_IV
37 STRLEN T_UV
38 U32 T_U_LONG
39 U16 T_U_SHORT
40 U8 T_UV
41 Result T_U_CHAR
42 Boolean T_BOOL
43 float T_FLOAT
44 double T_DOUBLE
45 SysRet T_SYSRET
46 SysRetLong T_SYSRET
47 FILE * T_STDIO
48 PerlIO * T_INOUT
49 FileHandle T_PTROBJ
50 InputStream T_IN
51 InOutStream T_INOUT
52 OutputStream T_OUT
53 bool T_BOOL
54
55 #############################################################################
56 INPUT
57 T_SV
58 $var = $arg
59 T_SVREF
60 STMT_START {
61 SV* const xsub_tmp_sv = $arg;
62 SvGETMAGIC(xsub_tmp_sv);
63 if (SvROK(xsub_tmp_sv)){
64 $var = SvRV(xsub_tmp_sv);
65 }
66 else{
67 Perl_croak(aTHX_ \"%s: %s is not a reference\",
68 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
69 \"$var\");
70 }
71 } STMT_END
72 T_AVREF
73 STMT_START {
74 SV* const xsub_tmp_sv = $arg;
75 SvGETMAGIC(xsub_tmp_sv);
76 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
77 $var = (AV*)SvRV(xsub_tmp_sv);
78 }
79 else{
80 Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
81 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
82 \"$var\");
83 }
84 } STMT_END
85 T_HVREF
86 STMT_START {
87 SV* const xsub_tmp_sv = $arg;
88 SvGETMAGIC(xsub_tmp_sv);
89 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
90 $var = (HV*)SvRV(xsub_tmp_sv);
91 }
92 else{
93 Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
94 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
95 \"$var\");
96 }
97 } STMT_END
98 T_CVREF
99 STMT_START {
100 SV* const xsub_tmp_sv = $arg;
101 SvGETMAGIC(xsub_tmp_sv);
102 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
103 $var = (CV*)SvRV(xsub_tmp_sv);
104 }
105 else{
106 Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
107 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
108 \"$var\");
109 }
110 } STMT_END
111 T_SYSRET
112 $var NOT IMPLEMENTED
113 T_UV
114 $var = ($type)SvUV($arg)
115 T_IV
116 $var = ($type)SvIV($arg)
117 T_INT
118 $var = (int)SvIV($arg)
119 T_ENUM
120 $var = ($type)SvIV($arg)
121 T_BOOL
122 $var = (bool)SvTRUE($arg)
123 T_U_INT
124 $var = (unsigned int)SvUV($arg)
125 T_SHORT
126 $var = (short)SvIV($arg)
127 T_U_SHORT
128 $var = (unsigned short)SvUV($arg)
129 T_LONG
130 $var = (long)SvIV($arg)
131 T_U_LONG
132 $var = (unsigned long)SvUV($arg)
133 T_CHAR
134 $var = (char)*SvPV_nolen($arg)
135 T_U_CHAR
136 $var = (unsigned char)SvUV($arg)
137 T_FLOAT
138 $var = (float)SvNV($arg)
139 T_NV
140 $var = ($type)SvNV($arg)
141 T_DOUBLE
142 $var = (double)SvNV($arg)
143 T_PV
144 $var = ($type)SvPV_nolen($arg)
145 T_PTR
146 $var = INT2PTR($type,SvIV($arg))
147 T_PTRREF
148 if (SvROK($arg)) {
149 IV tmp = SvIV((SV*)SvRV($arg));
150 $var = INT2PTR($type,tmp);
151 }
152 else
153 Perl_croak(aTHX_ \"%s: %s is not a reference\",
154 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
155 \"$var\")
156 T_REF_IV_REF
157 if (sv_isa($arg, \"${ntype}\")) {
158 IV tmp = SvIV((SV*)SvRV($arg));
159 $var = *INT2PTR($type *, tmp);
160 }
161 else
162 Perl_croak(aTHX_ \"%s: %s is not of type %s\",
163 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
164 \"$var\", \"$ntype\")
165 T_REF_IV_PTR
166 if (sv_isa($arg, \"${ntype}\")) {
167 IV tmp = SvIV((SV*)SvRV($arg));
168 $var = INT2PTR($type, tmp);
169 }
170 else
171 Perl_croak(aTHX_ \"%s: %s is not of type %s\",
172 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
173 \"$var\", \"$ntype\")
174 T_PTROBJ
175 if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
176 IV tmp = SvIV((SV*)SvRV($arg));
177 $var = INT2PTR($type,tmp);
178 }
179 else
180 Perl_croak(aTHX_ \"%s: %s is not of type %s\",
181 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
182 \"$var\", \"$ntype\")
183 T_PTRDESC
184 if (sv_isa($arg, \"${ntype}\")) {
185 IV tmp = SvIV((SV*)SvRV($arg));
186 ${type}_desc = (\U${type}_DESC\E*) tmp;
187 $var = ${type}_desc->ptr;
188 }
189 else
190 Perl_croak(aTHX_ \"%s: %s is not of type %s\",
191 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
192 \"$var\", \"$ntype\")
193 T_REFREF
194 if (SvROK($arg)) {
195 IV tmp = SvIV((SV*)SvRV($arg));
196 $var = *INT2PTR($type,tmp);
197 }
198 else
199 Perl_croak(aTHX_ \"%s: %s is not a reference\",
200 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
201 \"$var\")
202 T_REFOBJ
203 if (sv_isa($arg, \"${ntype}\")) {
204 IV tmp = SvIV((SV*)SvRV($arg));
205 $var = *INT2PTR($type,tmp);
206 }
207 else
208 Perl_croak(aTHX_ \"%s: %s is not of type %s\",
209 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
210 \"$var\", \"$ntype\")
211 T_OPAQUE
212 $var = *($type *)SvPV_nolen($arg)
213 T_OPAQUEPTR
214 $var = ($type)SvPV_nolen($arg)
215 T_PACKED
216 $var = XS_unpack_$ntype($arg)
217 T_PACKEDARRAY
218 $var = XS_unpack_$ntype($arg)
219 T_CALLBACK
220 $var = make_perl_cb_$type($arg)
221 T_ARRAY
222 U32 ix_$var = $argoff;
223 $var = $ntype(items -= $argoff);
224 while (items--) {
225 DO_ARRAY_ELEM;
226 ix_$var++;
227 }
228 /* this is the number of elements in the array */
229 ix_$var -= $argoff
230 T_STDIO
231 $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
232 T_IN
233 $var = IoIFP(sv_2io($arg))
234 T_INOUT
235 $var = IoIFP(sv_2io($arg))
236 T_OUT
237 $var = IoOFP(sv_2io($arg))
238 #############################################################################
239 OUTPUT
240 T_SV
241 $arg = $var;
242 T_SVREF
243 $arg = newRV((SV*)$var);
244 T_AVREF
245 $arg = newRV((SV*)$var);
246 T_HVREF
247 $arg = newRV((SV*)$var);
248 T_CVREF
249 $arg = newRV((SV*)$var);
250 T_IV
251 sv_setiv($arg, (IV)$var);
252 T_UV
253 sv_setuv($arg, (UV)$var);
254 T_INT
255 sv_setiv($arg, (IV)$var);
256 T_SYSRET
257 if ($var != -1) {
258 if ($var == 0)
259 sv_setpvn($arg, "0 but true", 10);
260 else
261 sv_setiv($arg, (IV)$var);
262 }
263 T_ENUM
264 sv_setiv($arg, (IV)$var);
265 T_BOOL
266 $arg = boolSV($var);
267 T_U_INT
268 sv_setuv($arg, (UV)$var);
269 T_SHORT
270 sv_setiv($arg, (IV)$var);
271 T_U_SHORT
272 sv_setuv($arg, (UV)$var);
273 T_LONG
274 sv_setiv($arg, (IV)$var);
275 T_U_LONG
276 sv_setuv($arg, (UV)$var);
277 T_CHAR
278 sv_setpvn($arg, (char *)&$var, 1);
279 T_U_CHAR
280 sv_setuv($arg, (UV)$var);
281 T_FLOAT
282 sv_setnv($arg, (double)$var);
283 T_NV
284 sv_setnv($arg, (NV)$var);
285 T_DOUBLE
286 sv_setnv($arg, (double)$var);
287 T_PV
288 sv_setpv((SV*)$arg, $var);
289 T_PTR
290 sv_setiv($arg, PTR2IV($var));
291 T_PTRREF
292 sv_setref_pv($arg, Nullch, (void*)$var);
293 T_REF_IV_REF
294 sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
295 T_REF_IV_PTR
296 sv_setref_pv($arg, \"${ntype}\", (void*)$var);
297 T_PTROBJ
298 sv_setref_pv($arg, \"${ntype}\", (void*)$var);
299 T_PTRDESC
300 sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
301 T_REFREF
302 NOT_IMPLEMENTED
303 T_REFOBJ
304 NOT IMPLEMENTED
305 T_OPAQUE
306 sv_setpvn($arg, (char *)&$var, sizeof($var));
307 T_OPAQUEPTR
308 sv_setpvn($arg, (char *)$var, sizeof(*$var));
309 T_PACKED
310 XS_pack_$ntype($arg, $var);
311 T_PACKEDARRAY
312 XS_pack_$ntype($arg, $var, count_$ntype);
313 T_DATAUNIT
314 sv_setpvn($arg, $var.chp(), $var.size());
315 T_CALLBACK
316 sv_setpvn($arg, $var.context.value().chp(),
317 $var.context.value().size());
318 T_ARRAY
319 {
320 U32 ix_$var;
321 EXTEND(SP,size_$var);
322 for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
323 ST(ix_$var) = sv_newmortal();
324 DO_ARRAY_ELEM
325 }
326 }
327 T_STDIO
328 {
329 GV *gv = newGVgen("$Package");
330 PerlIO *fp = PerlIO_importFILE($var,0);
331 if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
332 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
333 else
334 $arg = &PL_sv_undef;
335 }
336 T_IN
337 {
338 GV *gv = newGVgen("$Package");
339 if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
340 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
341 else
342 $arg = &PL_sv_undef;
343 }
344 T_INOUT
345 {
346 GV *gv = newGVgen("$Package");
347 if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
348 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
349 else
350 $arg = &PL_sv_undef;
351 }
352 T_OUT
353 {
354 GV *gv = newGVgen("$Package");
355 if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
356 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
357 else
358 $arg = &PL_sv_undef;
359 }
+15
-0
t/data/simple.typemap less more
0 TYPEMAP
1 unsigned int T_UV
2 int T_IV
3
4 INPUT
5 T_UV
6 $var = ($type)SvUV($arg);
7 T_IV
8 $var = ($type)SvIV($arg);
9
10 OUTPUT
11 T_UV
12 sv_setuv($arg, (UV)$var);
13 T_IV
14 sv_setiv($arg, (IV)$var);
+0
-75
t/include/nsUniversalDetector.h less more
0 /* -*- Mode: C++; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*- */
1 /* ***** BEGIN LICENSE BLOCK *****
2 * Version: MPL 1.1/GPL 2.0/LGPL 2.1
3 *
4 * The contents of this file are subject to the Mozilla Public License Version
5 * 1.1 (the "License"); you may not use this file except in compliance with
6 * the License. You may obtain a copy of the License at
7 * http://www.mozilla.org/MPL/
8 *
9 * Software distributed under the License is distributed on an "AS IS" basis,
10 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11 * for the specific language governing rights and limitations under the
12 * License.
13 *
14 * The Original Code is Mozilla Communicator client code.
15 *
16 * The Initial Developer of the Original Code is
17 * Netscape Communications Corporation.
18 * Portions created by the Initial Developer are Copyright (C) 1998
19 * the Initial Developer. All Rights Reserved.
20 *
21 * Contributor(s):
22 *
23 * Alternatively, the contents of this file may be used under the terms of
24 * either the GNU General Public License Version 2 or later (the "GPL"), or
25 * the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
26 * in which case the provisions of the GPL or the LGPL are applicable instead
27 * of those above. If you wish to allow use of your version of this file only
28 * under the terms of either the GPL or the LGPL, and not to allow others to
29 * use your version of this file under the terms of the MPL, indicate your
30 * decision by deleting the provisions above and replace them with the notice
31 * and other provisions required by the GPL or the LGPL. If you do not delete
32 * the provisions above, a recipient may use your version of this file under
33 * the terms of any one of the MPL, the GPL or the LGPL.
34 *
35 * ***** END LICENSE BLOCK ***** */
36
37 #ifndef nsUniversalDetector_h__
38 #define nsUniversalDetector_h__
39
40 class nsCharSetProber;
41
42 #define NUM_OF_CHARSET_PROBERS 3
43
44 typedef enum {
45 ePureAscii = 0,
46 eEscAscii = 1,
47 eHighbyte = 2
48 } nsInputState;
49
50 class nsUniversalDetector {
51 public:
52 nsUniversalDetector();
53 virtual ~nsUniversalDetector();
54 virtual nsresult HandleData(const char* aBuf, PRUint32 aLen);
55 virtual void DataEnd(void);
56
57 protected:
58 virtual void Report(const char* aCharset) = 0;
59 virtual void Reset();
60 nsInputState mInputState;
61 PRBool mDone;
62 PRBool mInTag;
63 PRBool mStart;
64 PRBool mGotData;
65 char mLastChar;
66 const char * mDetectedCharset;
67 PRInt32 mBestGuess;
68
69 nsCharSetProber *mCharSetProbers[NUM_OF_CHARSET_PROBERS];
70 nsCharSetProber *mEscCharSetProber;
71 };
72
73 #endif
74
+0
-20
t/include/nscore.h less more
0 #ifndef INCLUDED_NSCORE_H
1 #define INCLUDED_NSCORE_H
2
3 typedef short PRInt16;
4 typedef unsigned short PRUint16;
5
6 typedef int PRInt32;
7 typedef unsigned PRUint32;
8
9 typedef int PRBool;
10 #define PR_TRUE 1
11 #define PR_FALSE 0
12
13 #define nsnull 0
14
15 typedef PRUint32 nsresult;
16 #define NS_OK 0
17 #define NS_ERROR_OUT_OF_MEMORY ((nsresult)(0x8007000eL))
18
19 #endif /* INCLUDED_NSCORE_H */
+33
-0
t/lib/PrimitiveCapture.pm less more
0 package PrimitiveCapture;
1 use strict;
2 use warnings;
3
4 sub capture_stdout {
5 my $sub = shift;
6 my $stdout;
7 open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!";
8 close STDOUT;
9 open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!";
10
11 $sub->();
12
13 close STDOUT;
14 open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!";
15 return $stdout;
16 }
17
18 sub capture_stderr {
19 my $sub = shift;
20 my $stderr;
21 open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!";
22 close STDERR;
23 open STDERR, '>', \$stderr or die "Can't open STDERR: $!";
24
25 $sub->();
26
27 close STDERR;
28 open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!";
29 return $stderr;
30 }
31
32 1;
+0
-110
t/more.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7 use attributes;
8 use overload;
9
10 plan tests => 25;
11
12 my ($source_file, $obj_file, $lib_file);
13
14 require_ok( 'ExtUtils::ParseXS' );
15 ExtUtils::ParseXS->import('process_file');
16
17 chdir 't' or die "Can't chdir to t/, $!";
18
19 use Carp; $SIG{__WARN__} = \&Carp::cluck;
20
21 #########################
22
23 $source_file = 'XSMore.c';
24
25 # Try sending to file
26 ExtUtils::ParseXS->process_file(
27 filename => 'XSMore.xs',
28 output => $source_file,
29 );
30 ok -e $source_file, "Create an output file";
31
32 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
33 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
34
35 SKIP: {
36 skip "no compiler available", 2
37 if ! $b->have_compiler;
38 $obj_file = $b->compile( source => $source_file );
39 ok $obj_file;
40 ok -e $obj_file, "Make sure $obj_file exists";
41 }
42
43 SKIP: {
44 skip "no dynamic loading", 6
45 if !$b->have_compiler || !$Config{usedl};
46 my $module = 'XSMore';
47 $lib_file = $b->link( objects => $obj_file, module_name => $module );
48 ok $lib_file;
49 ok -e $lib_file, "Make sure $lib_file exists";
50
51 eval{
52 package XSMore;
53 our $VERSION = 42;
54 our $boot_ok;
55 DynaLoader::bootstrap_inherit(__PACKAGE__, $VERSION); # VERSIONCHECK disabled
56
57 sub new{ bless {}, shift }
58 };
59 is $@, '';
60 is ExtUtils::ParseXS::errors(), 0, 'ExtUtils::ParseXS::errors()';
61
62 is $XSMore::boot_ok, 100, 'the BOOT keyword';
63
64 ok XSMore::include_ok(), 'the INCLUDE keyword';
65 is prototype(\&XSMore::include_ok), "", 'the PROTOTYPES keyword';
66
67 is prototype(\&XSMore::prototype_ssa), '$$@', 'the PROTOTYPE keyword';
68
69 is_deeply [attributes::get(\&XSMore::attr_method)], [qw(method)], 'the ATTRS keyword';
70 is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype';
71
72 is XSMore::return_1(), 1, 'the CASE keyword (1)';
73 is XSMore::return_2(), 2, 'the CASE keyword (2)';
74 is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)';
75 is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)';
76
77 is XSMore::arg_init(200), 200, 'argument init';
78
79 ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword';
80 is abs(XSMore->new), 42, 'the OVERLOAD keyword';
81
82 my @a;
83 XSMore::hook(\@a);
84 is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords';
85
86 is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword';
87
88 is XSMore::len("foo"), 3, 'the length keyword';
89
90 is XSMore::sum(5, 9), 14, 'the INCLUDE_COMMAND directive';
91
92 # Win32 needs to close the DLL before it can unlink it, but unfortunately
93 # dl_unload_file was missing on Win32 prior to perl change #24679!
94 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
95 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
96 if ($DynaLoader::dl_modules[$i] eq $module) {
97 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
98 last;
99 }
100 }
101 }
102 }
103
104 unless ($ENV{PERL_NO_CLEANUP}) {
105 for ( $obj_file, $lib_file, $source_file) {
106 next unless defined $_;
107 1 while unlink $_;
108 }
109 }
+5
-0
t/pseudotypemap1 less more
0 # pseudotypemap1: comment with leading whitespace
1 TYPEMAP
2
3 line_to_generate_insufficient_columns_warning
4 unsigned long T_UV
+0
-117
t/usage.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use Test::More;
4 use Config;
5 use DynaLoader;
6 use ExtUtils::CBuilder;
7
8 if ( $] < 5.008 ) {
9 plan skip_all => "INTERFACE keyword support broken before 5.8";
10 }
11 else {
12 plan tests => 24;
13 }
14
15 my ($source_file, $obj_file, $lib_file, $module);
16
17 require_ok( 'ExtUtils::ParseXS' );
18 ExtUtils::ParseXS->import('process_file');
19
20 chdir 't' or die "Can't chdir to t/, $!";
21
22 use Carp; $SIG{__WARN__} = \&Carp::cluck;
23
24 #########################
25
26 $source_file = 'XSUsage.c';
27
28 # Try sending to file
29 process_file(filename => 'XSUsage.xs', output => $source_file);
30 ok -e $source_file, "Create an output file";
31
32 # TEST doesn't like extraneous output
33 my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
34
35 # Try to compile the file! Don't get too fancy, though.
36 my $b = ExtUtils::CBuilder->new(quiet => $quiet);
37
38 SKIP: {
39 skip "no compiler available", 2
40 if ! $b->have_compiler;
41 $module = 'XSUsage';
42
43 $obj_file = $b->compile( source => $source_file );
44 ok $obj_file;
45 ok -e $obj_file, "Make sure $obj_file exists";
46 }
47 SKIP: {
48 skip "no dynamic loading", 20
49 if !$b->have_compiler || !$Config{usedl};
50
51 $lib_file = $b->link( objects => $obj_file, module_name => $module );
52 ok $lib_file;
53 ok -e $lib_file, "Make sure $lib_file exists";
54
55 eval {require XSUsage};
56 is $@, '';
57
58 # The real tests here - for each way of calling the functions, call with the
59 # wrong number of arguments and check the Usage line is what we expect
60
61 eval { XSUsage::one(1) };
62 ok $@;
63 ok $@ =~ /^Usage: XSUsage::one/;
64
65 eval { XSUsage::two(1) };
66 ok $@;
67 ok $@ =~ /^Usage: XSUsage::two/;
68
69 eval { XSUsage::two_x(1) };
70 ok $@;
71 ok $@ =~ /^Usage: XSUsage::two_x/;
72
73 eval { FOO::two(1) };
74 ok $@;
75 ok $@ =~ /^Usage: FOO::two/;
76
77 eval { XSUsage::three(1) };
78 ok $@;
79 ok $@ =~ /^Usage: XSUsage::three/;
80
81 eval { XSUsage::four(1) };
82 ok !$@;
83
84 eval { XSUsage::five() };
85 ok $@;
86 ok $@ =~ /^Usage: XSUsage::five/;
87
88 eval { XSUsage::six() };
89 ok !$@;
90
91 eval { XSUsage::six(1) };
92 ok !$@;
93
94 eval { XSUsage::six(1,2) };
95 ok $@;
96 ok $@ =~ /^Usage: XSUsage::six/;
97
98 # Win32 needs to close the DLL before it can unlink it, but unfortunately
99 # dl_unload_file was missing on Win32 prior to perl change #24679!
100 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
101 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
102 if ($DynaLoader::dl_modules[$i] eq $module) {
103 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
104 last;
105 }
106 }
107 }
108 }
109
110 unless ($ENV{PERL_NO_CLEANUP}) {
111 for ( $obj_file, $lib_file, $source_file) {
112 next unless defined $_;
113 1 while unlink $_;
114 }
115 }
116