1 package ExtUtils::ParseXS::Utilities;
7 use ExtUtils::ParseXS::Constants ();
8 require ExtUtils::Typemaps;
10 our (@ISA, @EXPORT_OK);
13 standard_typemap_locations
19 process_single_typemap
24 analyze_preprocessor_statements
29 check_conditional_preprocessor_statements
34 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
38 use ExtUtils::ParseXS::Utilities qw(
39 standard_typemap_locations
45 process_single_typemap
50 analyze_preprocessor_statements
55 check_conditional_preprocessor_statements
60 The following functions are not considered to be part of the public interface.
61 They are documented here for the benefit of future maintainers of this module.
63 =head2 C<standard_typemap_locations()>
69 Provide a list of filepaths where F<typemap> files may be found. The
70 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
72 The highest priority is to look in the current directory.
76 The second and third highest priorities are to look in the parent of the
77 current directory and a directory called F<lib/ExtUtils> underneath the parent
81 '../lib/ExtUtils/typemap',
83 The fourth through ninth highest priorities are to look in the corresponding
84 grandparent, great-grandparent and great-great-grandparent directories.
87 '../../lib/ExtUtils/typemap',
89 '../../../lib/ExtUtils/typemap',
90 '../../../../typemap',
91 '../../../../lib/ExtUtils/typemap',
93 The tenth and subsequent priorities are to look in directories named
94 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
95 I<provided> a file named F<typemap> actually exists in such a directory.
98 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
100 However, these filepaths appear in the list returned by
101 C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
103 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
104 '../../../../lib/ExtUtils/typemap',
105 '../../../../typemap',
106 '../../../lib/ExtUtils/typemap',
108 '../../lib/ExtUtils/typemap',
110 '../lib/ExtUtils/typemap',
116 my @stl = standard_typemap_locations( \@INC );
118 Reference to C<@INC>.
122 Array holding list of directories to be searched for F<typemap> files.
128 sub standard_typemap_locations {
129 my $include_ref = shift;
130 my @tm = qw(typemap);
132 my $updir = File::Spec->updir();
134 File::Spec->catdir(($updir) x 1),
135 File::Spec->catdir(($updir) x 2),
136 File::Spec->catdir(($updir) x 3),
137 File::Spec->catdir(($updir) x 4),
139 unshift @tm, File::Spec->catfile($dir, 'typemap');
140 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
142 foreach my $dir (@{ $include_ref}) {
143 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
144 unshift @tm, $file if -e $file;
149 =head2 C<trim_whitespace()>
155 Perform an in-place trimming of leading and trailing whitespace from the
156 first argument provided to the function.
160 trim_whitespace($arg);
164 None. Remember: this is an I<in-place> modification of the argument.
170 sub trim_whitespace {
171 $_[0] =~ s/^\s+|\s+$//go;
174 =head2 C<tidy_type()>
180 Rationalize any asterisks (C<*>) by joining them into bunches, removing
181 interior whitespace, then trimming leading and trailing whitespace.
185 ($ret_type) = tidy_type($_);
187 String to be cleaned up.
200 # rationalise any '*' by joining them into bunches and removing whitespace
204 # change multiple whitespace into a single space
207 # trim leading & trailing whitespace
219 Escape backslashes (C<\>) in prototype strings.
223 $ProtoThisXSUB = C_string($_);
225 String needing escaping.
229 Properly escaped string.
238 $string =~ s[\\][\\\\]g;
242 =head2 C<valid_proto_string()>
248 Validate prototype string.
252 String needing checking.
256 Upon success, returns the same string passed as argument.
258 Upon failure, returns C<0>.
264 sub valid_proto_string {
267 if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
274 =head2 C<process_typemaps()>
280 Process all typemap files.
284 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
285 process_typemaps( $args{typemap}, $pwd );
287 List of two elements: C<typemap> element from C<%args>; current working
292 Upon success, returns a list of four hash references. (This will probably be
293 refactored.) Here is a I<rough> description of what is in these hashrefs:
297 =item * C<$type_kind_ref>
300 'char **' => 'T_PACKEDARRAY',
303 'InputStream' => 'T_IN',
304 'double' => 'T_DOUBLE',
308 Keys: C types. Values: XS types identifiers
310 =item * C<$proto_letter_ref>
316 'InputStream' => '$',
321 Keys: C types. Values. Corresponding prototype letters.
323 =item * C<$input_expr_ref>
326 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg)
328 'T_OUT' => ' $var = IoOFP(sv_2io($arg))
330 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) {
334 Keys: XS typemap identifiers. Values: Newline-terminated strings that
335 will be written to C source code (F<.c>) files. The strings are C code, but
336 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
337 by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
339 =item * C<$output_expr_ref>
342 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(),
343 $var.context.value().size());
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)));
356 Keys: XS typemap identifiers. Values: Newline-terminated strings that
357 will be written to C source code (F<.c>) files. The strings are C code, but
358 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
359 by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
367 sub process_typemaps {
368 my ($tmap, $pwd) = @_;
370 my @tm = ref $tmap ? @{$tmap} : ($tmap);
372 foreach my $typemap (@tm) {
373 die "Can't find $typemap in $pwd\n" unless -r $typemap;
376 push @tm, standard_typemap_locations( \@INC );
378 my $typemap = ExtUtils::Typemaps->new;
379 foreach my $typemap_loc (@tm) {
380 next unless -f $typemap_loc;
381 # skip directories, binary files etc.
382 warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
383 unless -T $typemap_loc;
385 $typemap->merge(file => $typemap_loc, replace => 1);
389 $typemap->_get_typemap_hash(),
390 $typemap->_get_prototype_hash(),
391 $typemap->_get_inputmap_hash(),
392 $typemap->_get_outputmap_hash(),
396 =head2 C<make_targetable()>
402 Populate C<%targetable>. This constitutes a refinement of the output of
403 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
407 %targetable = make_targetable($output_expr_ref);
409 Single hash reference: the fourth such ref returned by C<process_typemaps()>.
419 sub make_targetable {
420 my $output_expr_ref = shift;
422 our $bal; # ()-balanced
431 # matches variations on (SV*)
434 \( \s* SV \s* \* \s* \) \s*
438 my $size = qr[ # Third arg (to setpvn)
443 foreach my $key (keys %{ $output_expr_ref }) {
444 # We can still bootstrap compile 're', because in code re.pm is
445 # available to miniperl, and does not attempt to load the XS code.
448 my ($type, $with_size, $arg, $sarg) =
449 ($output_expr_ref->{$key} =~
452 sv_set([iunp])v(n)? # Type, is_setpvn
455 $sv_cast \$arg \s* , \s*
456 ( (??{ $bal }) ) # Set from
457 ( (??{ $size }) )? # Possible sizeof set-from
461 $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
472 Performs a mapping at several places inside C<PARAGRAPH> loop.
476 $type = map_type($self, $type, $varname);
478 List of three arguments.
482 String holding augmented version of second argument.
489 my ($self, $type, $varname) = @_;
491 # C++ has :: in types too so skip this
492 $type =~ tr/:/_/ unless $self->{hiertype};
493 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
495 if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
496 (substr $type, pos $type, 0) = " $varname ";
499 $type .= "\t$varname";
505 =head2 C<standard_XS_defs()>
511 Writes to the C<.c> output file certain preprocessor directives and function
512 headers needed in all such files.
526 sub standard_XS_defs {
528 #ifndef PERL_UNUSED_VAR
529 # define PERL_UNUSED_VAR(var) if (0) var = var
535 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
536 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
538 /* prototype to pass -Wmissing-prototypes */
540 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
543 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
545 const GV *const gv = CvGV(cv);
547 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
550 const char *const gvname = GvNAME(gv);
551 const HV *const stash = GvSTASH(gv);
552 const char *const hvname = stash ? HvNAME(stash) : NULL;
555 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
557 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
559 /* Pants. I don't think that it should be possible to get here. */
560 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
563 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
565 #ifdef PERL_IMPLICIT_CONTEXT
566 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
568 #define croak_xs_usage S_croak_xs_usage
573 /* NOTE: the prototype of newXSproto() is different in versions of perls,
574 * so we define a portable version of newXSproto()
577 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
579 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
580 #endif /* !defined(newXS_flags) */
586 =head2 C<assign_func_args()>
592 Perform assignment to the C<func_args> attribute.
596 $string = assign_func_args($self, $argsref, $class);
598 List of three elements. Second is an array reference; third is a string.
608 sub assign_func_args {
609 my ($self, $argsref, $class) = @_;
610 my @func_args = @{$argsref};
611 shift @func_args if defined($class);
613 for my $arg (@func_args) {
614 $arg =~ s/^/&/ if $self->{in_out}->{$arg};
616 return join(", ", @func_args);
619 =head2 C<analyze_preprocessor_statements()>
625 Within each function inside each Xsub, print to the F<.c> output file certain
626 preprocessor statements.
630 ( $self, $XSS_work_idx, $BootCode_ref ) =
631 analyze_preprocessor_statements(
632 $self, $statement, $XSS_work_idx, $BootCode_ref
635 List of four elements.
639 Modifed values of three of the arguments passed to the function. In
640 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
646 sub analyze_preprocessor_statements {
647 my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
649 if ($statement eq 'if') {
650 $XSS_work_idx = @{ $self->{XSStack} };
651 push(@{ $self->{XSStack} }, {type => 'if'});
654 death ("Error: `$statement' with no matching `if'")
655 if $self->{XSStack}->[-1]{type} ne 'if';
656 if ($self->{XSStack}->[-1]{varname}) {
657 push(@{ $self->{InitFileCode} }, "#endif\n");
658 push(@{ $BootCode_ref }, "#endif");
661 my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
662 if ($statement ne 'endif') {
663 # Hide the functions defined in other #if branches, and reset.
664 @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
665 @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
668 my($tmp) = pop(@{ $self->{XSStack} });
669 0 while (--$XSS_work_idx
670 && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
671 # Keep all new defined functions
672 push(@fns, keys %{$tmp->{other_functions}});
673 @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
676 return ($self, $XSS_work_idx, $BootCode_ref);
694 my ($ellipsis, $min_args, $num_args) = @_;
697 $cond = ($min_args ? qq(items < $min_args) : 0);
699 elsif ($min_args == $num_args) {
700 $cond = qq(items != $min_args);
703 $cond = qq(items < $min_args || items > $num_args);
724 # work out the line number
725 my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
727 print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
770 =head2 C<check_conditional_preprocessor_statements()>
784 sub check_conditional_preprocessor_statements {
786 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
790 if ($cpp =~ /^\#\s*if/) {
794 Warn( $self, "Warning: #else/elif/endif without #if in this function");
795 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
796 if $self->{XSStack}->[-1]{type} eq 'if';
799 elsif ($cpp =~ /^\#\s*endif/) {
803 Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;