dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm

   1 package ExtUtils::ParseXS::Utilities;
   2 use strict;
   3 use warnings;
   4 use Exporter;
   5 use File::Spec;
   6 use lib qw( lib );
   7 use ExtUtils::ParseXS::Constants ();
   8 our (@ISA, @EXPORT_OK);
   9 @ISA = qw(Exporter);
  10 @EXPORT_OK = qw(
  11   standard_typemap_locations
  12   trim_whitespace
  13   tidy_type
  14   C_string
  15   valid_proto_string
  16   process_typemaps
  17   process_single_typemap
  18   make_targetable
  19   map_type
  20 );
  21
  22 =head1 NAME
  23
  24 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
  25
  26 =head1 SYNOPSIS
  27
  28   use ExtUtils::ParseXS::Utilities qw(
  29     standard_typemap_locations
  30     trim_whitespace
  31     tidy_type
  32     C_string
  33     valid_proto_string
  34     process_typemaps
  35     make_targetable
  36   );
  37
  38 =head1 SUBROUTINES
  39
  40 The following functions are not considered to be part of the public interface.
  41 They are documented here for the benefit of future maintainers of this module.
  42
  43 =head2 C<standard_typemap_locations()>
  44
  45 =over 4
  46
  47 =item * Purpose
  48
  49 Provide a list of filepaths where F<typemap> files may be found.  The
  50 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
  51
  52 The highest priority is to look in the current directory.
  53
  54   'typemap'
  55
  56 The second and third highest priorities are to look in the parent of the
  57 current directory and a directory called F<lib/ExtUtils> underneath the parent
  58 directory.
  59
  60   '../typemap',
  61   '../lib/ExtUtils/typemap',
  62
  63 The fourth through ninth highest priorities are to look in the corresponding
  64 grandparent, great-grandparent and great-great-grandparent directories.
  65
  66   '../../typemap',
  67   '../../lib/ExtUtils/typemap',
  68   '../../../typemap',
  69   '../../../lib/ExtUtils/typemap',
  70   '../../../../typemap',
  71   '../../../../lib/ExtUtils/typemap',
  72
  73 The tenth and subsequent priorities are to look in directories named
  74 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
  75 I<provided> a file named F<typemap> actually exists in such a directory.
  76 Example:
  77
  78   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
  79
  80 However, these filepaths appear in the list returned by
  81 C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
  82
  83   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
  84   '../../../../lib/ExtUtils/typemap',
  85   '../../../../typemap',
  86   '../../../lib/ExtUtils/typemap',
  87   '../../../typemap',
  88   '../../lib/ExtUtils/typemap',
  89   '../../typemap',
  90   '../lib/ExtUtils/typemap',
  91   '../typemap',
  92   'typemap'
  93
  94 =item * Arguments
  95
  96   my @stl = standard_typemap_locations( \@INC );
  97
  98 Reference to C<@INC>.
  99
 100 =item * Return Value
 101
 102 Array holding list of directories to be searched for F<typemap> files.
 103
 104 =back
 105
 106 =cut
 107
 108 sub standard_typemap_locations {
 109   my $include_ref = shift;
 110   my @tm = qw(typemap);
 111
 112   my $updir = File::Spec->updir();
 113   foreach my $dir (
 114       File::Spec->catdir(($updir) x 1),
 115       File::Spec->catdir(($updir) x 2),
 116       File::Spec->catdir(($updir) x 3),
 117       File::Spec->catdir(($updir) x 4),
 118   ) {
 119     unshift @tm, File::Spec->catfile($dir, 'typemap');
 120     unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
 121   }
 122   foreach my $dir (@{ $include_ref}) {
 123     my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
 124     unshift @tm, $file if -e $file;
 125   }
 126   return @tm;
 127 }
 128
 129 =head2 C<trim_whitespace()>
 130
 131 =over 4
 132
 133 =item * Purpose
 134
 135 Perform an in-place trimming of leading and trailing whitespace from the
 136 first argument provided to the function.
 137
 138 =item * Argument
 139
 140   trim_whitespace($arg);
 141
 142 =item * Return Value
 143
 144 None.  Remember:  this is an I<in-place> modification of the argument.
 145
 146 =back
 147
 148 =cut
 149
 150 sub trim_whitespace {
 151   $_[0] =~ s/^\s+|\s+$//go;
 152 }
 153
 154 =head2 C<tidy_type()>
 155
 156 =over 4
 157
 158 =item * Purpose
 159
 160 Rationalize any asterisks (C<*>) by joining them into bunches, removing
 161 interior whitespace, then trimming leading and trailing whitespace.
 162
 163 =item * Arguments
 164
 165     ($ret_type) = tidy_type($_);
 166
 167 String to be cleaned up.
 168
 169 =item * Return Value
 170
 171 String cleaned up.
 172
 173 =back
 174
 175 =cut
 176
 177 sub tidy_type {
 178   local ($_) = @_;
 179
 180   # rationalise any '*' by joining them into bunches and removing whitespace
 181   s#\s*(\*+)\s*#$1#g;
 182   s#(\*+)# $1 #g;
 183
 184   # change multiple whitespace into a single space
 185   s/\s+/ /g;
 186
 187   # trim leading & trailing whitespace
 188   trim_whitespace($_);
 189
 190   $_;
 191 }
 192
 193 =head2 C<C_string()>
 194
 195 =over 4
 196
 197 =item * Purpose
 198
 199 Escape backslashes (C<\>) in prototype strings.
 200
 201 =item * Arguments
 202
 203       $ProtoThisXSUB = C_string($_);
 204
 205 String needing escaping.
 206
 207 =item * Return Value
 208
 209 Properly escaped string.
 210
 211 =back
 212
 213 =cut
 214
 215 sub C_string {
 216   my($string) = @_;
 217
 218   $string =~ s[\\][\\\\]g;
 219   $string;
 220 }
 221
 222 =head2 C<valid_proto_string()>
 223
 224 =over 4
 225
 226 =item * Purpose
 227
 228 Validate prototype string.
 229
 230 =item * Arguments
 231
 232 String needing checking.
 233
 234 =item * Return Value
 235
 236 Upon success, returns the same string passed as argument.
 237
 238 Upon failure, returns C<0>.
 239
 240 =back
 241
 242 =cut
 243
 244 sub valid_proto_string {
 245   my($string) = @_;
 246
 247   if ( $string =~ /^$ExtUtils::ParseXS::Constants::proto_re+$/ ) {
 248     return $string;
 249   }
 250
 251   return 0;
 252 }
 253
 254 =head2 C<process_typemaps()>
 255
 256 =over 4
 257
 258 =item * Purpose
 259
 260 Process all typemap files.
 261
 262 =item * Arguments
 263
 264   my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
 265     process_typemaps( $args{typemap}, $pwd );
 266
 267 List of two elements:  C<typemap> element from C<%args>; current working
 268 directory.
 269
 270 =item * Return Value
 271
 272 Upon success, returns a list of four hash references.  (This will probably be
 273 refactored.)
 274
 275 =back
 276
 277 =cut
 278
 279 sub process_typemaps {
 280   my ($tmap, $pwd) = @_;
 281
 282   my @tm = ref $tmap ? @{$tmap} : ($tmap);
 283
 284   foreach my $typemap (@tm) {
 285     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 286   }
 287
 288   push @tm, standard_typemap_locations( \@INC );
 289
 290   my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
 291     = ( {}, {}, {}, {} );
 292
 293   foreach my $typemap (@tm) {
 294     next unless -f $typemap;
 295     # skip directories, binary files etc.
 296     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 297       unless -T $typemap;
 298     ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
 299       process_single_typemap( $typemap,
 300         $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
 301   }
 302   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
 303 }
 304
 305 sub process_single_typemap {
 306   my ($typemap,
 307     $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
 308   open my $TYPEMAP, '<', $typemap
 309     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 310   my $mode = 'Typemap';
 311   my $junk = "";
 312   my $current = \$junk;
 313   while (<$TYPEMAP>) {
 314     # skip comments
 315     next if /^\s*#/;
 316     if (/^INPUT\s*$/) {
 317       $mode = 'Input';   $current = \$junk;  next;
 318     }
 319     if (/^OUTPUT\s*$/) {
 320       $mode = 'Output';  $current = \$junk;  next;
 321     }
 322     if (/^TYPEMAP\s*$/) {
 323       $mode = 'Typemap'; $current = \$junk;  next;
 324     }
 325     if ($mode eq 'Typemap') {
 326       chomp;
 327       my $logged_line = $_;
 328       trim_whitespace($_);
 329       # skip blank lines
 330       next if /^$/;
 331       my($type,$kind, $proto) =
 332         m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::proto_re*)\s*$/
 333           or warn(
 334             "Warning: File '$typemap' Line $.  '$logged_line' " .
 335             "TYPEMAP entry needs 2 or 3 columns\n"
 336           ),
 337           next;
 338       $type = tidy_type($type);
 339       $type_kind_ref->{$type} = $kind;
 340       # prototype defaults to '$'
 341       $proto = "\$" unless $proto;
 342 #      warn(
 343 #          "Warning: File '$typemap' Line $. '$logged_line' " .
 344 #          "Invalid prototype '$proto'\n"
 345 #      ) unless valid_proto_string($proto);
 346       $proto_letter_ref->{$type} = C_string($proto);
 347     }
 348     elsif (/^\s/) {
 349       $$current .= $_;
 350     }
 351     elsif ($mode eq 'Input') {
 352       s/\s+$//;
 353       $input_expr_ref->{$_} = '';
 354       $current = \$input_expr_ref->{$_};
 355     }
 356     else {
 357       s/\s+$//;
 358       $output_expr_ref->{$_} = '';
 359       $current = \$output_expr_ref->{$_};
 360     }
 361   }
 362   close $TYPEMAP;
 363   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
 364 }
 365
 366 =head2 C<make_targetable()>
 367
 368 =over 4
 369
 370 =item * Purpose
 371
 372 Populate C<%targetable>.
 373
 374 =item * Arguments
 375
 376   %targetable = make_targetable(\%output_expr);
 377
 378 Reference to C<%output_expr>.
 379
 380 =item * Return Value
 381
 382 Hash.
 383
 384 =back
 385
 386 =cut
 387
 388 sub make_targetable {
 389   my $output_expr_ref = shift;
 390   my ($cast, $size);
 391   our $bal;
 392   $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
 393   $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
 394   $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
 395
 396   my %targetable;
 397   foreach my $key (keys %{ $output_expr_ref }) {
 398     # We can still bootstrap compile 're', because in code re.pm is
 399     # available to miniperl, and does not attempt to load the XS code.
 400     use re 'eval';
 401
 402     my ($t, $with_size, $arg, $sarg) =
 403       ($output_expr_ref->{$key} =~
 404         m[^ \s+ sv_set ( [iunp] ) v (n)?    # Type, is_setpvn
 405           \s* \( \s* $cast \$arg \s* ,
 406           \s* ( (??{ $bal }) )    # Set from
 407           ( (??{ $size }) )?    # Possible sizeof set-from
 408           \) \s* ; \s* $
 409         ]x
 410     );
 411     $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
 412   }
 413   return %targetable;
 414 }
 415
 416 sub map_type {
 417   my ($type, $varname, $hiertype) = @_;
 418
 419   # C++ has :: in types too so skip this
 420   $type =~ tr/:/_/ unless $hiertype;
 421   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
 422   if ($varname) {
 423     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
 424       (substr $type, pos $type, 0) = " $varname ";
 425     }
 426     else {
 427       $type .= "\t$varname";
 428     }
 429   }
 430   return $type;
 431 }
 432
 433 1;