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