Edit File: Utilities.pm
package ExtUtils::ParseXS::Utilities; use strict; use warnings; use Exporter; use File::Spec; use lib qw( lib ); use ExtUtils::ParseXS::Constants (); our $VERSION = '3.18'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( standard_typemap_locations trim_whitespace tidy_type C_string valid_proto_string process_typemaps make_targetable map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 NAME ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS =head1 SYNOPSIS use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace tidy_type C_string valid_proto_string process_typemaps make_targetable map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 SUBROUTINES The following functions are not considered to be part of the public interface. They are documented here for the benefit of future maintainers of this module. =head2 C<standard_typemap_locations()> =over 4 =item * Purpose Provide a list of filepaths where F<typemap> files may be found. The filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority. The highest priority is to look in the current directory. 'typemap' The second and third highest priorities are to look in the parent of the current directory and a directory called F<lib/ExtUtils> underneath the parent directory. '../typemap', '../lib/ExtUtils/typemap', The fourth through ninth highest priorities are to look in the corresponding grandparent, great-grandparent and great-great-grandparent directories. '../../typemap', '../../lib/ExtUtils/typemap', '../../../typemap', '../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../../lib/ExtUtils/typemap', The tenth and subsequent priorities are to look in directories named F<ExtUtils> which are subdirectories of directories found in C<@INC> -- I<provided> a file named F<typemap> actually exists in such a directory. Example: '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', However, these filepaths appear in the list returned by C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest. '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', '../../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../lib/ExtUtils/typemap', '../../../typemap', '../../lib/ExtUtils/typemap', '../../typemap', '../lib/ExtUtils/typemap', '../typemap', 'typemap' =item * Arguments my @stl = standard_typemap_locations( \@INC ); Reference to C<@INC>. =item * Return Value Array holding list of directories to be searched for F<typemap> files. =back =cut sub standard_typemap_locations { my $include_ref = shift; my @tm = qw(typemap); my $updir = File::Spec->updir(); foreach my $dir ( File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2), File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4), ) { unshift @tm, File::Spec->catfile($dir, 'typemap'); unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); } foreach my $dir (@{ $include_ref}) { my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); unshift @tm, $file if -e $file; } return @tm; } =head2 C<trim_whitespace()> =over 4 =item * Purpose Perform an in-place trimming of leading and trailing whitespace from the first argument provided to the function. =item * Argument trim_whitespace($arg); =item * Return Value None. Remember: this is an I<in-place> modification of the argument. =back =cut sub trim_whitespace { $_[0] =~ s/^\s+|\s+$//go; } =head2 C<tidy_type()> =over 4 =item * Purpose Rationalize any asterisks (C<*>) by joining them into bunches, removing interior whitespace, then trimming leading and trailing whitespace. =item * Arguments ($ret_type) = tidy_type($_); String to be cleaned up. =item * Return Value String cleaned up. =back =cut sub tidy_type { local ($_) = @_; # for templated C++ types, do some bit of flawed canonicalization # wrt. templates at least if (/[<>]/) { s/\s*([<>])\s*/$1/g; s/>>/> >/g; } # rationalise any '*' by joining them into bunches and removing whitespace s#\s*(\*+)\s*#$1#g; s#(\*+)# $1 #g; # change multiple whitespace into a single space s/\s+/ /g; # trim leading & trailing whitespace trim_whitespace($_); $_; } =head2 C<C_string()> =over 4 =item * Purpose Escape backslashes (C<\>) in prototype strings. =item * Arguments $ProtoThisXSUB = C_string($_); String needing escaping. =item * Return Value Properly escaped string. =back =cut sub C_string { my($string) = @_; $string =~ s[\\][\\\\]g; $string; } =head2 C<valid_proto_string()> =over 4 =item * Purpose Validate prototype string. =item * Arguments String needing checking. =item * Return Value Upon success, returns the same string passed as argument. Upon failure, returns C<0>. =back =cut sub valid_proto_string { my($string) = @_; if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) { return $string; } return 0; } =head2 C<process_typemaps()> =over 4 =item * Purpose Process all typemap files. =item * Arguments my $typemaps_object = process_typemaps( $args{typemap}, $pwd ); List of two elements: C<typemap> element from C<%args>; current working directory. =item * Return Value Upon success, returns an L<ExtUtils::Typemaps> object. =back =cut sub process_typemaps { my ($tmap, $pwd) = @_; my @tm = ref $tmap ? @{$tmap} : ($tmap); foreach my $typemap (@tm) { die "Can't find $typemap in $pwd\n" unless -r $typemap; } push @tm, standard_typemap_locations( \@INC ); require ExtUtils::Typemaps; my $typemap = ExtUtils::Typemaps->new; foreach my $typemap_loc (@tm) { next unless -f $typemap_loc; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next unless -T $typemap_loc; $typemap->merge(file => $typemap_loc, replace => 1); } return $typemap; } =head2 C<make_targetable()> =over 4 =item * Purpose Populate C<%targetable>. This constitutes a refinement of the output of C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>. =item * Arguments %targetable = make_targetable($output_expr_ref); Single hash reference: the fourth such ref returned by C<process_typemaps()>. =item * Return Value Hash. =back =cut sub make_targetable { my $output_expr_ref = shift; our $bal; # ()-balanced $bal = qr[ (?: (?>[^()]+) | \( (??{ $bal }) \) )* ]x; # matches variations on (SV*) my $sv_cast = qr[ (?: \( \s* SV \s* \* \s* \) \s* )? ]x; my $size = qr[ # Third arg (to setpvn) , \s* (??{ $bal }) ]x; my %targetable; foreach my $key (keys %{ $output_expr_ref }) { # We can still bootstrap compile 're', because in code re.pm is # available to miniperl, and does not attempt to load the XS code. use re 'eval'; my ($type, $with_size, $arg, $sarg) = ($output_expr_ref->{$key} =~ m[^ \s+ sv_set([iunp])v(n)? # Type, is_setpvn \s* \( \s* $sv_cast \$arg \s* , \s* ( (??{ $bal }) ) # Set from ( (??{ $size }) )? # Possible sizeof set-from \) \s* ; \s* $ ]x ); $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type; } return %targetable; } =head2 C<map_type()> =over 4 =item * Purpose Performs a mapping at several places inside C<PARAGRAPH> loop. =item * Arguments $type = map_type($self, $type, $varname); List of three arguments. =item * Return Value String holding augmented version of second argument. =back =cut sub map_type { my ($self, $type, $varname) = @_; # C++ has :: in types too so skip this $type =~ tr/:/_/ unless $self->{hiertype}; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; if ($varname) { if ($type =~ / \( \s* \* (?= \s* \) ) /xg) { (substr $type, pos $type, 0) = " $varname "; } else { $type .= "\t$varname"; } } return $type; } =head2 C<standard_XS_defs()> =over 4 =item * Purpose Writes to the C<.c> output file certain preprocessor directives and function headers needed in all such files. =item * Arguments None. =item * Return Value Returns true. =back =cut sub standard_XS_defs { print <<"EOF"; #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef dVAR # define dVAR dNOOP #endif /* This stuff is not part of the API! You have been warned. */ #ifndef PERL_VERSION_DECIMAL # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #endif #ifndef PERL_DECIMAL_VERSION # define PERL_DECIMAL_VERSION \\ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #endif #ifndef PERL_VERSION_GE # define PERL_VERSION_GE(r,v,s) \\ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #endif #ifndef PERL_VERSION_LE # define PERL_VERSION_LE(r,v,s) \\ (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) #endif /* XS_INTERNAL is the explicit static-linkage variant of the default * XS macro. * * XS_EXTERNAL is the same as XS_INTERNAL except it does not include * "STATIC", ie. it exports XSUB symbols. You probably don't want that * for anything but the BOOT XSUB. * * See XSUB.h in core! */ /* TODO: This might be compatible further back than 5.10.0. */ #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) # undef XS_EXTERNAL # undef XS_INTERNAL # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # if defined(__SYMBIAN32__) # define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) # define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) # endif # ifndef XS_EXTERNAL # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) # define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) # else # ifdef __cplusplus # define XS_EXTERNAL(name) extern "C" XSPROTO(name) # define XS_INTERNAL(name) static XSPROTO(name) # else # define XS_EXTERNAL(name) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # endif # endif #endif /* perl >= 5.10.0 && perl <= 5.15.1 */ /* The XS_EXTERNAL macro is used for functions that must not be static * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL * macro defined, the best we can do is assume XS is the same. * Dito for XS_INTERNAL. */ #ifndef XS_EXTERNAL # define XS_EXTERNAL(name) XS(name) #endif #ifndef XS_INTERNAL # define XS_INTERNAL(name) XS(name) #endif /* Now, finally, after all this mess, we want an ExtUtils::ParseXS * internal macro that we're free to redefine for varying linkage due * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! */ #undef XS_EUPXS #if defined(PERL_EUPXS_ALWAYS_EXPORT) # define XS_EUPXS(name) XS_EXTERNAL(name) #else /* default to internal */ # define XS_EUPXS(name) XS_INTERNAL(name) #endif EOF print <<"EOF"; #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #ifdef PERL_IMPLICIT_CONTEXT #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) #else #define croak_xs_usage S_croak_xs_usage #endif #endif /* NOTE: the prototype of newXSproto() is different in versions of perls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ EOF return 1; } =head2 C<assign_func_args()> =over 4 =item * Purpose Perform assignment to the C<func_args> attribute. =item * Arguments $string = assign_func_args($self, $argsref, $class); List of three elements. Second is an array reference; third is a string. =item * Return Value String. =back =cut sub assign_func_args { my ($self, $argsref, $class) = @_; my @func_args = @{$argsref}; shift @func_args if defined($class); for my $arg (@func_args) { $arg =~ s/^/&/ if $self->{in_out}->{$arg}; } return join(", ", @func_args); } =head2 C<analyze_preprocessor_statements()> =over 4 =item * Purpose Within each function inside each Xsub, print to the F<.c> output file certain preprocessor statements. =item * Arguments ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); List of four elements. =item * Return Value Modifed values of three of the arguments passed to the function. In particular, the C<XSStack> and C<InitFileCode> attributes are modified. =back =cut sub analyze_preprocessor_statements { my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_; if ($statement eq 'if') { $XSS_work_idx = @{ $self->{XSStack} }; push(@{ $self->{XSStack} }, {type => 'if'}); } else { $self->death("Error: '$statement' with no matching 'if'") if $self->{XSStack}->[-1]{type} ne 'if'; if ($self->{XSStack}->[-1]{varname}) { push(@{ $self->{InitFileCode} }, "#endif\n"); push(@{ $BootCode_ref }, "#endif"); } my(@fns) = keys %{$self->{XSStack}->[-1]{functions}}; if ($statement ne 'endif') { # Hide the functions defined in other #if branches, and reset. @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns; @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {}); } else { my($tmp) = pop(@{ $self->{XSStack} }); 0 while (--$XSS_work_idx && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if'); # Keep all new defined functions push(@fns, keys %{$tmp->{other_functions}}); @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; } } return ($self, $XSS_work_idx, $BootCode_ref); } =head2 C<set_cond()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub set_cond { my ($ellipsis, $min_args, $num_args) = @_; my $cond; if ($ellipsis) { $cond = ($min_args ? qq(items < $min_args) : 0); } elsif ($min_args == $num_args) { $cond = qq(items != $min_args); } else { $cond = qq(items < $min_args || items > $num_args); } return $cond; } =head2 C<current_line_number()> =over 4 =item * Purpose Figures out the current line number in the XS file. =item * Arguments C<$self> =item * Return Value The current line number. =back =cut sub current_line_number { my $self = shift; my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1]; return $line_number; } =head2 C<Warn()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub Warn { my $self = shift; my $warn_line_number = $self->current_line_number(); print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; } =head2 C<blurt()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub blurt { my $self = shift; $self->Warn(@_); $self->{errors}++ } =head2 C<death()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub death { my $self = shift; $self->Warn(@_); exit 1; } =head2 C<check_conditional_preprocessor_statements()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub check_conditional_preprocessor_statements { my ($self) = @_; my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} }); if (@cpp) { my $cpplevel; for my $cpp (@cpp) { if ($cpp =~ /^\#\s*if/) { $cpplevel++; } elsif (!$cpplevel) { $self->Warn("Warning: #else/elif/endif without #if in this function"); print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" if $self->{XSStack}->[-1]{type} eq 'if'; return; } elsif ($cpp =~ /^\#\s*endif/) { $cpplevel--; } } $self->Warn("Warning: #if without #endif in this function") if $cpplevel; } } =head2 C<escape_file_for_line_directive()> =over 4 =item * Purpose Escapes a given code source name (typically a file name but can also be a command that was read from) so that double-quotes and backslashes are escaped. =item * Arguments A string. =item * Return Value A string with escapes for double-quotes and backslashes. =back =cut sub escape_file_for_line_directive { my $string = shift; $string =~ s/\\/\\\\/g; $string =~ s/"/\\"/g; return $string; } =head2 C<report_typemap_failure> =over 4 =item * Purpose Do error reporting for missing typemaps. =item * Arguments The C<ExtUtils::ParseXS> object. An C<ExtUtils::Typemaps> object. The string that represents the C type that was not found in the typemap. Optionally, the string C<death> or C<blurt> to choose whether the error is immediately fatal or not. Default: C<blurt> =item * Return Value Returns nothing. Depending on the arguments, this may call C<death> or C<blurt>, the former of which is fatal. =back =cut sub report_typemap_failure { my ($self, $tm, $ctype, $error_method) = @_; $error_method ||= 'blurt'; my @avail_ctypes = $tm->list_mapped_ctypes; my $err = "Could not find a typemap for C type '$ctype'.\n" . "The following C types are mapped by the current typemap:\n'" . join("', '", @avail_ctypes) . "'\n"; $self->$error_method($err); return(); } 1; # vim: ts=2 sw=2 et: