[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / ParseXS / Utilities.pm

package ExtUtils::ParseXS::Utilities;
use strict;
use warnings;
use Exporter;
use File::Spec;
use lib qw( lib );
use ExtUtils::ParseXS::Constants ();
our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
  standard_typemap_locations
  trim_whitespace
  tidy_type
  C_string
  valid_proto_string
  process_typemaps
  process_single_typemap
  make_targetable
  map_type
  standard_XS_defs
  assign_func_args
  print_preprocessor_statements
  set_cond
);

=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
  );

=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::proto_re+$/ ) {
    return $string;
  }

  return 0;
}

=head2 C<process_typemaps()>

=over 4

=item * Purpose

Process all typemap files.

=item * Arguments

  my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
    process_typemaps( $args{typemap}, $pwd );
      
List of two elements:  C<typemap> element from C<%args>; current working
directory.

=item * Return Value

Upon success, returns a list of four hash references.  (This will probably be
refactored.)

=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 );

  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::proto_re*)\s*$/
          or warn(
            "Warning: File '$typemap' Line $.  '$logged_line' " .
            "TYPEMAP entry needs 2 or 3 columns\n"
          ),
          next;
      $type = tidy_type($type);
      $type_kind_ref->{$type} = $kind;
      # prototype defaults to '$'
      $proto = "\$" unless $proto;
#      warn(
#          "Warning: File '$typemap' Line $. '$logged_line' " .
#          "Invalid prototype '$proto'\n"
#      ) unless valid_proto_string($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);
}

=head2 C<make_targetable()>

=over 4

=item * Purpose

Populate C<%targetable>.

=item * Arguments

  %targetable = make_targetable(\%output_expr);
      
Reference to C<%output_expr>.

=item * Return Value

Hash.

=back

=cut

sub make_targetable {
  my $output_expr_ref = shift;
  my ($cast, $size);
  our $bal;
  $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
  $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
  $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)

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

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

  # C++ has :: in types too so skip this
  $type =~ tr/:/_/ unless $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;
}

sub standard_XS_defs {
  print <<"EOF";
#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#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
}

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

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

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

  my $statement = $+;
  if ($statement eq 'if') {
    $XSS_work_idx = @{ $self->{XSStack} };
    push(@{ $self->{XSStack} }, {type => 'if'});
  }
  else {
    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);
}

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;
}

1;

# vim: ts=2 sw=2 et:
Commit	Line	Data
a65c06db S	1	package ExtUtils::ParseXS::Utilities;
	2	use strict;
	3	use warnings;
	4	use Exporter;
f3aadd09	5	use File::Spec;
547742ac JK	6	use lib qw( lib );
547742ac JK	7	use ExtUtils::ParseXS::Constants ();
a65c06db S	8	our (@ISA, @EXPORT_OK);
	9	@ISA = qw(Exporter);
	10	@EXPORT_OK = qw(
	11	standard_typemap_locations
1d40e528	12	trim_whitespace
73e91d5a	13	tidy_type
c1e43162	14	C_string
547742ac	15	valid_proto_string
50b96cc2	16	process_typemaps
bb5e8eb4	17	process_single_typemap
af4112ab	18	make_targetable
0ec7450c	19	map_type
6c2c48aa	20	standard_XS_defs
362926c8	21	assign_func_args
1d3d7190	22	print_preprocessor_statements
40a3ae2f	23	set_cond
a65c06db S	24	);
a65c06db S	25
f3aadd09 S	26	=head1 NAME
	27
	28	ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
	29
	30	=head1 SYNOPSIS
	31
	32	use ExtUtils::ParseXS::Utilities qw(
	33	standard_typemap_locations
1d40e528	34	trim_whitespace
73e91d5a	35	tidy_type
3f0c8333 JK	36	C_string
	37	valid_proto_string
	38	process_typemaps
	39	make_targetable
f3aadd09 S	40	);
	41
	42	=head1 SUBROUTINES
	43
	44	The following functions are not considered to be part of the public interface.
	45	They are documented here for the benefit of future maintainers of this module.
	46
	47	=head2 C<standard_typemap_locations()>
	48
	49	=over 4
	50
	51	=item * Purpose
	52
	53	Provide a list of filepaths where F<typemap> files may be found. The
	54	filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
	55
	56	The highest priority is to look in the current directory.
	57
	58	'typemap'
	59
	60	The second and third highest priorities are to look in the parent of the
	61	current directory and a directory called F<lib/ExtUtils> underneath the parent
	62	directory.
	63
	64	'../typemap',
	65	'../lib/ExtUtils/typemap',
	66
	67	The fourth through ninth highest priorities are to look in the corresponding
	68	grandparent, great-grandparent and great-great-grandparent directories.
	69
	70	'../../typemap',
	71	'../../lib/ExtUtils/typemap',
	72	'../../../typemap',
	73	'../../../lib/ExtUtils/typemap',
	74	'../../../../typemap',
	75	'../../../../lib/ExtUtils/typemap',
	76
	77	The tenth and subsequent priorities are to look in directories named
	78	F<ExtUtils> which are subdirectories of directories found in C<@INC> --
	79	I<provided> a file named F<typemap> actually exists in such a directory.
	80	Example:
	81
	82	'/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
	83
	84	However, these filepaths appear in the list returned by
	85	C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
	86
	87	'/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
	88	'../../../../lib/ExtUtils/typemap',
	89	'../../../../typemap',
	90	'../../../lib/ExtUtils/typemap',
	91	'../../../typemap',
	92	'../../lib/ExtUtils/typemap',
	93	'../../typemap',
	94	'../lib/ExtUtils/typemap',
	95	'../typemap',
	96	'typemap'
	97
	98	=item * Arguments
	99
	100	my @stl = standard_typemap_locations( \@INC );
	101
	102	Reference to C<@INC>.
	103
104	=item * Return Value
105
106	Array holding list of directories to be searched for F<typemap> files.
107
108	=back
109
110	=cut
111
a65c06db S	112	sub standard_typemap_locations {
a65c06db S	113	my $include_ref = shift;
a65c06db S	114	my @tm = qw(typemap);
a65c06db S	115
f3aadd09 S	116	my $updir = File::Spec->updir();
	117	foreach my $dir (
	118	File::Spec->catdir(($updir) x 1),
	119	File::Spec->catdir(($updir) x 2),
	120	File::Spec->catdir(($updir) x 3),
	121	File::Spec->catdir(($updir) x 4),
	122	) {
a65c06db S	123	unshift @tm, File::Spec->catfile($dir, 'typemap');
	124	unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
	125	}
	126	foreach my $dir (@{ $include_ref}) {
	127	my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
	128	unshift @tm, $file if -e $file;
	129	}
	130	return @tm;
	131	}
	132
1d40e528 JK	133	=head2 C<trim_whitespace()>
	134
	135	=over 4
	136
	137	=item * Purpose
	138
	139	Perform an in-place trimming of leading and trailing whitespace from the
	140	first argument provided to the function.
	141
	142	=item * Argument
	143
	144	trim_whitespace($arg);
	145
	146	=item * Return Value
	147
	148	None. Remember: this is an I<in-place> modification of the argument.
	149
	150	=back
	151
	152	=cut
	153
	154	sub trim_whitespace {
	155	$_[0] =~ s/^\s+\|\s+$//go;
	156	}
	157
