| 1 | package Inline::C; |
| 2 | $VERSION = '0.44'; |
| 3 | |
| 4 | use strict; |
| 5 | require Inline; |
| 6 | use Config; |
| 7 | use Data::Dumper; |
| 8 | use Carp; |
| 9 | use Cwd qw(cwd abs_path); |
| 10 | use File::Spec; |
| 11 | |
| 12 | @Inline::C::ISA = qw(Inline); |
| 13 | |
| 14 | #============================================================================== |
| 15 | # Register this module as an Inline language support module |
| 16 | #============================================================================== |
| 17 | sub register { |
| 18 | return { |
| 19 | language => 'C', |
| 20 | # XXX Breaking this on purpose; let's see who screams |
| 21 | # aliases => ['c'], |
| 22 | type => 'compiled', |
| 23 | suffix => $Config{dlext}, |
| 24 | }; |
| 25 | } |
| 26 | |
| 27 | #============================================================================== |
| 28 | # Validate the C config options |
| 29 | #============================================================================== |
| 30 | sub usage_validate { |
| 31 | my $key = shift; |
| 32 | return <<END; |
| 33 | The value of config option '$key' must be a string or an array ref |
| 34 | |
| 35 | END |
| 36 | } |
| 37 | |
| 38 | sub validate { |
| 39 | my $o = shift; |
| 40 | |
| 41 | $o->{ILSM} ||= {}; |
| 42 | $o->{ILSM}{XS} ||= {}; |
| 43 | $o->{ILSM}{MAKEFILE} ||= {}; |
| 44 | if (not $o->UNTAINT) { |
| 45 | require FindBin; |
| 46 | $o->{ILSM}{MAKEFILE}{INC} = "-I$FindBin::Bin"; |
| 47 | } |
| 48 | $o->{ILSM}{AUTOWRAP} = 0 if not defined $o->{ILSM}{AUTOWRAP}; |
| 49 | $o->{ILSM}{XSMODE} = 0 if not defined $o->{ILSM}{XSMODE}; |
| 50 | $o->{ILSM}{AUTO_INCLUDE} ||= <<END; |
| 51 | #include "EXTERN.h" |
| 52 | #include "perl.h" |
| 53 | #include "XSUB.h" |
| 54 | #include "INLINE.h" |
| 55 | END |
| 56 | $o->{ILSM}{FILTERS} ||= []; |
| 57 | $o->{STRUCT} ||= { |
| 58 | '.macros' => '', |
| 59 | '.xs' => '', |
| 60 | '.any' => 0, |
| 61 | '.all' => 0, |
| 62 | }; |
| 63 | |
| 64 | while (@_) { |
| 65 | my ($key, $value) = (shift, shift); |
| 66 | if ($key eq 'MAKE' or |
| 67 | $key eq 'AUTOWRAP' or |
| 68 | $key eq 'XSMODE' |
| 69 | ) { |
| 70 | $o->{ILSM}{$key} = $value; |
| 71 | next; |
| 72 | } |
| 73 | if ($key eq 'CC' or |
| 74 | $key eq 'LD') { |
| 75 | $o->{ILSM}{MAKEFILE}{$key} = $value; |
| 76 | next; |
| 77 | } |
| 78 | if ($key eq 'LIBS') { |
| 79 | $o->add_list($o->{ILSM}{MAKEFILE}, $key, $value, []); |
| 80 | next; |
| 81 | } |
| 82 | if ($key eq 'INC' or |
| 83 | $key eq 'MYEXTLIB' or |
| 84 | $key eq 'OPTIMIZE' or |
| 85 | $key eq 'CCFLAGS' or |
| 86 | $key eq 'LDDLFLAGS') { |
| 87 | $o->add_string($o->{ILSM}{MAKEFILE}, $key, $value, ''); |
| 88 | next; |
| 89 | } |
| 90 | if ($key eq 'TYPEMAPS') { |
| 91 | croak "TYPEMAPS file '$value' not found" |
| 92 | unless -f $value; |
| 93 | $value = File::Spec->rel2abs($value); |
| 94 | $o->add_list($o->{ILSM}{MAKEFILE}, $key, $value, []); |
| 95 | next; |
| 96 | } |
| 97 | if ($key eq 'AUTO_INCLUDE') { |
| 98 | $o->add_text($o->{ILSM}, $key, $value, ''); |
| 99 | next; |
| 100 | } |
| 101 | if ($key eq 'BOOT') { |
| 102 | $o->add_text($o->{ILSM}{XS}, $key, $value, ''); |
| 103 | next; |
| 104 | } |
| 105 | if ($key eq 'PREFIX') { |
| 106 | croak "Invalid value for 'PREFIX' option" |
| 107 | unless ($value =~ /^\w*$/ and |
| 108 | $value !~ /\n/); |
| 109 | $o->{ILSM}{XS}{PREFIX} = $value; |
| 110 | next; |
| 111 | } |
| 112 | if ($key eq 'FILTERS') { |
| 113 | next if $value eq '1' or $value eq '0'; # ignore ENABLE, DISABLE |
| 114 | $value = [$value] unless ref($value) eq 'ARRAY'; |
| 115 | my %filters; |
| 116 | for my $val (@$value) { |
| 117 | if (ref($val) eq 'CODE') { |
| 118 | $o->add_list($o->{ILSM}, $key, $val, []); |
| 119 | } |
| 120 | else { |
| 121 | eval { require Inline::Filters }; |
| 122 | croak "'FILTERS' option requires Inline::Filters to be installed." |
| 123 | if $@; |
| 124 | %filters = Inline::Filters::get_filters($o->{API}{language}) |
| 125 | unless keys %filters; |
| 126 | if (defined $filters{$val}) { |
| 127 | my $filter = Inline::Filters->new($val, |
| 128 | $filters{$val}); |
| 129 | $o->add_list($o->{ILSM}, $key, $filter, []); |
| 130 | } |
| 131 | else { |
| 132 | croak "Invalid filter $val specified."; |
| 133 | } |
| 134 | } |
| 135 | } |
| 136 | next; |
| 137 | } |
| 138 | if ($key eq 'STRUCTS') { |
| 139 | # A list of struct names |
| 140 | if (ref($value) eq 'ARRAY') { |
| 141 | for my $val (@$value) { |
| 142 | croak "Invalid value for 'STRUCTS' option" |
| 143 | unless ($val =~ /^[_a-z][_0-9a-z]*$/i); |
| 144 | $o->{STRUCT}{$val}++; |
| 145 | } |
| 146 | } |
| 147 | # Enable or disable |
| 148 | elsif ($value =~ /^\d+$/) { |
| 149 | $o->{STRUCT}{'.any'} = $value; |
| 150 | } |
| 151 | # A single struct name |
| 152 | else { |
| 153 | croak "Invalid value for 'STRUCTS' option" |
| 154 | unless ($value =~ /^[_a-z][_0-9a-z]*$/i); |
| 155 | $o->{STRUCT}{$value}++; |
| 156 | } |
| 157 | eval { require Inline::Struct }; |
| 158 | croak "'STRUCTS' option requires Inline::Struct to be installed." |
| 159 | if $@; |
| 160 | $o->{STRUCT}{'.any'} = 1; |
| 161 | next; |
| 162 | } |
| 163 | my $class = ref $o; # handles subclasses correctly. |
| 164 | croak "'$key' is not a valid config option for $class\n"; |
| 165 | } |
| 166 | } |
| 167 | |
| 168 | sub add_list { |
| 169 | my $o = shift; |
| 170 | my ($ref, $key, $value, $default) = @_; |
| 171 | $value = [$value] unless ref $value eq 'ARRAY'; |
| 172 | for (@$value) { |
| 173 | if (defined $_) { |
| 174 | push @{$ref->{$key}}, $_; |
| 175 | } |
| 176 | else { |
| 177 | $ref->{$key} = $default; |
| 178 | } |
| 179 | } |
| 180 | } |
| 181 | |
| 182 | sub add_string { |
| 183 | my $o = shift; |
| 184 | my ($ref, $key, $value, $default) = @_; |
| 185 | $value = [$value] unless ref $value; |
| 186 | croak usage_validate($key) unless ref($value) eq 'ARRAY'; |
| 187 | for (@$value) { |
| 188 | if (defined $_) { |
| 189 | $ref->{$key} .= ' ' . $_; |
| 190 | } |
| 191 | else { |
| 192 | $ref->{$key} = $default; |
| 193 | } |
| 194 | } |
| 195 | } |
| 196 | |
| 197 | sub add_text { |
| 198 | my $o = shift; |
| 199 | my ($ref, $key, $value, $default) = @_; |
| 200 | $value = [$value] unless ref $value; |
| 201 | croak usage_validate($key) unless ref($value) eq 'ARRAY'; |
| 202 | for (@$value) { |
| 203 | if (defined $_) { |
| 204 | chomp; |
| 205 | $ref->{$key} .= $_ . "\n"; |
| 206 | } |
| 207 | else { |
| 208 | $ref->{$key} = $default; |
| 209 | } |
| 210 | } |
| 211 | } |
| 212 | |
| 213 | #============================================================================== |
| 214 | # Return a small report about the C code.. |
| 215 | #============================================================================== |
| 216 | sub info { |
| 217 | my $o = shift; |
| 218 | return <<END if $o->{ILSM}{XSMODE}; |
| 219 | No information is currently generated when using XSMODE. |
| 220 | |
| 221 | END |
| 222 | my $text = ''; |
| 223 | $o->preprocess; |
| 224 | $o->parse; |
| 225 | if (defined $o->{ILSM}{parser}{data}{functions}) { |
| 226 | $text .= "The following Inline $o->{API}{language} function(s) have been successfully bound to Perl:\n"; |
| 227 | my $parser = $o->{ILSM}{parser}; |
| 228 | my $data = $parser->{data}; |
| 229 | for my $function (sort @{$data->{functions}}) { |
| 230 | my $return_type = $data->{function}{$function}{return_type}; |
| 231 | my @arg_names = @{$data->{function}{$function}{arg_names}}; |
| 232 | my @arg_types = @{$data->{function}{$function}{arg_types}}; |
| 233 | my @args = map {$_ . ' ' . shift @arg_names} @arg_types; |
| 234 | $text .= "\t$return_type $function(" . join(', ', @args) . ")\n"; |
| 235 | } |
| 236 | } |
| 237 | else { |
| 238 | $text .= "No $o->{API}{language} functions have been successfully bound to Perl.\n\n"; |
| 239 | } |
| 240 | $text .= Inline::Struct::info($o) if $o->{STRUCT}{'.any'}; |
| 241 | return $text; |
| 242 | } |
| 243 | |
| 244 | sub config { |
| 245 | my $o = shift; |
| 246 | } |
| 247 | |
| 248 | #============================================================================== |
| 249 | # Parse and compile C code |
| 250 | #============================================================================== |
| 251 | my $total_build_time; |
| 252 | sub build { |
| 253 | my $o = shift; |
| 254 | |
| 255 | if ($o->{CONFIG}{BUILD_TIMERS}) { |
| 256 | eval {require Time::HiRes}; |
| 257 | croak "You need Time::HiRes for BUILD_TIMERS option:\n$@" if $@; |
| 258 | $total_build_time = Time::HiRes::time(); |
| 259 | } |
| 260 | $o->call('preprocess', 'Build Prepocess'); |
| 261 | $o->call('parse', 'Build Parse'); |
| 262 | $o->call('write_XS', 'Build Glue 1'); |
| 263 | $o->call('write_Inline_headers', 'Build Glue 2'); |
| 264 | $o->call('write_Makefile_PL', 'Build Glue 3'); |
| 265 | $o->call('compile', 'Build Compile'); |
| 266 | if ($o->{CONFIG}{BUILD_TIMERS}) { |
| 267 | $total_build_time = Time::HiRes::time() - $total_build_time; |
| 268 | printf STDERR "Total Build Time: %5.4f secs\n", $total_build_time; |
| 269 | } |
| 270 | } |
| 271 | |
| 272 | sub call { |
| 273 | my ($o, $method, $header, $indent) = (@_, 0); |
| 274 | my $time; |
| 275 | my $i = ' ' x $indent; |
| 276 | print STDERR "${i}Starting $header Stage\n" if $o->{CONFIG}{BUILD_NOISY}; |
| 277 | $time = Time::HiRes::time() |
| 278 | if $o->{CONFIG}{BUILD_TIMERS}; |
| 279 | |
| 280 | $o->$method(); |
| 281 | |
| 282 | $time = Time::HiRes::time() - $time |
| 283 | if $o->{CONFIG}{BUILD_TIMERS}; |
| 284 | print STDERR "${i}Finished $header Stage\n" if $o->{CONFIG}{BUILD_NOISY}; |
| 285 | printf STDERR "${i}Time for $header Stage: %5.4f secs\n", $time |
| 286 | if $o->{CONFIG}{BUILD_TIMERS}; |
| 287 | print STDERR "\n" if $o->{CONFIG}{BUILD_NOISY}; |
| 288 | } |
| 289 | |
| 290 | #============================================================================== |
| 291 | # Apply any |
| 292 | #============================================================================== |
| 293 | sub preprocess { |
| 294 | my $o = shift; |
| 295 | return if $o->{ILSM}{parser}; |
| 296 | $o->get_maps; |
| 297 | $o->get_types; |
| 298 | $o->{ILSM}{code} = $o->filter(@{$o->{ILSM}{FILTERS}}); |
| 299 | } |
| 300 | |
| 301 | #============================================================================== |
| 302 | # Parse the function definition information out of the C code |
| 303 | #============================================================================== |
| 304 | sub parse { |
| 305 | my $o = shift; |
| 306 | return if $o->{ILSM}{parser}; |
| 307 | return if $o->{ILSM}{XSMODE}; |
| 308 | my $parser = $o->{ILSM}{parser} = $o->get_parser; |
| 309 | $parser->{data}{typeconv} = $o->{ILSM}{typeconv}; |
| 310 | $parser->{data}{AUTOWRAP} = $o->{ILSM}{AUTOWRAP}; |
| 311 | Inline::Struct::parse($o) if $o->{STRUCT}{'.any'}; |
| 312 | $parser->code($o->{ILSM}{code}) |
| 313 | or croak <<END; |
| 314 | Bad $o->{API}{language} code passed to Inline at @{[caller(2)]} |
| 315 | END |
| 316 | } |
| 317 | |
| 318 | # Create and initialize a parser |
| 319 | sub get_parser { |
| 320 | my $o = shift; |
| 321 | require Inline::C::ParseRecDescent; |
| 322 | Inline::C::ParseRecDescent::get_parser($o); |
| 323 | } |
| 324 | |
| 325 | #============================================================================== |
| 326 | # Gather the path names of all applicable typemap files. |
| 327 | #============================================================================== |
| 328 | sub get_maps { |
| 329 | my $o = shift; |
| 330 | |
| 331 | my $typemap = ''; |
| 332 | my $file; |
| 333 | $file = File::Spec->catfile($Config::Config{installprivlib},"ExtUtils","typemap"); |
| 334 | $typemap = $file if -f $file; |
| 335 | $file = File::Spec->catfile($Config::Config{privlibexp} ,"ExtUtils","typemap"); |
| 336 | $typemap = $file |
| 337 | if (not $typemap and -f $file); |
| 338 | warn "Can't find the default system typemap file" |
| 339 | if (not $typemap and $^W); |
| 340 | |
| 341 | unshift(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $typemap) if $typemap; |
| 342 | |
| 343 | if (not $o->UNTAINT) { |
| 344 | require FindBin; |
| 345 | $file = File::Spec->catfile($FindBin::Bin,"typemap"); |
| 346 | push(@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, $file) if -f $file; |
| 347 | } |
| 348 | } |
| 349 | |
| 350 | #============================================================================== |
| 351 | # This routine parses XS typemap files to get a list of valid types to create |
| 352 | # bindings to. This code is mostly hacked out of Larry Wall's xsubpp program. |
| 353 | #============================================================================== |
| 354 | sub get_types { |
| 355 | my (%type_kind, %proto_letter, %input_expr, %output_expr); |
| 356 | my $o = shift; |
| 357 | croak "No typemaps specified for Inline C code" |
| 358 | unless @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}; |
| 359 | |
| 360 | my $proto_re = "[" . quotemeta('\$%&*@;') . "]"; |
| 361 | foreach my $typemap (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) { |
| 362 | next unless -e $typemap; |
| 363 | # skip directories, binary files etc. |
| 364 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
| 365 | unless -T $typemap; |
| 366 | open(TYPEMAP, $typemap) |
| 367 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
| 368 | my $mode = 'Typemap'; |
| 369 | my $junk = ""; |
| 370 | my $current = \$junk; |
| 371 | while (<TYPEMAP>) { |
| 372 | next if /^\s*\#/; |
| 373 | my $line_no = $. + 1; |
| 374 | if (/^INPUT\s*$/) {$mode = 'Input'; $current = \$junk; next} |
| 375 | if (/^OUTPUT\s*$/) {$mode = 'Output'; $current = \$junk; next} |
| 376 | if (/^TYPEMAP\s*$/) {$mode = 'Typemap'; $current = \$junk; next} |
| 377 | if ($mode eq 'Typemap') { |
| 378 | chomp; |
| 379 | my $line = $_; |
| 380 | TrimWhitespace($_); |
| 381 | # skip blank lines and comment lines |
| 382 | next if /^$/ or /^\#/; |
| 383 | my ($type,$kind, $proto) = |
| 384 | /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
| 385 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; |
| 386 | $type = TidyType($type); |
| 387 | $type_kind{$type} = $kind; |
| 388 | # prototype defaults to '$' |
| 389 | $proto = "\$" unless $proto; |
| 390 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
| 391 | unless ValidProtoString($proto); |
| 392 | $proto_letter{$type} = C_string($proto); |
| 393 | } |
| 394 | elsif (/^\s/) { |
| 395 | $$current .= $_; |
| 396 | } |
| 397 | elsif ($mode eq 'Input') { |
| 398 | s/\s+$//; |
| 399 | $input_expr{$_} = ''; |
| 400 | $current = \$input_expr{$_}; |
| 401 | } |
| 402 | else { |
| 403 | s/\s+$//; |
| 404 | $output_expr{$_} = ''; |
| 405 | $current = \$output_expr{$_}; |
| 406 | } |
| 407 | } |
| 408 | close(TYPEMAP); |
| 409 | } |
| 410 | |
| 411 | my %valid_types = |
| 412 | map {($_, 1)} |
| 413 | grep {defined $input_expr{$type_kind{$_}}} |
| 414 | keys %type_kind; |
| 415 | |
| 416 | my %valid_rtypes = |
| 417 | map {($_, 1)} |
| 418 | (grep {defined $output_expr{$type_kind{$_}}} |
| 419 | keys %type_kind), 'void'; |
| 420 | |
| 421 | $o->{ILSM}{typeconv}{type_kind} = \%type_kind; |
| 422 | $o->{ILSM}{typeconv}{input_expr} = \%input_expr; |
| 423 | $o->{ILSM}{typeconv}{output_expr} = \%output_expr; |
| 424 | $o->{ILSM}{typeconv}{valid_types} = \%valid_types; |
| 425 | $o->{ILSM}{typeconv}{valid_rtypes} = \%valid_rtypes; |
| 426 | } |
| 427 | |
| 428 | sub ValidProtoString ($) { |
| 429 | my $string = shift; |
| 430 | my $proto_re = "[" . quotemeta('\$%&*@;') . "]"; |
| 431 | return ($string =~ /^$proto_re+$/) ? $string : 0; |
| 432 | } |
| 433 | |
| 434 | sub TrimWhitespace { |
| 435 | $_[0] =~ s/^\s+|\s+$//go; |
| 436 | } |
| 437 | |
| 438 | sub TidyType { |
| 439 | local $_ = shift; |
| 440 | s|\s*(\*+)\s*|$1|g; |
| 441 | s|(\*+)| $1 |g; |
| 442 | s|\s+| |g; |
| 443 | TrimWhitespace($_); |
| 444 | $_; |
| 445 | } |
| 446 | |
| 447 | sub C_string ($) { |
| 448 | (my $string = shift) =~ s|\\|\\\\|g; |
| 449 | $string; |
| 450 | } |
| 451 | |
| 452 | #============================================================================== |
| 453 | # Write the XS code |
| 454 | #============================================================================== |
| 455 | sub write_XS { |
| 456 | my $o = shift; |
| 457 | my $modfname = $o->{API}{modfname}; |
| 458 | my $module = $o->{API}{module}; |
| 459 | $o->mkpath($o->{API}{build_dir}); |
| 460 | open XS, "> ".File::Spec->catfile($o->{API}{build_dir},"$modfname.xs") |
| 461 | or croak $!; |
| 462 | if ($o->{ILSM}{XSMODE}) { |
| 463 | warn <<END if $^W and $o->{ILSM}{code} !~ /MODULE\s*=\s*$module\b/; |
| 464 | While using Inline XSMODE, your XS code does not have a line with |
| 465 | |
| 466 | MODULE = $module |
| 467 | |
| 468 | You should use the Inline NAME config option, and it should match the |
| 469 | XS MODULE name. |
| 470 | |
| 471 | END |
| 472 | print XS $o->xs_code; |
| 473 | } |
| 474 | else { |
| 475 | print XS $o->xs_generate; |
| 476 | } |
| 477 | close XS; |
| 478 | } |
| 479 | |
| 480 | #============================================================================== |
| 481 | # Generate the XS glue code (piece together lots of snippets) |
| 482 | #============================================================================== |
| 483 | sub xs_generate { |
| 484 | my $o = shift; |
| 485 | return join '', ($o->xs_includes, |
| 486 | $o->xs_struct_macros, |
| 487 | $o->xs_code, |
| 488 | $o->xs_struct_code, |
| 489 | $o->xs_bindings, |
| 490 | $o->xs_boot, |
| 491 | ); |
| 492 | } |
| 493 | |
| 494 | sub xs_includes { |
| 495 | my $o = shift; |
| 496 | return $o->{ILSM}{AUTO_INCLUDE}; |
| 497 | } |
| 498 | |
| 499 | sub xs_struct_macros { |
| 500 | my $o = shift; |
| 501 | return $o->{STRUCT}{'.macros'}; |
| 502 | } |
| 503 | |
| 504 | sub xs_code { |
| 505 | my $o = shift; |
| 506 | return $o->{ILSM}{code}; |
| 507 | } |
| 508 | |
| 509 | sub xs_struct_code { |
| 510 | my $o = shift; |
| 511 | return $o->{STRUCT}{'.xs'}; |
| 512 | } |
| 513 | |
| 514 | sub xs_boot { |
| 515 | my $o = shift; |
| 516 | if (defined $o->{ILSM}{XS}{BOOT} and |
| 517 | $o->{ILSM}{XS}{BOOT}) { |
| 518 | return <<END; |
| 519 | BOOT: |
| 520 | $o->{ILSM}{XS}{BOOT} |
| 521 | END |
| 522 | } |
| 523 | return ''; |
| 524 | } |
| 525 | |
| 526 | sub xs_bindings { |
| 527 | my $o = shift; |
| 528 | my ($pkg, $module) = @{$o->{API}}{qw(pkg module)}; |
| 529 | my $prefix = (($o->{ILSM}{XS}{PREFIX}) ? |
| 530 | "PREFIX = $o->{ILSM}{XS}{PREFIX}" : |
| 531 | ''); |
| 532 | my $XS = <<END; |
| 533 | |
| 534 | MODULE = $module PACKAGE = $pkg $prefix |
| 535 | |
| 536 | PROTOTYPES: DISABLE |
| 537 | |
| 538 | END |
| 539 | |
| 540 | my $parser = $o->{ILSM}{parser}; |
| 541 | my $data = $parser->{data}; |
| 542 | |
| 543 | warn("Warning. No Inline C functions bound to Perl\n" . |
| 544 | "Check your C function definition(s) for Inline compatibility\n\n") |
| 545 | if ((not defined$data->{functions}) and ($^W)); |
| 546 | |
| 547 | for my $function (@{$data->{functions}}) { |
| 548 | my $return_type = $data->{function}->{$function}->{return_type}; |
| 549 | my @arg_names = @{$data->{function}->{$function}->{arg_names}}; |
| 550 | my @arg_types = @{$data->{function}->{$function}->{arg_types}}; |
| 551 | |
| 552 | $XS .= join '', ("\n$return_type\n$function (", |
| 553 | join(', ', @arg_names), ")\n"); |
| 554 | |
| 555 | for my $arg_name (@arg_names) { |
| 556 | my $arg_type = shift @arg_types; |
| 557 | last if $arg_type eq '...'; |
| 558 | $XS .= "\t$arg_type\t$arg_name\n"; |
| 559 | } |
| 560 | |
| 561 | my $listargs = ''; |
| 562 | $listargs = pop @arg_names if (@arg_names and |
| 563 | $arg_names[-1] eq '...'); |
| 564 | my $arg_name_list = join(', ', @arg_names); |
| 565 | |
| 566 | if ($return_type eq 'void') { |
| 567 | $XS .= <<END; |
| 568 | PREINIT: |
| 569 | I32* temp; |
| 570 | PPCODE: |
| 571 | temp = PL_markstack_ptr++; |
| 572 | $function($arg_name_list); |
| 573 | if (PL_markstack_ptr != temp) { |
| 574 | /* truly void, because dXSARGS not invoked */ |
| 575 | PL_markstack_ptr = temp; |
| 576 | XSRETURN_EMPTY; /* return empty stack */ |
| 577 | } |
| 578 | /* must have used dXSARGS; list context implied */ |
| 579 | return; /* assume stack size is correct */ |
| 580 | END |
| 581 | } |
| 582 | elsif ($listargs) { |
| 583 | $XS .= <<END; |
| 584 | PREINIT: |
| 585 | I32* temp; |
| 586 | CODE: |
| 587 | temp = PL_markstack_ptr++; |
| 588 | RETVAL = $function($arg_name_list); |
| 589 | PL_markstack_ptr = temp; |
| 590 | OUTPUT: |
| 591 | RETVAL |
| 592 | END |
| 593 | } |
| 594 | } |
| 595 | $XS .= "\n"; |
| 596 | return $XS; |
| 597 | } |
| 598 | |
| 599 | #============================================================================== |
| 600 | # Generate the INLINE.h file. |
| 601 | #============================================================================== |
| 602 | sub write_Inline_headers { |
| 603 | my $o = shift; |
| 604 | |
| 605 | open HEADER, "> ".File::Spec->catfile($o->{API}{build_dir},"INLINE.h") |
| 606 | or croak; |
| 607 | |
| 608 | print HEADER <<'END'; |
| 609 | #define Inline_Stack_Vars dXSARGS |
| 610 | #define Inline_Stack_Items items |
| 611 | #define Inline_Stack_Item(x) ST(x) |
| 612 | #define Inline_Stack_Reset sp = mark |
| 613 | #define Inline_Stack_Push(x) XPUSHs(x) |
| 614 | #define Inline_Stack_Done PUTBACK |
| 615 | #define Inline_Stack_Return(x) XSRETURN(x) |
| 616 | #define Inline_Stack_Void XSRETURN(0) |
| 617 | |
| 618 | #define INLINE_STACK_VARS Inline_Stack_Vars |
| 619 | #define INLINE_STACK_ITEMS Inline_Stack_Items |
| 620 | #define INLINE_STACK_ITEM(x) Inline_Stack_Item(x) |
| 621 | #define INLINE_STACK_RESET Inline_Stack_Reset |
| 622 | #define INLINE_STACK_PUSH(x) Inline_Stack_Push(x) |
| 623 | #define INLINE_STACK_DONE Inline_Stack_Done |
| 624 | #define INLINE_STACK_RETURN(x) Inline_Stack_Return(x) |
| 625 | #define INLINE_STACK_VOID Inline_Stack_Void |
| 626 | |
| 627 | #define inline_stack_vars Inline_Stack_Vars |
| 628 | #define inline_stack_items Inline_Stack_Items |
| 629 | #define inline_stack_item(x) Inline_Stack_Item(x) |
| 630 | #define inline_stack_reset Inline_Stack_Reset |
| 631 | #define inline_stack_push(x) Inline_Stack_Push(x) |
| 632 | #define inline_stack_done Inline_Stack_Done |
| 633 | #define inline_stack_return(x) Inline_Stack_Return(x) |
| 634 | #define inline_stack_void Inline_Stack_Void |
| 635 | END |
| 636 | |
| 637 | close HEADER; |
| 638 | } |
| 639 | |
| 640 | #============================================================================== |
| 641 | # Generate the Makefile.PL |
| 642 | #============================================================================== |
| 643 | sub write_Makefile_PL { |
| 644 | my $o = shift; |
| 645 | $o->{ILSM}{xsubppargs} = ''; |
| 646 | for (@{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}) { |
| 647 | $o->{ILSM}{xsubppargs} .= "-typemap $_ "; |
| 648 | } |
| 649 | |
| 650 | my %options = ( |
| 651 | VERSION => $o->{API}{version} || '0.00', |
| 652 | %{$o->{ILSM}{MAKEFILE}}, |
| 653 | NAME => $o->{API}{module}, |
| 654 | ); |
| 655 | |
| 656 | open MF, "> ".File::Spec->catfile($o->{API}{build_dir},"Makefile.PL") |
| 657 | or croak; |
| 658 | |
| 659 | print MF <<END; |
| 660 | use ExtUtils::MakeMaker; |
| 661 | my %options = %\{ |
| 662 | END |
| 663 | |
| 664 | local $Data::Dumper::Terse = 1; |
| 665 | local $Data::Dumper::Indent = 1; |
| 666 | print MF Data::Dumper::Dumper(\ %options); |
| 667 | |
| 668 | print MF <<END; |
| 669 | \}; |
| 670 | WriteMakefile(\%options); |
| 671 | |
| 672 | # Remove the Makefile dependency. Causes problems on a few systems. |
| 673 | sub MY::makefile { '' } |
| 674 | END |
| 675 | close MF; |
| 676 | } |
| 677 | |
| 678 | #============================================================================== |
| 679 | # Run the build process. |
| 680 | #============================================================================== |
| 681 | sub compile { |
| 682 | my $o = shift; |
| 683 | |
| 684 | my $build_dir = $o->{API}{build_dir}; |
| 685 | my $cwd = &cwd; |
| 686 | ($cwd) = $cwd =~ /(.*)/ if $o->UNTAINT; |
| 687 | |
| 688 | chdir $build_dir; |
| 689 | $o->call('makefile_pl', '"perl Makefile.PL"', 2); |
| 690 | $o->call('make', '"make"', 2); |
| 691 | $o->call('make_install', '"make install"', 2); |
| 692 | chdir $cwd; |
| 693 | $o->call('cleanup', 'Cleaning Up', 2); |
| 694 | } |
| 695 | |
| 696 | sub makefile_pl { |
| 697 | my ($o) = @_; |
| 698 | my $perl; |
| 699 | -f ($perl = $Config::Config{perlpath}) |
| 700 | or ($perl = $^X) |
| 701 | or croak "Can't locate your perl binary"; |
| 702 | $o->system_call("$perl Makefile.PL", 'out.Makefile_PL'); |
| 703 | $o->fix_make; |
| 704 | } |
| 705 | sub make { |
| 706 | my ($o) = @_; |
| 707 | my $make = $o->{ILSM}{MAKE} || $Config::Config{make} |
| 708 | or croak "Can't locate your make binary"; |
| 709 | $o->system_call("$make", 'out.make'); |
| 710 | } |
| 711 | sub make_install { |
| 712 | my ($o) = @_; |
| 713 | my $make = $o->{ILSM}{MAKE} || $Config::Config{make} |
| 714 | or croak "Can't locate your make binary"; |
| 715 | $o->system_call("$make pure_install", 'out.make_install'); |
| 716 | } |
| 717 | sub cleanup { |
| 718 | my ($o) = @_; |
| 719 | my ($modpname, $modfname, $install_lib) = |
| 720 | @{$o->{API}}{qw(modpname modfname install_lib)}; |
| 721 | if ($o->{API}{cleanup}) { |
| 722 | $o->rmpath(File::Spec->catdir($o->{API}{directory},'build'), |
| 723 | $modpname); |
| 724 | my $autodir = File::Spec->catdir($install_lib,'auto',$modpname); |
| 725 | unlink (File::Spec->catfile($autodir,'.packlist'), |
| 726 | File::Spec->catfile($autodir,'$modfname.bs'), |
| 727 | File::Spec->catfile($autodir,'$modfname.exp'), #MSWin32 |
| 728 | File::Spec->catfile($autodir,'$modfname.lib'), #MSWin32 |
| 729 | ); |
| 730 | } |
| 731 | } |
| 732 | |
| 733 | sub system_call { |
| 734 | my ($o, $cmd, $output_file) = @_; |
| 735 | my $build_noisy = |
| 736 | defined $ENV{PERL_INLINE_BUILD_NOISY} |
| 737 | ? $ENV{PERL_INLINE_BUILD_NOISY} |
| 738 | : $o->{CONFIG}{BUILD_NOISY}; |
| 739 | if (not $build_noisy) { |
| 740 | $cmd = "$cmd > $output_file 2>&1"; |
| 741 | } |
| 742 | ($cmd) = $cmd =~ /(.*)/ if $o->UNTAINT; |
| 743 | system($cmd) == 0 |
| 744 | or croak($o->build_error_message($cmd, $output_file, $build_noisy)); |
| 745 | } |
| 746 | |
| 747 | sub build_error_message { |
| 748 | my ($o, $cmd, $output_file, $build_noisy) = @_; |
| 749 | my $build_dir = $o->{API}{build_dir}; |
| 750 | my $output = ''; |
| 751 | if (not $build_noisy and |
| 752 | open(OUTPUT, $output_file) |
| 753 | ) { |
| 754 | local $/; |
| 755 | $output = <OUTPUT>; |
| 756 | close OUTPUT; |
| 757 | } |
| 758 | |
| 759 | return $output . <<END; |
| 760 | |
| 761 | A problem was encountered while attempting to compile and install your Inline |
| 762 | $o->{API}{language} code. The command that failed was: |
| 763 | $cmd |
| 764 | |
| 765 | The build directory was: |
| 766 | $build_dir |
| 767 | |
| 768 | To debug the problem, cd to the build directory, and inspect the output files. |
| 769 | |
| 770 | END |
| 771 | } |
| 772 | |
| 773 | #============================================================================== |
| 774 | # This routine fixes problems with the MakeMaker Makefile. |
| 775 | #============================================================================== |
| 776 | my %fixes = ( |
| 777 | INSTALLSITEARCH => 'install_lib', |
| 778 | INSTALLDIRS => 'installdirs', |
| 779 | XSUBPPARGS => 'xsubppargs', |
| 780 | INSTALLSITELIB => 'install_lib', |
| 781 | ); |
| 782 | |
| 783 | sub fix_make { |
| 784 | use strict; |
| 785 | my (@lines, $fix); |
| 786 | my $o = shift; |
| 787 | |
| 788 | $o->{ILSM}{install_lib} = $o->{API}{install_lib}; |
| 789 | $o->{ILSM}{installdirs} = 'site'; |
| 790 | |
| 791 | open(MAKEFILE, '< Makefile') |
| 792 | or croak "Can't open Makefile for input: $!\n"; |
| 793 | @lines = <MAKEFILE>; |
| 794 | close MAKEFILE; |
| 795 | |
| 796 | open(MAKEFILE, '> Makefile') |
| 797 | or croak "Can't open Makefile for output: $!\n"; |
| 798 | for (@lines) { |
| 799 | if (/^(\w+)\s*=\s*\S+.*$/ and |
| 800 | $fix = $fixes{$1} |
| 801 | ) { |
| 802 | print MAKEFILE "$1 = $o->{ILSM}{$fix}\n" |
| 803 | } |
| 804 | else { |
| 805 | print MAKEFILE; |
| 806 | } |
| 807 | } |
| 808 | close MAKEFILE; |
| 809 | } |
| 810 | |
| 811 | 1; |
| 812 | |
| 813 | __END__ |