package ExtUtils::ParseXS::Utilities;
use strict;
use warnings;
use Exporter;
use File::Spec;
use lib qw( lib );
use ExtUtils::ParseXS::Constants ();

our $VERSION = '3.19';

our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
standard_typemap_locations
trim_whitespace
tidy_type
C_string
valid_proto_string
process_typemaps
make_targetable
map_type
standard_XS_defs
assign_func_args
analyze_preprocessor_statements
set_cond
Warn
current_line_number
blurt
death
check_conditional_preprocessor_statements
escape_file_for_line_directive
report_typemap_failure
);

=head1 NAME

ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS

=head1 SYNOPSIS

use ExtUtils::ParseXS::Utilities qw(
standard_typemap_locations
trim_whitespace
tidy_type
C_string
valid_proto_string
process_typemaps
make_targetable
map_type
standard_XS_defs
assign_func_args
analyze_preprocessor_statements
set_cond
Warn
blurt
death
check_conditional_preprocessor_statements
escape_file_for_line_directive
report_typemap_failure
);

=head1 SUBROUTINES

The following functions are not considered to be part of the public interface.
They are documented here for the benefit of future maintainers of this module.

=head2 C<standard_typemap_locations()>

=over 4

=item * Purpose

Provide a list of filepaths where F<typemap> files may be found. The
filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.

The highest priority is to look in the current directory.

'typemap'

The second and third highest priorities are to look in the parent of the
current directory and a directory called F<lib/ExtUtils> underneath the parent
directory.

'../typemap',
'../lib/ExtUtils/typemap',

The fourth through ninth highest priorities are to look in the corresponding
grandparent, great-grandparent and great-great-grandparent directories.

'../../typemap',
'../../lib/ExtUtils/typemap',
'../../../typemap',
'../../../lib/ExtUtils/typemap',
'../../../../typemap',
'../../../../lib/ExtUtils/typemap',

The tenth and subsequent priorities are to look in directories named
F<ExtUtils> which are subdirectories of directories found in C<@INC> --
I<provided> a file named F<typemap> actually exists in such a directory.
Example:

'/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',

However, these filepaths appear in the list returned by
C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.

'/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
'../../../../lib/ExtUtils/typemap',
'../../../../typemap',
'../../../lib/ExtUtils/typemap',
'../../../typemap',
'../../lib/ExtUtils/typemap',
'../../typemap',
'../lib/ExtUtils/typemap',
'../typemap',
'typemap'

=item * Arguments

my @stl = standard_typemap_locations( \@INC );

Reference to C<@INC>.

=item * Return Value

Array holding list of directories to be searched for F<typemap> files.

=back

=cut

sub standard_typemap_locations {
my $include_ref = shift;
my @tm = qw(typemap);

my $updir = File::Spec->updir();
foreach my $dir (
File::Spec->catdir(($updir) x 1),
File::Spec->catdir(($updir) x 2),
File::Spec->catdir(($updir) x 3),
File::Spec->catdir(($updir) x 4),
) {
unshift @tm, File::Spec->catfile($dir, 'typemap');
unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
}
foreach my $dir (@{ $include_ref}) {
my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
unshift @tm, $file if -e $file;
}
return @tm;
}

=head2 C<trim_whitespace()>

=over 4

=item * Purpose

Perform an in-place trimming of leading and trailing whitespace from the
first argument provided to the function.

=item * Argument

trim_whitespace($arg);

=item * Return Value

None. Remember: this is an I<in-place> modification of the argument.

=back

=cut

sub trim_whitespace {
$_[0] =~ s/^\s+|\s+$//go;
}

=head2 C<tidy_type()>

=over 4

=item * Purpose

Rationalize any asterisks (C<*>) by joining them into bunches, removing
interior whitespace, then trimming leading and trailing whitespace.

=item * Arguments

($ret_type) = tidy_type($_);

String to be cleaned up.

=item * Return Value

String cleaned up.

=back

=cut

sub tidy_type {
local ($_) = @_;

# rationalise any '*' by joining them into bunches and removing whitespace
s#\s*(\*+)\s*#$1#g;
s#(\*+)# $1 #g;

# change multiple whitespace into a single space
s/\s+/ /g;

# trim leading & trailing whitespace
trim_whitespace($_);

$_;
}

=head2 C<C_string()>

=over 4

=item * Purpose

Escape backslashes (C<\>) in prototype strings.

=item * Arguments

$ProtoThisXSUB = C_string($_);

String needing escaping.

=item * Return Value

Properly escaped string.

=back

=cut

sub C_string {
my($string) = @_;

$string =~ s[\\][\\\\]g;
$string;
}

=head2 C<valid_proto_string()>

=over 4

=item * Purpose

Validate prototype string.

=item * Arguments

String needing checking.

=item * Return Value

Upon success, returns the same string passed as argument.

Upon failure, returns C<0>.

=back

=cut

sub valid_proto_string {
my($string) = @_;

if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
return $string;
}

return 0;
}

=head2 C<process_typemaps()>

=over 4

=item * Purpose

Process all typemap files.

=item * Arguments

my $typemaps_object = process_typemaps( $args{typemap}, $pwd );

List of two elements: C<typemap> element from C<%args>; current working
directory.

=item * Return Value

Upon success, returns an L<ExtUtils::Typemaps> object.

=back

=cut

sub process_typemaps {
my ($tmap, $pwd) = @_;

my @tm = ref $tmap ? @{$tmap} : ($tmap);

foreach my $typemap (@tm) {
die "Can't find $typemap in $pwd\n" unless -r $typemap;
}

push @tm, standard_typemap_locations( \@INC );

require ExtUtils::Typemaps;
my $typemap = ExtUtils::Typemaps->new;
foreach my $typemap_loc (@tm) {
next unless -f $typemap_loc;
# skip directories, binary files etc.
warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
unless -T $typemap_loc;

$typemap->merge(file => $typemap_loc, replace => 1);
}

return $typemap;
}

=head2 C<make_targetable()>

=over 4

=item * Purpose

Populate C<%targetable>. This constitutes a refinement of the output of
C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.

=item * Arguments

%targetable = make_targetable($output_expr_ref);

Single hash reference: the fourth such ref returned by C<process_typemaps()>.

=item * Return Value

Hash.

=back

=cut

sub make_targetable {
my $output_expr_ref = shift;

our $bal; # ()-balanced
$bal = qr[
(?:
(?>[^()]+)
|
\( (??{ $bal }) \)
)*
]x;

# matches variations on (SV*)
my $sv_cast = qr[
(?:
\( \s* SV \s* \* \s* \) \s*
)?
]x;

my $size = qr[ # Third arg (to setpvn)
, \s* (??{ $bal })
]x;

my %targetable;
foreach my $key (keys %{ $output_expr_ref }) {
# We can still bootstrap compile 're', because in code re.pm is
# available to miniperl, and does not attempt to load the XS code.
use re 'eval';

my ($type, $with_size, $arg, $sarg) =
($output_expr_ref->{$key} =~
m[^
\s+
sv_set([iunp])v(n)? # Type, is_setpvn
\s*
\( \s*
$sv_cast \$arg \s* , \s*
( (??{ $bal }) ) # Set from
( (??{ $size }) )? # Possible sizeof set-from
\) \s* ; \s* $
]x
);
$targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
}
return %targetable;
}

=head2 C<map_type()>

=over 4

=item * Purpose

Performs a mapping at several places inside C<PARAGRAPH> loop.

=item * Arguments

$type = map_type($self, $type, $varname);

List of three arguments.

=item * Return Value

String holding augmented version of second argument.

=back

=cut

sub map_type {
my ($self, $type, $varname) = @_;

# C++ has :: in types too so skip this
$type =~ tr/:/_/ unless $self->{hiertype};
$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
if ($varname) {
if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
(substr $type, pos $type, 0) = " $varname ";
}
else {
$type .= "\t$varname";
}
}
return $type;
}

=head2 C<standard_XS_defs()>

=over 4

=item * Purpose

Writes to the C<.c> output file certain preprocessor directives and function
headers needed in all such files.

=item * Arguments

None.

=item * Return Value

Returns true.

=back

=cut

sub standard_XS_defs {
print <<"EOF";
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif

#ifndef dVAR
# define dVAR dNOOP
#endif


/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
# define PERL_DECIMAL_VERSION \\
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
# define PERL_VERSION_GE(r,v,s) \\
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
# define PERL_VERSION_LE(r,v,s) \\
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif

/* XS_INTERNAL is the explicit static-linkage variant of the default
* XS macro.
*
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include
* "STATIC", ie. it exports XSUB symbols. You probably don't want that
* for anything but the BOOT XSUB.
*
* See XSUB.h in core!
*/


/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
# undef XS_EXTERNAL
# undef XS_INTERNAL
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# if defined(__SYMBIAN32__)
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
# endif
# ifndef XS_EXTERNAL
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
# else
# ifdef __cplusplus
# define XS_EXTERNAL(name) extern "C" XSPROTO(name)
# define XS_INTERNAL(name) static XSPROTO(name)
# else
# define XS_EXTERNAL(name) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# endif
# endif
#endif

/* perl >= 5.10.0 && perl <= 5.15.1 */


/* The XS_EXTERNAL macro is used for functions that must not be static
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
* macro defined, the best we can do is assume XS is the same.
* Dito for XS_INTERNAL.
*/
#ifndef XS_EXTERNAL
# define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
# define XS_INTERNAL(name) XS(name)
#endif

/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
* internal macro that we're free to redefine for varying linkage due
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
*/

#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
# define XS_EUPXS(name) XS_EXTERNAL(name)
#else
/* default to internal */
# define XS_EUPXS(name) XS_INTERNAL(name)
#endif

EOF

print <<"EOF";
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)

/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);

STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);

PERL_ARGS_ASSERT_CROAK_XS_USAGE;

if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;

if (hvname)
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE

#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage S_croak_xs_usage
#endif

#endif

/* NOTE: the prototype of newXSproto() is different in versions of perls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */

EOF
return 1;
}

=head2 C<assign_func_args()>

=over 4

=item * Purpose

Perform assignment to the C<func_args> attribute.

=item * Arguments

$string = assign_func_args($self, $argsref, $class);

List of three elements. Second is an array reference; third is a string.

=item * Return Value

String.

=back

=cut

sub assign_func_args {
my ($self, $argsref, $class) = @_;
my @func_args = @{$argsref};
shift @func_args if defined($class);

for my $arg (@func_args) {
$arg =~ s/^/&/ if $self->{in_out}->{$arg};
}
return join(", ", @func_args);
}

=head2 C<analyze_preprocessor_statements()>

=over 4

=item * Purpose

Within each function inside each Xsub, print to the F<.c> output file certain
preprocessor statements.

=item * Arguments

( $self, $XSS_work_idx, $BootCode_ref ) =
analyze_preprocessor_statements(
$self, $statement, $XSS_work_idx, $BootCode_ref
);

List of four elements.

=item * Return Value

Modifed values of three of the arguments passed to the function. In
particular, the C<XSStack> and C<InitFileCode> attributes are modified.

=back

=cut

sub analyze_preprocessor_statements {
my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;

if ($statement eq 'if') {
$XSS_work_idx = @{ $self->{XSStack} };
push(@{ $self->{XSStack} }, {type => 'if'});
}
else {
$self->death("Error: '$statement' with no matching 'if'")
if $self->{XSStack}->[-1]{type} ne 'if';
if ($self->{XSStack}->[-1]{varname}) {
push(@{ $self->{InitFileCode} }, "#endif\n");
push(@{ $BootCode_ref }, "#endif");
}

my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
if ($statement ne 'endif') {
# Hide the functions defined in other #if branches, and reset.
@{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
@{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
}
else {
my($tmp) = pop(@{ $self->{XSStack} });
0 while (--$XSS_work_idx
&& $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
# Keep all new defined functions
push(@fns, keys %{$tmp->{other_functions}});
@{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
}
}
return ($self, $XSS_work_idx, $BootCode_ref);
}

=head2 C<set_cond()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub set_cond {
my ($ellipsis, $min_args, $num_args) = @_;
my $cond;
if ($ellipsis) {
$cond = ($min_args ? qq(items < $min_args) : 0);
}
elsif ($min_args == $num_args) {
$cond = qq(items != $min_args);
}
else {
$cond = qq(items < $min_args || items > $num_args);
}
return $cond;
}

=head2 C<current_line_number()>

=over 4

=item * Purpose

Figures out the current line number in the XS file.

=item * Arguments

C<$self>

=item * Return Value

The current line number.

=back

=cut

sub current_line_number {
my $self = shift;
my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
return $line_number;
}

=head2 C<Warn()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub Warn {
my $self = shift;
my $warn_line_number = $self->current_line_number();
print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
}

=head2 C<blurt()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub blurt {
my $self = shift;
$self->Warn(@_);
$self->{errors}++
}

=head2 C<death()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub death {
my $self = shift;
$self->Warn(@_);
exit 1;
}

=head2 C<check_conditional_preprocessor_statements()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=back

=cut

sub check_conditional_preprocessor_statements {
my ($self) = @_;
my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
if (@cpp) {
my $cpplevel;
for my $cpp (@cpp) {
if ($cpp =~ /^\#\s*if/) {
$cpplevel++;
}
elsif (!$cpplevel) {
$self->Warn("Warning: #else/elif/endif without #if in this function");
print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
if $self->{XSStack}->[-1]{type} eq 'if';
return;
}
elsif ($cpp =~ /^\#\s*endif/) {
$cpplevel--;
}
}
$self->Warn("Warning: #if without #endif in this function") if $cpplevel;
}
}

=head2 C<escape_file_for_line_directive()>

=over 4

=item * Purpose

Escapes a given code source name (typically a file name but can also
be a command that was read from) so that double-quotes and backslashes are escaped.

=item * Arguments

A string.

=item * Return Value

A string with escapes for double-quotes and backslashes.

=back

=cut

sub escape_file_for_line_directive {
my $string = shift;
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
return $string;
}

=head2 C<report_typemap_failure>

=over 4

=item * Purpose

Do error reporting for missing typemaps.

=item * Arguments

The C<ExtUtils::ParseXS> object.

An C<ExtUtils::Typemaps> object.

The string that represents the C type that was not found in the typemap.

Optionally, the string C<death> or C<blurt> to choose
whether the error is immediately fatal or not. Default: C<blurt>

=item * Return Value

Returns nothing. Depending on the arguments, this
may call C<death> or C<blurt>, the former of which is
fatal.

=back

=cut

sub report_typemap_failure {
my ($self, $tm, $ctype, $error_method) = @_;
$error_method ||= 'blurt';

my @avail_ctypes = $tm->list_mapped_ctypes;

my $err = "Could not find a typemap for C type '$ctype'.\n"
. "The following C types are mapped by the current typemap:\n'"
. join("', '", @avail_ctypes) . "'\n";

$self->$error_method($err);
return();
}

1;

# vim: ts=2 sw=2 et: