[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
);
#  check_conditional_preprocessor_statements

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

#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) {
#        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--;
#      }
#    }
#    Warn("Warning: #if without #endif in this function") if $cpplevel;
#  }
#}

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