ExtUtils-ParseXS-3.30/0000755000175000017500000000000012571011400013214 5ustar tseetseeExtUtils-ParseXS-3.30/META.yml0000664000175000017500000000142712571011400014473 0ustar tseetsee--- abstract: 'converts Perl XS code into C code' author: - 'Ken Williams ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '6.46' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150001' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: ExtUtils-ParseXS no_index: directory: - t - inc requires: Carp: '0' Cwd: '0' DynaLoader: '0' Exporter: '5.57' ExtUtils::CBuilder: '0' ExtUtils::MakeMaker: '6.46' File::Basename: '0' File::Spec: '0' Symbol: '0' Test::More: '0.47' resources: bugtracker: http://rt.perl.org/rt3/ repository: git://perl5.git.perl.org/gitroot/perl.git version: '3.30' ExtUtils-ParseXS-3.30/lib/0000755000175000017500000000000012571011400013762 5ustar tseetseeExtUtils-ParseXS-3.30/lib/ExtUtils/0000755000175000017500000000000012571011400015543 5ustar tseetseeExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS.pod0000644000175000017500000001047012305657012017610 0ustar tseetsee=head1 NAME ExtUtils::ParseXS - converts Perl XS code into C code =head1 SYNOPSIS use ExtUtils::ParseXS; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file( filename => 'foo.xs' ); $pxs->process_file( filename => 'foo.xs', output => 'bar.c', 'C++' => 1, typemap => 'path/to/typemap', hiertype => 1, except => 1, versioncheck => 1, linenumbers => 1, optimize => 1, prototypes => 1, ); # Legacy non-OO interface using a singleton: use ExtUtils::ParseXS qw(process_file); process_file( filename => 'foo.xs' ); =head1 DESCRIPTION C will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to determine how to map C function parameters and variables to Perl values. The compiler will search for typemap files called I. It will use the following search path to find default typemaps, with the rightmost typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap =head1 EXPORT None by default. C and/or C may be exported upon request. Using the functional interface is discouraged. =head1 METHODS =over 4 =item $pxs->new() Returns a new, empty XS parser/compiler object. =item $pxs->process_file() This method processes an XS file and sends output to a C file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. Named parameters control how the processing is done. The following parameters are accepted: =over 4 =item B Adds C to the C code. Default is false. =item B Retains C<::> in type names so that C++ hierarchical types can be mapped. Default is false. =item B Adds exception handling stubs to the C code. Default is false. =item B Indicates that a user-supplied typemap should take precedence over the default typemaps. A single typemap may be specified as a string, or multiple typemaps can be specified in an array reference, with the last typemap having the highest precedence. =item B Generates prototype code for all xsubs. Default is false. =item B Makes sure at run time that the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. Default is true. =item B Adds C<#line> directives to the C output so error messages will look like they came from the original XS file. Default is true. =item B Enables certain optimizations. The only optimization that is currently affected is the use of Is by the output C code (see L). Not optimizing may significantly slow down the generated code, but this is the way B of 5.005 and earlier operated. Default is to optimize. =item B Enable recognition of C, C and C declarations. Default is true. =item B Enable recognition of ANSI-like descriptions of function signature. Default is true. =item B I I have no clue what this does. Strips function prefixes? =back =item $pxs->report_error_count() This method returns the number of [a certain kind of] errors encountered during processing of the XS file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. =back =head1 AUTHOR Based on xsubpp code, written by Larry Wall. Maintained by: =over 4 =item * Ken Williams, =item * David Golden, =item * James Keenan, =item * Steffen Mueller, =back =head1 COPYRIGHT Copyright 2002-2014 by Ken Williams, David Golden and other contributors. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Based on the C code by Larry Wall and the Perl 5 Porters, which was released under the same license terms. =head1 SEE ALSO L, ExtUtils::xsubpp, ExtUtils::MakeMaker, L, L. =cut ExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS/0000755000175000017500000000000012571011400017070 5ustar tseetseeExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS/Constants.pm0000644000175000017500000000217012571011006021404 0ustar tseetseepackage ExtUtils::ParseXS::Constants; use strict; use warnings; use Symbol; our $VERSION = '3.30'; =head1 NAME ExtUtils::ParseXS::Constants - Initialization values for some globals =head1 SYNOPSIS use ExtUtils::ParseXS::Constants (); $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp; =head1 DESCRIPTION Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its supporting packages has been moved into this package so that those values can be defined exactly once and then re-used in any package. Nothing is exported. Use fully qualified variable names. =cut # FIXME: THESE ARE NOT CONSTANTS! our @InitFileCode; # Note that to reduce maintenance, $PrototypeRegexp is used # by ExtUtils::Typemaps, too! our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]"; our @XSKeywords = qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK EXPORT_XSUB_SYMBOLS ); our $XSKeywordsAlternation = join('|', @XSKeywords); 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS/CountLines.pm0000644000175000017500000000171312571011013021513 0ustar tseetseepackage ExtUtils::ParseXS::CountLines; use strict; our $VERSION = '3.30'; our $SECTION_END_MARKER; sub TIEHANDLE { my ($class, $cfile, $fh) = @_; $cfile =~ s/\\/\\\\/g; $cfile =~ s/"/\\"/g; $SECTION_END_MARKER = qq{#line --- "$cfile"}; return bless { buffer => '', fh => $fh, line_no => 1, }, $class; } sub PRINT { my $self = shift; for (@_) { $self->{buffer} .= $_; while ($self->{buffer} =~ s/^([^\n]*\n)//) { my $line = $1; ++$self->{line_no}; $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; print {$self->{fh}} $line; } } } sub PRINTF { my $self = shift; my $fmt = shift; $self->PRINT(sprintf($fmt, @_)); } sub DESTROY { # Not necessary if we're careful to end with a "\n" my $self = shift; print {$self->{fh}} $self->{buffer}; } sub UNTIE { # This sub does nothing, but is necessary for references to be released. } sub end_marker { return $SECTION_END_MARKER; } 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS/Utilities.pm0000644000175000017500000004142112571011021021402 0ustar tseetseepackage ExtUtils::ParseXS::Utilities; use strict; use warnings; use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); our $VERSION = '3.30'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps 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 C_string valid_proto_string process_typemaps 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 =over 4 =item * Purpose Provide a list of filepaths where F 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 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 which are subdirectories of directories found in C<@INC> -- I a file named F 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 in reverse order, I, 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 files. =back =cut SCOPE: { my @tm_template; sub standard_typemap_locations { my $include_ref = shift; if (not @tm_template) { @tm_template = 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_template, File::Spec->catfile($dir, 'typemap'); unshift @tm_template, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); } } my @tm = @tm_template; foreach my $dir (@{ $include_ref}) { my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); unshift @tm, $file if -e $file; } return @tm; } } # end SCOPE =head2 C =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 modification of the argument. =back =cut sub trim_whitespace { $_[0] =~ s/^\s+|\s+$//go; } =head2 C =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 =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 =over 4 =item * Purpose Process all typemap files. =item * Arguments my $typemaps_object = process_typemaps( $args{typemap}, $pwd ); List of two elements: C element from C<%args>; current working directory. =item * Return Value Upon success, returns an L 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 =over 4 =item * Purpose Performs a mapping at several places inside C 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->{RetainCplusplusHierarchicalTypes}; $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 =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(const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(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_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak_nocontext("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define croak_xs_usage S_croak_xs_usage #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) */ #if PERL_VERSION_LE(5, 21, 5) # define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file) #else # define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) #endif EOF return 1; } =head2 C =over 4 =item * Purpose Perform assignment to the C 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 =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 and C 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 =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 =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 =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 =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub blurt { my $self = shift; $self->Warn(@_); $self->{errors}++ } =head2 C =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub death { my $self = shift; $self->Warn(@_); exit 1; } =head2 C =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 =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 =over 4 =item * Purpose Do error reporting for missing typemaps. =item * Arguments The C object. An C object. The string that represents the C type that was not found in the typemap. Optionally, the string C or C to choose whether the error is immediately fatal or not. Default: C =item * Return Value Returns nothing. Depending on the arguments, this may call C or C, 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: ExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS/Eval.pm0000644000175000017500000000450612571011016020325 0ustar tseetseepackage ExtUtils::ParseXS::Eval; use strict; use warnings; our $VERSION = '3.30'; =head1 NAME ExtUtils::ParseXS::Eval - Clean package to evaluate code in =head1 SYNOPSIS use ExtUtils::ParseXS::Eval; my $rv = ExtUtils::ParseXS::Eval::eval_typemap_code( $parsexs_obj, "some Perl code" ); =head1 SUBROUTINES =head2 $pxs->eval_output_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $Alias $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $arg =cut sub eval_output_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $ntype, $subtype, $arg) = @{$_other}{qw(var type ntype subtype arg)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head2 $pxs->eval_input_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $Alias $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $num $init $printed_name $arg $argoff =cut sub eval_input_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) = @{$_other}{qw(var type num init printed_name arg ntype argoff subtype)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head1 TODO Eventually, with better documentation and possible some cleanup, this could be part of C. =cut 1; # vim: ts=2 sw=2 et: ExtUtils-ParseXS-3.30/lib/ExtUtils/ParseXS.pm0000644000175000017500000020176112571010771017447 0ustar tseetseepackage ExtUtils::ParseXS; use strict; use 5.006001; use Cwd; use Config; use Exporter 'import'; use File::Basename; use File::Spec; use Symbol; our $VERSION; BEGIN { $VERSION = '3.30'; } use ExtUtils::ParseXS::Constants $VERSION; use ExtUtils::ParseXS::CountLines $VERSION; use ExtUtils::ParseXS::Utilities $VERSION; use ExtUtils::ParseXS::Eval $VERSION; $VERSION = eval $VERSION if $VERSION =~ /_/; use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps 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 ); our @EXPORT_OK = qw( process_file report_error_count ); ############################## # A number of "constants" our ($C_group_rex, $C_arg); # Group in C (no support for comments or literals) $C_group_rex = qr/ [({\[] (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* [)}\]] /x; # Chunk in C without comma at toplevel (no comments): $C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) | (??{ $C_group_rex }) | " (?: (?> [^\\"]+ ) | \\. )* " # String literal | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal )* /xs; # "impossible" keyword (multiple newline) my $END = "!End!\n\n"; # Match an XS Keyword my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:"; sub new { return bless {} => shift; } our $Singleton = __PACKAGE__->new; sub process_file { my $self; # Allow for $package->process_file(%hash), $obj->process_file, and process_file() if (@_ % 2) { my $invocant = shift; $self = ref($invocant) ? $invocant : $invocant->new; } else { $self = $Singleton; } my %options = @_; $self->{ProtoUsed} = exists $options{prototypes}; # Set defaults. my %args = ( argtypes => 1, csuffix => '.c', except => 0, hiertype => 0, inout => 1, linenumbers => 1, optimize => 1, output => \*STDOUT, prototypes => 0, typemap => [], versioncheck => 1, FH => Symbol::gensym(), %options, ); $args{except} = $args{except} ? ' TRY' : ''; # Global Constants my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { $Is_VMS = 1; # Establish set of global symbols with max length 28, since xsubpp # will later add the 'XS_' prefix. require ExtUtils::XSSymSet; $SymSet = ExtUtils::XSSymSet->new(28); } @{ $self->{XSStack} } = ({type => 'none'}); $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; $self->{Overload} = 0; # bool $self->{errors} = 0; # count $self->{Fallback} = '&PL_sv_undef'; # Most of the 1500 lines below uses these globals. We'll have to # clean this up sometime, probably. For now, we just pull them out # of %args. -Ken $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; $self->{WantPrototypes} = $args{prototypes}; $self->{WantVersionChk} = $args{versioncheck}; $self->{WantLineNumbers} = $args{linenumbers}; $self->{IncludedFiles} = {}; die "Missing required parameter 'filename'" unless $args{filename}; $self->{filepathname} = $args{filename}; ($self->{dir}, $self->{filename}) = (dirname($args{filename}), basename($args{filename})); $self->{filepathname} =~ s/\\/\\\\/g; $self->{IncludedFiles}->{$args{filename}}++; # Open the output file if given as a string. If they provide some # other kind of reference, trust them that we can print to it. if (not ref $args{output}) { open my($fh), "> $args{output}" or die "Can't create $args{output}: $!"; $args{outfile} = $args{output}; $args{output} = $fh; } # Really, we shouldn't have to chdir() or select() in the first # place. For now, just save and restore. my $orig_cwd = cwd(); my $orig_fh = select(); chdir($self->{dir}); my $pwd = cwd(); my $csuffix = $args{csuffix}; if ($self->{WantLineNumbers}) { my $cfile; if ( $args{outfile} ) { $cfile = $args{outfile}; } else { $cfile = $args{filename}; $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; } tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); select PSEUDO_STDOUT; } else { select $args{output}; } $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); # Move more settings from parameters to object foreach my $datum ( qw| argtypes except inout optimize | ) { $self->{$datum} = $args{$datum}; } $self->{strip_c_func_prefix} = $args{s}; # Identify the version of xsubpp used print <{filename}. Do not edit this file, edit $self->{filename} instead. * * ANY CHANGES MADE HERE WILL BE LOST! * */ EOM print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n") if $self->{WantLineNumbers}; # Open the input file (using $self->{filename} which # is a basename'd $args{filename} due to chdir above) open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; FIRSTMODULE: while (readline($self->{FH})) { if (/^=/) { my $podstartline = $.; do { if (/^=cut\s*$/) { # We can't just write out a /* */ comment, as our embedded # POD might itself be in a comment. We can't put a /**/ # comment inside #if 0, as the C standard says that the source # file is decomposed into preprocessing characters in the stage # before preprocessing commands are executed. # I don't want to leave the text as barewords, because the spec # isn't clear whether macros are expanded before or after # preprocessing commands are executed, and someone pathological # may just have defined one of the 3 words as a macro that does # something strange. Multiline strings are illegal in C, so # the "" we write must be a string literal. And they aren't # concatenated until 2 steps later, so we are safe. # - Nicholas Clark print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) if $self->{WantLineNumbers}; next FIRSTMODULE; } } while (readline($self->{FH})); # At this point $. is at end of file so die won't state the start # of the problem, and as we haven't yet read any lines &death won't # show the correct line in the message either. die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n") unless $self->{lastline}; } last if ($self->{Package}, $self->{Prefix}) = /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; print $_; } unless (defined $_) { warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; exit 0; # Not a fatal error for the caller process } print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; standard_XS_defs(); print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; $self->{lastline} = $_; $self->{lastline_no} = $.; my $BootCode_ref = []; my $XSS_work_idx = 0; my $cpp_next_tmp = 'XSubPPtmpAAAA'; PARAGRAPH: while ($self->fetch_para()) { my $outlist_ref = []; # Print initial preprocessor statements and blank lines while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { my $ln = shift(@{ $self->{line} }); print $ln, "\n"; next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; my $statement = $+; ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); } next PARAGRAPH unless @{ $self->{line} }; if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) { # We are inside an #if, but have not yet #defined its xsubpp variable. print "#define $cpp_next_tmp 1\n\n"; push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; } $self->death( "Code is not inside a function" ." (maybe last function was ended by a blank line " ." followed by a statement on column one?)") if $self->{line}->[0] =~ /^\s/; # initialize info arrays foreach my $member (qw(args_match var_types defaults arg_list argtype_seen in_out lengthof)) { $self->{$member} = {}; } $self->{proto_arg} = []; $self->{processing_arg_with_types} = 0; # bool $self->{proto_in_this_xsub} = 0; # counter & bool $self->{scope_in_this_xsub} = 0; # counter & bool $self->{interface} = 0; # bool $self->{interface_macro} = 'XSINTERFACE_FUNC'; $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; $self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) $self->{ScopeThisXSUB} = 0; # bool my $xsreturn = 0; $_ = shift(@{ $self->{line} }); while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { my $method = $kwd . "_handler"; $self->$method($_); next PARAGRAPH unless @{ $self->{line} }; $_ = shift(@{ $self->{line} }); } if ($self->check_keyword("BOOT")) { check_conditional_preprocessor_statements($self); push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" . escape_file_for_line_directive($self->{filepathname}) . "\"") if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; push (@{ $BootCode_ref }, @{ $self->{line} }, ""); next PARAGRAPH; } # extract return type, function name and arguments ($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_); my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; # Allow one-line ANSI-like declaration unshift @{ $self->{line} }, $2 if $self->{argtypes} and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; # a function definition needs at least 2 lines $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH unless @{ $self->{line} }; my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; my $static = 1 if $self->{ret_type} =~ s/^static\s+//; my $func_header = shift(@{ $self->{line} }); $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; my ($class, $orig_args); ($class, $self->{func_name}, $orig_args) = ($1, $2, $3); $class = "$4 $class" if $4; ($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; my $clean_func_name; ($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//; $self->{Full_func_name} = "$self->{Packid}_$clean_func_name"; if ($Is_VMS) { $self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} ); } # Check for duplicate function definition for my $tmp (@{ $self->{XSStack} }) { next unless defined $tmp->{functions}{ $self->{Full_func_name} }; Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); last; } $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; delete $self->{XsubAliases}; delete $self->{XsubAliasValues}; %{ $self->{Interfaces} } = (); @{ $self->{Attributes} } = (); $self->{DoSetMagic} = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations my @args; my (@fake_INPUT_pre); # For length(s) generated variables my (@fake_INPUT); my $only_C_inlist_ref = {}; # Not in the signature of Perl function if ($self->{argtypes} and $orig_args =~ /\S/) { my $args = "$orig_args ,"; use re 'eval'; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); no re 'eval'; for ( @args ) { s/^\s+//; s/\s+$//; my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); my ($pre, $len_name) = ($arg =~ /(.*?) \s* \b ( \w+ | length\( \s*\w+\s* \) ) \s* $ /x); next unless defined($pre) && length($pre); my $out_type = ''; my $inout_var; if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { my $type = $1; $out_type = $type if $type ne 'IN'; $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; } my $islength; if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { $len_name = "XSauto_length_of_$1"; $islength = 1; die "Default value on length() argument: '$_'" if length $default; } if (length $pre or $islength) { # Has a type if ($islength) { push @fake_INPUT_pre, $arg; } else { push @fake_INPUT, $arg; } # warn "pushing '$arg'\n"; $self->{argtype_seen}->{$len_name}++; $_ = "$len_name$default"; # Assigns to @args } $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; $self->{in_out}->{$len_name} = $out_type if $out_type; } } else { no re 'eval'; @args = split(/\s*,\s*/, $orig_args); Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); } } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { my $out_type = $1; next if $out_type eq 'IN'; $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; if ($out_type =~ /OUTLIST$/) { push @{ $outlist_ref }, undef; } $self->{in_out}->{$_} = $out_type; } } } if (defined($class)) { my $arg0 = ((defined($static) or $self->{func_name} eq 'new') ? "CLASS" : "THIS"); unshift(@args, $arg0); } my $extra_args = 0; my @args_num = (); my $num_args = 0; my $report_args = ''; my $ellipsis; foreach my $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { $ellipsis = 1; if ($args[$i] eq '' && $i == $#args) { $report_args .= ", ..."; pop(@args); last; } } if ($only_C_inlist_ref->{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; $report_args .= ", $args[$i]"; } if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { $extra_args++; $args[$i] = $1; $self->{defaults}->{$args[$i]} = $2; $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } $self->{proto_arg}->[$i+1] = '$'; } my $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; $report_args =~ s/^,\s+//; $self->{func_args} = assign_func_args($self, \@args, $class); @{ $self->{args_match} }{@args} = @args_num; my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) # to set explicit return values. my $EXPLICIT_RETURN = ($CODE && ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $self->{ALIAS} = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); $xsreturn = 1 if $EXPLICIT_RETURN; $externC = $externC ? qq[extern "C"] : ""; # print function header print Q(<<"EOF"); #$externC #XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Full_func_name}) #[[ # dVAR; dXSARGS; EOF print Q(<<"EOF") if $self->{ALIAS}; # dXSI32; EOF print Q(<<"EOF") if $INTERFACE; # dXSFUNCTION($self->{ret_type}); EOF $self->{cond} = set_cond($ellipsis, $min_args, $num_args); print Q(<<"EOF") if $self->{except}; # char errbuf[1024]; # *errbuf = '\\0'; EOF if($self->{cond}) { print Q(<<"EOF"); # if ($self->{cond}) # croak_xs_usage(cv, "$report_args"); EOF } else { # cv likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ EOF } #gcc -Wall: if an xsub has PPCODE is used #it is possible none of ST, XSRETURN or XSprePUSH macros are used #hence 'ax' (setup by dXSARGS) is unused #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS #but such a move could break third-party extensions print Q(<<"EOF") if $PPCODE; # PERL_UNUSED_VAR(ax); /* -Wall */ EOF print Q(<<"EOF") if $PPCODE; # SP -= items; EOF # Now do a block of some sort. $self->{condnum} = 0; $self->{cond} = ''; # last CASE: conditional push(@{ $self->{line} }, "$END:"); push(@{ $self->{line_no} }, $self->{line_no}->[-1]); $_ = ''; check_conditional_preprocessor_statements(); while (@{ $self->{line} }) { $self->CASE_handler($_) if $self->check_keyword("CASE"); print Q(<<"EOF"); # $self->{except} [[ EOF # do initialization of input variables $self->{thisdone} = 0; $self->{retvaldone} = 0; $self->{deferred} = ""; %{ $self->{arg_list} } = (); $self->{gotRETVAL} = 0; $self->INPUT_handler($_); $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ENTER; # [[ EOF if (!$self->{thisdone} && defined($class)) { if (defined($static) or $self->{func_name} eq 'new') { print "\tchar *"; $self->{var_types}->{"CLASS"} = "char *"; $self->generate_init( { type => "char *", num => 1, var => "CLASS", printed_name => undef, } ); } else { print "\t$class *"; $self->{var_types}->{"THIS"} = "$class *"; $self->generate_init( { type => "$class *", num => 1, var => "THIS", printed_name => undef, } ); } } # These are set if OUTPUT is found and/or CODE using RETVAL $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; my ($wantRETVAL); # do code if (/^\s*NOT_IMPLEMENTED_YET/) { print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; $_ = ''; } else { if ($self->{ret_type} ne "void") { print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" if !$self->{retvaldone}; $self->{args_match}->{"RETVAL"} = 0; $self->{var_types}->{"RETVAL"} = $self->{ret_type}; my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); print "\tdXSTARG;\n" if $self->{optimize} and $outputmap and $outputmap->targetable; } if (@fake_INPUT or @fake_INPUT_pre) { unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; $_ = ""; $self->{processing_arg_with_types} = 1; $self->INPUT_handler($_); } print $self->{deferred}; $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); if ($self->check_keyword("PPCODE")) { $self->print_section(); $self->death("PPCODE must be last thing") if @{ $self->{line} }; print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; print "\tPUTBACK;\n\treturn;\n"; } elsif ($self->check_keyword("CODE")) { my $consumed_code = $self->print_section(); if ($consumed_code =~ /\bRETVAL\b/) { $self->{have_CODE_with_RETVAL} = 1; } } elsif (defined($class) and $self->{func_name} eq "DESTROY") { print "\n\t"; print "delete THIS;\n"; } else { print "\n\t"; if ($self->{ret_type} ne "void") { print "RETVAL = "; $wantRETVAL = 1; } if (defined($static)) { if ($self->{func_name} eq 'new') { $self->{func_name} = "$class"; } else { print "${class}::"; } } elsif (defined($class)) { if ($self->{func_name} eq 'new') { $self->{func_name} .= " $class"; } else { print "THIS->"; } } my $strip = $self->{strip_c_func_prefix}; $self->{func_name} =~ s/^\Q$strip// if defined $strip; $self->{func_name} = 'XSFUNCTION' if $self->{interface}; print "$self->{func_name}($self->{func_args});\n"; } } # do output variables $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; undef %{ $self->{outargs} }; $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); # A CODE section with RETVAL, but no OUTPUT? FAIL! if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); } $self->generate_output( { type => $self->{var_types}->{$_}, num => $self->{args_match}->{$_}, var => $_, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} }; my $prepush_done; # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; my $var = 'RETVAL'; my $type = $self->{ret_type}; if ($trgt) { my $what = $self->eval_output_typemap_code( qq("$trgt->{what}"), {var => $var, type => $self->{ret_type}} ); if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; $prepush_done = 1; } else { my $tsize = $trgt->{what_size}; $tsize = '' unless defined $tsize; $tsize = $self->eval_output_typemap_code( qq("$tsize"), {var => $var, type => $self->{ret_type}} ); print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; $prepush_done = 1; } } else { # RETVAL almost never needs SvSETMAGIC() $self->generate_output( { type => $self->{ret_type}, num => 0, var => 'RETVAL', do_setmagic => 0, do_push => undef, } ); } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; my $c = @{ $outlist_ref }; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; $self->generate_output( { type => $self->{var_types}->{$_}, num => $num++, var => $_, do_setmagic => 0, do_push => 1, } ) for @{ $outlist_ref }; # do cleanup $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ]] EOF print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; # LEAVE; EOF # print function trailer print Q(<<"EOF"); # ]] EOF print Q(<<"EOF") if $self->{except}; # BEGHANDLERS # CATCHALL # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); # ENDHANDLERS EOF if ($self->check_keyword("CASE")) { $self->blurt("Error: No 'CASE:' at top of function") unless $self->{condnum}; $_ = "CASE: $_"; # Restore CASE: label next; } last if $_ eq "$END:"; $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); } print Q(<<"EOF") if $self->{except}; # if (errbuf[0]) # Perl_croak(aTHX_ errbuf); EOF if ($xsreturn) { print Q(<<"EOF") unless $PPCODE; # XSRETURN($xsreturn); EOF } else { print Q(<<"EOF") unless $PPCODE; # XSRETURN_EMPTY; EOF } print Q(<<"EOF"); #]] # EOF $self->{proto} = ""; unless($self->{ProtoThisXSUB}) { $self->{newXS} = "newXS_deffile"; $self->{file} = ""; } else { # Build the prototype string for the xsub $self->{newXS} = "newXSproto_portable"; $self->{file} = ", file"; if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype } elsif ($self->{ProtoThisXSUB} eq 1) { my $s = ';'; if ($min_args < $num_args) { $s = ''; $self->{proto_arg}->[$min_args] .= ";"; } push @{ $self->{proto_arg} }, "$s\@" if $ellipsis; $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); } else { # User has specified a prototype $self->{proto} = $self->{ProtoThisXSUB}; } $self->{proto} = qq{, "$self->{proto}"}; } if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { $self->{XsubAliases}->{ $self->{pname} } = 0 unless defined $self->{XsubAliases}->{ $self->{pname} }; foreach my $xname (sort keys %{ $self->{XsubAliases} }) { my $value = $self->{XsubAliases}{$xname}; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # XSANY.any_i32 = $value; EOF } } elsif (@{ $self->{Attributes} }) { push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); EOF } elsif ($self->{interface}) { foreach my $yname (sort keys %{ $self->{Interfaces} }) { my $value = $self->{Interfaces}{$yname}; $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # $self->{interface_macro_set}(cv,$value); EOF } } elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro push(@{ $self->{InitFileCode} }, " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } else { push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop if ($self->{Overload}) { # make it findable with fetchmethod print Q(<<"EOF"); #XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Packid}_nil) #{ # dXSARGS; # XSRETURN_EMPTY; #} # EOF unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); /* Making a sub named "$self->{Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("$self->{Package}") to return true. */ (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); MAKE_FETCHMETHOD_WORK } # print initialization routine print Q(<<"EOF"); ##ifdef __cplusplus #extern "C" ##endif EOF print Q(<<"EOF"); #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ #XS_EXTERNAL(boot_$self->{Module_cname}) #[[ ##if PERL_VERSION_LE(5, 21, 5) # dVAR; dXSARGS; ##else # dVAR; ${\($self->{WantVersionChk} ? 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} ##endif EOF #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const #file name argument. If the wrong qualifier is used, it causes breakage with #C++ compilers and warnings with recent gcc. #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs #so 'file' is unused print Q(<<"EOF") if $self->{Full_func_name}; ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # char* file = __FILE__; ##else # const char* file = __FILE__; ##endif # # PERL_UNUSED_VAR(file); EOF print Q("#\n"); print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ EOF if( $self->{WantVersionChk}){ print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) # XS_VERSION_BOOTCHECK; ## ifdef XS_APIVERSION_BOOTCHECK # XS_APIVERSION_BOOTCHECK; ## endif ##endif EOF } else { print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) # XS_APIVERSION_BOOTCHECK; ##endif EOF } print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # { # CV * cv; # EOF print Q(<<"EOF") if ($self->{Overload}); # /* register the overloading (type 'A') magic */ ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # PL_amagic_generation++; ##endif # /* The magic for overload gets a GV* via gv_fetchmeth as */ # /* mentioned above, and looks in the SV* slot of it for */ # /* the "fallback" status. */ # sv_setsv( # get_sv( "$self->{Package}::()", TRUE ), # $self->{Fallback} # ); EOF print @{ $self->{InitFileCode} }; print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # } EOF if (@{ $BootCode_ref }) { print "\n /* Initialisation Section */\n\n"; @{ $self->{line} } = @{ $BootCode_ref }; $self->print_section(); print "\n /* End of Initialisation Section */\n\n"; } print Q(<<'EOF'); ##if PERL_VERSION_LE(5, 21, 5) ## if PERL_VERSION_GE(5, 9, 0) # if (PL_unitcheckav) # call_list(PL_scopestack_ix, PL_unitcheckav); ## endif # XSRETURN_YES; ##else # Perl_xs_boot_epilog(aTHX_ ax); ##endif #]] # EOF warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") unless $self->{ProtoUsed}; chdir($orig_cwd); select($orig_fh); untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; close $self->{FH}; return 1; } sub report_error_count { if (@_) { return $_[0]->{errors}||0; } else { return $Singleton->{errors}||0; } } # Input: ($self, $_, @{ $self->{line} }) == unparsed input. # Output: ($_, @{ $self->{line} }) == (rest of line, following lines). # Return: the matched keyword if found, otherwise 0 sub check_keyword { my $self = shift; $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } sub print_section { my $self = shift; # the "do" is required for right semantics do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; my $consumed_code = ''; print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", escape_file_for_line_directive($self->{filepathname}), "\"\n") if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { print "$_\n"; $consumed_code .= "$_\n"; } print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; return $consumed_code; } sub merge_section { my $self = shift; my $in = ''; while (!/\S/ && @{ $self->{line} }) { $_ = shift(@{ $self->{line} }); } for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { $in .= "$_\n"; } chomp $in; return $in; } sub process_keyword { my($self, $pattern) = @_; while (my $kwd = $self->check_keyword($pattern)) { my $method = $kwd . "_handler"; $self->$method($_); } } sub CASE_handler { my $self = shift; $_ = shift; $self->blurt("Error: 'CASE:' after unconditional 'CASE:'") if $self->{condnum} && $self->{cond} eq ''; $self->{cond} = $_; trim_whitespace($self->{cond}); print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); $_ = ''; } sub INPUT_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { last if /^\s*NOT_IMPLEMENTED_YET/; next unless /\S/; # skip blank lines trim_whitespace($_); my $ln = $_; # remove trailing semicolon if no initialisation s/\s*;$//g unless /[=;+].*\S/; # Process the length(foo) declarations if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; $self->{lengthof}->{$2} = undef; $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; } # check for optional initialisation code my $var_init = ''; $var_init = $1 if s/\s*([=;+].*)$//s; $var_init =~ s/"/\\"/g; # *sigh* It's valid to supply explicit input typemaps in the argument list... my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; s/\s+/ /g; my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or $self->blurt("Error: invalid argument declaration '$ln'"), next; # Check for duplicate definitions $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next if $self->{arg_list}->{$var_name}++ or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; $self->{thisdone} |= $var_name eq "THIS"; $self->{retvaldone} |= $var_name eq "RETVAL"; $self->{var_types}->{$var_name} = $var_type; # XXXX This check is a safeguard against the unfinished conversion of # generate_init(). When generate_init() is fixed, # one can use 2-args map_type() unconditionally. my $printed_name; if ($var_type =~ / \( \s* \* \s* \) /x) { # Function pointers are not yet supported with output_init()! print "\t" . map_type($self, $var_type, $var_name); $printed_name = 1; } else { print "\t" . map_type($self, $var_type, undef); $printed_name = 0; } $self->{var_num} = $self->{args_match}->{$var_name}; if ($self->{var_num}) { my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); $self->report_typemap_failure($self->{typemap}, $var_type, "death") if not $typemap and not $is_overridden_typemap; $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; } $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($printed_name) { print ";\n"; } else { print "\t$var_name;\n"; } } elsif ($var_init =~ /\S/) { $self->output_init( { type => $var_type, num => $self->{var_num}, var => $var_name, init => $var_init, printed_name => $printed_name, } ); } elsif ($self->{var_num}) { $self->generate_init( { type => $var_type, num => $self->{var_num}, var => $var_name, printed_name => $printed_name, } ); } else { print ";\n"; } } } sub OUTPUT_handler { my $self = shift; $self->{have_OUTPUT} = 1; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); next; } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next if $self->{outargs}->{$outarg}++; if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { # deal with RETVAL last $self->{RETVAL_code} = $outcode; $self->{gotRETVAL} = 1; next; } $self->blurt("Error: OUTPUT $outarg not an argument"), next unless defined($self->{args_match}->{$outarg}); $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $self->{var_types}->{$outarg}; $self->{var_num} = $self->{args_match}->{$outarg}; if ($outcode) { print "\t$outcode\n"; print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; } else { $self->generate_output( { type => $self->{var_types}->{$outarg}, num => $self->{var_num}, var => $outarg, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ); } delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; } } sub C_ARGS_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); $self->{func_args} = $in; } sub INTERFACE_MACRO_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); if ($in =~ /\s/) { # two ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; } else { $self->{interface_macro} = $in; $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later } $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub INTERFACE_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); foreach (split /[\s,]+/, $in) { my $iface_name = $_; $iface_name =~ s/^$self->{Prefix}//; $self->{Interfaces}->{$iface_name} = $_; } print Q(<<"EOF"); # XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); EOF $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub CLEANUP_handler { my $self = shift; $self->print_section(); } sub PREINIT_handler { my $self = shift; $self->print_section(); } sub POSTCALL_handler { my $self = shift; $self->print_section(); } sub INIT_handler { my $self = shift; $self->print_section(); } sub get_aliases { my $self = shift; my ($line) = @_; my ($orig) = $line; # Parse alias definitions # format is # alias = value alias = value ... while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { my ($alias, $value) = ($1, $2); my $orig_alias = $alias; # check for optional package definition in the alias $alias = $self->{Packprefix} . $alias if $alias !~ /::/; # check for duplicate alias name & duplicate value Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") if defined $self->{XsubAliases}->{$alias}; Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") if $self->{XsubAliasValues}->{$value}; $self->{XsubAliases}->{$alias} = $value; $self->{XsubAliasValues}->{$value} = $orig_alias; } blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") if $line; } sub ATTRS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); push @{ $self->{Attributes} }, $_; } } sub ALIAS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); $self->get_aliases($_) if $_; } } sub OVERLOAD_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$self->{Package}\::(".$1; push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } } sub FALLBACK_handler { my ($self, $setting) = @_; # the rest of the current line should contain either TRUE, # FALSE or UNDEF trim_whitespace($setting); $setting = uc($setting); my %map = ( TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", FALSE => "&PL_sv_no", 0 => "&PL_sv_no", UNDEF => "&PL_sv_undef", ); # check for valid FALLBACK value $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; $self->{Fallback} = $map{$setting}; } sub REQUIRE_handler { # the rest of the current line should contain a version number my ($self, $ver) = @_; trim_whitespace($ver); $self->death("Error: REQUIRE expects a version number") unless $ver; # check that the version number is of the form n.n $self->death("Error: REQUIRE: expected a number, got '$ver'") unless $ver =~ /^\d+(\.\d*)?/; $self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.") unless $VERSION >= $ver; } sub VERSIONCHECK_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; } sub PROTOTYPE_handler { my $self = shift; $_ = shift; my $specified; $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") if $self->{proto_in_this_xsub}++; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; $specified = 1; trim_whitespace($_); if ($_ eq 'DISABLE') { $self->{ProtoThisXSUB} = 0; } elsif ($_ eq 'ENABLE') { $self->{ProtoThisXSUB} = 1; } else { # remove any whitespace s/\s+//g; $self->death("Error: Invalid prototype '$_'") unless valid_proto_string($_); $self->{ProtoThisXSUB} = C_string($_); } } # If no prototype specified, then assume empty prototype "" $self->{ProtoThisXSUB} = 2 unless $specified; $self->{ProtoUsed} = 1; } sub SCOPE_handler { # Rest of line should be either ENABLE or DISABLE my ($self, $setting) = @_; $self->death("Error: Only 1 SCOPE declaration allowed per xsub") if $self->{scope_in_this_xsub}++; trim_whitespace($setting); $self->death("Error: SCOPE: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)\b/i; $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); } sub PROTOTYPES_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: PROTOTYPES: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; $self->{ProtoUsed} = 1; } sub EXPORT_XSUB_SYMBOLS_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; print Q(<<"EOF"); ##undef XS_EUPXS ##if defined(PERL_EUPXS_ALWAYS_EXPORT) ## define XS_EUPXS(name) XS_EXTERNAL(name) ##elif defined(PERL_EUPXS_NEVER_EXPORT) ## define XS_EUPXS(name) XS_INTERNAL(name) ##else ## define XS_EUPXS(name) $xs_impl(name) ##endif EOF } sub PushXSStack { my $self = shift; my %args = @_; # Save the current file context. push(@{ $self->{XSStack} }, { type => 'file', LastLine => $self->{lastline}, LastLineNo => $self->{lastline_no}, Line => $self->{line}, LineNo => $self->{line_no}, Filename => $self->{filename}, Filepathname => $self->{filepathname}, Handle => $self->{FH}, IsPipe => scalar($self->{filename} =~ /\|\s*$/), %args, }); } sub INCLUDE_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid filename trim_whitespace($_); $self->death("INCLUDE: filename missing") unless $_; $self->death("INCLUDE: output pipe is illegal") if /^\s*\|/; # simple minded recursion detector $self->death("INCLUDE loop detected") if $self->{IncludedFiles}->{$_}; ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; if (/\|\s*$/ && /^\s*perl\s/) { Warn( $self, "The INCLUDE directive with a command is discouraged." . " Use INCLUDE_COMMAND instead! In particular using 'perl'" . " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . " up the correct perl. The INCLUDE_COMMAND directive allows" . " the use of \$^X as the currently running perl, see" . " 'perldoc perlxs' for details."); } $self->PushXSStack(); $self->{FH} = Symbol::gensym(); # open the new file open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); print Q(<<"EOF"); # #/* INCLUDE: Including '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = ( $^O =~ /^mswin/i ) ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? : File::Spec->catfile($self->{dir}, $self->{filename}); # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub QuoteArgs { my $cmd = shift; my @args = split /\s+/, $cmd; $cmd = shift @args; for (@args) { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; } return join (' ', ($cmd, @args)); } # code copied from CPAN::HandleConfig::safe_quote # - that has doc saying leave if start/finish with same quote, but no code # given text, will conditionally quote it to protect from shell { my ($quote, $use_quote) = $^O eq 'MSWin32' ? (q{"}, q{"}) : (q{"'}, q{'}); sub _safe_quote { my ($self, $command) = @_; # Set up quote/default quote if (defined($command) and $command =~ /\s/ and $command !~ /[$quote]/) { return qq{$use_quote$command$use_quote} } return $command; } } sub INCLUDE_COMMAND_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid command trim_whitespace($_); $_ = QuoteArgs($_) if $^O eq 'VMS'; $self->death("INCLUDE_COMMAND: command missing") unless $_; $self->death("INCLUDE_COMMAND: pipes are illegal") if /^\s*\|/ or /\|\s*$/; $self->PushXSStack( IsPipe => 1 ); $self->{FH} = Symbol::gensym(); # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be # the same perl interpreter as we're currently running my $X = $self->_safe_quote($^X); # quotes if has spaces s/^\s*\$\^X/$X/; # open the new file open ($self->{FH}, "-|", $_) or $self->death( $self, "Cannot run command '$_' to include its output: $!"); print Q(<<"EOF"); # #/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = $self->{filename}; #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub PopFile { my $self = shift; return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; my $data = pop @{ $self->{XSStack} }; my $ThisFile = $self->{filename}; my $isPipe = $data->{IsPipe}; --$self->{IncludedFiles}->{$self->{filename}} unless $isPipe; close $self->{FH}; $self->{FH} = $data->{Handle}; # $filename is the leafname, which for some reason is used for diagnostic # messages, whereas $filepathname is the full pathname, and is used for # #line directives. $self->{filename} = $data->{Filename}; $self->{filepathname} = $data->{Filepathname}; $self->{lastline} = $data->{LastLine}; $self->{lastline_no} = $data->{LastLineNo}; @{ $self->{line} } = @{ $data->{Line} }; @{ $self->{line_no} } = @{ $data->{LineNo} }; if ($isPipe and $? ) { --$self->{lastline_no}; print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; exit 1; } print Q(<<"EOF"); # #/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ # EOF return 1; } sub Q { my($text) = @_; $text =~ s/^#//gm; $text =~ s/\[\[/{/g; $text =~ s/\]\]/}/g; $text; } # Process "MODULE = Foo ..." lines and update global state accordingly sub _process_module_xs_line { my ($self, $module, $pkg, $prefix) = @_; ($self->{Module_cname} = $module) =~ s/\W/_/g; $self->{Package} = defined($pkg) ? $pkg : ''; $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); ($self->{Packid} = $self->{Package}) =~ tr/:/_/; $self->{Packprefix} = $self->{Package}; $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; $self->{lastline} = ""; } # Skip any embedded POD sections sub _maybe_skip_pod { my ($self) = @_; while ($self->{lastline} =~ /^=/) { while ($self->{lastline} = readline($self->{FH})) { last if ($self->{lastline} =~ /^=cut\s*$/); } $self->death("Error: Unterminated pod") unless defined $self->{lastline}; $self->{lastline} = readline($self->{FH}); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } } # This chunk of code strips out (and parses) embedded TYPEMAP blocks # which support a HEREdoc-alike block syntax. sub _maybe_parse_typemap_block { my ($self) = @_; # This is special cased from the usual paragraph-handler logic # due to the HEREdoc-ish syntax. if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) { my $end_marker = quotemeta(defined($1) ? $2 : $3); # Scan until we find $end_marker alone on a line. my @tmaplines; while (1) { $self->{lastline} = readline($self->{FH}); $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; last if $self->{lastline} =~ /^$end_marker\s*$/; push @tmaplines, $self->{lastline}; } my $tmap = ExtUtils::Typemaps->new( string => join("", @tmaplines), lineno_offset => 1 + ($self->current_line_number() || 0), fake_filename => $self->{filename}, ); $self->{typemap}->merge(typemap => $tmap, replace => 1); $self->{lastline} = ""; } } # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). sub fetch_para { my $self = shift; # parse paragraph $self->death("Error: Unterminated '#if/#ifdef/#ifndef'") if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; @{ $self->{line} } = (); @{ $self->{line_no} } = (); return $self->PopFile() if not defined $self->{lastline}; # EOF if ($self->{lastline} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { $self->_process_module_xs_line($1, $2, $3); } for (;;) { $self->_maybe_skip_pod; $self->_maybe_parse_typemap_block; if ($self->{lastline} !~ /^\s*#/ # not a CPP directive # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef # line error pragma # gcc: warning include_next # obj-c: import # others: ident (gcc notes that some cpps have this one) || $self->{lastline} =~ /^\#[ \t]* (?: (?:if|ifn?def|elif|else|endif| define|undef|pragma|error| warning|line\s+\d+|ident) \b | (?:include(?:_next)?|import) \s* ["<] .* [>"] ) /x ) { last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; push(@{ $self->{line} }, $self->{lastline}); push(@{ $self->{line_no} }, $self->{lastline_no}); } # Read next line and continuation lines last unless defined($self->{lastline} = readline($self->{FH})); $self->{lastline_no} = $.; my $tmp_line; $self->{lastline} .= $tmp_line while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } # Nuke trailing "line" entries until there's one that's not empty pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq ""; return 1; } sub output_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $init, $printed_name) = @{$argsref}{qw(type num var init printed_name)}; # local assign for efficiently passing in to eval_input_typemap_code local $argsref->{arg} = $num ? "ST(" . ($num-1) . ")" : "/* not a parameter */"; if ( $init =~ /^=/ ) { if ($printed_name) { $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); } else { $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); } } else { if ( $init =~ s/^\+// && $num ) { $self->generate_init( { type => $type, num => $num, var => $var, printed_name => $printed_name, } ); } elsif ($printed_name) { print ";\n"; $init =~ s/^;//; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); $init =~ s/^;//; } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); } } sub generate_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $printed_name) = @{$argsref}{qw(type num var printed_name)}; my $argoff = $num - 1; my $arg = "ST($argoff)"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); if (not $typemaps->get_typemap(ctype => $type)) { $self->report_typemap_failure($typemaps, $type); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $typem = $typemaps->get_typemap(ctype => $type); my $xstype = $typem->xstype; #this is an optimization from perl 5.0 alpha 6, class check is skipped #T_REF_IV_REF is missing since it has no untyped analog at the moment $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ if $self->{func_name} =~ /DESTROY$/; if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { print "\t$var" unless $printed_name; print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; die "default value not supported with length(NAME) supplied" if defined $self->{defaults}->{$var}; return; } $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; my $inputmap = $typemaps->get_inputmap(xstype => $xstype); if (not defined $inputmap) { $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); return; } my $expr = $inputmap->cleaned_code; # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); if (not $subinputmap) { $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $subinputmap->cleaned_code; $subexpr =~ s/\$type/\$subtype/g; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\n\t/\n\t\t/g; $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; $subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/; $expr =~ s/DO_ARRAY_ELEM/$subexpr/; } if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments $self->{ScopeThisXSUB} = 1; } my $eval_vars = { var => $var, printed_name => $printed_name, type => $type, ntype => $ntype, subtype => $subtype, num => $num, arg => $arg, argoff => $argoff, }; if (defined($self->{defaults}->{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } if ($self->{defaults}->{$var} eq 'NO_INIT') { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } else { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } } elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); } else { die "panic: do not know how to handle this branch for function pointers" if $printed_name; $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); } } sub generate_output { my $self = shift; my $argsref = shift; my ($type, $num, $var, $do_setmagic, $do_push) = @{$argsref}{qw(type num var do_setmagic do_push)}; my $arg = "ST(" . ($num - ($num != 0)) . ")"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); local $argsref->{type} = $type; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\t$arg = sv_newmortal();\n"; print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { my $typemap = $typemaps->get_typemap(ctype => $type); if (not $typemap) { $self->report_typemap_failure($typemaps, $type); return; } my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); if (not $outputmap) { $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; my $expr = $outputmap->cleaned_code; if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); if (not $suboutputmap) { $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $suboutputmap->cleaned_code; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\$var/${var}\[ix_$var]/g; $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { my $orig_arg = $arg; my $indent; my $use_RETVALSV = 1; my $do_mortal = 0; my $do_copy_tmp = 1; my $pre_expr; local $eval_vars->{arg} = $arg = 'RETVALSV'; my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); if ($expr =~ /^\t\Q$arg\E = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. $do_mortal = 1; } # If RETVAL is immortal, don't mortalize it. This code is not perfect: # It won't detect a func or expression that only returns immortals, for # example, this RE must be tried before next elsif. elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV $use_RETVALSV = 0; } elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { # We expect that $arg has refcnt >=1, so we need # to mortalize it! $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block $do_mortal = 1; } else { # Just hope that the entry would safely write it # over an already mortalized value. By # coincidence, something like $arg = &PL_sv_undef # works too, but should be caught above. $pre_expr = "RETVALSV = sv_newmortal();\n"; # new mortals don't have set magic $do_setmagic = 0; } if($use_RETVALSV) { print "\t{\n\t SV * RETVALSV;\n"; $indent = "\t "; } else { $indent = "\t"; } print $indent.$pre_expr if $pre_expr; if($use_RETVALSV) { #take control of 1 layer of indent, may or may not indent more $evalexpr =~ s/^(\t| )/$indent/gm; #"\t \t" doesn't draw right in some IDEs #break down all \t into spaces $evalexpr =~ s/\t/ /g; #rebuild back into \t'es, \t==8 spaces, indent==4 spaces $evalexpr =~ s/ /\t/g; } else { if($do_mortal || $do_setmagic) { #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code } else { #if no extra boilerplate (no mortal, no set magic) is needed #after $evalexport, get rid of RETVALSV's visual cluter and change $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) } } #stop " RETVAL = RETVAL;" for SVPtr type print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" if $do_mortal || $do_setmagic || $do_copy_tmp; print "\t}\n" if $use_RETVALSV; } elsif ($do_push) { print "\tPUSHs(sv_newmortal());\n"; local $eval_vars->{arg} = "ST($num)"; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } elsif ($arg =~ /^ST\(\d+\)$/) { $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } # Just delegates to a clean package. # Shim to evaluate Perl code in the right variable context # for typemap code (having things such as $ALIAS set up). sub eval_output_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); } sub eval_input_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); } 1; # vim: ts=2 sw=2 et: ExtUtils-ParseXS-3.30/lib/ExtUtils/xsubpp0000644000175000017500000001165112207702337017027 0ustar tseetsee#!perl use 5.006; use strict; eval { require ExtUtils::ParseXS; 1; } or do { my $err = $@ || 'Zombie error'; my $v = $ExtUtils::ParseXS::VERSION; $v = '' if not defined $v; die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err"; }; use Getopt::Long; my %args = (); my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n"; Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case); @ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility GetOptions(\%args, qw(hiertype! prototypes! versioncheck! linenumbers! optimize! inout! argtypes! object_capi! except! v typemap=s@ output=s s|strip=s csuffix=s )) or die $usage; if ($args{v}) { print "xsubpp version $ExtUtils::ParseXS::VERSION\n"; exit; } @ARGV == 1 or die $usage; $args{filename} = shift @ARGV; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file(%args); exit( $pxs->report_error_count() ? 1 : 0 ); __END__ =head1 NAME xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS B [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs =head1 DESCRIPTION This compiler is typically run by the makefiles created by L or by L or other Perl module build tools. I will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to determine how to map C function parameters and variables to Perl values. The compiler will search for typemap files called I. It will use the following search path to find default typemaps, with the rightmost typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap It will also use a default typemap installed as C. =head1 OPTIONS Note that the C MakeMaker option may be used to add these options to any makefiles generated by MakeMaker. =over 5 =item B<-hiertype> Retains '::' in type names so that C++ hierarchical types can be mapped. =item B<-except> Adds exception handling stubs to the C code. =item B<-typemap typemap> Indicates that a user-supplied typemap should take precedence over the default typemaps. This option may be used multiple times, with the last typemap having the highest precedence. =item B<-output filename> Specifies the name of the output file to generate. If no file is specified, output will be written to standard output. =item B<-v> Prints the I version number to standard output, then exits. =item B<-prototypes> By default I will not automatically generate prototype code for all xsubs. This flag will enable prototypes. =item B<-noversioncheck> Disables the run time test that determines if the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. =item B<-nolinenumbers> Prevents the inclusion of '#line' directives in the output. =item B<-nooptimize> Disables certain optimizations. The only optimization that is currently affected is the use of Is by the output C code (see L). This may significantly slow down the generated code, but this is the way B of 5.005 and earlier operated. =item B<-noinout> Disable recognition of C, C and C declarations. =item B<-noargtypes> Disable recognition of ANSI-like descriptions of function signature. =item B<-C++> Currently doesn't do anything at all. This flag has been a no-op for many versions of perl, at least as far back as perl5.003_07. It's allowed here for backwards compatibility. =item B<-s=...> or B<-strip=...> I If specified, the given string will be stripped off from the beginning of the C function name in the generated XS functions (if it starts with that prefix). This only applies to XSUBs without C or C blocks. For example, the XS: void foo_bar(int i); when C is invoked with C<-s foo_> will install a C function in Perl, but really call C in C. Most of the time, this is the opposite of what you want and failure modes are somewhat obscure, so please avoid this option where possible. =back =head1 ENVIRONMENT No environment variables are used. =head1 AUTHOR Originally by Larry Wall. Turned into the C module by Ken Williams. =head1 MODIFICATION HISTORY See the file F. =head1 SEE ALSO perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS =cut ExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps/0000755000175000017500000000000012571011400017345 5ustar tseetseeExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps/OutputMap.pm0000644000175000017500000001051412571011044021646 0ustar tseetseepackage ExtUtils::Typemaps::OutputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.30'; =head1 NAME ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $output = $typemap->get_output_map('T_NV'); my $code = $output->code(); $output->code("..."); =head1 DESCRIPTION Refer to L for details. =head1 METHODS =cut =head2 new Requires C and C parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the OUTPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the OUTPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head2 targetable This is an obscure but effective optimization that used to live in C directly. Not implementing it should never result in incorrect use of typemaps, just less efficient code. In a nutshell, this will check whether the output code involves calling C, C, C, C or C to set the special C<$arg> placeholder to a new value B. If that is the case, the code is eligible for using the C-related macros to optimize this. Thus the name of the method: C. If this optimization is applicable, C will emit a C definition at the start of the generated XSUB code, and type (see below) dependent code to set C and push it on the stack at the end of the generated XSUB code. If the optimization can not be applied, this returns undef. If it can be applied, this method returns a hash reference containing the following information: type: Any of the characters i, u, n, p with_size: Bool indicating whether this is the sv_setpvn variant what: The code that actually evaluates to the output scalar what_size: If "with_size", this has the string length (as code, not constant, including leading comma) =cut sub targetable { my $self = shift; return $self->{targetable} if exists $self->{targetable}; our $bal; # ()-balanced $bal = qr[ (?: (?>[^()]+) | \( (??{ $bal }) \) )* ]x; my $bal_no_comma = 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 }) ]xo; my $code = $self->code; # 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) = ($code =~ m[^ \s+ sv_set([iunp])v(n)? # Type, is_setpvn \s* \( \s* $sv_cast \$arg \s* , \s* ( $bal_no_comma ) # Set from ( $size )? # Possible sizeof set-from \s* \) \s* ; \s* $ ]xo ); my $rv = undef; if ($type) { $rv = { type => $type, with_size => $with_size, what => $arg, what_size => $sarg, }; } $self->{targetable} = $rv; return $rv; } =head1 SEE ALSO L =head1 AUTHOR Steffen Mueller C<> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps/Cmd.pm0000644000175000017500000001004512571011027020413 0ustar tseetseepackage ExtUtils::Typemaps::Cmd; use 5.006001; use strict; use warnings; our $VERSION = '3.30'; use ExtUtils::Typemaps; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(embeddable_typemap); our %EXPORT_TAGS = (all => \@EXPORT); sub embeddable_typemap { my @tms = @_; # Get typemap objects my @tm_objs = map [$_, _intuit_typemap_source($_)], @tms; # merge or short-circuit my $final_tm; if (@tm_objs == 1) { # just one, merge would be pointless $final_tm = shift(@tm_objs)->[1]; } else { # multiple, need merge $final_tm = ExtUtils::Typemaps->new; foreach my $other_tm (@tm_objs) { my ($tm_ident, $tm_obj) = @$other_tm; eval { $final_tm->merge(typemap => $tm_obj); 1 } or do { my $err = $@ || 'Zombie error'; die "Failed to merge typ"; } } } # stringify for embedding return $final_tm->as_embedded_typemap(); } sub _load_module { my $name = shift; return eval "require $name; 1"; } SCOPE: { my %sources = ( module => sub { my $ident = shift; my $tm; if (/::/) { # looks like FQ module name, try that first foreach my $module ($ident, "ExtUtils::Typemaps::$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } else { foreach my $module ("ExtUtils::Typemaps::$ident", "$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } return(); }, file => sub { my $ident = shift; return unless -e $ident and -r _; return ExtUtils::Typemaps->new(file => $ident); }, ); # Try to find typemap either from module or file sub _intuit_typemap_source { my $identifier = shift; my @locate_attempts; if ($identifier =~ /::/ || $identifier !~ /[^\w_]/) { @locate_attempts = qw(module file); } else { @locate_attempts = qw(file module); } foreach my $source (@locate_attempts) { my $tm = $sources{$source}->($identifier); return $tm if defined $tm; } die "Unable to find typemap for '$identifier': " . "Tried to load both as file or module and failed.\n"; } } # end SCOPE =head1 NAME ExtUtils::Typemaps::Cmd - Quick commands for handling typemaps =head1 SYNOPSIS From XS: INCLUDE_COMMAND: $^X -MExtUtils::Typemaps::Cmd \ -e "print embeddable_typemap(q{Excommunicated})" Loads C, instantiates an object, and dumps it as an embeddable typemap for use directly in your XS file. =head1 DESCRIPTION This is a helper module for L for quick one-liners, specifically for inclusion of shared typemaps that live on CPAN into an XS file (see SYNOPSIS). For this reason, the following functions are exported by default: =head1 EXPORTED FUNCTIONS =head2 embeddable_typemap Given a list of identifiers, C tries to load typemaps from a file of the given name(s), or from a module that is an C subclass. Returns a string representation of the merged typemaps that can be included verbatim into XS. Example: print embeddable_typemap( "Excommunicated", "ExtUtils::Typemaps::Basic", "./typemap" ); This will try to load a module C and use it as an C subclass. If that fails, it'll try loading C as a module, if that fails, it'll try to read a file called F. It'll work similarly for the second argument, but the third will be loaded as a file first. After loading all typemap files or modules, it will merge them in the specified order and dump the result as an embeddable typemap. =head1 SEE ALSO L L =head1 AUTHOR Steffen Mueller C<> =head1 COPYRIGHT & LICENSE Copyright 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps/Type.pm0000644000175000017500000000404512571011047020636 0ustar tseetseepackage ExtUtils::Typemaps::Type; use 5.006001; use strict; use warnings; require ExtUtils::Typemaps; our $VERSION = '3.30'; =head1 NAME ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $type = $typemap->get_type_map('char*'); my $input = $typemap->get_input_map($type->xstype); =head1 DESCRIPTION Refer to L for details. Object associates C with C, which is the index into the in- and output mapping tables. =head1 METHODS =cut =head2 new Requires C and C parameters. Optionally takes C parameter. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{ctype}) { die("Need xstype and ctype parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {proto => ''}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{ctype} = $args{ctype} if defined $args{ctype}; $self->{tidy_ctype} = ExtUtils::Typemaps::tidy_type($self->{ctype}); $self->{proto} = $args{'prototype'} if defined $args{'prototype'}; return $self; } =head2 proto Returns or sets the prototype. =cut sub proto { $_[0]->{proto} = $_[1] if @_ > 1; return $_[0]->{proto}; } =head2 xstype Returns the name of the XS type that this C type is associated to. =cut sub xstype { return $_[0]->{xstype}; } =head2 ctype Returns the name of the C type as it was set on construction. =cut sub ctype { return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype}; } =head2 tidy_ctype Returns the canonicalized name of the C type. =cut sub tidy_ctype { return $_[0]->{tidy_ctype}; } =head1 SEE ALSO L =head1 AUTHOR Steffen Mueller C<> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps/InputMap.pm0000644000175000017500000000364212571011034021450 0ustar tseetseepackage ExtUtils::Typemaps::InputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.30'; =head1 NAME ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $input = $typemap->get_input_map('T_NV'); my $code = $input->code(); $input->code("..."); =head1 DESCRIPTION Refer to L for details. =head1 METHODS =cut =head2 new Requires C and C parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the INPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the INPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; $code =~ s/(?:;+\s*|;*\s+)\z//s; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head1 SEE ALSO L =head1 AUTHOR Steffen Mueller C<> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; ExtUtils-ParseXS-3.30/lib/ExtUtils/Typemaps.pm0000644000175000017500000006427012571011024017716 0ustar tseetseepackage ExtUtils::Typemaps; use 5.006001; use strict; use warnings; our $VERSION = '3.30'; require ExtUtils::ParseXS; require ExtUtils::ParseXS::Constants; require ExtUtils::Typemaps::InputMap; require ExtUtils::Typemaps::OutputMap; require ExtUtils::Typemaps::Type; =head1 NAME ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files =head1 SYNOPSIS # read/create file my $typemap = ExtUtils::Typemaps->new(file => 'typemap'); # alternatively create an in-memory typemap # $typemap = ExtUtils::Typemaps->new(); # alternatively create an in-memory typemap by parsing a string # $typemap = ExtUtils::Typemaps->new(string => $sometypemap); # add a mapping $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV'); $typemap->add_inputmap( xstype => 'T_NV', code => '$var = ($type)SvNV($arg);' ); $typemap->add_outputmap( xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);' ); $typemap->add_string(string => $typemapstring); # will be parsed and merged # remove a mapping (same for remove_typemap and remove_outputmap...) $typemap->remove_inputmap(xstype => 'SomeType'); # save a typemap to a file $typemap->write(file => 'anotherfile.map'); # merge the other typemap into this one $typemap->merge(typemap => $another_typemap); =head1 DESCRIPTION This module can read, modify, create and write Perl XS typemap files. If you don't know what a typemap is, please confer the L and L manuals. The module is not entirely round-trip safe: For example it currently simply strips all comments. The order of entries in the maps is, however, preserved. We check for duplicate entries in the typemap, but do not check for missing C entries for C or C entries since these might be hidden in a different typemap. =head1 METHODS =cut =head2 new Returns a new typemap object. Takes an optional C parameter. If set, the given file will be read. If the file doesn't exist, an empty typemap is returned. Alternatively, if the C parameter is given, the supplied string will be parsed instead of a file. =cut sub new { my $class = shift; my %args = @_; if (defined $args{file} and defined $args{string}) { die("Cannot handle both 'file' and 'string' arguments to constructor"); } my $self = bless { file => undef, %args, typemap_section => [], typemap_lookup => {}, input_section => [], input_lookup => {}, output_section => [], output_lookup => {}, } => $class; $self->_init(); return $self; } sub _init { my $self = shift; if (defined $self->{string}) { $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); delete $self->{string}; } elsif (defined $self->{file} and -e $self->{file}) { open my $fh, '<', $self->{file} or die "Cannot open typemap file '" . $self->{file} . "' for reading: $!"; local $/ = undef; my $string = <$fh>; $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); } } =head2 file Get/set the file that the typemap is written to when the C method is called. =cut sub file { $_[0]->{file} = $_[1] if @_ > 1; $_[0]->{file} } =head2 add_typemap Add a C entry to the typemap. Required named arguments: The C (e.g. C 'double'>) and the C (e.g. C 'T_NV'>). Optional named arguments: C 1> forces removal/replacement of existing C entries of the same C. C 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C object as first argument, a copy of which will be added to the typemap. In that case, only the C or C named parameters may be used after the object. Example: $map->add_typemap($type_obj, replace => 1); =cut sub add_typemap { my $self = shift; my $type; my %args; if ((@_ % 2) == 1) { my $orig = shift; $type = $orig->new(); %args = @_; } else { %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; $type = ExtUtils::Typemaps::Type->new( xstype => $xstype, 'prototype' => $args{'prototype'}, ctype => $ctype, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_typemap(ctype => $type->ctype); } elsif ($args{skip}) { return() if exists $self->{typemap_lookup}{$type->ctype}; } else { $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype); } # store push @{$self->{typemap_section}}, $type; # remember type for lookup, too. $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}}; return 1; } =head2 add_inputmap Add an C entry to the typemap. Required named arguments: The C (e.g. C 'T_NV'>) and the C to associate with it for input. Optional named arguments: C 1> forces removal/replacement of existing C entries of the same C. C 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C object as first argument, a copy of which will be added to the typemap. In that case, only the C or C named parameters may be used after the object. Example: $map->add_inputmap($type_obj, replace => 1); =cut sub add_inputmap { my $self = shift; my $input; my %args; if ((@_ % 2) == 1) { my $orig = shift; $input = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $input = ExtUtils::Typemaps::InputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_inputmap(xstype => $input->xstype); } elsif ($args{skip}) { return() if exists $self->{input_lookup}{$input->xstype}; } else { $self->validate(inputmap_xstype => $input->xstype); } # store push @{$self->{input_section}}, $input; # remember type for lookup, too. $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}}; return 1; } =head2 add_outputmap Add an C entry to the typemap. Works exactly the same as C. =cut sub add_outputmap { my $self = shift; my $output; my %args; if ((@_ % 2) == 1) { my $orig = shift; $output = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $output = ExtUtils::Typemaps::OutputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_outputmap(xstype => $output->xstype); } elsif ($args{skip}) { return() if exists $self->{output_lookup}{$output->xstype}; } else { $self->validate(outputmap_xstype => $output->xstype); } # store push @{$self->{output_section}}, $output; # remember type for lookup, too. $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}}; return 1; } =head2 add_string Parses a string as a typemap and merge it into the typemap object. Required named argument: C to specify the string to parse. =cut sub add_string { my $self = shift; my %args = @_; die("Need 'string' argument") if not defined $args{string}; # no, this is not elegant. my $other = ExtUtils::Typemaps->new(string => $args{string}); $self->merge(typemap => $other); } =head2 remove_typemap Removes a C entry from the typemap. Required named argument: C to specify the entry to remove from the typemap. Alternatively, you may pass a single C object. =cut sub remove_typemap { my $self = shift; my $ctype; if (@_ > 1) { my %args = @_; $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); } else { $ctype = $_[0]->tidy_ctype; } return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup}); } =head2 remove_inputmap Removes an C entry from the typemap. Required named argument: C to specify the entry to remove from the typemap. Alternatively, you may pass a single C object. =cut sub remove_inputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup}); } =head2 remove_inputmap Removes an C entry from the typemap. Required named argument: C to specify the entry to remove from the typemap. Alternatively, you may pass a single C object. =cut sub remove_outputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup}); } sub _remove { my $self = shift; my $rm = shift; my $array = shift; my $lookup = shift; # Just fetch the index of the item from the lookup table my $index = $lookup->{$rm}; return() if not defined $index; # Nuke the item from storage splice(@$array, $index, 1); # Decrement the storage position of all items thereafter foreach my $key (keys %$lookup) { if ($lookup->{$key} > $index) { $lookup->{$key}--; } } return(); } =head2 get_typemap Fetches an entry of the TYPEMAP section of the typemap. Mandatory named arguments: The C of the entry. Returns the C object for the entry if found. =cut sub get_typemap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); my $index = $self->{typemap_lookup}{$ctype}; return() if not defined $index; return $self->{typemap_section}[$index]; } =head2 get_inputmap Fetches an entry of the INPUT section of the typemap. Mandatory named arguments: The C of the entry or the C of the typemap that can be used to find the C. To wit, the following pieces of code are equivalent: my $type = $typemap->get_typemap(ctype => $ctype) my $input_map = $typemap->get_inputmap(xstype => $type->xstype); my $input_map = $typemap->get_inputmap(ctype => $ctype); Returns the C object for the entry if found. =cut sub get_inputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{input_lookup}{$xstype}; return() if not defined $index; return $self->{input_section}[$index]; } =head2 get_outputmap Fetches an entry of the OUTPUT section of the typemap. Mandatory named arguments: The C of the entry or the C of the typemap that can be used to resolve the C. (See above for an example.) Returns the C object for the entry if found. =cut sub get_outputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{output_lookup}{$xstype}; return() if not defined $index; return $self->{output_section}[$index]; } =head2 write Write the typemap to a file. Optionally takes a C argument. If given, the typemap will be written to the specified file. If not, the typemap is written to the currently stored file name (see C<-Efile> above, this defaults to the file it was read from if any). =cut sub write { my $self = shift; my %args = @_; my $file = defined $args{file} ? $args{file} : $self->file(); die("write() needs a file argument (or set the file name of the typemap using the 'file' method)") if not defined $file; open my $fh, '>', $file or die "Cannot open typemap file '$file' for writing: $!"; print $fh $self->as_string(); close $fh; } =head2 as_string Generates and returns the string form of the typemap. =cut sub as_string { my $self = shift; my $typemap = $self->{typemap_section}; my @code; push @code, "TYPEMAP\n"; foreach my $entry (@$typemap) { # type kind proto # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o push @code, $entry->ctype . "\t" . $entry->xstype . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n"; } my $input = $self->{input_section}; if (@$input) { push @code, "\nINPUT\n"; foreach my $entry (@$input) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } my $output = $self->{output_section}; if (@$output) { push @code, "\nOUTPUT\n"; foreach my $entry (@$output) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } return join '', @code; } =head2 as_embedded_typemap Generates and returns the string form of the typemap with the appropriate prefix around it for verbatim inclusion into an XS file as an embedded typemap. This will return a string like TYPEMAP: <as_string; my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END); my $icand = 0; my $cand_suffix = ""; while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) { $icand++; if ($icand == @ident_cand) { $icand = 0; ++$cand_suffix; } } my $marker = "$ident_cand[$icand]$cand_suffix"; return "TYPEMAP: <<$marker;\n$string\n$marker\n"; } =head2 merge Merges a given typemap into the object. Note that a failed merge operation leaves the object in an inconsistent state so clone it if necessary. Mandatory named arguments: Either C $another_typemap_obj> or C $path_to_typemap_file> but not both. Optional arguments: C 1> to force replacement of existing typemap entries without warning or C 1> to skip entries that exist already in the typemap. =cut sub merge { my $self = shift; my %args = @_; if (exists $args{typemap} and exists $args{file}) { die("Need {file} OR {typemap} argument. Not both!"); } elsif (not exists $args{typemap} and not exists $args{file}) { die("Need {file} or {typemap} argument!"); } my @params; push @params, 'replace' => $args{replace} if exists $args{replace}; push @params, 'skip' => $args{skip} if exists $args{skip}; my $typemap = $args{typemap}; if (not defined $typemap) { $typemap = ref($self)->new(file => $args{file}, @params); } # FIXME breaking encapsulation. Add accessor code. foreach my $entry (@{$typemap->{typemap_section}}) { $self->add_typemap( $entry, @params ); } foreach my $entry (@{$typemap->{input_section}}) { $self->add_inputmap( $entry, @params ); } foreach my $entry (@{$typemap->{output_section}}) { $self->add_outputmap( $entry, @params ); } return 1; } =head2 is_empty Returns a bool indicating whether this typemap is entirely empty. =cut sub is_empty { my $self = shift; return @{ $self->{typemap_section} } == 0 && @{ $self->{input_section} } == 0 && @{ $self->{output_section} } == 0; } =head2 list_mapped_ctypes Returns a list of the C types that are mappable by this typemap object. =cut sub list_mapped_ctypes { my $self = shift; return sort keys %{ $self->{typemap_lookup} }; } =head2 _get_typemap_hash Returns a hash mapping the C types to the XS types: { 'char **' => 'T_PACKEDARRAY', 'bool_t' => 'T_IV', 'AV *' => 'T_AVREF', 'InputStream' => 'T_IN', 'double' => 'T_DOUBLE', # ... } This is documented because it is used by C, but it's not intended for general consumption. May be removed at any time. =cut sub _get_typemap_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; } return \%rv; } =head2 _get_inputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding INPUT code: { 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) ', 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) ', 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { # ... } This is documented because it is used by C, but it's not intended for general consumption. May be removed at any time. =cut sub _get_inputmap_hash { my $self = shift; my $lookup = $self->{input_lookup}; my $storage = $self->{input_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_outputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding OUTPUT code: { 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); ', 'T_OUT' => ' { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv( $arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)) ); else $arg = &PL_sv_undef; } ', # ... } This is documented because it is used by C, but it's not intended for general consumption. May be removed at any time. =cut sub _get_outputmap_hash { my $self = shift; my $lookup = $self->{output_lookup}; my $storage = $self->{output_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_prototype_hash Returns a hash mapping the C types of the typemap to their corresponding prototypes. { 'char **' => '$', 'bool_t' => '$', 'AV *' => '$', 'InputStream' => '$', 'double' => '$', # ... } This is documented because it is used by C, but it's not intended for general consumption. May be removed at any time. =cut sub _get_prototype_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; } return \%rv; } # make sure that the provided types wouldn't collide with what's # in the object already. sub validate { my $self = shift; my %args = @_; if ( exists $args{ctype} and exists $self->{typemap_lookup}{tidy_type($args{ctype})} ) { die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); } if ( exists $args{inputmap_xstype} and exists $self->{input_lookup}{$args{inputmap_xstype}} ) { die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); } if ( exists $args{outputmap_xstype} and exists $self->{output_lookup}{$args{outputmap_xstype}} ) { die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); } return 1; } =head2 clone Creates and returns a clone of a full typemaps object. Takes named parameters: If C is true, the clone will share the actual individual type/input/outputmap objects, but not share their storage. Use with caution. Without C, the clone will be fully independent. =cut sub clone { my $proto = shift; my %args = @_; my $self; if ($args{shallow}) { $self = bless( { %$proto, typemap_section => [@{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [@{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [@{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } else { $self = bless( { %$proto, typemap_section => [map $_->new, @{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [map $_->new, @{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [map $_->new, @{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } return $self; } =head2 tidy_type Function to (heuristically) canonicalize a C type. Works to some degree with C++ types. $halfway_canonical_type = tidy_type($ctype); Moved from C. =cut sub tidy_type { local $_ = shift; # 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 ; # trim leading & trailing whitespace s/^\s+//; s/\s+$//; # change multiple whitespace into a single space s/\s+/ /g; $_; } sub _parse { my $self = shift; my $stringref = shift; my $lineno_offset = shift; $lineno_offset = 0 if not defined $lineno_offset; my $filename = shift; $filename = '' if not defined $filename; my $replace = $self->{replace}; my $skip = $self->{skip}; die "Can only replace OR skip" if $replace and $skip; my @add_params; push @add_params, replace => 1 if $replace; push @add_params, skip => 1 if $skip; # TODO comments should round-trip, currently ignoring # TODO order of sections, multiple sections of same type # Heavily influenced by ExtUtils::ParseXS my $section = 'typemap'; my $lineno = $lineno_offset; my $junk = ""; my $current = \$junk; my @input_expr; my @output_expr; while ($$stringref =~ /^(.*)$/gcm) { local $_ = $1; ++$lineno; chomp; next if /^\s*#/; if (/^INPUT\s*$/) { $section = 'input'; $current = \$junk; next; } elsif (/^OUTPUT\s*$/) { $section = 'output'; $current = \$junk; next; } elsif (/^TYPEMAP\s*$/) { $section = 'typemap'; $current = \$junk; next; } if ($section eq 'typemap') { my $line = $_; s/^\s+//; s/\s+$//; next if $_ eq '' or /^#/; my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; # prototype defaults to '$' $proto = '$' unless $proto; warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") unless _valid_proto_string($proto); $self->add_typemap( ExtUtils::Typemaps::Type->new( xstype => $kind, proto => $proto, ctype => $type ), @add_params ); } elsif (/^\s/) { s/\s+$//; $$current .= $$current eq '' ? $_ : "\n".$_; } elsif ($_ eq '') { next; } elsif ($section eq 'input') { s/\s+$//; push @input_expr, {xstype => $_, code => ''}; $current = \$input_expr[-1]{code}; } else { # output section s/\s+$//; push @output_expr, {xstype => $_, code => ''}; $current = \$output_expr[-1]{code}; } } # end while lines foreach my $inexpr (@input_expr) { $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); } foreach my $outexpr (@output_expr) { $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); } return 1; } # taken from ExtUtils::ParseXS sub _valid_proto_string { my $string = shift; if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { return $string; } return 0 ; } # taken from ExtUtils::ParseXS (C_string) sub _escape_backslashes { my $string = shift; $string =~ s[\\][\\\\]g; $string; } =head1 CAVEATS Inherits some evil code from C. =head1 SEE ALSO The parser is heavily inspired from the one in L. For details on typemaps: L, L. =head1 AUTHOR Steffen Mueller C<> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012, 2013 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; ExtUtils-ParseXS-3.30/MANIFEST0000644000175000017500000000302412571011400014344 0ustar tseetseeChanges INSTALL lib/ExtUtils/ParseXS.pm lib/ExtUtils/ParseXS.pod lib/ExtUtils/ParseXS/Constants.pm lib/ExtUtils/ParseXS/CountLines.pm lib/ExtUtils/ParseXS/Eval.pm lib/ExtUtils/ParseXS/Utilities.pm lib/ExtUtils/Typemaps.pm lib/ExtUtils/Typemaps/Cmd.pm lib/ExtUtils/Typemaps/InputMap.pm lib/ExtUtils/Typemaps/OutputMap.pm lib/ExtUtils/Typemaps/Type.pm lib/ExtUtils/xsubpp Makefile.PL MANIFEST This list of files README t/001-basic.t t/002-more.t t/003-usage.t t/101-standard_typemap_locations.t t/102-trim_whitespace.t t/103-tidy_type.t t/104-map_type.t t/105-valid_proto_string.t t/106-process_typemaps.t t/108-map_type.t t/109-standard_XS_defs.t t/110-assign_func_args.t t/111-analyze_preprocessor_statements.t t/112-set_cond.t t/113-check_cond_preproc_statements.t t/114-blurt_death_Warn.t t/115-avoid-noise.t t/501-t-compile.t t/510-t-bare.t t/511-t-whitespace.t t/512-t-file.t t/513-t-merge.t t/514-t-embed.t t/515-t-cmd.t t/516-t-clone.t t/517-t-targetable.t t/600-t-compat.t t/data/b.typemap t/data/combined.typemap t/data/confl_repl.typemap t/data/confl_skip.typemap t/data/conflicting.typemap t/data/other.typemap t/data/perl.typemap t/data/simple.typemap t/lib/ExtUtils/Typemaps/Test.pm t/lib/IncludeTester.pm t/lib/PrimitiveCapture.pm t/lib/TypemapTest/Foo.pm t/pseudotypemap1 t/typemap t/XSInclude.xsh t/XSMore.xs t/XSTest.pm t/XSTest.xs t/XSUsage.pm t/XSUsage.xs t/XSWarn.xs META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) ExtUtils-ParseXS-3.30/t/0000755000175000017500000000000012571011400013457 5ustar tseetseeExtUtils-ParseXS-3.30/t/XSTest.xs0000644000175000017500000000231612162346264015246 0ustar tseetsee#include "EXTERN.h" #include "perl.h" #include "XSUB.h" void xstest_something (char * some_thing) { some_thing = some_thing; } void xstest_something2 (char * some_thing) { some_thing = some_thing; } MODULE = XSTest PACKAGE = XSTest PREFIX = xstest_ PROTOTYPES: DISABLE int is_even(input) int input CODE: RETVAL = (input % 2 == 0); OUTPUT: RETVAL void xstest_something (myclass, some_thing) char * some_thing C_ARGS: some_thing void xstest_something2 (some_thing) char * some_thing void xstest_something3 (myclass, some_thing) SV * myclass char * some_thing PREINIT: int i = 0; PPCODE: /* it's up to us clear these warnings */ myclass = myclass; some_thing = some_thing; i = i; XSRETURN_UNDEF; int consts (myclass) SV * myclass ALIAS: const_one = 1 const_two = 2 const_three = 3 CODE: /* it's up to us clear these warnings */ myclass = myclass; ix = ix; RETVAL = 1; OUTPUT: RETVAL bool T_BOOL(in) bool in CODE: RETVAL = in; OUTPUT: RETVAL bool T_BOOL_2(in) bool in CODE: OUTPUT: in void T_BOOL_OUT( out, in ) bool out bool in CODE: out = in; OUTPUT: out ExtUtils-ParseXS-3.30/t/XSUsage.xs0000644000175000017500000000202711624165440015367 0ustar tseetsee#include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* Old perls (pre 5.8.9 or so) did not have PERL_UNUSED_ARG in XSUB.h. * This is normally covered by ppport.h. */ #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif int xsusage_one() { return 1; } int xsusage_two() { return 2; } int xsusage_three() { return 3; } int xsusage_four() { return 4; } int xsusage_five(int i) { PERL_UNUSED_ARG(i); return 5; } int xsusage_six(int i) { PERL_UNUSED_ARG(i); return 6; } MODULE = XSUsage PACKAGE = XSUsage PREFIX = xsusage_ PROTOTYPES: DISABLE int xsusage_one() int xsusage_two() ALIAS: two_x = 1 FOO::two = 2 int interface_v_i() INTERFACE: xsusage_three int xsusage_four(...) int xsusage_five(int i, ...) int xsusage_six(int i = 0) ExtUtils-ParseXS-3.30/t/115-avoid-noise.t0000644000175000017500000000103012142362131016363 0ustar tseetsee#!/usr/bin/perl -w use strict; use warnings; use File::Spec; use Test::More tests => 1; use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); use ExtUtils::ParseXS qw(process_file); chdir('t') if -d 't'; # Module-Build uses ExtUtils::ParseXS with $^W set, try to avoid # warning in that case. { my $out; open my $out_fh, ">", \$out; my @warnings; local $SIG{__WARN__} = sub { push @warnings, "@_" }; process_file(filename => "XSWarn.xs", output => $out_fh); is_deeply(\@warnings, [], "shouldn't be any warnings"); } ExtUtils-ParseXS-3.30/t/002-more.t0000644000175000017500000000715512305422611015122 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More; use Config; use DynaLoader; use ExtUtils::CBuilder; use attributes; use overload; plan tests => 29; my ($source_file, $obj_file, $lib_file); require_ok( 'ExtUtils::ParseXS' ); ExtUtils::ParseXS->import('process_file'); chdir 't' if -d 't'; use Carp; $SIG{__WARN__} = \&Carp::cluck; # See the comments about this in 001-basics.t @INC = map { File::Spec->rel2abs($_) } @INC if $^O =~ /android/; ######################### $source_file = 'XSMore.c'; # Try sending to file ExtUtils::ParseXS->process_file( filename => 'XSMore.xs', output => $source_file, ); ok -e $source_file, "Create an output file"; my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; my $b = ExtUtils::CBuilder->new(quiet => $quiet); SKIP: { skip "no compiler available", 2 if ! $b->have_compiler; $obj_file = $b->compile( source => $source_file ); ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; ok -e $obj_file, "Make sure $obj_file exists"; } SKIP: { skip "no dynamic loading", 25 if !$b->have_compiler || !$Config{usedl}; my $module = 'XSMore'; $lib_file = $b->link( objects => $obj_file, module_name => $module ); ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; ok -e $lib_file, "Make sure $lib_file exists"; eval{ package XSMore; our $VERSION = 42; our $boot_ok; DynaLoader::bootstrap_inherit(__PACKAGE__, $VERSION); # VERSIONCHECK disabled sub new{ bless {}, shift } }; is $@, '', "No error message recorded, as expected"; is ExtUtils::ParseXS::report_error_count(), 0, 'ExtUtils::ParseXS::errors()'; is $XSMore::boot_ok, 100, 'the BOOT keyword'; ok XSMore::include_ok(), 'the INCLUDE keyword'; is prototype(\&XSMore::include_ok), "", 'the PROTOTYPES keyword'; is prototype(\&XSMore::prototype_ssa), '$$@', 'the PROTOTYPE keyword'; is_deeply [attributes::get(\&XSMore::attr_method)], [qw(method)], 'the ATTRS keyword'; is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype'; is XSMore::return_1(), 1, 'the CASE keyword (1)'; is XSMore::return_2(), 2, 'the CASE keyword (2)'; is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)'; is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)'; is XSMore::arg_init(200), 200, 'argument init'; ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword'; is abs(XSMore->new), 42, 'the OVERLOAD keyword'; my @a; XSMore::hook(\@a); is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords'; is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword'; is XSMore::len("foo"), 3, 'the length keyword'; is XSMore::sum(5, 9), 14, 'the INCLUDE_COMMAND directive'; # Tests for embedded typemaps is XSMore::typemaptest1(), 42, 'Simple embedded typemap works'; is XSMore::typemaptest2(), 42, 'Simple embedded typemap works with funny end marker'; is XSMore::typemaptest3(12, 13, 14), 12, 'Simple embedded typemap works for input, too'; is XSMore::typemaptest6(5), 5, '< # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif STATIC void outlist(int* a, int* b){ *a = 'a'; *b = 'b'; } STATIC int len(const char* const s, int const l){ PERL_UNUSED_ARG(s); return l; } MODULE = XSMore PACKAGE = XSMore =for testing This parts are also ignored. =cut PROTOTYPES: ENABLE VERSIONCHECK: DISABLE REQUIRE: 2.20 SCOPE: DISABLE FALLBACK: TRUE BOOT: sv_setiv(get_sv("XSMore::boot_ok", TRUE), 100); TYPEMAP: <', 'std::vector'], ['std::vector< unsigned int >', 'std::vector'], ['std::vector< vector >', 'std::vector >'], ['std::map< map , int>', 'std::map, int>'], ); plan tests => scalar(@tests); foreach my $test (@tests) { is(ExtUtils::Typemaps::tidy_type($test->[0]), $test->[1], "Tidying '$test->[0]'"); } ExtUtils-ParseXS-3.30/t/lib/0000755000175000017500000000000012571011400014225 5ustar tseetseeExtUtils-ParseXS-3.30/t/lib/PrimitiveCapture.pm0000644000175000017500000000432112052350535020070 0ustar tseetseepackage PrimitiveCapture; use strict; use warnings; if ("$]" >= 5.008000) { eval "#line @{[__LINE__+1]} ".q{"lib/PrimitiveCapture.pm" sub capture_stdout { my $sub = shift; my $stdout; open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; close STDOUT; open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!"; $sub->(); close STDOUT; open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; return $stdout; } sub capture_stderr { my $sub = shift; my $stderr; open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!"; close STDERR; open STDERR, '>', \$stderr or die "Can't open STDERR: $!"; $sub->(); close STDERR; open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!"; return $stderr; } }; die $@ unless $@ eq ""; } else { eval "#line @{[__LINE__+1]} ".q{"lib/PrimitiveCapture.pm" use File::Spec; use File::Temp; my $tmpdir; my $i = 0; sub _tmpfile { $tmpdir ||= File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1); return File::Spec->catfile($tmpdir, $i++); } sub _slurp { my $filename = shift; open my $fh, "<", $filename or die "Can't read $filename: $!"; local $/ = undef; my $content = <$fh>; defined $content or die "Can't read $filename: $!"; return $content; } sub capture_stdout { my $sub = shift; my $tmpfile = _tmpfile(); local *OLDSTDOUT; open OLDSTDOUT, ">&STDOUT" or die "Can't dup STDOUT: $!"; close STDOUT; open STDOUT, '>', $tmpfile or die "Can't open STDOUT: $!"; $sub->(); close STDOUT; open STDOUT, ">&OLDSTDOUT" or die "Can't dup OLDSTDOUT: $!"; close OLDSTDOUT; return _slurp($tmpfile); } sub capture_stderr { my $sub = shift; my $tmpfile = _tmpfile(); local *OLDSTDERR; open OLDSTDERR, ">&STDERR" or die "Can't dup STDERR: $!"; close STDERR; open STDERR, '>', $tmpfile or die "Can't open STDERR: $!"; $sub->(); close STDERR; open STDERR, ">&OLDSTDERR" or die "Can't dup OLDSTDERR: $!"; close OLDSTDERR; return _slurp($tmpfile); } }; die $@ unless $@ eq ""; } 1; ExtUtils-ParseXS-3.30/t/lib/TypemapTest/0000755000175000017500000000000012571011400016504 5ustar tseetseeExtUtils-ParseXS-3.30/t/lib/TypemapTest/Foo.pm0000644000175000017500000000043512132712744017603 0ustar tseetseepackage # hide from indexers TypemapTest::Foo; use strict; use warnings; require ExtUtils::Typemaps; our @ISA = qw(ExtUtils::Typemaps); sub new { my $class = shift; my $obj = $class->SUPER::new(@_); $obj->add_typemap(ctype => 'myfoo*', xstype => 'T_PV'); return $obj; } 1; ExtUtils-ParseXS-3.30/t/lib/ExtUtils/0000755000175000017500000000000012571011400016006 5ustar tseetseeExtUtils-ParseXS-3.30/t/lib/ExtUtils/Typemaps/0000755000175000017500000000000012571011400017610 5ustar tseetseeExtUtils-ParseXS-3.30/t/lib/ExtUtils/Typemaps/Test.pm0000644000175000017500000000044612132712736021106 0ustar tseetseepackage # hide from indexers ExtUtils::Typemaps::Test; use strict; use warnings; require ExtUtils::Typemaps; our @ISA = qw(ExtUtils::Typemaps); sub new { my $class = shift; my $obj = $class->SUPER::new(@_); $obj->add_typemap(ctype => 'mytype*', xstype => 'T_SV'); return $obj; } 1; ExtUtils-ParseXS-3.30/t/lib/IncludeTester.pm0000644000175000017500000000024611607127676017365 0ustar tseetseepackage IncludeTester; use strict; sub print_xs { print <<'HERE'; int sum(a, b) int a int b CODE: RETVAL = a + b; OUTPUT: RETVAL HERE } 1; ExtUtils-ParseXS-3.30/t/515-t-cmd.t0000644000175000017500000000376412132712533015202 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; # tests for the quick-n-dirty interface for XS inclusion use Test::More tests => 6; use File::Spec; use ExtUtils::Typemaps::Cmd; my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; my $libdir = -d 't' ? File::Spec->catdir(qw/t lib/) : 'lib'; unshift @INC, $libdir; sub slurp { my $file = shift; open my $fh, '<', $file or die "Cannot open file '$file' for reading: $!"; local $/ = undef; return <$fh>; } sub permute (&@) { my $code = shift; my @idx = 0..$#_; while ( $code->(@_[@idx]) ) { my $p = $#idx; --$p while $idx[$p-1] > $idx[$p]; my $q = $p or return; push @idx, reverse splice @idx, $p; ++$q while $idx[$p-1] > $idx[$q]; @idx[$p-1,$q]=@idx[$q,$p-1]; } } SCOPE: { no warnings 'once'; ok(defined(*embeddable_typemap{CODE}), "function exported"); } my $start = "TYPEMAP: <catfile($datadir, "simple.typemap"); is( embeddable_typemap($typemap_file), $start . slurp($typemap_file) . $end, "embeddable typemap from file" ); my $foo_content = < 7; use File::Spec; use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); use ExtUtils::ParseXS; use ExtUtils::ParseXS::Utilities qw( Warn blurt death ); use PrimitiveCapture; my $self = ExtUtils::ParseXS->new; $self->{line} = []; $self->{line_no} = []; { $self->{line} = [ 'Alpha', 'Beta', 'Gamma', 'Delta', ]; $self->{line_no} = [ 17 .. 20 ]; $self->{filename} = 'myfile1'; my $message = 'Warning: Ignoring duplicate alias'; my $stderr = PrimitiveCapture::capture_stderr(sub { Warn( $self, $message); }); like( $stderr, qr/$message in $self->{filename}, line 20/, "Got expected Warn output", ); } { $self->{line} = [ 'Alpha', 'Beta', 'Gamma', 'Delta', 'Epsilon', ]; $self->{line_no} = [ 17 .. 20 ]; $self->{filename} = 'myfile2'; my $message = 'Warning: Ignoring duplicate alias'; my $stderr = PrimitiveCapture::capture_stderr(sub { Warn( $self, $message); }); like( $stderr, qr/$message in $self->{filename}, line 19/, "Got expected Warn output", ); } { $self->{line} = [ 'Alpha', 'Beta', 'Gamma', 'Delta', ]; $self->{line_no} = [ 17 .. 21 ]; $self->{filename} = 'myfile1'; my $message = 'Warning: Ignoring duplicate alias'; my $stderr = PrimitiveCapture::capture_stderr(sub { Warn( $self, $message); }); like( $stderr, qr/$message in $self->{filename}, line 17/, "Got expected Warn output", ); } { $self->{line} = [ 'Alpha', 'Beta', 'Gamma', 'Delta', ]; $self->{line_no} = [ 17 .. 20 ]; $self->{filename} = 'myfile1'; $self->{errors} = 0; my $message = 'Error: Cannot parse function definition'; my $stderr = PrimitiveCapture::capture_stderr(sub { blurt( $self, $message); }); like( $stderr, qr/$message in $self->{filename}, line 20/, "Got expected blurt output", ); is( $self->report_error_count, 1, "Error count incremented correctly" ); } SKIP: { skip "death() not testable as long as it contains hard-coded 'exit'", 1; $self->{line} = [ 'Alpha', 'Beta', 'Gamma', 'Delta', ]; $self->{line_no} = [ 17 .. 20 ]; $self->{filename} = 'myfile1'; my $message = "Code is not inside a function"; eval { my $stderr = PrimitiveCapture::capture_stderr(sub { death( $self, $message); }); like( $stderr, qr/$message in $self->{filename}, line 20/, "Got expected death output", ); }; } pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/512-t-file.t0000644000175000017500000000337711624165440015357 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6; use ExtUtils::Typemaps; use File::Spec; use File::Temp; my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; sub slurp { my $file = shift; open my $fh, '<', $file or die "Cannot open file '$file' for reading: $!"; local $/ = undef; return <$fh>; } my $cmp_typemap_file = File::Spec->catfile($datadir, 'simple.typemap'); my $cmp_typemap_str = slurp($cmp_typemap_file); my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); $map->add_typemap(ctype => 'int', xstype => 'T_IV'); $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);'); $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);'); is($map->as_string(), $cmp_typemap_str, "Simple typemap matches reference file"); my $tmpdir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1); my $tmpfile = File::Spec->catfile($tmpdir, 'simple.typemap'); $map->write(file => $tmpfile); is($map->as_string(), slurp($tmpfile), "Simple typemap write matches as_string"); is(ExtUtils::Typemaps->new(file => $cmp_typemap_file)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips"); is(ExtUtils::Typemaps->new(file => $tmpfile)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips (2)"); SCOPE: { local $map->{file} = $cmp_typemap_file; is_deeply(ExtUtils::Typemaps->new(file => $cmp_typemap_file), $map, "Simple typemap roundtrips (in memory)"); } # test that we can also create them from a string my $map_from_str = ExtUtils::Typemaps->new(string => $map->as_string()); is_deeply($map_from_str, $map); ExtUtils-ParseXS-3.30/t/105-valid_proto_string.t0000644000175000017500000000150512142361657020100 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6; use ExtUtils::ParseXS::Utilities qw( valid_proto_string ); my ($input, $output); $input = '[\$]'; $output = valid_proto_string($input); is( $output, $input, "Got expected value for <$input>" ); $input = '[$]'; $output = valid_proto_string($input); is( $output, $input, "Got expected value for <$input>" ); $input = '[\$\@]'; $output = valid_proto_string($input); is( $output, $input, "Got expected value for <$input>" ); $input = '[\$alpha]'; $output = valid_proto_string($input); is( $output, 0, "Got expected value for <$input>" ); $input = '[alpha]'; $output = valid_proto_string($input); is( $output, 0, "Got expected value for <$input>" ); $input = '[_]'; $output = valid_proto_string($input); is( $output, $input, "Got expected value for <$input>" ); ExtUtils-ParseXS-3.30/t/001-basic.t0000644000175000017500000001170712305422611015236 0ustar tseetsee#!/usr/bin/perl use strict; use Test::More tests => 17; use Config; use DynaLoader; use ExtUtils::CBuilder; my ($source_file, $obj_file, $lib_file); require_ok( 'ExtUtils::ParseXS' ); chdir('t') if -d 't'; use Carp; $SIG{__WARN__} = \&Carp::cluck; # Some trickery for Android. If we leave @INC as-is, it'll have '.' in it. # Later on, the 'require XSTest' end up in DynaLoader looking for # ./PL_XSTest.so, but unless our current directory happens to be in # LD_LIBRARY_PATH, Android's linker will never find the file, and the test # will fail. Instead, if we have all absolute paths, it'll just work. @INC = map { File::Spec->rel2abs($_) } @INC if $^O =~ /android/; ######################### { # first block: try without linenumbers my $pxs = ExtUtils::ParseXS->new; # Try sending to filehandle tie *FH, 'Foo'; $pxs->process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 ); like tied(*FH)->content, '/is_even/', "Test that output contains some text"; $source_file = 'XSTest.c'; # Try sending to file $pxs->process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0); ok -e $source_file, "Create an output file"; my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; my $b = ExtUtils::CBuilder->new(quiet => $quiet); SKIP: { skip "no compiler available", 2 if ! $b->have_compiler; $obj_file = $b->compile( source => $source_file ); ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; ok -e $obj_file, "Make sure $obj_file exists"; } SKIP: { skip "no dynamic loading", 5 if !$b->have_compiler || !$Config{usedl}; my $module = 'XSTest'; $lib_file = $b->link( objects => $obj_file, module_name => $module ); ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; ok -e $lib_file, "Make sure $lib_file exists"; eval {require XSTest}; is $@, '', "No error message recorded, as expected"; ok XSTest::is_even(8), "Function created thru XS returned expected true value"; ok !XSTest::is_even(9), "Function created thru XS returned expected false value"; # Win32 needs to close the DLL before it can unlink it, but unfortunately # dl_unload_file was missing on Win32 prior to perl change #24679! if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { if ($DynaLoader::dl_modules[$i] eq $module) { DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); last; } } } } my $seen = 0; open my $IN, '<', $source_file or die "Unable to open $source_file: $!"; while (my $l = <$IN>) { $seen++ if $l =~ m/#line\s1\s/; } is( $seen, 1, "Line numbers created in output file, as intended" ); { #rewind .c file and regexp it to look for code generation problems local $/ = undef; seek($IN, 0, 0); my $filecontents = <$IN>; my $good_T_BOOL_re = qr|\QXS_EUPXS(XS_XSTest_T_BOOL)\E .+? #line \d+\Q "XSTest.c" ST(0) = boolSV(RETVAL); } XSRETURN(1); } \E|s; like($filecontents, $good_T_BOOL_re, "T_BOOL doesn\'t have an extra sv_newmortal or sv_2mortal"); my $good_T_BOOL_2_re = qr|\QXS_EUPXS(XS_XSTest_T_BOOL_2)\E .+? #line \d+\Q "XSTest.c" sv_setsv(ST(0), boolSV(in)); SvSETMAGIC(ST(0)); } XSRETURN(1); } \E|s; like($filecontents, $good_T_BOOL_2_re, 'T_BOOL_2 doesn\'t have an extra sv_newmortal or sv_2mortal'); my $good_T_BOOL_OUT_re = qr|\QXS_EUPXS(XS_XSTest_T_BOOL_OUT)\E .+? #line \d+\Q "XSTest.c" sv_setsv(ST(0), boolSV(out)); SvSETMAGIC(ST(0)); } XSRETURN_EMPTY; } \E|s; like($filecontents, $good_T_BOOL_OUT_re, 'T_BOOL_OUT doesn\'t have an extra sv_newmortal or sv_2mortal'); } close $IN or die "Unable to close $source_file: $!"; unless ($ENV{PERL_NO_CLEANUP}) { for ( $obj_file, $lib_file, $source_file) { next unless defined $_; 1 while unlink $_; } } } ##################################################################### { # second block: try with linenumbers my $pxs = ExtUtils::ParseXS->new; # Try sending to filehandle tie *FH, 'Foo'; $pxs->process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1, linenumbers => 0, ); like tied(*FH)->content, '/is_even/', "Test that output contains some text"; $source_file = 'XSTest.c'; # Try sending to file $pxs->process_file( filename => 'XSTest.xs', output => $source_file, prototypes => 0, linenumbers => 0, ); ok -e $source_file, "Create an output file"; my $seen = 0; open my $IN, '<', $source_file or die "Unable to open $source_file: $!"; while (my $l = <$IN>) { $seen++ if $l =~ m/#line\s1\s/; } close $IN or die "Unable to close $source_file: $!"; is( $seen, 0, "No linenumbers created in output file, as intended" ); unless ($ENV{PERL_NO_CLEANUP}) { for ( $obj_file, $lib_file, $source_file) { next unless defined $_; 1 while unlink $_; } } } ##################################################################### sub Foo::TIEHANDLE { bless {}, 'Foo' } sub Foo::PRINT { shift->{buf} .= join '', @_ } sub Foo::content { shift->{buf} } ExtUtils-ParseXS-3.30/t/data/0000755000175000017500000000000012571011400014370 5ustar tseetseeExtUtils-ParseXS-3.30/t/data/b.typemap0000644000175000017500000000271512132712577016237 0ustar tseetseeTYPEMAP B::OP T_OP_OBJ B::UNOP T_OP_OBJ B::BINOP T_OP_OBJ B::LOGOP T_OP_OBJ B::LISTOP T_OP_OBJ B::PMOP T_OP_OBJ B::SVOP T_OP_OBJ B::PADOP T_OP_OBJ B::PVOP T_OP_OBJ B::LOOP T_OP_OBJ B::COP T_OP_OBJ B::SV T_SV_OBJ B::PV T_SV_OBJ B::IV T_SV_OBJ B::NV T_SV_OBJ B::PVMG T_SV_OBJ B::REGEXP T_SV_OBJ B::PVLV T_SV_OBJ B::BM T_SV_OBJ B::RV T_SV_OBJ B::GV T_SV_OBJ B::CV T_SV_OBJ B::HV T_SV_OBJ B::AV T_SV_OBJ B::IO T_SV_OBJ B::FM T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV STRLEN T_UV PADOFFSET T_UV B::HE T_HE_OBJ B::RHE T_RHE_OBJ INPUT T_OP_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_SV_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_MG_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_HE_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") T_RHE_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") OUTPUT T_MG_OBJ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); T_HE_OBJ sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var)); T_RHE_OBJ sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var)); ExtUtils-ParseXS-3.30/t/data/other.typemap0000644000175000017500000000014312132712577017130 0ustar tseetseeTYPEMAP double T_NV INPUT T_NV $var = ($type)SvNV($arg); OUTPUT T_NV sv_setnv($arg, (NV)$var); ExtUtils-ParseXS-3.30/t/data/confl_repl.typemap0000644000175000017500000000022112132712577020127 0ustar tseetseeTYPEMAP double T_DIFFERENT INPUT T_NV $var = ($type)SvNV($arg); T_DIFFERENT $var = ($type)SvNV($arg); OUTPUT T_NV sv_setnv($arg, (NV)$var); ExtUtils-ParseXS-3.30/t/data/confl_skip.typemap0000644000175000017500000000021212132712577020133 0ustar tseetseeTYPEMAP double T_NV INPUT T_NV $var = ($type)SvNV($arg); T_DIFFERENT $var = ($type)SvNV($arg); OUTPUT T_NV sv_setnv($arg, (NV)$var); ExtUtils-ParseXS-3.30/t/data/conflicting.typemap0000644000175000017500000000011112132712577020301 0ustar tseetseeTYPEMAP double T_DIFFERENT INPUT T_DIFFERENT $var = ($type)SvNV($arg); ExtUtils-ParseXS-3.30/t/data/combined.typemap0000644000175000017500000000037612132712577017577 0ustar tseetseeTYPEMAP unsigned int T_UV int T_IV double T_NV INPUT T_UV $var = ($type)SvUV($arg); T_IV $var = ($type)SvIV($arg); T_NV $var = ($type)SvNV($arg); OUTPUT T_UV sv_setuv($arg, (UV)$var); T_IV sv_setiv($arg, (IV)$var); T_NV sv_setnv($arg, (NV)$var); ExtUtils-ParseXS-3.30/t/data/perl.typemap0000644000175000017500000001760312132712577016762 0ustar tseetsee# basic C types int T_IV unsigned T_UV unsigned int T_UV long T_IV unsigned long T_UV short T_IV unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV unsigned char * T_PV const char * T_PV caddr_t T_PV wchar_t * T_PV wchar_t T_IV # bool_t is defined in bool_t T_IV size_t T_UV ssize_t T_IV time_t T_NV unsigned long * T_OPAQUEPTR char ** T_PACKEDARRAY void * T_PTR Time_t * T_PV SV * T_SV SVREF T_SVREF AV * T_AVREF HV * T_HVREF CV * T_CVREF IV T_IV UV T_UV NV T_NV I32 T_IV I16 T_IV I8 T_IV STRLEN T_UV U32 T_U_LONG U16 T_U_SHORT U8 T_UV Result T_U_CHAR Boolean T_BOOL float T_FLOAT double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET FILE * T_STDIO PerlIO * T_INOUT FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT OutputStream T_OUT bool T_BOOL ############################################################################# INPUT T_SV $var = $arg T_SVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv)){ $var = SvRV(xsub_tmp_sv); } else{ Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_AVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ $var = (AV*)SvRV(xsub_tmp_sv); } else{ Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_HVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ $var = (HV*)SvRV(xsub_tmp_sv); } else{ Perl_croak(aTHX_ \"%s: %s is not a HASH reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_CVREF STMT_START { SV* const xsub_tmp_sv = $arg; SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){ $var = (CV*)SvRV(xsub_tmp_sv); } else{ Perl_croak(aTHX_ \"%s: %s is not a CODE reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\"); } } STMT_END T_SYSRET $var NOT IMPLEMENTED T_UV $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT $var = (int)SvIV($arg) T_ENUM $var = ($type)SvIV($arg) T_BOOL $var = (bool)SvTRUE($arg) T_U_INT $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG $var = (unsigned long)SvUV($arg) T_CHAR $var = (char)*SvPV_nolen($arg) T_U_CHAR $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV $var = ($type)SvNV($arg) T_DOUBLE $var = (double)SvNV($arg) T_PV $var = ($type)SvPV_nolen($arg) T_PTR $var = INT2PTR($type,SvIV($arg)) T_PTRREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REF_IV_REF if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type *, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REF_IV_PTR if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTROBJ if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_OPAQUE $var = *($type *)SvPV_nolen($arg) T_OPAQUEPTR $var = ($type)SvPV_nolen($arg) T_PACKED $var = XS_unpack_$ntype($arg) T_PACKEDARRAY $var = XS_unpack_$ntype($arg) T_CALLBACK $var = make_perl_cb_$type($arg) T_ARRAY U32 ix_$var = $argoff; $var = $ntype(items -= $argoff); while (items--) { DO_ARRAY_ELEM; ix_$var++; } /* this is the number of elements in the array */ ix_$var -= $argoff T_STDIO $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) T_IN $var = IoIFP(sv_2io($arg)) T_INOUT $var = IoIFP(sv_2io($arg)) T_OUT $var = IoOFP(sv_2io($arg)) ############################################################################# OUTPUT T_SV $arg = $var; T_SVREF $arg = newRV((SV*)$var); T_AVREF $arg = newRV((SV*)$var); T_HVREF $arg = newRV((SV*)$var); T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); T_UV sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else sv_setiv($arg, (IV)$var); } T_ENUM sv_setiv($arg, (IV)$var); T_BOOL $arg = boolSV($var); T_U_INT sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (NV)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR sv_setiv($arg, PTR2IV($var)); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); T_REF_IV_PTR sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); T_REFREF NOT_IMPLEMENTED T_REFOBJ NOT IMPLEMENTED T_OPAQUE sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR sv_setpvn($arg, (char *)$var, sizeof(*$var)); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT sv_setpvn($arg, $var.chp(), $var.size()); T_CALLBACK sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY { U32 ix_$var; EXTEND(SP,size_$var); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } } T_STDIO { GV *gv = newGVgen("$Package"); PerlIO *fp = PerlIO_importFILE($var,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ExtUtils-ParseXS-3.30/t/data/simple.typemap0000644000175000017500000000026212132712577017302 0ustar tseetseeTYPEMAP unsigned int T_UV int T_IV INPUT T_UV $var = ($type)SvUV($arg); T_IV $var = ($type)SvIV($arg); OUTPUT T_UV sv_setuv($arg, (UV)$var); T_IV sv_setiv($arg, (IV)$var); ExtUtils-ParseXS-3.30/t/513-t-merge.t0000644000175000017500000000670611624165440015537 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 19; use ExtUtils::Typemaps; use File::Spec; use File::Temp; my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; sub slurp { my $file = shift; open my $fh, '<', $file or die "Cannot open file '$file' for reading: $!"; local $/ = undef; return <$fh>; } my $first_typemap_file = File::Spec->catfile($datadir, 'simple.typemap'); my $second_typemap_file = File::Spec->catfile($datadir, 'other.typemap'); my $combined_typemap_file = File::Spec->catfile($datadir, 'combined.typemap'); my $conflicting_typemap_file = File::Spec->catfile($datadir, 'conflicting.typemap'); my $confl_replace_typemap_file = File::Spec->catfile($datadir, 'confl_repl.typemap'); my $confl_skip_typemap_file = File::Spec->catfile($datadir, 'confl_skip.typemap'); # test merging two typemaps SCOPE: { my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); isa_ok($first, 'ExtUtils::Typemaps'); my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); isa_ok($second, 'ExtUtils::Typemaps'); $first->merge(typemap => $second); is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output"); } # test merging a typemap from file SCOPE: { my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); isa_ok($first, 'ExtUtils::Typemaps'); $first->merge(file => $second_typemap_file); is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output"); } # test merging a typemap as string SCOPE: { my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); isa_ok($first, 'ExtUtils::Typemaps'); my $second_str = slurp($second_typemap_file); $first->add_string(string => $second_str); is($first->as_string(), slurp($combined_typemap_file), "merging (string) produces expected output"); } # test merging a conflicting typemap without "replace" SCOPE: { my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); isa_ok($second, 'ExtUtils::Typemaps'); my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); isa_ok($conflict, 'ExtUtils::Typemaps'); ok( !eval { $second->merge(typemap => $conflict); 1; }, "Merging conflicting typemap croaks" ); ok( $@ =~ /Multiple definition/, "Conflicting typemap error as expected" ); } # test merging a conflicting typemap with "replace" SCOPE: { my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); isa_ok($second, 'ExtUtils::Typemaps'); my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); isa_ok($conflict, 'ExtUtils::Typemaps'); ok( eval { $second->merge(typemap => $conflict, replace => 1); 1; }, "Conflicting typemap merge with 'replace' doesn't croak" ); is($second->as_string(), slurp($confl_replace_typemap_file), "merging (string) produces expected output"); } # test merging a conflicting typemap file with "skip" SCOPE: { my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); isa_ok($second, 'ExtUtils::Typemaps'); my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); isa_ok($conflict, 'ExtUtils::Typemaps'); ok( eval { $second->merge(typemap => $conflict, skip => 1); 1; }, "Conflicting typemap merge with 'skip' doesn't croak" ); is($second->as_string(), slurp($confl_skip_typemap_file), "merging (string) produces expected output"); } ExtUtils-ParseXS-3.30/t/109-standard_XS_defs.t0000644000175000017500000000105012562061016017372 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; $| = 1; use Test::More tests => 4; use File::Spec; use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); use ExtUtils::ParseXS::Utilities qw( standard_XS_defs ); use PrimitiveCapture; my @statements = ( '#ifndef PERL_UNUSED_VAR', '#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE', '#ifdef newXS_flags', ); my $stdout = PrimitiveCapture::capture_stdout(sub { standard_XS_defs(); }); foreach my $s (@statements) { like( $stdout, qr/$s/s, "Printed <$s>" ); } pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/517-t-targetable.t0000644000175000017500000001226212142361414016543 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Carp; use Cwd; use File::Spec; use Test::More; use lib qw( lib ); use ExtUtils::Typemaps; my $output_expr_ref = { 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); ', 'T_OUT' => ' { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ', 'T_REF_IV_PTR' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); ', 'T_U_LONG' => ' sv_setuv($arg, (UV)$var); ', 'T_U_CHAR' => ' sv_setuv($arg, (UV)$var); ', 'T_U_INT' => ' sv_setuv($arg, (UV)$var); ', 'T_ARRAY' => ' { U32 ix_$var; EXTEND(SP,size_$var); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } } ', 'T_NV' => ' sv_setnv($arg, (NV)$var); ', 'T_SHORT' => ' sv_setiv($arg, (IV)$var); ', 'T_OPAQUE' => ' sv_setpvn($arg, (char *)&$var, sizeof($var)); ', 'T_PTROBJ' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); ', 'T_HVREF' => ' $arg = newRV((SV*)$var); ', 'T_PACKEDARRAY' => ' XS_pack_$ntype($arg, $var, count_$ntype); ', 'T_INT' => ' sv_setiv($arg, (IV)$var); ', 'T_OPAQUEPTR' => ' sv_setpvn($arg, (char *)$var, sizeof(*$var)); ', 'T_BOOL' => ' $arg = boolSV($var); ', 'T_REFREF' => ' NOT_IMPLEMENTED ', 'T_REF_IV_REF' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var)); ', 'T_STDIO' => ' { GV *gv = newGVgen("$Package"); PerlIO *fp = PerlIO_importFILE($var,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ', 'T_FLOAT' => ' sv_setnv($arg, (double)$var); ', 'T_IN' => ' { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ', 'T_PV' => ' sv_setpv((SV*)$arg, $var); ', 'T_INOUT' => ' { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ', 'T_CHAR' => ' sv_setpvn($arg, (char *)&$var, 1); ', 'T_LONG' => ' sv_setiv($arg, (IV)$var); ', 'T_DOUBLE' => ' sv_setnv($arg, (double)$var); ', 'T_PTR' => ' sv_setiv($arg, PTR2IV($var)); ', 'T_AVREF' => ' $arg = newRV((SV*)$var); ', 'T_SV' => ' $arg = $var; ', 'T_ENUM' => ' sv_setiv($arg, (IV)$var); ', 'T_REFOBJ' => ' NOT IMPLEMENTED ', 'T_CVREF' => ' $arg = newRV((SV*)$var); ', 'T_UV' => ' sv_setuv($arg, (UV)$var); ', 'T_PACKED' => ' XS_pack_$ntype($arg, $var); ', 'T_SYSRET' => ' if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else sv_setiv($arg, (IV)$var); } ', 'T_IV' => ' sv_setiv($arg, (IV)$var); ', 'T_PTRDESC' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var)); ', 'T_DATAUNIT' => ' sv_setpvn($arg, $var.chp(), $var.size()); ', 'T_U_SHORT' => ' sv_setuv($arg, (UV)$var); ', 'T_SVREF' => ' $arg = newRV((SV*)$var); ', 'T_PTRREF' => ' sv_setref_pv($arg, Nullch, (void*)$var); ', }; plan tests => scalar(keys %$output_expr_ref); my %results = ( T_UV => { type => 'u', with_size => undef, what => '(UV)$var', what_size => undef }, T_IV => { type => 'i', with_size => undef, what => '(IV)$var', what_size => undef }, T_NV => { type => 'n', with_size => undef, what => '(NV)$var', what_size => undef }, T_FLOAT => { type => 'n', with_size => undef, what => '(double)$var', what_size => undef }, T_PTR => { type => 'i', with_size => undef, what => 'PTR2IV($var)', what_size => undef }, T_PV => { type => 'p', with_size => undef, what => '$var', what_size => undef }, T_OPAQUE => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', sizeof($var)' }, T_OPAQUEPTR => { type => 'p', with_size => 'n', what => '(char *)$var', what_size => ', sizeof(*$var)' }, T_CHAR => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', 1' }, T_CALLBACK => { type => 'p', with_size => 'n', what => '$var.context.value().chp()', what_size => ",\n \$var.context.value().size()" }, # whitespace is significant here T_DATAUNIT => { type => 'p', with_size => 'n', what => '$var.chp()', what_size => ', $var.size()' }, ); $results{$_} = $results{T_UV} for qw(T_U_LONG T_U_INT T_U_CHAR T_U_SHORT); $results{$_} = $results{T_IV} for qw(T_LONG T_INT T_SHORT T_ENUM); $results{$_} = $results{T_FLOAT} for qw(T_DOUBLE); foreach my $xstype (sort keys %$output_expr_ref) { my $om = ExtUtils::Typemaps::OutputMap->new( xstype => $xstype, code => $output_expr_ref->{$xstype} ); my $targetable = $om->targetable; if (not exists($results{$xstype})) { ok(not(defined($targetable)), "$xstype not targetable") or diag(join ", ", map {defined($_) ? $_ : ""} %$targetable); } else { my $res = $results{$xstype}; is_deeply($targetable, $res, "$xstype targetable and has right output") or diag(join ", ", map {defined($_) ? $_ : ""} %$targetable); } } ExtUtils-ParseXS-3.30/t/111-analyze_preprocessor_statements.t0000644000175000017500000000055712142362004022676 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; $| = 1; use Test::More qw(no_plan); # tests => 7; use ExtUtils::ParseXS::Utilities qw( analyze_preprocessor_statements ); # ( $self, $XSS_work_idx, $BootCode_ref ) = # analyze_preprocessor_statements( # $self, $statement, $XSS_work_idx, $BootCode_ref # ); pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/104-map_type.t0000644000175000017500000000433312305422547016004 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 7; use ExtUtils::ParseXS; use ExtUtils::ParseXS::Utilities qw( map_type ); my ($self, $type, $varname); my ($result, $expected); $self = ExtUtils::ParseXS->new; $type = 'struct DATA *'; $varname = 'RETVAL'; $self->{RetainCplusplusHierarchicalTypes} = 0; $expected = "$type\t$varname"; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, <$varname>, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = 'Crypt::Shark'; $varname = undef; $self->{RetainCplusplusHierarchicalTypes} = 0; $expected = 'Crypt__Shark'; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, undef, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = 'Crypt::Shark'; $varname = undef; $self->{RetainCplusplusHierarchicalTypes} = 1; $expected = 'Crypt::Shark'; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, undef, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = 'Crypt::TC18'; $varname = 'RETVAL'; $self->{RetainCplusplusHierarchicalTypes} = 0; $expected = "Crypt__TC18\t$varname"; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, <$varname>, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = 'Crypt::TC18'; $varname = 'RETVAL'; $self->{RetainCplusplusHierarchicalTypes} = 1; $expected = "Crypt::TC18\t$varname"; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, <$varname>, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = 'array(alpha,beta) gamma'; $varname = 'RETVAL'; $self->{RetainCplusplusHierarchicalTypes} = 0; $expected = "alpha *\t$varname"; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, <$varname>, <$self->{RetainCplusplusHierarchicalTypes}>" ); $type = '(*)'; $varname = 'RETVAL'; $self->{RetainCplusplusHierarchicalTypes} = 0; $expected = "(* $varname )"; $result = map_type($self, $type, $varname); is( $result, $expected, "Got expected map_type for <$type>, <$varname>, <$self->{RetainCplusplusHierarchicalTypes}>" ); ExtUtils-ParseXS-3.30/t/102-trim_whitespace.t0000644000175000017500000000114512142361645017351 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 5; use ExtUtils::ParseXS::Utilities qw( trim_whitespace ); my $str; $str = 'overworked'; trim_whitespace($str); is( $str, 'overworked', "Got expected value" ); $str = ' overworked'; trim_whitespace($str); is( $str, 'overworked', "Got expected value" ); $str = 'overworked '; trim_whitespace($str); is( $str, 'overworked', "Got expected value" ); $str = ' overworked '; trim_whitespace($str); is( $str, 'overworked', "Got expected value" ); $str = "\toverworked"; trim_whitespace($str); is( $str, 'overworked', "Got expected value" ); ExtUtils-ParseXS-3.30/t/XSTest.pm0000644000175000017500000000016711607127676015241 0ustar tseetseepackage XSTest; require DynaLoader; @ISA = qw(Exporter DynaLoader); $VERSION = '0.01'; bootstrap XSTest $VERSION; 1; ExtUtils-ParseXS-3.30/t/106-process_typemaps.t0000644000175000017500000000256412142361703017567 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Carp; use Cwd qw(cwd); use File::Temp qw( tempdir ); use Test::More tests => 2; use ExtUtils::ParseXS::Utilities qw( process_typemaps ); my $startdir = cwd(); { my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); my $typemap = 'typemap'; my $tdir = tempdir( CLEANUP => 1 ); chdir $tdir or croak "Unable to change to tempdir for testing"; eval { ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = process_typemaps( $typemap, $tdir ); }; like( $@, qr/Can't find \Q$typemap\E in \Q$tdir\E/, #' "Got expected result for no typemap in current directory" ); chdir $startdir; } { my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); my $typemap = [ qw( pseudo typemap ) ]; my $tdir = tempdir( CLEANUP => 1 ); chdir $tdir or croak "Unable to change to tempdir for testing"; open my $IN, '>', 'typemap' or croak "Cannot open for writing"; print $IN "\n"; close $IN or croak "Cannot close after writing"; eval { ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = process_typemaps( $typemap, $tdir ); }; like( $@, qr/Can't find pseudo in \Q$tdir\E/, #' "Got expected result for no typemap in current directory" ); chdir $startdir; } ExtUtils-ParseXS-3.30/t/XSWarn.xs0000644000175000017500000000033312052350717015227 0ustar tseetsee#include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = XSWarn PACKAGE = XSWarn PREFIX = xswarn_ PROTOTYPES: DISABLE void xswarn_nonargs() # see perl #112776 SV *sv = sv_2mortal(newSV()); CODE: ; ExtUtils-ParseXS-3.30/t/typemap0000644000175000017500000001671412162346305015105 0ustar tseetsee# basic C types int T_IV unsigned T_UV unsigned int T_UV long T_IV unsigned long T_UV short T_IV unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV unsigned char * T_PV const char * T_PV caddr_t T_PV wchar_t * T_PV wchar_t T_IV # bool_t is defined in bool_t T_IV size_t T_UV ssize_t T_IV time_t T_NV unsigned long * T_OPAQUEPTR char ** T_PACKEDARRAY void * T_PTR Time_t * T_PV SV * T_SV SVREF T_SVREF AV * T_AVREF HV * T_HVREF CV * T_CVREF IV T_IV UV T_UV NV T_NV I32 T_IV I16 T_IV I8 T_IV STRLEN T_UV U32 T_U_LONG U16 T_U_SHORT U8 T_UV Result T_U_CHAR Boolean T_BOOL float T_FLOAT double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET FILE * T_STDIO PerlIO * T_INOUT FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT OutputStream T_OUT bool T_BOOL ############################################################################# INPUT T_SV $var = $arg T_SVREF if (SvROK($arg)) $var = (SV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_AVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) $var = (AV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not an array reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_HVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV) $var = (HV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a hash reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_CVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) $var = (CV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a code reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_SYSRET $var NOT IMPLEMENTED T_UV $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT $var = (int)SvIV($arg) T_ENUM $var = ($type)SvIV($arg) T_BOOL $var = (bool)SvTRUE($arg) T_U_INT $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG $var = (unsigned long)SvUV($arg) T_CHAR $var = (char)*SvPV_nolen($arg) T_U_CHAR $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV $var = ($type)SvNV($arg) T_DOUBLE $var = (double)SvNV($arg) T_PV $var = ($type)SvPV_nolen($arg) T_PTR $var = INT2PTR($type,SvIV($arg)) T_PTRREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REF_IV_REF if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type *, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REF_IV_PTR if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_OPAQUE $var = *($type *)SvPV_nolen($arg) T_OPAQUEPTR $var = ($type)SvPV_nolen($arg) T_PACKED $var = XS_unpack_$ntype($arg) T_PACKEDARRAY $var = XS_unpack_$ntype($arg) T_CALLBACK $var = make_perl_cb_$type($arg) T_ARRAY U32 ix_$var = $argoff; $var = $ntype(items -= $argoff); while (items--) { DO_ARRAY_ELEM; ix_$var++; } /* this is the number of elements in the array */ ix_$var -= $argoff T_STDIO $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) T_IN $var = IoIFP(sv_2io($arg)) T_INOUT $var = IoIFP(sv_2io($arg)) T_OUT $var = IoOFP(sv_2io($arg)) ############################################################################# OUTPUT T_SV $arg = $var; T_SVREF $arg = newRV((SV*)$var); T_AVREF $arg = newRV((SV*)$var); T_HVREF $arg = newRV((SV*)$var); T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); T_UV sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else sv_setiv($arg, (IV)$var); } T_ENUM sv_setiv($arg, (IV)$var); T_BOOL ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"} T_U_INT sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (NV)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR sv_setiv($arg, PTR2IV($var)); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); T_REF_IV_PTR sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); T_REFREF NOT_IMPLEMENTED T_REFOBJ NOT IMPLEMENTED T_OPAQUE sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR sv_setpvn($arg, (char *)$var, sizeof(*$var)); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT sv_setpvn($arg, $var.chp(), $var.size()); T_CALLBACK sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY { U32 ix_$var; EXTEND(SP,size_$var); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } } T_STDIO { GV *gv = newGVgen("$Package"); PerlIO *fp = PerlIO_importFILE($var,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &PL_sv_undef; } ExtUtils-ParseXS-3.30/t/600-t-compat.t0000644000175000017500000001152412134267776015726 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More; # This test is for making sure that the new EU::Typemaps # based typemap merging produces the same result as the old # EU::ParseXS code. use ExtUtils::Typemaps; use ExtUtils::ParseXS::Utilities qw( C_string trim_whitespace process_typemaps ); use ExtUtils::ParseXS::Constants; use File::Spec; my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data)); my @tests = ( { name => 'Simple conflict', local_maps => [ File::Spec->catfile($path_prefix, "conflicting.typemap"), ], std_maps => [ File::Spec->catfile($path_prefix, "other.typemap"), ], }, { name => 'B', local_maps => [ File::Spec->catfile($path_prefix, "b.typemap"), ], std_maps => [], }, { name => 'B and perl', local_maps => [ File::Spec->catfile($path_prefix, "b.typemap"), ], std_maps => [ File::Spec->catfile($path_prefix, "perl.typemap"), ], }, { name => 'B and perl and B again', local_maps => [ File::Spec->catfile($path_prefix, "b.typemap"), ], std_maps => [ File::Spec->catfile($path_prefix, "perl.typemap"), File::Spec->catfile($path_prefix, "b.typemap"), ], }, ); plan tests => scalar(@tests); my @local_tmaps; my @standard_typemap_locations; SCOPE: { no warnings 'redefine'; sub ExtUtils::ParseXS::Utilities::standard_typemap_locations { @standard_typemap_locations; } sub standard_typemap_locations { @standard_typemap_locations; } } foreach my $test (@tests) { @local_tmaps = @{ $test->{local_maps} }; @standard_typemap_locations = @{ $test->{std_maps} }; my $res = [_process_typemaps([@local_tmaps], '.')]; my $tm = process_typemaps([@local_tmaps], '.'); my $res_new = [map $tm->$_(), qw(_get_typemap_hash _get_prototype_hash _get_inputmap_hash _get_outputmap_hash) ]; # Normalize trailing whitespace. Let's be that lenient, mkay? for ($res, $res_new) { for ($_->[2], $_->[3]) { for (values %$_) { s/\s+\z//; } } } #use Data::Dumper; warn Dumper $res; #use Data::Dumper; warn Dumper $res_new; is_deeply($res_new, $res, "typemap equivalency for '$test->{name}'"); } # The code below is a reproduction of what the pre-ExtUtils::Typemaps # typemap-parsing/handling code in ExtUtils::ParseXS looked like. For # bug-compatibility, we want to produce the same data structures as that # code as much as possible. 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 ); my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = ( {}, {}, {}, {} ); foreach my $typemap (@tm) { next unless -f $typemap; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap'\n"), next unless -T $typemap; ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = _process_single_typemap( $typemap, $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); } return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); } sub _process_single_typemap { my ($typemap, $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_; open my $TYPEMAP, '<', $typemap or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; my $mode = 'Typemap'; my $junk = ""; my $current = \$junk; while (<$TYPEMAP>) { # skip comments next if /^\s*#/; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } if ($mode eq 'Typemap') { chomp; my $logged_line = $_; trim_whitespace($_); # skip blank lines next if /^$/; my($type,$kind, $proto) = m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/ or warn( "Warning: File '$typemap' Line $. '$logged_line' " . "TYPEMAP entry needs 2 or 3 columns\n" ), next; $type = ExtUtils::Typemaps::tidy_type($type); $type_kind_ref->{$type} = $kind; # prototype defaults to '$' $proto = "\$" unless $proto; $proto_letter_ref->{$type} = C_string($proto); } elsif (/^\s/) { $$current .= $_; } elsif ($mode eq 'Input') { s/\s+$//; $input_expr_ref->{$_} = ''; $current = \$input_expr_ref->{$_}; } else { s/\s+$//; $output_expr_ref->{$_} = ''; $current = \$output_expr_ref->{$_}; } } close $TYPEMAP; return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); } ExtUtils-ParseXS-3.30/t/516-t-clone.t0000644000175000017500000000260712131564525015540 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6; use ExtUtils::Typemaps; # Test that cloning typemap object shallowly or deeply both # works as designed. SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); $map->add_typemap(ctype => 'int', xstype => 'T_IV'); $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);'); $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);'); my $clone = $map->clone; my $shallow = $map->clone(shallow => 1); is_deeply($clone, $map, "Full clone equivalent to original"); is_deeply($shallow, $map, "Shallow clone equivalent to original"); $map->add_typemap(ctype => "foo", xstype => "bar"); ok(!$clone->get_typemap(ctype => 'foo'), "New typemap not propagated to full clone"); ok(!$shallow->get_typemap(ctype => 'foo'), "New typemap not propagated to shallow clone"); my $t = $map->get_typemap(ctype => 'unsigned int'); $t->{blubb} = 1; ok(!$clone->get_typemap(ctype => 'unsigned int')->{blubb}, "Direct modification does not propagate to full clone"); ok($shallow->get_typemap(ctype => 'unsigned int')->{blubb}, "Direct modification does propagate to shallow clone"); } ExtUtils-ParseXS-3.30/t/112-set_cond.t0000644000175000017500000000025312142362015015750 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More qw(no_plan); # tests => 7; use ExtUtils::ParseXS::Utilities qw( set_cond ); pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/pseudotypemap10000644000175000017500000000020211624165440016370 0ustar tseetsee # pseudotypemap1: comment with leading whitespace TYPEMAP line_to_generate_insufficient_columns_warning unsigned long T_UV ExtUtils-ParseXS-3.30/t/110-assign_func_args.t0000644000175000017500000000253412142361767017504 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More qw(no_plan); # tests => 7; use ExtUtils::ParseXS::Utilities qw( assign_func_args ); #sub assign_func_args { # my ($self, $argsref, $class) = @_; # return join(", ", @func_args); my ($self, @args, $class); my ($func_args, $expected); @args = qw( alpha beta gamma ); $self->{in_out}->{alpha} = 'OUT'; $expected = q|&alpha, beta, gamma|; $func_args = assign_func_args($self, \@args, $class); is( $func_args, $expected, "Got expected func_args: in_out true; class undefined" ); @args = ( 'My::Class', qw( beta gamma ) ); $self->{in_out}->{beta} = 'OUT'; $class = 'My::Class'; $expected = q|&beta, gamma|; $func_args = assign_func_args($self, \@args, $class); is( $func_args, $expected, "Got expected func_args: in_out true; class defined" ); @args = ( 'My::Class', qw( beta gamma ) ); $self->{in_out}->{beta} = ''; $class = 'My::Class'; $expected = q|beta, gamma|; $func_args = assign_func_args($self, \@args, $class); is( $func_args, $expected, "Got expected func_args: in_out false; class defined" ); @args = qw( alpha beta gamma ); $self->{in_out}->{alpha} = ''; $class = undef; $expected = q|alpha, beta, gamma|; $func_args = assign_func_args($self, \@args, $class); is( $func_args, $expected, "Got expected func_args: in_out false; class undefined" ); pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/108-map_type.t0000644000175000017500000000057112142361516016005 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More qw(no_plan); # tests => 7; use ExtUtils::ParseXS::Utilities qw( map_type ); #print "\t" . map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n" #print "\t" . map_type($var_type, $var_name, $self->{hiertype}); #print "\t" . map_type($var_type, undef, $self->{hiertype}); pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/514-t-embed.t0000644000175000017500000000057512132712533015507 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; # tests for generating embedded typemaps use Test::More tests => 1; use ExtUtils::Typemaps; SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_string(string => <as_embedded_typemap(), <<'HERE', "Embedded typemap as expected"); TYPEMAP: <catdir(qw(t lib)) : 'lib'); use Test::More tests => 13; use ExtUtils::ParseXS; use ExtUtils::ParseXS::Utilities qw( check_conditional_preprocessor_statements ); use PrimitiveCapture; my $self = bless({} => 'ExtUtils::ParseXS'); $self->{line} = []; $self->{XSStack} = []; $self->{XSStack}->[0] = {}; { $self->{line} = [ "#if this_is_an_if_statement", "Alpha this is not an if/elif/elsif/endif", "#elif this_is_an_elif_statement", "Beta this is not an if/elif/elsif/endif", "#else this_is_an_else_statement", "Gamma this is not an if/elif/elsif/endif", "#endif this_is_an_endif_statement", ]; $self->{line_no} = [ 17 .. 23 ]; $self->{XSStack}->[-1]{type} = 'if'; $self->{filename} = 'myfile1'; my $rv; my $stderr = PrimitiveCapture::capture_stderr(sub { $rv = check_conditional_preprocessor_statements($self); }); is( $rv, 0, "Basic case: returned 0: all ifs resolved" ); ok( ! $stderr, "No warnings captured, as expected" ); } { $self->{line} = [ "#if this_is_an_if_statement", "Alpha this is not an if/elif/elsif/endif", "#if this_is_a_different_if_statement", "Beta this is not an if/elif/elsif/endif", "#endif this_is_a_different_endif_statement", "Gamma this is not an if/elif/elsif/endif", "#endif this_is_an_endif_statement", ]; $self->{line_no} = [ 17 .. 23 ]; $self->{XSStack}->[-1]{type} = 'if'; $self->{filename} = 'myfile1'; my $rv; my $stderr = PrimitiveCapture::capture_stderr(sub { $rv = check_conditional_preprocessor_statements($self); }); is( $rv, 0, "One nested if case: returned 0: all ifs resolved" ); ok( ! $stderr, "No warnings captured, as expected" ); } { $self->{line} = [ "Alpha this is not an if/elif/elsif/endif", "#elif this_is_an_elif_statement", "Beta this is not an if/elif/elsif/endif", "#else this_is_an_else_statement", "Gamma this is not an if/elif/elsif/endif", "#endif this_is_an_endif_statement", ]; $self->{line_no} = [ 17 .. 22 ]; $self->{XSStack}->[-1]{type} = 'if'; $self->{filename} = 'myfile1'; my $rv; my $stderr = PrimitiveCapture::capture_stderr(sub { $rv = check_conditional_preprocessor_statements($self); }); is( $rv, undef, "Missing 'if' case: returned undef: all ifs resolved" ); like( $stderr, qr/Warning: #else\/elif\/endif without #if in this function/, "Got expected warning: lack of #if" ); like( $stderr, qr/precede it with a blank line/s, "Got expected warning: advice re blank line" ); } { $self->{line} = [ "Alpha this is not an if/elif/elsif/endif", "#elif this_is_an_elif_statement", "Beta this is not an if/elif/elsif/endif", "#else this_is_an_else_statement", "Gamma this is not an if/elif/elsif/endif", "#endif this_is_an_endif_statement", ]; $self->{line_no} = [ 17 .. 22 ]; $self->{XSStack}->[-1]{type} = 'file'; $self->{filename} = 'myfile1'; my $rv; my $stderr = PrimitiveCapture::capture_stderr(sub { $rv = check_conditional_preprocessor_statements($self); }); is( $rv, undef, "Missing 'if' case: returned undef: all ifs resolved" ); like( $stderr, qr/Warning: #else\/elif\/endif without #if in this function/, "Got expected warning: lack of #if" ); unlike( $stderr, qr/precede it with a blank line/s, "Did not get unexpected stderr" ); } { $self->{line} = [ "#if this_is_an_if_statement", "Alpha this is not an if/elif/elsif/endif", "#elif this_is_an_elif_statement", "Beta this is not an if/elif/elsif/endif", "#else this_is_an_else_statement", "Gamma this is not an if/elif/elsif/endif", ]; $self->{line_no} = [ 17 .. 22 ]; $self->{XSStack}->[-1]{type} = 'if'; $self->{filename} = 'myfile1'; my $rv; my $stderr = PrimitiveCapture::capture_stderr(sub { $rv = check_conditional_preprocessor_statements($self); }); isnt( $rv, 0, "Missing 'endif' case: returned non-zero as expected" ); like( $stderr, qr/Warning: #if without #endif in this function/s, "Got expected warning: lack of #endif" ); } pass("Passed all tests in $0"); ExtUtils-ParseXS-3.30/t/XSUsage.pm0000644000175000017500000000016511607127676015364 0ustar tseetseepackage XSUsage; require DynaLoader; @ISA = qw(Exporter DynaLoader); $VERSION = '0.01'; bootstrap XSUsage $VERSION; ExtUtils-ParseXS-3.30/t/003-usage.t0000644000175000017500000000523312305422611015260 0ustar tseetsee#!/usr/bin/perl use strict; use Test::More; use Config; use DynaLoader; use ExtUtils::CBuilder; if ( $] < 5.008 ) { plan skip_all => "INTERFACE keyword support broken before 5.8"; } else { plan tests => 24; } my ($source_file, $obj_file, $lib_file, $module); require_ok( 'ExtUtils::ParseXS' ); chdir('t') if -d 't'; use Carp; $SIG{__WARN__} = \&Carp::cluck; # See the comments about this in 001-basics.t @INC = map { File::Spec->rel2abs($_) } @INC if $^O =~ /android/; ######################### $source_file = 'XSUsage.c'; # Try sending to file ExtUtils::ParseXS->process_file(filename => 'XSUsage.xs', output => $source_file); ok -e $source_file, "Create an output file"; # TEST doesn't like extraneous output my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; # Try to compile the file! Don't get too fancy, though. my $b = ExtUtils::CBuilder->new(quiet => $quiet); SKIP: { skip "no compiler available", 2 if ! $b->have_compiler; $module = 'XSUsage'; $obj_file = $b->compile( source => $source_file ); ok $obj_file; ok -e $obj_file, "Make sure $obj_file exists"; } SKIP: { skip "no dynamic loading", 20 if !$b->have_compiler || !$Config{usedl}; $lib_file = $b->link( objects => $obj_file, module_name => $module ); ok $lib_file; ok -e $lib_file, "Make sure $lib_file exists"; eval {require XSUsage}; is $@, ''; # The real tests here - for each way of calling the functions, call with the # wrong number of arguments and check the Usage line is what we expect eval { XSUsage::one(1) }; ok $@; ok $@ =~ /^Usage: XSUsage::one/; eval { XSUsage::two(1) }; ok $@; ok $@ =~ /^Usage: XSUsage::two/; eval { XSUsage::two_x(1) }; ok $@; ok $@ =~ /^Usage: XSUsage::two_x/; eval { FOO::two(1) }; ok $@; ok $@ =~ /^Usage: FOO::two/; eval { XSUsage::three(1) }; ok $@; ok $@ =~ /^Usage: XSUsage::three/; eval { XSUsage::four(1) }; ok !$@; eval { XSUsage::five() }; ok $@; ok $@ =~ /^Usage: XSUsage::five/; eval { XSUsage::six() }; ok !$@; eval { XSUsage::six(1) }; ok !$@; eval { XSUsage::six(1,2) }; ok $@; ok $@ =~ /^Usage: XSUsage::six/; # Win32 needs to close the DLL before it can unlink it, but unfortunately # dl_unload_file was missing on Win32 prior to perl change #24679! if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { if ($DynaLoader::dl_modules[$i] eq $module) { DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); last; } } } } unless ($ENV{PERL_NO_CLEANUP}) { for ( $obj_file, $lib_file, $source_file) { next unless defined $_; 1 while unlink $_; } } ExtUtils-ParseXS-3.30/t/511-t-whitespace.t0000644000175000017500000000156611624165440016571 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; use ExtUtils::Typemaps; SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => ' $var = ($type)SvUV($arg);'); is($map->as_string(), <<'HERE', "Simple typemap (with input and code including leading whitespace) matches expectations"); TYPEMAP unsigned int T_UV INPUT T_UV $var = ($type)SvUV($arg); HERE } SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => " \$var =\n(\$type)\n SvUV(\$arg);"); is($map->as_string(), <<'HERE', "Simple typemap (with input and multi-line code) matches expectations"); TYPEMAP unsigned int T_UV INPUT T_UV $var = ($type) SvUV($arg); HERE } ExtUtils-ParseXS-3.30/t/510-t-bare.t0000644000175000017500000001161211624165440015336 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 43; use ExtUtils::Typemaps; # empty typemap SCOPE: { ok(ExtUtils::Typemaps->new()->is_empty(), "This is an empty typemap"); } # typemap only SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_IV'); ok(!$map->is_empty(), "This is not an empty typemap"); is($map->as_string(), <<'HERE', "Simple typemap matches expectations"); TYPEMAP unsigned int T_IV HERE my $type = $map->get_typemap(ctype => 'unsigned int'); isa_ok($type, 'ExtUtils::Typemaps::Type'); is($type->ctype, 'unsigned int'); is($type->xstype, 'T_IV'); is($type->tidy_ctype, 'unsigned int'); # test failure ok(!$map->get_typemap(ctype => 'foo'), "Access to nonexistent typemap doesn't die"); ok(!$map->get_inputmap(ctype => 'foo'), "Access to nonexistent inputmap via ctype doesn't die"); ok(!$map->get_outputmap(ctype => 'foo'), "Access to nonexistent outputmap via ctype doesn't die"); ok(!$map->get_inputmap(xstype => 'foo'), "Access to nonexistent inputmap via xstype doesn't die"); ok(!$map->get_outputmap(xstype => 'foo'), "Access to nonexistent outputmap via xstype doesn't die"); ok(!eval{$map->get_typemap('foo')} && $@, "Access to typemap with positional params dies"); ok(!eval{$map->get_inputmap('foo')} && $@, "Access to inputmap with positional params dies"); ok(!eval{$map->get_outputmap('foo')} && $@, "Access to outputmap with positional params dies"); } # typemap & input SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); ok(!$map->is_empty(), "This is not an empty typemap"); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); is($map->as_string(), <<'HERE', "Simple typemap (with input) matches expectations"); TYPEMAP unsigned int T_UV INPUT T_UV $var = ($type)SvUV($arg); HERE my $type = $map->get_typemap(ctype => 'unsigned int'); isa_ok($type, 'ExtUtils::Typemaps::Type'); is($type->ctype, 'unsigned int'); is($type->xstype, 'T_UV'); is($type->tidy_ctype, 'unsigned int'); my $in = $map->get_inputmap(xstype => 'T_UV'); isa_ok($in, 'ExtUtils::Typemaps::InputMap'); is($in->xstype, 'T_UV'); # test fetching inputmap by ctype my $in2 = $map->get_inputmap(ctype => 'unsigned int'); is_deeply($in2, $in, "get_inputmap returns the same typemap for ctype and xstype"); } # typemap & output SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); ok(!$map->is_empty(), "This is not an empty typemap"); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); is($map->as_string(), <<'HERE', "Simple typemap (with output) matches expectations"); TYPEMAP unsigned int T_UV OUTPUT T_UV sv_setuv($arg, (UV)$var); HERE my $type = $map->get_typemap(ctype => 'unsigned int'); isa_ok($type, 'ExtUtils::Typemaps::Type'); is($type->ctype, 'unsigned int'); is($type->xstype, 'T_UV'); is($type->tidy_ctype, 'unsigned int'); my $in = $map->get_outputmap(xstype => 'T_UV'); isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); is($in->xstype, 'T_UV'); } # typemap & input & output SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); ok(!$map->is_empty(), "This is not an empty typemap"); is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations"); TYPEMAP unsigned int T_UV INPUT T_UV $var = ($type)SvUV($arg); OUTPUT T_UV sv_setuv($arg, (UV)$var); HERE } # two typemaps & input & output SCOPE: { my $map = ExtUtils::Typemaps->new(); $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); $map->add_typemap(ctype => 'int', xstype => 'T_IV'); $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);'); $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);'); is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations"); TYPEMAP unsigned int T_UV int T_IV INPUT T_UV $var = ($type)SvUV($arg); T_IV $var = ($type)SvIV($arg); OUTPUT T_UV sv_setuv($arg, (UV)$var); T_IV sv_setiv($arg, (IV)$var); HERE my $type = $map->get_typemap(ctype => 'unsigned int'); isa_ok($type, 'ExtUtils::Typemaps::Type'); is($type->ctype, 'unsigned int'); is($type->xstype, 'T_UV'); is($type->tidy_ctype, 'unsigned int'); my $in = $map->get_outputmap(xstype => 'T_UV'); isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); is($in->xstype, 'T_UV'); $in = $map->get_outputmap(xstype => 'T_IV'); isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); is($in->xstype, 'T_IV'); } ExtUtils-ParseXS-3.30/t/101-standard_typemap_locations.t0000644000175000017500000000221512142361637021573 0ustar tseetsee#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations ); { local @INC = @INC; my @stl = standard_typemap_locations( \@INC ); ok( @stl >= 9, "At least 9 entries in typemap locations list" ); is( $stl[$#stl], 'typemap', "Last element is typemap in current directory"); SKIP: { skip "No lib/ExtUtils/ directories under directories in \@INC", 1 unless @stl > 9; # We check only as many location entries from the start of the array # (where the @INC-related entries are) as there are entries from @INC. # We manage to do that by stopping when we find the "updir" related # entries, which we assume is never contained in a default @INC entry. my $updir = File::Spec->updir; my $max = $#INC; $max = $#stl if $#stl < $max; foreach my $i (0.. $max) { $max = $i, last if $stl[$i] =~ /\Q$updir\E/; } ok( ( 0 < (grep -f $_, @stl[0..$max]) ), "At least one typemap file exists underneath \@INC directories" ); } } ExtUtils-ParseXS-3.30/t/501-t-compile.t0000644000175000017500000000033511624165440016055 0ustar tseetsee#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; } use Test::More tests => 2; # Check their perl version ok( $] >= 5.006001, "Your perl is new enough" ); # Does the module load use_ok( 'ExtUtils::Typemaps' ); ExtUtils-ParseXS-3.30/META.json0000664000175000017500000000254412571011400014644 0ustar tseetsee{ "abstract" : "converts Perl XS code into C code", "author" : [ "Ken Williams " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150001", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "ExtUtils-ParseXS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.46" } }, "runtime" : { "requires" : { "Carp" : "0", "Cwd" : "0", "DynaLoader" : "0", "Exporter" : "5.57", "ExtUtils::CBuilder" : "0", "ExtUtils::MakeMaker" : "6.46", "File::Basename" : "0", "File::Spec" : "0", "Symbol" : "0", "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.perl.org/rt3/" }, "repository" : { "url" : "git://perl5.git.perl.org/gitroot/perl.git" } }, "version" : "3.30" } ExtUtils-ParseXS-3.30/INSTALL0000644000175000017500000000044711332012433014253 0ustar tseetsee Installation instructions for ExtUtils::ParseXS To install this module, follow the standard steps for installing most Perl modules: perl Makefile.PL make make test make install Or you may use the CPAN.pm module, which will automatically execute these steps for you. -Ken ExtUtils-ParseXS-3.30/Makefile.PL0000644000175000017500000000570612207701703015206 0ustar tseetseeuse 5.006001; use strict; use warnings; use ExtUtils::MakeMaker 6.46; use Config '%Config'; use File::Spec; # It's a weirdness in ExtUtils::MakeMaker that, when searching for xsubpp, # it searches @INC for $path/ExtUtils/xsubpp instead of looking for an # executable in the $PATH or whatever. # EU::MM will pick up whatever xsubpp is found first in @INC. # Thus, we must at least warn the user when we're about to install a new # xsubpp to a location that may be shadowed by an old one. my $whereto = ($] > 5.010001 ? 'site' : 'perl'); my $instdir = $whereto eq 'site' ? $Config{installsitelib} : $Config{installprivlib}; $instdir = File::Spec->canonpath($instdir); my $target_xsubpp = File::Spec->catfile($instdir, 'ExtUtils', 'xsubpp'); my @shadowing_xsubpps; foreach my $dir (grep !ref, @INC) { my $cpath = File::Spec->canonpath($dir); my $test_xsubpp = File::Spec->catdir($cpath, 'ExtUtils', 'xsubpp'); last if $cpath eq $instdir or $target_xsubpp eq $test_xsubpp; if (-r $test_xsubpp) { push @shadowing_xsubpps, $test_xsubpp; } } if (@shadowing_xsubpps) { my $problems = join("\n ", @shadowing_xsubpps); warn < 'ExtUtils::ParseXS', 'VERSION_FROM' => 'lib/ExtUtils/ParseXS.pm', 'PREREQ_PM' => { 'Carp' => 0, 'Cwd' => 0, 'DynaLoader' => 0, 'Exporter' => '5.57', 'ExtUtils::CBuilder' => 0, 'File::Basename' => 0, 'File::Spec' => 0, 'Symbol' => 0, 'Test::More' => '0.47', 'ExtUtils::MakeMaker' => '6.46', }, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '6.46', }, META_MERGE => { resources => { bugtracker => 'http://rt.perl.org/rt3/', repository => 'git://perl5.git.perl.org/gitroot/perl.git', }, }, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/ExtUtils/ParseXS.pod', AUTHOR => 'Ken Williams ') : ()), 'INSTALLDIRS' => $whereto, 'EXE_FILES' => ['lib/ExtUtils/xsubpp'], 'PL_FILES' => {} ); ExtUtils-ParseXS-3.30/Changes0000644000175000017500000004544412571010705014531 0ustar tseetseeRevision history for Perl extension ExtUtils::ParseXS. 3.30 - Mon Aug 31 10:35:00 CET 2015 - Promote to stable CPAN release. 3.29_01 - Mon Aug 10 10:45:00 CET 2015 - Support added for XS handshake API introduced in 5.21.6. - Backported S_croak_xs_usage optimized on threaded builds - Fix INCLUDE_COMMAND $^X for Perl In Space - Remove 'use lib' left over from refactoring - Document + improve ancient optimization in ParseXS - Improve RETVAL code gen 3.24 - Wed Mar 5 18:20:00 CET 2014 - Native Android build fixes - More lenient syntax for embedded TYPEMAP blocks in XS: a trailing semicolon will not be required for the block terminator. - Code cleanup. 3.22 - Thu Aug 29 19:30:00 CET 2013 - Fix parallel testing crashes. - Explicitly require new-enough Exporter. 3.21 - Fri Aug 9 19:08:00 CET 2013 - stop "sv_2mortal(&PL_sv_yes)" and "(void)sv_newmortal()" for immortal typemap entries [perl #116152] - Deterministic C output (fix for hash randomization in 5.18). 3.18_04 - Fri Jun 20 17:47:00 CET 2013 - Fix targetable size detection (& better tests) - Assorted cleanup and refactoring. 3.18_03 - Fri Apr 19 18:40:00 CET 2013 - Heuristic (and flawed) type canonicalization for templated C++ types. - More tests ported from core. 3.18_02 - Mon Apr 15 07:30:00 CET 2013 - ExtUtils::ParseXS no longer uses global state (if using OO interface). - New "real" OO interface. 3.18_01 - Thu Apr 11 19:17:00 CET 2013 - ExtUtils::Typemaps gains a clone method. 3.18 - Mon Nov 19 07:35:00 CET 2012 - Restore portability to Perl 5.6, which was lost at EU-PXS 3.00. - [perl #112776] avoid warning on an initialized non-parameter - Only increment PL_amagic_generation before 5.9 3.15 - Thu Feb 2 08:12:00 CET 2012 - Fix version for PAUSE indexer. 3.14 - Wed Feb 1 18:22:00 CET 2012 - Promote to stable release. - Proper repository and bugtracker info in META.json. 3.13_01 - Sat Jan 29 12:45:00 CET 2012 - ExtUtils::Typemaps: => Embedded typemap dumping: A method which will produce the verbatim string for inclusion in XS. => Introducing ExtUtils::Typemaps::Cmd, a helper module which can produce embedded typemap strings via simple one-liners. Useful for including typemaps from other modules in XS code with INCLUDE_COMMAND. See "perldoc ExtUtils::Typemaps::Cmd". - ExtUtils::ParseXS: => Bugfix: Used to have parsing problems with embedded typemaps occasionally. => Better error messages on typemap-related issues. If a no typemap was found for a given C type, list all mapped C types so that the user hopefully spots his mistake easily. 3.11 - Thu Dec 29 17:55:00 CET 2011 - Version/distribution fixes. 3.09 - Wed Dec 28 18:48:00 CET 2011 - Escape double quotes of file names/commands in #line directives. 3.08 - Mon Dec 19 18:03:00 CET 2011 - Silence undefined-value-in-addition warning (Nothing serious, just happened sometimes when reporting line numbers for errors. But warning during build process.) 3.07 - Wed Dec 7 14:10:00 CET 2011 - Fix inconsistent versioning in 3.06. 3.06 - Fri Dec 2 08:10:00 CET 2011 - Fix Cygwin issues [Tony Cook] avoid conflicting static / dllexport on legacy perls too This probably fixes rt.cpan.org 72313 and 71964. (3928a66ad4bd8aee704eda1942b7877c0ff1ab2c in core) - Convert ` to ' [James Keenan] 55bee391aeff3c3b8d22fa4ce5491ee9440028aa and 6dfee1ec62c64d7afe8ced4650596dd9e7f71a63 in core - Avoid some test-time warnings [Zefram] 97bae9c59cd181b3b54061213ec1fdce0ccb30d4 in core 3.05 - Wed Oct 5 08:14:00 CET 2011 - No functional changes, promoted to stable release. 3.04_04 - Mon Sep 12 08:12:00 CET 2011 - Simplify generated XS code by emitting a compatibility version of dVAR. [Nicholas Clark] - Fixed "INCLUDE: $cmd |", CPAN RT #70213 3.04_03 - Sun Sep 4 18:49:00 CET 2011 - By #defining PERL_EUPXS_ALWAYS_EXPORT or PERL_EUPXS_NEVER_EXPORT early in your XS code, you can force ExtUtils::ParseXS to always or never export XSUB symbols. This has no effect on boot_* symbols since those must be exported. 3.04_02 - Sat Sep 3 15:28:00 CET 2011 - Don't put null characters into the generated source file when -except is used; write the '\0' escape sequence properly instead. [Stephen Bennett] 3.04_01 - Sun Aug 28 17:50:00 CET 2011 - The XSUB.h changes to make XS(name) use XS_INTERNAL(name) by default (which were in the 5.15.2 dev release of perl) have been reverted since too many CPAN modules expect to be able to refer to XSUBs declared with XS(name). Instead, ExtUtils::ParseXS will define a copy of the XS_INTERNAL/XS_EXTERNAL macros as necessary going back to perl 5.10.0 (which is the oldest perl I had for testing). By default, ExtUtils::ParseXS will use XS_INTERNAL(name) instead of XS(name). 3.04 - Thu Aug 25 08:20:00 CET 2011 - Stable release based on 3.03_03, no functional changes. 3.03_03 - Wed Aug 24 19:43:00 CET 2011 - Try to fix regression for input-typemap override in XS argument list. (CPAN RT #70448) - Explicit versions in submodules to fail early if something goes wrong. 3.03_02 - Sun Aug 21 13:19:00 CET 2011 - Properly strip trailing semicolons form inputmaps. These could trigger warnings (errors in strict C89 compilers) due to additional semicolons being interpreted as empty statements. [Torsten Schoenfeld, Jan Dubois, Steffen Mueller] - Now detects and throws a warning if there is a CODE section using RETVAL, but no OUTPUT section. [CPAN RT #69536] - Uses the explicit XS_EXTERNAL macro (from perl 5.15.2 and newer) for XSUBs that need to be exported. Defines XS_EXTERNAL to fall back to XS where that is not available. - Introduces new EXPORT_XSUB_SYMBOLS XS keyword that forces exported XSUB symbols. It's a no-op on perls before 5.15.2. 3.03 - Thu Aug 11 08:24:00 CET 2011 - Test fix: Try all @INC-derived typemap locations. (CPAN RT #70047) [Mike Sheldrake] 3.02 - Thu Aug 4 18:19:00 CET 2011 - Test fix: Use File::Spec->catfile instead of catdir where appropriate. 3.01 - Thu Aug 4 17:51:00 CET 2011 - No significant changes from 3.00_05. 3.00_05 - Wed Jul 27 22:54:00 CET 2011 - Define PERL_UNUSED_ARG for pre-3.8.9 perls. This should fix the tests on those perls. 3.00_04 - Wed Jul 27 22:22:00 CET 2011 - Require perl 5.8.1. - Patches from CPAN RT #53938, #61908 Both of these are attempts to fix win32 problems: Bug #61908 for ExtUtils-ParseXS: MSWin compilers and back-slashed paths Bug #53938 for ExtUtils-ParseXS: MinGW Broken after 2.21 3.00_03 - Fri Jul 22 20:13:00 CET 2011 - Add some diagnostics when xsubpp fails to load a current-enough version of ExtUtils::ParseXS. [Steffen Mueller] - Add a check to Makefile.PL that scans @INC to determine whether the new xsubpp will be shadowed by another, existing xsubpp and warn the user vehemently. [Steffen Mueller] 3.00_02 - Thu Jul 14 18:00:00 CET 2011 - Move script/xsubpp back to lib/ExtUtils/xsubpp The original move caused old xsubpp's to be used. 3.00_01 - Tue Jul 12 22:00:00 CET 2011 - Major refactoring of the whole code base. It finally runs under 'use strict' for the first time! [James Keenan, Steffen Mueller] - Typemaps can now be embedded into XS code using a here-doc like syntax and the new "TYPEMAP:" XS keyword. [Steffen Mueller] - Move typemap handling code to ExtUtils::Typemaps with full object-oriented goodness. [Steffen Mueller] - Check API compatibility when loading xs modules. If on a new-enough perl, add the XS_APIVERSION_BOOTCHECK macro to the _boot function of every XS module to compare it against the API version the module has been compiled against. If the versions do not match, an exception is thrown. [Florian Ragwitz] - Fixed compiler warnings in XS. [Zefram] - Spell-check [Peter J. Acklam] 2.2206 - Sun Jul 4 15:43:21 EDT 2010 Bug fixes: - Make xsubpp accept the _ prototype (RT#57157) [Rafael Garcia-Suarez] - INCLUDE_COMMAND portability fixes for VMS (RT#58181) [Craig Berry] - INCLUDE_COMMAND fixes to detect non-zero exit codes (RT#52873) [Steffen Mueller] 2.2205 - Wed Mar 10 18:15:36 EST 2010 Other: - No longer ships with Build.PL to avoid creating a circular dependency 2.2204 - Wed Mar 10 14:23:52 EST 2010 Other: - Downgraded warnings on using INCLUDE with a command from "deprecated" to "discouraged" and limited it to the case where the command includes "perl" [Steffen Mueller] 2.2203 - Thu Feb 11 14:00:51 EST 2010 Bug fixes: - Build.PL was not including ExtUtils/xsubpp for installation. Fixed by subclassing M::B::find_pm_files to include it [David Golden] 2.2202 - Wed Jan 27 15:04:59 EST 2010 Bug fixes: - The fix to IN/OUT/OUTLIST was itself broken and is now fixed. [Reported by Serdar Dalgic; fix suggested by Rafael Garcia-Suarez] We apologize for the fault in the regex. Those responsible have been sacked. 2.2201 Mon Jan 25 16:12:05 EST 2010 Bug fixes: - IN/OUT/OUTLIST, etc. were broken due to a bad regexp. [Simon Cozens] 2.22 - Mon Jan 11 15:00:07 EST 2010 No changes from 2.21_02 2.21_02 - Sat Dec 19 10:55:41 EST 2009 Bug fixes: - fixed bugs and added tests for INCLUDE_COMMAND [Steffen Mueller] 2.21_01 - Sat Dec 19 07:22:44 EST 2009 Enhancements: - New 'INCLUDE_COMMAND' directive [Steffen Mueller] Bug fixes: - Workaround for empty newXS macro found in P5NCI [Goro Fuji] 2.21 - Mon Oct 5 11:17:53 EDT 2009 Bug fixes: - Adds full path in INCLUDE #line directives (RT#50198) [patch by "spb"] Other: - Updated copyright and maintainer list 2.20_07 - Sat Oct 3 11:26:55 EDT 2009 Bug fixes: - Use "char* file" for perl < 5.9, not "char[] file"; fixes mod_perl breakage due to prior attempts to fix RT#48104 [David Golden] 2.20_06 - Fri Oct 2 23:45:45 EDT 2009 Bug fixes: - Added t/typemap to fix broken test on perl 5.6.2 [David Golden] - More prototype fixes for older perls [Goro Fuji] - Avoid "const char *" in test files as it breaks on 5.6.2 [Goro Fuji] Other: - Merged changes from 2.2004 maintenance branch (see 2.200401 to 2.200403) [David Golden] 2.20_05 - Sat Aug 22 21:46:56 EDT 2009 Bug fixes: - Fix prototype related bugs [Goro Fuji] - Fix the SCOPE keyword [Goro Fuji] 2.200403 - Fri Oct 2 02:01:58 EDT 2009 Other: - Removed PERL_CORE specific @INC manipulation (no longer needed) [Nicholas Clark] - Changed hard-coded $^H manipulation in favor of "use re 'eval'" [Nicholas Clark] 2.200402 - Fri Oct 2 01:26:40 EDT 2009 Bug fixes: - UNITCHECK subroutines were not being called (detected in ext/XS-APItest in Perl blead) [reported by Jesse Vincent, patched by David Golden] 2.200401 - Mon Sep 14 22:26:03 EDT 2009 - No changes from 2.20_04. 2.20_04 - Mon Aug 10 11:18:47 EDT 2009 Bug fixes: - Changed install_dirs to 'core' for 5.8.9 as well (RT#48474) - Removed t/bugs.t until there is better C++ support in ExtUtils::CBuilder Other: - Updated repository URL in META file 2.20_03 - Thu Jul 23 23:14:50 EDT 2009 Bug fixes: - Fixed "const char *" errors for 5.8.8 (and older) (RT#48104) [Vincent Pit] - Added newline before a preprocessor directive (RT#30673) [patch by hjp] 2.2002 - Sat Jul 18 17:22:27 EDT 2009 Bug fixes: - Fix Makefile.PL installdirs for older perls 2.20_01 - Wed Jul 8 12:12:47 EDT 2009 - Fix XSUsage prototypes for testing [Jan Dubois] 2.20 - Wed Jul 1 13:42:11 EDT 2009 - No changes from 2.19_04 2.19_04 - Mon Jun 29 11:49:12 EDT 2009 - Changed tests to use Test::More and added it to prereqs - Some tests skip if no compiler or if no dynamic loading - INTERFACE keyword tests skipped for perl < 5.8 2.19_03 - Sat Jun 27 22:51:18 EDT 2009 - Released to see updated results from smoke testers - Fix minor doc typo pulled from blead 2.19_02 - Wed Aug 6 22:18:33 2008 - Fix the usage reports to consistently report package name as well as sub name across ALIAS, INTERFACE and regular XSUBS. [Robert May] - Cleaned up a warning with -Wwrite-strings that gets passed into every parsed XS file. [Steve Peters] - Allow (pedantically correct) C pre-processor comments in the code snippets of typemap files. [Nicholas Clark] 2.19 - Sun Feb 17 14:27:40 2008 - Fixed the treatment of the OVERLOAD: keyword, which was causing a C compile error. [Toshiyuki Yamato] 2.18 - Mon Jan 29 20:56:36 2007 - Added some UNITCHECK stuff, which (I think) makes XS code able to do UNITCHECK blocks. [Nicholas Clark] - Changed 'use re "eval";' to 'BEGIN { $^H |= 0x00200000 };' so we can compile re.xs in bleadperl. [Yves Orton] - Fix an undefined-variable warning related to 'inout' parameter processing. 2.17 - Mon Nov 20 17:07:27 2006 - Stacked $filepathname to make #line directives in #INCLUDEs work. [Nicholas Clark] - Sprinked dVAR in with dXSARGS, for God-(Jarkko)-knows-what reason. [Jarkko Hietaniemi] - Use printf-style formats in Perl_croak() for some significant savings in number of distinct constant strings in the linked binaries we create. [Alexey Tourbin] - Don't use 'class' as a variable name in the t/XSTest.xs module, since that's a keyword in C++. [Jarkko Hietaniemi] 2.16 Fri Sep 15 22:33:24 CDT 2006 - Fix a problem with PREFIX not working inside INTERFACE sections. [Salvador Fandin~o] 2.15 Mon Oct 10 11:02:13 EDT 2005 - I accidentally left out a README from the distribution. Now it's auto-created from the main documentation in ExtUtils/ParseXS.pm. 2.14 Sat Oct 8 21:49:15 EDT 2005 - The filehandle for the .xs file was never being properly closed, and now it is. This was causing some Win32 problems with Module::Build's tests, which create a .xs file, process it with ParseXS, and then try to remove it. [Spotted by Randy Sims] 2.13 Mon Oct 3 21:59:06 CDT 2005 - Integrate a cleanup-related change from bleadperl that somehow never got into this copy. [Steve Hay] 2.12 Wed Aug 24 20:03:09 CDT 2005 - On Win32, there was a DLL file we create during testing that we couldn't delete unless we closed it first, so testing failed when the deletion was attempted. This should now work (provided the version of perl is high enough to have DynaLoader::dl_unload_file() - I'm not sure what will happen otherwise). [Steve Hay] - Fix a spurious warning during testing about a variable that's used before it's initialized. [Steve Hay] 2.11 Mon Jun 13 23:00:23 CDT 2005 - Make some variables global, to avoid some "will not stay shared" warnings at compile time. [Rafael Garcia-Suarez] 2.10 Mon May 30 21:29:44 CDT 2005 - This module is being integrated into the perl core; the regression tests will now work properly when run as part of the core build. [Yitzchak Scott-Thoennes] - Added the ability to create output files with a suffix other than ".c", via the new "csuffix" option. This gets the module working on Symbian. [Jarkko Hietaniemi] - Added the ability to put 'extern "C"' declarations in front of prototypes. [Jarkko Hietaniemi] 2.09 Sun Mar 27 11:11:49 CST 2005 - Integrated change #18270 from the perl core, which fixed a problem in which xsubpp can make nested comments in C code (which is bad). [Nicholas Clark] - When no "MODULE ... PACKAGE ... PREFIX" line is found, it's now still a fatal error for ParseXS, but we exit with status 0, which is what the old xsubpp did and seems to work best with some modules like Win32::NetAdmin. See RT ticket 11472. [Steve Hay] 2.08 Fri Feb 20 21:41:22 CST 2004 - Fixed a problem with backslashes in file paths (e.g. C:\Foo\Bar.xs) disappearing in error messages. [Randy Sims, Steve Hay] - Did a little minor internal code cleanup in the ExtUtils::ParseXS::CountLines class, now other classes don't poke around in its package variables. 2.07 Sun Jan 25 17:01:52 CST 2004 - We now use ExtUtils::CBuilder for testing the compile/build phase in the regression tests. It's not necessary to have it for runtime usage, though. - Fixed a minor documentation error (look in 'Changes' for revision history, not 'changes.pod'). [Scott R. Godin] 2.06 Fri Dec 26 09:00:47 CST 2003 - Some fixes in the regression tests for the AIX platform. 2.05 Mon Sep 29 10:33:39 CDT 2003 - We no longer trim the directory portions from the "#line " comments in the generated C code. This helps cooperation with many editors' auto-jump-to-error stuff. [Ross McFarland] - In some cases the PERL_UNUSED_VAR macro is needed to get rid of C compile-time warnings in generated code. Since this eliminates so many warnings, turning on "-Wall -W" (or your platform's equivalent) can once again be helpful. [Ross McFarland] - Did a huge amount of variable-scoping cleanup, and it *still* doesn't compile under 'use strict;'. Much progress was made though, and many scoping issues were fixed. 2.04 Thu Sep 4 13:10:59 CDT 2003 - Added a COPYRIGHT section to the documentation. [Spotted by Ville Skytta] 2.03 Sat Aug 16 17:49:03 CST 2003 - Fixed a warning that occurs if a regular expression (buried deep within the bowels of the code here) fails. [Spotted by Michael Schwern] - Fixed a testing error on Cygwin. [Reini Urban] 2.02 Sun Mar 30 18:20:12 CST 2003 - Now that we know this module doesn't work (yet?) with perl 5.005, put a couple 'use 5.006' statements in the module & Makefile.PL so we're explicit about the dependency. [Richard Clamp] 2.01 Thu Mar 20 08:22:36 CST 2003 - Allow -C++ flag for backward compatibility. It's a no-op, and has been since perl5.003_07. [PodMaster] 2.00 Sun Feb 23 16:40:17 CST 2003 - Tests now function under all three of the supported compilers on Windows environments. [Randy W. Sims] - Will now install to the 'core' perl module directory instead of to 'site_perl' or the like, because this is the only place MakeMaker will look for the xsubpp script. - Explicitly untie and close the output file handle because ParseXS was holding the file handle open, preventing the compiler from opening it on Win32. [Randy W. Sims] - Added an '--output FILENAME' flag to xsubpp and changed ParseXS to use the named file in the #line directives when the output file has an extension other than '.c' (i.e. '.cpp'). [Randy W. Sims] - Added conditional definition of the PERL_UNUSED_VAR macro to the output file in case it's not already defined for backwards compatibility with pre-5.8 versions of perl. (Not sure if this is the best solution.) [Randy W. Sims] 1.99 Wed Feb 5 10:07:47 PST 2003 - Version bump to 1.99 so it doesn't look like a 'beta release' to CPAN.pm. No code changes, since I haven't had any bug reports. - Fixed a minor problem in the regression tests that was creating an XSTest..o file instead of XSTest.o 1.98_01 Mon Dec 9 11:50:41 EST 2002 - Converted from ExtUtils::xsubpp in bleadperl - Basic set of regression tests written ExtUtils-ParseXS-3.30/README0000644000175000017500000001115712562062036014114 0ustar tseetseeNAME ExtUtils::ParseXS - converts Perl XS code into C code SYNOPSIS use ExtUtils::ParseXS; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file( filename => 'foo.xs' ); $pxs->process_file( filename => 'foo.xs', output => 'bar.c', 'C++' => 1, typemap => 'path/to/typemap', hiertype => 1, except => 1, versioncheck => 1, linenumbers => 1, optimize => 1, prototypes => 1, ); # Legacy non-OO interface using a singleton: use ExtUtils::ParseXS qw(process_file); process_file( filename => 'foo.xs' ); DESCRIPTION "ExtUtils::ParseXS" will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to determine how to map C function parameters and variables to Perl values. The compiler will search for typemap files called *typemap*. It will use the following search path to find default typemaps, with the rightmost typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap EXPORT None by default. "process_file()" and/or "report_error_count()" may be exported upon request. Using the functional interface is discouraged. METHODS $pxs->new() Returns a new, empty XS parser/compiler object. $pxs->process_file() This method processes an XS file and sends output to a C file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. Named parameters control how the processing is done. The following parameters are accepted: C++ Adds "extern "C"" to the C code. Default is false. hiertype Retains "::" in type names so that C++ hierarchical types can be mapped. Default is false. except Adds exception handling stubs to the C code. Default is false. typemap Indicates that a user-supplied typemap should take precedence over the default typemaps. A single typemap may be specified as a string, or multiple typemaps can be specified in an array reference, with the last typemap having the highest precedence. prototypes Generates prototype code for all xsubs. Default is false. versioncheck Makes sure at run time that the object file (derived from the ".xs" file) and the ".pm" files have the same version number. Default is true. linenumbers Adds "#line" directives to the C output so error messages will look like they came from the original XS file. Default is true. optimize Enables certain optimizations. The only optimization that is currently affected is the use of *target*s by the output C code (see perlguts). Not optimizing may significantly slow down the generated code, but this is the way xsubpp of 5.005 and earlier operated. Default is to optimize. inout Enable recognition of "IN", "OUT_LIST" and "INOUT_LIST" declarations. Default is true. argtypes Enable recognition of ANSI-like descriptions of function signature. Default is true. s *Maintainer note:* I have no clue what this does. Strips function prefixes? $pxs->report_error_count() This method returns the number of [a certain kind of] errors encountered during processing of the XS file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. AUTHOR Based on xsubpp code, written by Larry Wall. Maintained by: * Ken Williams, * David Golden, * James Keenan, * Steffen Mueller, COPYRIGHT Copyright 2002-2014 by Ken Williams, David Golden and other contributors. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Based on the "ExtUtils::xsubpp" code by Larry Wall and the Perl 5 Porters, which was released under the same license terms. SEE ALSO perl, ExtUtils::xsubpp, ExtUtils::MakeMaker, perlxs, perlxstut.