73e91d5a JK	158	=head2 C<tidy_type()>
	159
	160	=over 4
	161
	162	=item * Purpose
	163
	164	Rationalize any asterisks (C<*>) by joining them into bunches, removing
	165	interior whitespace, then trimming leading and trailing whitespace.
	166
	167	=item * Arguments
	168
	169	($ret_type) = tidy_type($_);
	170
	171	String to be cleaned up.
	172
	173	=item * Return Value
	174
	175	String cleaned up.
	176
	177	=back
	178
	179	=cut
	180
	181	sub tidy_type {
	182	local ($_) = @_;
	183
	184	# rationalise any '*' by joining them into bunches and removing whitespace
	185	s#\s(\+)\s*#$1#g;
	186	s#(\*+)# $1 #g;
	187
	188	# change multiple whitespace into a single space
	189	s/\s+/ /g;
	190
	191	# trim leading & trailing whitespace
	192	trim_whitespace($_);
	193
	194	$_;
	195	}
	196
c1e43162 JK	197	=head2 C<C_string()>
	198
	199	=over 4
	200
	201	=item * Purpose
	202
	203	Escape backslashes (C<\>) in prototype strings.
	204
	205	=item * Arguments
	206
	207	$ProtoThisXSUB = C_string($_);
	208
	209	String needing escaping.
	210
	211	=item * Return Value
	212
	213	Properly escaped string.
	214
	215	=back
	216
	217	=cut
	218
	219	sub C_string {
	220	my($string) = @_;
	221
	222	$string =~ s[\\][\\\\]g;
	223	$string;
	224	}
	225
547742ac JK	226	=head2 C<valid_proto_string()>
	227
	228	=over 4
	229
	230	=item * Purpose
	231
	232	Validate prototype string.
	233
	234	=item * Arguments
	235
	236	String needing checking.
	237
	238	=item * Return Value
	239
	240	Upon success, returns the same string passed as argument.
	241
	242	Upon failure, returns C<0>.
	243
	244	=back
	245
	246	=cut
	247
	248	sub valid_proto_string {
	249	my($string) = @_;
	250
	251	if ( $string =~ /^$ExtUtils::ParseXS::Constants::proto_re+$/ ) {
	252	return $string;
	253	}
	254
	255	return 0;
	256	}
