File Coverage

blib/lib/Inline/C.pm
Criterion Covered Total %
statement 444 542 81.9
branch 172 294 58.5
condition 50 93 53.7
subroutine 46 51 90.2
pod 2 38 5.2
total 714 1018 70.1


line stmt bran cond sub pod time code
1 34     34   5644141 use strict; use warnings;
  34     34   626  
  34         1523  
  34         290  
  34         120  
  34         3831  
2             package Inline::C;
3             our $VERSION = '0.81_001';
4              
5 34     34   2387 use Inline 0.56;
  34         110379  
  34         589  
6 34     34   3506 use Config;
  34         162  
  34         2796  
7 34     34   18867 use Data::Dumper;
  34         192806  
  34         2962  
8 34     34   244 use Carp;
  34         93  
  34         2878  
9 34     34   219 use Cwd qw(cwd abs_path);
  34         73  
  34         2009  
10 34     34   219 use File::Spec;
  34         71  
  34         1285  
11 34     34   192 use constant IS_WIN32 => $^O eq 'MSWin32';
  34         84  
  34         2140  
12 34     34   18229 use if !IS_WIN32, Fcntl => ':flock';
  34         413  
  34         340  
13 34     34   10239 use if IS_WIN32, 'Win32::Mutex';
  34         93  
  34         128  
14              
15             our @ISA = qw(Inline);
16              
17             #==============================================================================
18             # Register this module as an Inline language support module
19             #==============================================================================
20             sub register {
21             return {
22             language => 'C',
23             # XXX Breaking this on purpose; let's see who screams
24             # aliases => ['c'],
25             type => 'compiled',
26             suffix => $Config{dlext},
27 0     0 0 0 };
28             }
29              
30             #==============================================================================
31             # Validate the C config options
32             #==============================================================================
33             sub usage_validate {
34 0     0 0 0 my $key = shift;
35 0         0 return <
36             The value of config option '$key' must be a string or an array ref
37              
38             END
39             }
40              
41             sub validate {
42 58     58 0 118678 my $o = shift;
43              
44 58 50       403 print STDERR "validate Stage\n" if $o->{CONFIG}{BUILD_NOISY};
45 58   100     688 $o->{ILSM} ||= {};
46 58   100     497 $o->{ILSM}{XS} ||= {};
47 58   100     416 $o->{ILSM}{MAKEFILE} ||= {};
48 58 100       522 if (not $o->UNTAINT) {
49 54         1314 require FindBin;
50 54 100       2030 if (not defined $o->{ILSM}{MAKEFILE}{INC}) {
51             # detect Microsoft Windows OS, and either Microsoft Visual Studio compiler "cl.exe", "clarm.exe", or Intel C compiler "icl.exe"
52 52 50 33     1706 if (($Config{osname} eq 'MSWin32') and ($Config{cc} =~ /\b(cl\b|clarm|icl)/)) {
    50 33        
      33        
      33        
53 0         0 warn "\n Any header files specified relative to\n",
54             " $FindBin::Bin\n",
55             " will be included only if no file of the same relative path and\n",
56             " name is found elsewhere in the search locations (including those\n",
57             " specified in \$ENV{INCLUDE}).\n",
58             " Otherwise, that header file \"found elsewhere\" will be included.\n";
59 0         0 warn " "; # provide filename and line number.
60 0         0 $ENV{INCLUDE} .= qq{;"$FindBin::Bin"};
61             }
62             # detect Oracle Solaris/SunOS OS, and Oracle Developer Studio compiler "cc" (and double check it is not GCC)
63             elsif ((($Config{osname} eq 'solaris') or ($Config{osname} eq 'sunos')) and ($Config{cc} eq 'cc') and (not $Config{gccversion})) {
64 0         0 $o->{ILSM}{MAKEFILE}{INC} = "-I\"$FindBin::Bin\" -I-"; # angle-bracket includes will NOT incorrectly search -I dirs given before -I-
65 0         0 warn q{NOTE: Oracle compiler detected, unable to utilize '-iquote' compiler option, falling back to '-I-' which should produce correct results for files included in angle brackets}, "\n";
66             }
67             else {
68 52         302 $o->{ILSM}{MAKEFILE}{INC} = qq{-iquote"$FindBin::Bin"}; # angle-bracket includes will NOT incorrectly search -iquote dirs
69             }
70             }
71             }
72 58 100       298 $o->{ILSM}{AUTOWRAP} = 0 if not defined $o->{ILSM}{AUTOWRAP};
73 58 100       215 $o->{ILSM}{XSMODE} = 0 if not defined $o->{ILSM}{XSMODE};
74 58   100     384 $o->{ILSM}{AUTO_INCLUDE} ||= <
75             #include "EXTERN.h"
76             #include "perl.h"
77             #include "XSUB.h"
78             #include "INLINE.h"
79             END
80 58   100     412 $o->{ILSM}{FILTERS} ||= [];
81             $o->{STRUCT} ||= {
82 58   100     533 '.macros' => '',
83             '.xs' => '',
84             '.any' => 0,
85             '.all' => 0,
86             };
87              
88 58         249 while (@_) {
89 26         103 my ($key, $value) = (shift, shift);
90 26 100       172 if ($key eq 'PRE_HEAD') {
91 1 50       18 unless( -f $value) {
92             $o->{ILSM}{AUTO_INCLUDE} = $value . "\n" .
93 0         0 $o->{ILSM}{AUTO_INCLUDE};
94             }
95             else {
96 1         2 my $insert;
97 1 50       27 open RD, '<', $value
98             or die "Couldn't open $value for reading: $!";
99 1         13 while () {$insert .= $_}
  5         17  
100 1 50       10 close RD
101             or die "Couldn't close $value after reading: $!";
102             $o->{ILSM}{AUTO_INCLUDE} =
103 1         15 $insert . "\n" . $o->{ILSM}{AUTO_INCLUDE};
104             }
105 1         7 next;
106             }
107 25 100 66     184 if ($key eq 'MAKE' or
      100        
108             $key eq 'AUTOWRAP' or
109             $key eq 'XSMODE'
110             ) {
111 2         4 $o->{ILSM}{$key} = $value;
112 2         11 next;
113             }
114 23 100 66     98 if ($key eq 'CC' or
115             $key eq 'LD'
116             ) {
117 1         2 $o->{ILSM}{MAKEFILE}{$key} = $value;
118 1         5 next;
119             }
120 22 50       54 if ($key eq 'LIBS') {
121 0         0 $o->add_list($o->{ILSM}{MAKEFILE}, $key, $value, []);
122 0         0 next;
123             }
124 22 100       45 if ($key eq 'INC') {
125             $o->add_string(
126             $o->{ILSM}{MAKEFILE},
127 4         15 $key,
128             quote_space($value),
129             '',
130             );
131 4         13 next;
132             }
133 18 100 33     183 if ($key eq 'MYEXTLIB' or
      66        
      66        
134             $key eq 'OPTIMIZE' or
135             $key eq 'CCFLAGS' or
136             $key eq 'LDDLFLAGS'
137             ) {
138 3         14 $o->add_string($o->{ILSM}{MAKEFILE}, $key, $value, '');
139 3         10 next;
140             }
141 15 100       35 if ($key eq 'CCFLAGSEX') {
142             $o->add_string(
143             $o->{ILSM}{MAKEFILE},
144             'CCFLAGS',
145 1         75 $Config{ccflags} . ' ' . $value, '',
146             );
147 1         6 next;
148             }
149 14 100       33 if ($key eq 'TYPEMAPS') {
150 2 100       6 unless(ref($value) eq 'ARRAY') {
151 1 50       18 croak "TYPEMAPS file '$value' not found"
152             unless -f $value;
153 1         47 $value = File::Spec->rel2abs($value);
154             }
155             else {
156 1         2 for (my $i = 0; $i < scalar(@$value); $i++) {
157 0         0 croak "TYPEMAPS file '${$value}[$i]' not found"
158 2 50       2 unless -f ${$value}[$i];
  2         29  
159 2         4 ${$value}[$i] = File::Spec->rel2abs(${$value}[$i]);
  2         13  
  2         76  
160             }
161             }
162 2         9 $o->add_list($o->{ILSM}{MAKEFILE}, $key, $value, []);
163 2         9 next;
164             }
165 12 50       28 if ($key eq 'AUTO_INCLUDE') {
166 0         0 $o->add_text($o->{ILSM}, $key, $value, '');
167 0         0 next;
168             }
169 12 50       25 if ($key eq 'BOOT') {
170 0         0 $o->add_text($o->{ILSM}{XS}, $key, $value, '');
171 0         0 next;
172             }
173 12 100       25 if ($key eq 'PREFIX') {
174 2 50 33     15 croak "Invalid value for 'PREFIX' option"
175             unless ($value =~ /^\w*$/ and
176             $value !~ /\n/);
177 2         6 $o->{ILSM}{XS}{PREFIX} = $value;
178 2         9 next;
179             }
180 10 50       23 if ($key eq 'FILTERS') {
181 0 0 0     0 next if $value eq '1' or $value eq '0'; # ignore ENABLE, DISABLE
182 0 0       0 $value = [$value] unless ref($value) eq 'ARRAY';
183 0         0 my %filters;
184 0         0 for my $val (@$value) {
185 0 0       0 if (ref($val) eq 'CODE') {
    0          
186 0         0 $o->add_list($o->{ILSM}, $key, $val, []);
187             }
188             elsif (ref($val) eq 'ARRAY') {
189 0         0 my ($filter_plugin, @args) = @$val;
190              
191 0 0       0 croak "Bad format for filter plugin name: '$filter_plugin'"
192             unless $filter_plugin =~ m/^[\w:]+$/;
193              
194 0         0 eval "require Inline::Filters::${filter_plugin}";
195 0 0       0 croak "Filter plugin Inline::Filters::$filter_plugin not installed"
196             if $@;
197              
198             croak "No Inline::Filters::${filter_plugin}::filter sub found"
199 0 0       0 unless defined &{"Inline::Filters::${filter_plugin}::filter"};
  0         0  
200              
201 0         0 my $filter_factory = \&{"Inline::Filters::${filter_plugin}::filter"};
  0         0  
202              
203 0         0 $o->add_list($o->{ILSM}, $key, $filter_factory->(@args), []);
204             }
205             else {
206 0         0 eval { require Inline::Filters };
  0         0  
207 0 0       0 croak "'FILTERS' option requires Inline::Filters to be installed."
208             if $@;
209             %filters = Inline::Filters::get_filters($o->{API}{language})
210 0 0       0 unless keys %filters;
211 0 0       0 if (defined $filters{$val}) {
212             my $filter = Inline::Filters->new(
213             $val,
214 0         0 $filters{$val});
215 0         0 $o->add_list($o->{ILSM}, $key, $filter, []);
216             }
217             else {
218 0         0 croak "Invalid filter $val specified.";
219             }
220             }
221             }
222 0         0 next;
223             }
224 10 50       22 if ($key eq 'STRUCTS') {
225             # A list of struct names
226 0 0       0 if (ref($value) eq 'ARRAY') {
    0          
227 0         0 for my $val (@$value) {
228 0 0       0 croak "Invalid value for 'STRUCTS' option"
229             unless ($val =~ /^[_a-z][_0-9a-z]*$/i);
230 0         0 $o->{STRUCT}{$val}++;
231             }
232             }
233             # Enable or disable
234             elsif ($value =~ /^\d+$/) {
235 0         0 $o->{STRUCT}{'.any'} = $value;
236             }
237             # A single struct name
238             else {
239 0 0       0 croak "Invalid value for 'STRUCTS' option"
240             unless ($value =~ /^[_a-z][_0-9a-z]*$/i);
241 0         0 $o->{STRUCT}{$value}++;
242             }
243 0         0 eval { require Inline::Struct };
  0         0  
244 0 0       0 croak "'STRUCTS' option requires Inline::Struct to be installed."
245             if $@;
246 0         0 $o->{STRUCT}{'.any'} = 1;
247 0         0 next;
248             }
249 10 100       25 if ($key eq 'PROTOTYPES') {
250 3         6 $o->{CONFIG}{PROTOTYPES} = $value;
251 3 100       14 next if $value eq 'ENABLE';
252 1 50       8 next if $value eq 'DISABLE';
253 1         14 die "PROTOTYPES can be only either 'ENABLE' or 'DISABLE' - not $value";
254             }
255 7 100       16 if ($key eq 'PROTOTYPE') {
256 4 100       32 die "PROTOTYPE configure arg must specify a hash reference"
257             unless ref($value) eq 'HASH';
258 3         10 $o->{CONFIG}{PROTOTYPE} = $value;
259 3         10 next;
260             }
261 3 100       6 if ($key eq 'CPPFLAGS') {
262             # C preprocessor flags, used by Inline::Filters::Preprocess()
263 2         7 next;
264             }
265              
266 1         3 my $class = ref $o; # handles subclasses correctly.
267 1         246 croak "'$key' is not a valid config option for $class\n";
268             }
269             }
270              
271             sub add_list {
272 2     2 0 4 my $o = shift;
273 2         4 my ($ref, $key, $value, $default) = @_;
274 2 100       11 $value = [$value] unless ref $value eq 'ARRAY';
275 2         5 for (@$value) {
276 3 50       6 if (defined $_) {
277 3         3 push @{$ref->{$key}}, $_;
  3         10  
278             }
279             else {
280 0         0 $ref->{$key} = $default;
281             }
282             }
283             }
284              
285             sub add_string {
286 8     8 0 26 my $o = shift;
287 8         19 my ($ref, $key, $value, $default) = @_;
288 8 50       20 $value = [$value] unless ref $value;
289 8 50       31 croak usage_validate($key) unless ref($value) eq 'ARRAY';
290 8         16 for (@$value) {
291 8 50       18 if (defined $_) {
292 8         32 $ref->{$key} .= ' ' . $_;
293             }
294             else {
295 0         0 $ref->{$key} = $default;
296             }
297             }
298             }
299              
300             sub add_text {
301 0     0 0 0 my $o = shift;
302 0         0 my ($ref, $key, $value, $default) = @_;
303 0 0       0 $value = [$value] unless ref $value;
304 0 0       0 croak usage_validate($key) unless ref($value) eq 'ARRAY';
305 0         0 for (@$value) {
306 0 0       0 if (defined $_) {
307 0         0 chomp;
308 0         0 $ref->{$key} .= $_ . "\n";
309             }
310             else {
311 0         0 $ref->{$key} = $default;
312             }
313             }
314             }
315              
316             #==============================================================================
317             # Return a small report about the C code..
318             #==============================================================================
319             sub info {
320 0     0 1 0 my $o = shift;
321 0 0       0 return <{ILSM}{XSMODE};
322             No information is currently generated when using XSMODE.
323              
324             END
325 0         0 my $text = '';
326 0         0 $o->preprocess;
327 0         0 $o->parse;
328 0 0       0 if (defined $o->{ILSM}{parser}{data}{functions}) {
329 0         0 $text .= "The following Inline $o->{API}{language} function(s) have been successfully bound to Perl:\n";
330 0         0 my $parser = $o->{ILSM}{parser};
331 0         0 my $data = $parser->{data};
332 0         0 for my $function (sort @{$data->{functions}}) {
  0         0  
333 0         0 my $return_type = $data->{function}{$function}{return_type};
334 0         0 my @arg_names = @{$data->{function}{$function}{arg_names}};
  0         0  
335 0         0 my @arg_types = @{$data->{function}{$function}{arg_types}};
  0         0  
336 0         0 my @args = map {$_ . ' ' . shift @arg_names} @arg_types;
  0         0  
337 0         0 $text .= "\t$return_type $function(" . join(', ', @args) . ")\n";
338             }
339             }
340             else {
341 0         0 $text .= "No $o->{API}{language} functions have been successfully bound to Perl.\n\n";
342             }
343 0 0       0 $text .= Inline::Struct::info($o) if $o->{STRUCT}{'.any'};
344 0         0 return $text;
345             }
346              
347             sub config {
348 0     0 0 0 my $o = shift;
349             }
350              
351             #==============================================================================
352             # Parse and compile C code
353             #==============================================================================
354             my $total_build_time;
355             sub build {
356 51     51 0 549 my $o = shift;
357              
358 51 50       172 if ($o->{CONFIG}{BUILD_TIMERS}) {
359 0         0 eval {require Time::HiRes};
  0         0  
360 0 0       0 croak "You need Time::HiRes for BUILD_TIMERS option:\n$@" if $@;
361 0         0 $total_build_time = Time::HiRes::time();
362             }
363 51         93 my ($file, $lockfh);
364 51         84 if (IS_WIN32) {
365             #this can not look like a file path, or new() fails
366             $file = 'Inline__C_' . $o->{API}{directory} . '.lock';
367             $file =~ s/\\/_/g; #per CreateMutex on MSDN
368             $lockfh = Win32::Mutex->new(0, $file) or die "lockmutex $file: $^E";
369             $lockfh->wait(); #acquire, can't use 1 to new(), since if new() opens
370             #existing instead of create new Muxtex, it is not acquired
371             }
372             else {
373 51         573 $file = File::Spec->catfile($o->{API}{directory}, '.lock');
374 51 50       3966 open $lockfh, '>', $file or die "lockfile $file: $!";
375 51 50 50     1009729 flock($lockfh, LOCK_EX) or die "flock: $!\n" if $^O !~ /^VMS|riscos|VOS$/;
376             }
377 51         969 $o->mkpath($o->{API}{build_dir});
378 51         17247 $o->call('preprocess', 'Build Preprocess');
379 51         157 $o->call('parse', 'Build Parse');
380 51         285 $o->call('write_XS', 'Build Glue 1');
381 51         183 $o->call('write_Inline_headers', 'Build Glue 2');
382 51         172 $o->call('write_Makefile_PL', 'Build Glue 3');
383 51         168 $o->call('compile', 'Build Compile');
384 50         222 if (IS_WIN32) {
385             $lockfh->release or die "releasemutex $file: $^E";
386             }
387             else {
388 50 50       2072 flock($lockfh, LOCK_UN) if $^O !~ /^VMS|riscos|VOS$/;
389             }
390 50 50       2624 if ($o->{CONFIG}{BUILD_TIMERS}) {
391 0         0 $total_build_time = Time::HiRes::time() - $total_build_time;
392 0         0 printf STDERR "Total Build Time: %5.4f secs\n", $total_build_time;
393             }
394             }
395              
396             sub call {
397 508     508 0 3612 my ($o, $method, $header, $indent) = (@_, 0);
398 508         907 my $time;
399 508         2436 my $i = ' ' x $indent;
400 508 50       1606 print STDERR "${i}Starting $header Stage\n" if $o->{CONFIG}{BUILD_NOISY};
401             $time = Time::HiRes::time()
402 508 50       1304 if $o->{CONFIG}{BUILD_TIMERS};
403              
404 508         3356 $o->$method();
405              
406             $time = Time::HiRes::time() - $time
407 506 50       1044954 if $o->{CONFIG}{BUILD_TIMERS};
408 506 50       1767 print STDERR "${i}Finished $header Stage\n" if $o->{CONFIG}{BUILD_NOISY};
409             printf STDERR "${i}Time for $header Stage: %5.4f secs\n", $time
410 506 50       1368 if $o->{CONFIG}{BUILD_TIMERS};
411 506 50       5823 print STDERR "\n" if $o->{CONFIG}{BUILD_NOISY};
412             }
413              
414             #==============================================================================
415             # Apply any
416             #==============================================================================
417             sub preprocess {
418 51     51 0 110 my $o = shift;
419 51 50       194 return if $o->{ILSM}{parser};
420 51         192 $o->get_maps;
421 51         228 $o->get_types;
422 51         92 $o->{ILSM}{code} = $o->filter(@{$o->{ILSM}{FILTERS}});
  51         788  
423             }
424              
425             #==============================================================================
426             # Parse the function definition information out of the C code
427             #==============================================================================
428             sub parse {
429 51     51 0 86 my $o = shift;
430 51 50       150 return if $o->{ILSM}{parser};
431 51 100       145 return if $o->{ILSM}{XSMODE};
432 50         174 my $parser = $o->{ILSM}{parser} = $o->get_parser;
433 50         3755433 $parser->{data}{typeconv} = $o->{ILSM}{typeconv};
434 50         195 $parser->{data}{AUTOWRAP} = $o->{ILSM}{AUTOWRAP};
435 50 50       309 Inline::Struct::parse($o) if $o->{STRUCT}{'.any'};
436             $parser->code($o->{ILSM}{code})
437 50 50       775 or croak <
438 0         0 Bad $o->{API}{language} code passed to Inline at @{[caller(2)]}
439             END
440             }
441              
442             # Create and initialize a parser
443             sub get_parser {
444 32     32 0 53 my $o = shift;
445             Inline::C::_parser_test($o->{CONFIG}{DIRECTORY}, "Inline::C::get_parser called\n")
446 32 100       107 if $o->{CONFIG}{_TESTING};
447 32         8724 require Inline::C::Parser::RecDescent;
448 32         175 Inline::C::Parser::RecDescent::get_parser($o);
449             }
450              
451             #==============================================================================
452             # Gather the path names of all applicable typemap files.
453             #==============================================================================
454             sub get_maps {
455 51     51 0 97 my $o = shift;
456              
457 51 50       141 print STDERR "get_maps Stage\n" if $o->{CONFIG}{BUILD_NOISY};
458 51         100 my $typemap = '';
459 51         71 my $file;
460             $file = File::Spec->catfile(
461             $Config::Config{installprivlib},
462 51         2853 "ExtUtils",
463             "typemap",
464             );
465 51 50       1044 $typemap = $file if -f $file;
466             $file = File::Spec->catfile(
467             $Config::Config{privlibexp}
468 51         662 ,"ExtUtils","typemap"
469             );
470 51 50 33     250 $typemap = $file
471             if (not $typemap and -f $file);
472 51 0 33     158 warn "Can't find the default system typemap file"
473             if (not $typemap and $^W);
474              
475 51 50       124 unshift(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $typemap) if $typemap;
  51         198  
476              
477 51 100       180 if (not $o->UNTAINT) {
478 47         371 require FindBin;
479 47         340 $file = File::Spec->catfile($FindBin::Bin,"typemap");
480 47 50       735 if ( -f $file ) {
481 47         101 push(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $file);
  47         172  
482             }
483             }
484             }
485              
486             #==============================================================================
487             # This routine parses XS typemap files to get a list of valid types to create
488             # bindings to. This code is mostly hacked out of Larry Wall's xsubpp program.
489             #==============================================================================
490             sub get_types {
491 51     51 0 115 my (%type_kind, %proto_letter, %input_expr, %output_expr);
492 51         95 my $o = shift;
493 51         94 local $_;
494             croak "No typemaps specified for Inline C code"
495 51 50       88 unless @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}};
  51         178  
496              
497 51         129 my $proto_re = "[" . quotemeta('\$%&*@;') . "]";
498 51         81 foreach my $typemap (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) {
  51         218  
499 101 50       1438 next unless -e $typemap;
500             # skip directories, binary files etc.
501 101 50       3993 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
502             unless -T $typemap;
503 101 50       2432 open(TYPEMAP, $typemap)
504             or warn ("Warning: could not open typemap file '$typemap': $!\n"),
505             next;
506 101         400 my $mode = 'Typemap';
507 101         168 my $junk = "";
508 101         153 my $current = \$junk;
509 101         1170 while () {
510 23350 100       38918 next if /^\s*\#/;
511 22891         29194 my $line_no = $. + 1;
512 22891 100       30644 if (/^INPUT\s*$/) {$mode = 'Input'; $current = \$junk; next}
  101         171  
  101         170  
  101         475  
513 22790 100       29248 if (/^OUTPUT\s*$/) {$mode = 'Output'; $current = \$junk; next}
  101         158  
  101         151  
  101         286  
514 22689 50       28350 if (/^TYPEMAP\s*$/) {$mode = 'Typemap'; $current = \$junk; next}
  0         0  
  0         0  
  0         0  
515 22689 100       45590 if ($mode eq 'Typemap') {
    100          
    100          
516 2854         3329 chomp;
517 2854         3387 my $line = $_;
518 2854         4661 TrimWhitespace($_);
519             # skip blank lines and comment lines
520 2854 100 66     9064 next if /^$/ or /^\#/;
521 2651 50       17110 my ($type,$kind, $proto) =
522             /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
523             warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
524 2651         4518 $type = TidyType($type);
525 2651         5451 $type_kind{$type} = $kind;
526             # prototype defaults to '$'
527 2651 50       4275 $proto = "\$" unless $proto;
528 2651 50       3356 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
529             unless ValidProtoString($proto);
530 2651         4095 $proto_letter{$type} = C_string($proto);
531             }
532             elsif (/^\s/) {
533 15349         38358 $$current .= $_;
534             }
535             elsif ($mode eq 'Input') {
536 2243         5939 s/\s+$//;
537 2243         4603 $input_expr{$_} = '';
538 2243         6197 $current = \$input_expr{$_};
539             }
540             else {
541 2243         5658 s/\s+$//;
542 2243         3911 $output_expr{$_} = '';
543 2243         6162 $current = \$output_expr{$_};
544             }
545             }
546 101         935 close(TYPEMAP);
547             }
548              
549 2602         3954 my %valid_types = map {($_, 1)} grep {
550 51         696 defined $input_expr{$type_kind{$_}}
  2602         3715  
551             } keys %type_kind;
552              
553 2653         3485 my %valid_rtypes = map {($_, 1)} (
554             grep {
555 51         494 defined $output_expr{$type_kind{$_}}
  2602         3525  
556             } keys %type_kind
557             ), 'void';
558              
559 51         365 $o->{ILSM}{typeconv}{type_kind} = \%type_kind;
560 51         178 $o->{ILSM}{typeconv}{input_expr} = \%input_expr;
561 51         175 $o->{ILSM}{typeconv}{output_expr} = \%output_expr;
562 51         122 $o->{ILSM}{typeconv}{valid_types} = \%valid_types;
563 51         522 $o->{ILSM}{typeconv}{valid_rtypes} = \%valid_rtypes;
564             }
565              
566             sub ValidProtoString ($) {
567 2651     2651 0 3068 my $string = shift;
568 2651         2865 my $proto_re = "[" . quotemeta('\$%&*@;') . "]";
569 2651 50       10762 return ($string =~ /^$proto_re+$/) ? $string : 0;
570             }
571              
572             sub TrimWhitespace {
573 5505     5505 0 15647 $_[0] =~ s/^\s+|\s+$//go;
574             }
575              
576             sub TidyType {
577 2651     2651 0 3809 local $_ = shift;
578 2651         5067 s|\s*(\*+)\s*|$1|g;
579 2651         4783 s|(\*+)| $1 |g;
580 2651         4989 s|\s+| |g;
581 2651         4260 TrimWhitespace($_);
582 2651         4367 $_;
583             }
584              
585             sub C_string ($) {
586 2651     2651 0 3700 (my $string = shift) =~ s|\\|\\\\|g;
587 2651         9926 $string;
588             }
589              
590             #==============================================================================
591             # Write the XS code
592             #==============================================================================
593             sub write_XS {
594 51     51 0 202 my $o = shift;
595 51         203 my $modfname = $o->{API}{modfname};
596 51         157 my $module = $o->{API}{module};
597 51         4427 my $file = File::Spec->catfile($o->{API}{build_dir},"$modfname.xs");
598 51 50       6425 open XS, ">", $file or croak "$file: $!";
599 51 100       328 if ($o->{ILSM}{XSMODE}) {
600 1 50 33     24 warn <{ILSM}{code} !~ /MODULE\s*=\s*$module\b/;
601             While using Inline XSMODE, your XS code does not have a line with
602              
603             MODULE = $module
604              
605             You should use the Inline NAME config option, and it should match the
606             XS MODULE name.
607              
608             END
609 1         3 print XS $o->xs_code;
610             }
611             else {
612 50         348 print XS $o->xs_generate;
613             }
614 51         2715 close XS;
615             }
616              
617             #==============================================================================
618             # Generate the XS glue code (piece together lots of snippets)
619             #==============================================================================
620             sub xs_generate {
621 50     50 0 127 my $o = shift;
622 50         209 return join '', (
623             $o->xs_includes,
624             $o->xs_struct_macros,
625             $o->xs_code,
626             $o->xs_struct_code,
627             $o->xs_bindings,
628             $o->xs_boot,
629             );
630             }
631              
632             sub xs_includes {
633 50     50 0 143 my $o = shift;
634 50         246 return $o->{ILSM}{AUTO_INCLUDE};
635             }
636              
637             sub xs_struct_macros {
638 50     50 0 104 my $o = shift;
639 50         325 return $o->{STRUCT}{'.macros'};
640             }
641              
642             sub xs_code {
643 51     51 0 129 my $o = shift;
644 51         340 return $o->{ILSM}{code};
645             }
646              
647             sub xs_struct_code {
648 50     50 0 107 my $o = shift;
649 50         356 return $o->{STRUCT}{'.xs'};
650             }
651              
652             sub xs_boot {
653 50     50 0 101 my $o = shift;
654 50 0 33     235 if (defined $o->{ILSM}{XS}{BOOT} and $o->{ILSM}{XS}{BOOT}) {
655 0         0 return <
656             BOOT:
657             $o->{ILSM}{XS}{BOOT}
658             END
659             }
660 50         715 return '';
661             }
662              
663             sub xs_bindings {
664 50     50 0 114 my $o = shift;
665 50         211 my $dir = $o->{API}{directory};
666              
667 50 100       298 if ($o->{CONFIG}{_TESTING}) {
668 13         46 my $file = "$dir/void_test";
669 13 100       217 if (! -f $file) {
670 2 50       76 warn "$file: $!" if !open(TEST_FH, '>', $file);
671 2 50       24 warn "$file: $!" if !close(TEST_FH);
672             }
673             }
674              
675 50         140 my ($pkg, $module) = @{$o->{API}}{qw(pkg module)};
  50         228  
676             my $prefix = (
677             ($o->{ILSM}{XS}{PREFIX})
678 50 100       347 ? "PREFIX = $o->{ILSM}{XS}{PREFIX}"
679             : ''
680             );
681              
682             my $prototypes = defined($o->{CONFIG}{PROTOTYPES})
683             ? $o->{CONFIG}{PROTOTYPES}
684 50 100       275 : 'DISABLE';
685              
686 50         272 my $XS = <
687              
688             MODULE = $module PACKAGE = $pkg $prefix
689              
690             PROTOTYPES: $prototypes
691              
692             END
693              
694 50         134 my $parser = $o->{ILSM}{parser};
695 50         98 my $data = $parser->{data};
696              
697             warn(
698             "Warning. No Inline C functions bound to Perl in ", $o->{API}{script},
699             "\n" .
700             "Check your C function definition(s) for Inline compatibility\n\n"
701 50 0 33     223 ) if ((not defined$data->{functions}) and ($^W));
702              
703 50         3611 for my $function (@{$data->{functions}}) {
  50         274  
704 81         279 my $return_type = $data->{function}->{$function}->{return_type};
705 81         135 my @arg_names = @{$data->{function}->{$function}->{arg_names}};
  81         223  
706 81         130 my @arg_types = @{$data->{function}->{$function}->{arg_types}};
  81         194  
707              
708 81         469 $XS .= join '', (
709             "\n$return_type\n$function (",
710             join(', ', @arg_names), ")\n"
711             );
712              
713 81         179 for my $arg_name (@arg_names) {
714 61         102 my $arg_type = shift @arg_types;
715 61 50       125 last if $arg_type eq '...';
716 61         142 $XS .= "\t$arg_type\t$arg_name\n";
717             }
718              
719 81         114 my %h;
720 81 100       328 if (defined($o->{CONFIG}{PROTOTYPE})) {
721 2         6 %h = %{$o->{CONFIG}{PROTOTYPE}};
  2         13  
722             }
723              
724 81 100       226 if (defined($h{$function})) {
725 2         7 $XS .= " PROTOTYPE: $h{$function}\n";
726             }
727              
728 81         227 my $listargs = '';
729 81 50 66     417 $listargs = pop @arg_names
730             if (@arg_names and $arg_names[-1] eq '...');
731 81         214 my $arg_name_list = join(', ', @arg_names);
732              
733 81 100       335 if ($return_type eq 'void') {
    50          
734 18 100       34 if ($o->{CONFIG}{_TESTING}) {
735 10         40 $XS .= <
736             PREINIT:
737             PerlIO* stream;
738             I32* temp;
739             PPCODE:
740             temp = PL_markstack_ptr++;
741             $function($arg_name_list);
742             stream = PerlIO_open(\"$dir/void_test\", \"a\");
743             if (stream == NULL) warn(\"%s\\n\", \"Unable to open $dir/void_test for appending\");
744             if (PL_markstack_ptr != temp) {
745             PerlIO_printf(stream, \"%s\\n\", \"TRULY_VOID\");
746             PerlIO_close(stream);
747             PL_markstack_ptr = temp;
748             XSRETURN_EMPTY; /* return empty stack */
749             }
750             PerlIO_printf(stream, \"%s\\n\", \"LIST_CONTEXT\");
751             PerlIO_close(stream);
752             return; /* assume stack size is correct */
753             END
754             }
755             else {
756 8         25 $XS .= <
757             PREINIT:
758             I32* temp;
759             PPCODE:
760             temp = PL_markstack_ptr++;
761             $function($arg_name_list);
762             if (PL_markstack_ptr != temp) {
763             /* truly void, because dXSARGS not invoked */
764             PL_markstack_ptr = temp;
765             XSRETURN_EMPTY; /* return empty stack */
766             }
767             /* must have used dXSARGS; list context implied */
768             return; /* assume stack size is correct */
769             END
770             }
771             }
772             elsif ($listargs) {
773 0         0 $XS .= <
774             PREINIT:
775             I32* temp;
776             CODE:
777             temp = PL_markstack_ptr++;
778             RETVAL = $function($arg_name_list);
779             PL_markstack_ptr = temp;
780             OUTPUT:
781             RETVAL
782             END
783             }
784             }
785 50         108 $XS .= "\n";
786 50         295 return $XS;
787             }
788              
789             #==============================================================================
790             # Generate the INLINE.h file.
791             #==============================================================================
792             sub write_Inline_headers {
793 51     51 0 108 my $o = shift;
794              
795 51 50       3056 open HEADER, "> ".File::Spec->catfile($o->{API}{build_dir},"INLINE.h")
796             or croak;
797              
798 51         389 print HEADER <<'END';
799             #define Inline_Stack_Vars dXSARGS
800             #define Inline_Stack_Items items
801             #define Inline_Stack_Item(x) ST(x)
802             #define Inline_Stack_Reset sp = mark
803             #define Inline_Stack_Push(x) XPUSHs(x)
804             #define Inline_Stack_Done PUTBACK
805             #define Inline_Stack_Return(x) XSRETURN(x)
806             #define Inline_Stack_Void XSRETURN(0)
807              
808             #define INLINE_STACK_VARS Inline_Stack_Vars
809             #define INLINE_STACK_ITEMS Inline_Stack_Items
810             #define INLINE_STACK_ITEM(x) Inline_Stack_Item(x)
811             #define INLINE_STACK_RESET Inline_Stack_Reset
812             #define INLINE_STACK_PUSH(x) Inline_Stack_Push(x)
813             #define INLINE_STACK_DONE Inline_Stack_Done
814             #define INLINE_STACK_RETURN(x) Inline_Stack_Return(x)
815             #define INLINE_STACK_VOID Inline_Stack_Void
816              
817             #define inline_stack_vars Inline_Stack_Vars
818             #define inline_stack_items Inline_Stack_Items
819             #define inline_stack_item(x) Inline_Stack_Item(x)
820             #define inline_stack_reset Inline_Stack_Reset
821             #define inline_stack_push(x) Inline_Stack_Push(x)
822             #define inline_stack_done Inline_Stack_Done
823             #define inline_stack_return(x) Inline_Stack_Return(x)
824             #define inline_stack_void Inline_Stack_Void
825             END
826              
827 51         1149 close HEADER;
828             }
829              
830             #==============================================================================
831             # Generate the Makefile.PL
832             #==============================================================================
833             sub write_Makefile_PL {
834 51     51 0 107 my $o = shift;
835 51         201 $o->{ILSM}{xsubppargs} = '';
836 51         109 my $i = 0;
837 51         117 for (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) {
  51         236  
838 101         366 $o->{ILSM}{xsubppargs} .= "-typemap \"$_\" ";
839             }
840              
841             my %options = (
842             VERSION => $o->{API}{version} || '0.00',
843 51         713 %{$o->{ILSM}{MAKEFILE}},
844             NAME => $o->{API}{module},
845 51   50     410 );
846              
847 51 50       2964 open MF, "> ".File::Spec->catfile($o->{API}{build_dir},"Makefile.PL")
848             or croak;
849              
850 51         423 print MF <
851             use ExtUtils::MakeMaker;
852             my %options = %\{
853             END
854              
855 51         145 local $Data::Dumper::Terse = 1;
856 51         214 local $Data::Dumper::Indent = 1;
857 51         448 print MF Data::Dumper::Dumper(\ %options);
858              
859 51         4882 print MF <
860             \};
861             WriteMakefile(\%options);
862              
863             # Remove the Makefile dependency. Causes problems on a few systems.
864             sub MY::makefile { '' }
865             END
866 51         1360 close MF;
867             }
868              
869             #==============================================================================
870             # Run the build process.
871             #==============================================================================
872             sub compile {
873 51     51 0 146 my $o = shift;
874              
875 51         165 my $build_dir = $o->{API}{build_dir};
876 51         163299 my $cwd = &cwd;
877 51 100       2364 ($cwd) = $cwd =~ /(.*)/ if $o->UNTAINT;
878              
879 51         1748 chdir $build_dir;
880             # Run these in an eval block, so that we get to chdir back to
881             # $cwd if there's a failure. (Ticket #81375.)
882 51         518 eval {
883 51         1171 $o->call('makefile_pl', '"perl Makefile.PL"', 2);
884 51         532 $o->call('make', '"make"', 2);
885 50         1537 $o->call('make_install', '"make install"', 2);
886             };
887 51         2033 chdir $cwd;
888 51 100       1184 die if $@; #Die now that we've done the chdir back to $cwd. (#81375)
889 50         1324 $o->call('cleanup', 'Cleaning Up', 2);
890             }
891              
892             sub makefile_pl {
893 51     51 0 277 my ($o) = @_;
894 51         186 my $perl;
895             -f ($perl = $Config::Config{perlpath})
896 51 50 33     4114 or ($perl = $^X)
897             or croak "Can't locate your perl binary";
898 51 50       839 $perl = qq{"$perl"} if $perl =~ m/\s/;
899 51         2221 my @_inc = map qq{"-I$_"}, $o->derive_minus_I;
900 51         30494 $o->system_call("$perl @_inc Makefile.PL", 'out.Makefile_PL');
901 51         2183 $o->fix_make;
902             }
903             sub make {
904 51     51 1 240 my ($o) = @_;
905             my $make = $o->{ILSM}{MAKE} || $Config::Config{make}
906 51 50 33     7527 or croak "Can't locate your make binary";
907             local $ENV{MAKEFLAGS} = $ENV{MAKEFLAGS} =~ s/(--jobserver-fds=[\d,]+)//
908 51 50       1616 if $ENV{MAKEFLAGS};
909 51         512 $o->system_call("$make", 'out.make');
910             }
911             sub make_install {
912 50     50 0 403 my ($o) = @_;
913             my $make = $o->{ILSM}{MAKE} || $Config::Config{make}
914 50 50 33     5738 or croak "Can't locate your make binary";
915 50 50       792 if ($ENV{MAKEFLAGS}) { # Avoid uninitialized warnings
916             local $ENV{MAKEFLAGS} = $ENV{MAKEFLAGS} =~
917 50         1163 s/(--jobserver-fds=[\d,]+)//;
918             }
919 50         928 $o->system_call("$make pure_install", 'out.make_install');
920             }
921             sub cleanup {
922 50     50 0 454 my ($o) = @_;
923             my ($modpname, $modfname, $install_lib) =
924 50         381 @{$o->{API}}{qw(modpname modfname install_lib)};
  50         1424  
925 50 50       862 if ($o->{API}{cleanup}) {
926             $o->rmpath(
927 50         4654 File::Spec->catdir($o->{API}{directory},'build'),
928             $modpname
929             );
930 50         189016 my $autodir = File::Spec->catdir($install_lib,'auto',$modpname);
931 50         1118 my @files = ( ".packlist", map "$modfname.$_", qw( bs exp lib ) );
932 50         273 my @paths = grep { -e } map { File::Spec->catfile($autodir,$_) } @files;
  200         3162  
  200         1332  
933 50   50     2343 unlink($_) || die "Can't delete file $_: $!" for @paths;
934             }
935             }
936              
937             sub system_call {
938 152     152 0 1389 my ($o, $cmd, $output_file) = @_;
939             my $build_noisy = defined $ENV{PERL_INLINE_BUILD_NOISY}
940             ? $ENV{PERL_INLINE_BUILD_NOISY}
941 152 50       1603 : $o->{CONFIG}{BUILD_NOISY};
942             # test this functionality with:
943             #perl -MInline=C,Config,BUILD_NOISY,1,FORCE_BUILD,1 -e "use Inline C => q[void inline_warner() { int *x = 2; }]"
944 152 50       1196 if (not $build_noisy) {
945 152         827 $cmd = "$cmd > $output_file 2>&1";
946             }
947 152 100       3073 ($cmd) = $cmd =~ /(.*)/ if $o->UNTAINT;
948 152 100       44586593 system($cmd) == 0
949             or croak($o->build_error_message($cmd, $output_file, $build_noisy));
950             }
951              
952             sub build_error_message {
953 1     1 0 42 my ($o, $cmd, $output_file, $build_noisy) = @_;
954 1         23 my $build_dir = $o->{API}{build_dir};
955 1         14 my $output = '';
956 1 50 33     145 if (not $build_noisy and
957             open(OUTPUT, $output_file)
958             ) {
959 1         31 local $/;
960 1         150 $output = ;
961 1         201 close OUTPUT;
962             }
963              
964 1         14 my $errcode = $? >> 8;
965 1         13 $output .= <
966              
967             A problem was encountered while attempting to compile and install your Inline
968             $o->{API}{language} code. The command that failed was:
969             \"$cmd\" with error code $errcode
970              
971             The build directory was:
972             $build_dir
973              
974             To debug the problem, cd to the build directory, and inspect the output files.
975              
976             END
977 1 50       36 if ($cmd =~ /^make >/) {
978 1         46 for (sort keys %ENV) {
979 33 100       109 $output .= "Environment $_ = '$ENV{$_}'\n" if /^(?:MAKE|PATH)/;
980             }
981             }
982 1         634 return $output;
983             }
984              
985             #==============================================================================
986             # This routine fixes problems with the MakeMaker Makefile.
987             #==============================================================================
988             my %fixes = (
989             INSTALLSITEARCH => 'install_lib',
990             INSTALLDIRS => 'installdirs',
991             XSUBPPARGS => 'xsubppargs',
992             INSTALLSITELIB => 'install_lib',
993             );
994              
995             sub fix_make {
996 34     34   201333 use strict;
  34         89  
  34         22713  
997 51     51 0 569 my (@lines, $fix);
998 51         403 my $o = shift;
999              
1000 51         1283 $o->{ILSM}{install_lib} = $o->{API}{install_lib};
1001 51         887 $o->{ILSM}{installdirs} = 'site';
1002              
1003 51 50       3717 open(MAKEFILE, '< Makefile')
1004             or croak "Can't open Makefile for input: $!\n";
1005 51         41190 @lines = ;
1006 51         1260 close MAKEFILE;
1007              
1008 51 50       4537 open(MAKEFILE, '> Makefile')
1009             or croak "Can't open Makefile for output: $!\n";
1010 51         570 for (@lines) {
1011 52833 100 100     108605 if (/^(\w+)\s*=\s*\S+.*$/ and
1012             $fix = $fixes{$1}
1013             ) {
1014 204         899 my $fixed = $o->{ILSM}{$fix};
1015 204         1023 print MAKEFILE "$1 = $fixed\n";
1016             }
1017             else {
1018 52629         71246 print MAKEFILE;
1019             }
1020             }
1021 51         7630 close MAKEFILE;
1022             }
1023              
1024             sub quote_space {
1025             # Do nothing if $ENV{NO_INSANE_DIRNAMES} is set
1026 19 100   19 0 375 return $_[0] if $ENV{NO_INSANE_DIRNAMES};
1027              
1028             # If $_[0] contains one or more doublequote characters, assume
1029             # that whitespace has already been quoted as required. Hence,
1030             # do nothing other than immediately return $_[0] as is.
1031             # We currently don't properly handle tabs either, so we'll
1032             # do the same if $_[0] =~ /\t/.
1033 18 100 66     85 return $_[0] if ($_[0] =~ /"/ || $_[0] =~ /\t/);
1034              
1035             # We want to split on /\s\-I/ not /\-I/
1036 15         64 my @in = split /\s\-I/, $_[0];
1037 15         33 my $s = @in - 1;
1038 15         19 my %s;
1039             my %q;
1040              
1041             # First up, let's reinstate the ' ' characters that split
1042             # removed
1043 15         30 for (my $i = 0; $i < $s; $i++) {
1044 41         58 $in[$i] .= ' ';
1045             }
1046              
1047             # This for{} block dies if it finds that any of the ' -I'
1048             # occurrences in $_[0] are part of a directory name.
1049 15         28 for (my $i = 1; $i < $s; $i++) {
1050 26         52 my $t = $in[$i + 1];
1051 26         62 while ($t =~ /\s$/) {chop $t}
  51         106  
1052 26 100       769 die "Found a '", $in[$i], "-I", $t, "' directory.",
1053             " INC Config argument is ambiguous.",
1054             " Please use doublequotes to signify your intentions"
1055             if -d ($in[$i] . "-I" . $t);
1056             }
1057              
1058 14         24 $s++; # Now the same as scalar(@in)
1059              
1060             # Remove (but also Keep track of the amount of) whitespace
1061             # at the end of each element of @in.
1062 14         26 for (my $i = 0; $i < $s; $i++) {
1063 50         56 my $count = 0;
1064 50         119 while ($in[$i] =~ /\s$/) {
1065 83         107 chop $in[$i];
1066 83         140 $count++;
1067             }
1068 50         100 $s{$i} = $count;
1069             }
1070              
1071             # Note which elements of @in still contain whitespace. These
1072             # (and only these) elements will be quoted
1073 14         26 for (my $i = 0; $i < $s; $i++) {
1074 50 100       100 $q{$i} = 1 if $in[$i] =~ /\s/;
1075             }
1076              
1077             # Reinstate the occurrences of '-I' that were removed by split(),
1078             # insert any quotes that are needed, reinstate the whitespace
1079             # that was removed earlier, then join() the array back together
1080             # again.
1081 14         25 for (my $i = 0; $i < $s; $i++) {
1082 50 100       78 $in[$i] = '-I' . $in[$i] if $i;
1083 50 100       66 $in[$i] = '"' . $in[$i] . '"' if $q{$i};
1084 50         96 $in[$i] .= ' ' x $s{$i};
1085             }
1086              
1087             # Note: If there was no whitespace that needed quoting, the
1088             # original argument should not have changed in any way.
1089              
1090 14         36 my $out = join '', @in;
1091 14         33 $out =~ s/"\-I\s+\//"\-I\//g;
1092 14         48 $_[0] = $out;
1093             }
1094              
1095             #==============================================================================
1096             # This routine used by C/t/09parser to test that the expected parser is in use
1097             #==============================================================================
1098              
1099             sub _parser_test {
1100 14     14   31 my $dir = shift;
1101 14         41 my $file = "$dir/parser_id";
1102 14 50       489 warn "$file: $!" if !open(TEST_FH, '>>', $file);
1103 14         135 print TEST_FH $_[0];
1104 14 50       363 warn "$file: $!" if !close(TEST_FH);
1105             }
1106              
1107             1;