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