50b96cc2 JK	257
	258	=head2 C<process_typemaps()>
	259
	260	=over 4
	261
	262	=item * Purpose
	263
	264	Process all typemap files.
	265
	266	=item * Arguments
	267
	268	my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
	269	process_typemaps( $args{typemap}, $pwd );
	270
	271	List of two elements: C<typemap> element from C<%args>; current working
	272	directory.
	273
	274	=item * Return Value
	275
	276	Upon success, returns a list of four hash references. (This will probably be
	277	refactored.)
	278
	279	=back
	280
	281	=cut
	282
	283	sub process_typemaps {
	284	my ($tmap, $pwd) = @_;
	285
	286	my @tm = ref $tmap ? @{$tmap} : ($tmap);
	287
	288	foreach my $typemap (@tm) {
	289	die "Can't find $typemap in $pwd\n" unless -r $typemap;
	290	}
	291
	292	push @tm, standard_typemap_locations( \@INC );
	293
bb5e8eb4 JK	294	my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
bb5e8eb4 JK	295	= ( {}, {}, {}, {} );
50b96cc2 JK	296
	297	foreach my $typemap (@tm) {
	298	next unless -f $typemap;
	299	# skip directories, binary files etc.
	300	warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
	301	unless -T $typemap;
bb5e8eb4 JK	302	($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
	303	process_single_typemap( $typemap,
	304	$type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
	305	}
	306	return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
	307	}
	308
	309	sub process_single_typemap {
	310	my ($typemap,
	311	$type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
	312	open my $TYPEMAP, '<', $typemap
	313	or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
	314	my $mode = 'Typemap';
	315	my $junk = "";
	316	my $current = \$junk;
	317	while (<$TYPEMAP>) {
	318	# skip comments
	319	next if /^\s*#/;
	320	if (/^INPUT\s*$/) {
	321	$mode = 'Input'; $current = \$junk; next;
	322	}
	323	if (/^OUTPUT\s*$/) {
	324	$mode = 'Output'; $current = \$junk; next;
	325	}
	326	if (/^TYPEMAP\s*$/) {
	327	$mode = 'Typemap'; $current = \$junk; next;
	328	}
	329	if ($mode eq 'Typemap') {
	330	chomp;
	331	my $logged_line = $_;
	332	trim_whitespace($_);
	333	# skip blank lines
	334	next if /^$/;
	335	my($type,$kind, $proto) =
	336	m/^\s(.?\S)\s+(\S+)\s($ExtUtils::ParseXS::Constants::proto_re)\s*$/
	337	or warn(
	338	"Warning: File '$typemap' Line $. '$logged_line' " .
	339	"TYPEMAP entry needs 2 or 3 columns\n"
	340	),
	341	next;
	342	$type = tidy_type($type);
	343	$type_kind_ref->{$type} = $kind;
	344	# prototype defaults to '$'
	345	$proto = "\$" unless $proto;
	346	# warn(
	347	# "Warning: File '$typemap' Line $. '$logged_line' " .
	348	# "Invalid prototype '$proto'\n"
	349	# ) unless valid_proto_string($proto);
	350	$proto_letter_ref->{$type} = C_string($proto);
	351	}
	352	elsif (/^\s/) {
	353	$$current .= $_;
	354	}
	355	elsif ($mode eq 'Input') {
	356	s/\s+$//;
	357	$input_expr_ref->{$_} = '';
	358	$current = \$input_expr_ref->{$_};
	359	}
	360	else {
	361	s/\s+$//;
	362	$output_expr_ref->{$_} = '';
	363	$current = \$output_expr_ref->{$_};
50b96cc2	364	}
50b96cc2	365	}
bb5e8eb4 JK	366	close $TYPEMAP;
bb5e8eb4 JK	367	return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
50b96cc2 JK	368	}
50b96cc2 JK	369
af4112ab JK	370	=head2 C<make_targetable()>
	371
	372	=over 4
	373
	374	=item * Purpose
	375
	376	Populate C<%targetable>.
	377
	378	=item * Arguments
	379
	380	%targetable = make_targetable(\%output_expr);
	381
	382	Reference to C<%output_expr>.
	383
	384	=item * Return Value
	385
	386	Hash.
	387
	388	=back
	389
	390	=cut
	391
	392	sub make_targetable {
	393	my $output_expr_ref = shift;
	394	my ($cast, $size);
	395	our $bal;
	396	$bal = qr[(?:(?>[^()]+)\|\((??{ $bal })\))*]; # ()-balanced
	397	$cast = qr[(?:\(\sSV\s\\s\)\s)?]; # Optional (SV) cast
	398	$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
	399
	400	my %targetable;
	401	foreach my $key (keys %{ $output_expr_ref }) {
	402	# We can still bootstrap compile 're', because in code re.pm is
	403	# available to miniperl, and does not attempt to load the XS code.
	404	use re 'eval';
	405
	406	my ($t, $with_size, $arg, $sarg) =
	407	($output_expr_ref->{$key} =~
	408	m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
	409	\s* \( \s* $cast \$arg \s* ,
	410	\s* ( (??{ $bal }) ) # Set from
	411	( (??{ $size }) )? # Possible sizeof set-from
	412	\) \s* ; \s* $
	413	]x
	414	);
	415	$targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
	416	}
	417	return %targetable;
	418	}
	419
0ec7450c JK	420	sub map_type {
	421	my ($type, $varname, $hiertype) = @_;
	422
	423	# C++ has :: in types too so skip this
	424	$type =~ tr/:/_/ unless $hiertype;
	425	$type =~ s/^array\(([^,]),(.)\)./$1 /s;
	426	if ($varname) {
	427	if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
	428	(substr $type, pos $type, 0) = " $varname ";
	429	}
	430	else {
	431	$type .= "\t$varname";
	432	}
	433	}
	434	return $type;
	435	}
	436
6c2c48aa JK	437	sub standard_XS_defs {
	438	print <<"EOF";
	439	#ifndef PERL_UNUSED_VAR
	440	# define PERL_UNUSED_VAR(var) if (0) var = var
	441	#endif
	442
	443	EOF
	444
	445	print <<"EOF";
	446	#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
	447	#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
	448
	449	/* prototype to pass -Wmissing-prototypes */
	450	STATIC void
	451	S_croak_xs_usage(pTHX_ const CV const cv, const char const params);
	452
	453	STATIC void
	454	S_croak_xs_usage(pTHX_ const CV const cv, const char const params)
	455	{
	456	const GV *const gv = CvGV(cv);
	457
	458	PERL_ARGS_ASSERT_CROAK_XS_USAGE;
	459
	460	if (gv) {
	461	const char *const gvname = GvNAME(gv);
	462	const HV *const stash = GvSTASH(gv);
	463	const char *const hvname = stash ? HvNAME(stash) : NULL;
	464
	465	if (hvname)
	466	Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
	467	else
	468	Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
	469	} else {
	470	/* Pants. I don't think that it should be possible to get here. */
	471	Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
	472	}
	473	}
	474	#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
	475
	476	#ifdef PERL_IMPLICIT_CONTEXT
	477	#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
	478	#else
	479	#define croak_xs_usage S_croak_xs_usage
	480	#endif
	481
	482	#endif
	483
	484	/* NOTE: the prototype of newXSproto() is different in versions of perls,
	485	* so we define a portable version of newXSproto()
	486	*/
	487	#ifdef newXS_flags
	488	#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
	489	#else
	490	#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV)PL_Sv)
	491	#endif /* !defined(newXS_flags) */
	492
	493	EOF
	494	}
	495
362926c8 JK	496	sub assign_func_args {
	497	my ($self, $argsref, $class) = @_;
	498	my @func_args = @{$argsref};
	499	shift @func_args if defined($class);
	500
	501	for (@func_args) {
	502	s/^/&/ if $self->{in_out}->{$_};
	503	}
	504	return join(", ", @func_args);
	505	}
	506
1d3d7190 JK	507	sub print_preprocessor_statements {
	508	my ($self, $XSS_work_idx, $BootCode_ref) = @_;
	509
	510	my $statement = $+;
	511	if ($statement eq 'if') {
	512	$XSS_work_idx = @{ $self->{XSStack} };
	513	push(@{ $self->{XSStack} }, {type => 'if'});
	514	}
	515	else {
	516	death ("Error: `$statement' with no matching `if'")
	517	if $self->{XSStack}->[-1]{type} ne 'if';
	518	if ($self->{XSStack}->[-1]{varname}) {
	519	push(@{ $self->{InitFileCode} }, "#endif\n");
	520	push(@{ $BootCode_ref }, "#endif");
	521	}
	522
	523	my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
	524	if ($statement ne 'endif') {
	525	# Hide the functions defined in other #if branches, and reset.
	526	@{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
	527	@{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
	528	}
	529	else {
	530	my($tmp) = pop(@{ $self->{XSStack} });
	531	0 while (--$XSS_work_idx
	532	&& $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
	533	# Keep all new defined functions
	534	push(@fns, keys %{$tmp->{other_functions}});
	535	@{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
	536	}
	537	}
	538	return ($self, $XSS_work_idx, $BootCode_ref);
	539	}
	540
40a3ae2f JK	541	sub set_cond {
	542	my ($ellipsis, $min_args, $num_args) = @_;
	543	my $cond;
	544	if ($ellipsis) {
	545	$cond = ($min_args ? qq(items < $min_args) : 0);
	546	}
	547	elsif ($min_args == $num_args) {
	548	$cond = qq(items != $min_args);
	549	}
	550	else {
	551	$cond = qq(items < $min_args \|\| items > $num_args);
	552	}
	553	return $cond;
	554	}
	555
a65c06db	556	1;
27b7514f JK	557
27b7514f JK	558	# vim: ts=2 sw=2 et: