Make the use of XS_EXTERNAL fall back to XS
[perl.git] / 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
9 our (@ISA, @EXPORT_OK);
10 @ISA = qw(Exporter);
11 @EXPORT_OK = qw(
12   standard_typemap_locations
13   trim_whitespace
14   tidy_type
15   C_string
16   valid_proto_string
17   process_typemaps
18   make_targetable
19   map_type
20   standard_XS_defs
21   assign_func_args
22   analyze_preprocessor_statements
23   set_cond
24   Warn
25   current_line_number
26   blurt
27   death
28   check_conditional_preprocessor_statements
29 );
30
31 =head1 NAME
32
33 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
34
35 =head1 SYNOPSIS
36
37   use ExtUtils::ParseXS::Utilities qw(
38     standard_typemap_locations
39     trim_whitespace
40     tidy_type
41     C_string
42     valid_proto_string
43     process_typemaps
44     make_targetable
45     map_type
46     standard_XS_defs
47     assign_func_args
48     analyze_preprocessor_statements
49     set_cond
50     Warn
51     blurt
52     death
53     check_conditional_preprocessor_statements
54   );
55
56 =head1 SUBROUTINES
57
58 The following functions are not considered to be part of the public interface.
59 They are documented here for the benefit of future maintainers of this module.
60
61 =head2 C<standard_typemap_locations()>
62
63 =over 4
64
65 =item * Purpose
66
67 Provide a list of filepaths where F<typemap> files may be found.  The
68 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
69
70 The highest priority is to look in the current directory.  
71
72   'typemap'
73
74 The second and third highest priorities are to look in the parent of the
75 current directory and a directory called F<lib/ExtUtils> underneath the parent
76 directory.
77
78   '../typemap',
79   '../lib/ExtUtils/typemap',
80
81 The fourth through ninth highest priorities are to look in the corresponding
82 grandparent, great-grandparent and great-great-grandparent directories.
83
84   '../../typemap',
85   '../../lib/ExtUtils/typemap',
86   '../../../typemap',
87   '../../../lib/ExtUtils/typemap',
88   '../../../../typemap',
89   '../../../../lib/ExtUtils/typemap',
90
91 The tenth and subsequent priorities are to look in directories named
92 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
93 I<provided> a file named F<typemap> actually exists in such a directory.
94 Example:
95
96   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
97
98 However, these filepaths appear in the list returned by
99 C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
100
101   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
102   '../../../../lib/ExtUtils/typemap',
103   '../../../../typemap',
104   '../../../lib/ExtUtils/typemap',
105   '../../../typemap',
106   '../../lib/ExtUtils/typemap',
107   '../../typemap',
108   '../lib/ExtUtils/typemap',
109   '../typemap',
110   'typemap'
111
112 =item * Arguments
113
114   my @stl = standard_typemap_locations( \@INC );
115
116 Reference to C<@INC>.
117
118 =item * Return Value
119
120 Array holding list of directories to be searched for F<typemap> files.
121
122 =back
123
124 =cut
125
126 sub standard_typemap_locations {
127   my $include_ref = shift;
128   my @tm = qw(typemap);
129
130   my $updir = File::Spec->updir();
131   foreach my $dir (
132       File::Spec->catdir(($updir) x 1),
133       File::Spec->catdir(($updir) x 2),
134       File::Spec->catdir(($updir) x 3),
135       File::Spec->catdir(($updir) x 4),
136   ) {
137     unshift @tm, File::Spec->catfile($dir, 'typemap');
138     unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
139   }
140   foreach my $dir (@{ $include_ref}) {
141     my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
142     unshift @tm, $file if -e $file;
143   }
144   return @tm;
145 }
146
147 =head2 C<trim_whitespace()>
148
149 =over 4
150
151 =item * Purpose
152
153 Perform an in-place trimming of leading and trailing whitespace from the
154 first argument provided to the function.
155
156 =item * Argument
157
158   trim_whitespace($arg);
159
160 =item * Return Value
161
162 None.  Remember:  this is an I<in-place> modification of the argument.
163
164 =back
165
166 =cut
167
168 sub trim_whitespace {
169   $_[0] =~ s/^\s+|\s+$//go;
170 }
171
172 =head2 C<tidy_type()>
173
174 =over 4
175
176 =item * Purpose
177
178 Rationalize any asterisks (C<*>) by joining them into bunches, removing
179 interior whitespace, then trimming leading and trailing whitespace.
180
181 =item * Arguments
182
183     ($ret_type) = tidy_type($_);
184
185 String to be cleaned up.
186
187 =item * Return Value
188
189 String cleaned up.
190
191 =back
192
193 =cut
194
195 sub tidy_type {
196   local ($_) = @_;
197
198   # rationalise any '*' by joining them into bunches and removing whitespace
199   s#\s*(\*+)\s*#$1#g;
200   s#(\*+)# $1 #g;
201
202   # change multiple whitespace into a single space
203   s/\s+/ /g;
204
205   # trim leading & trailing whitespace
206   trim_whitespace($_);
207
208   $_;
209 }
210
211 =head2 C<C_string()>
212
213 =over 4
214
215 =item * Purpose
216
217 Escape backslashes (C<\>) in prototype strings.
218
219 =item * Arguments
220
221       $ProtoThisXSUB = C_string($_);
222
223 String needing escaping.
224
225 =item * Return Value
226
227 Properly escaped string.
228
229 =back
230
231 =cut
232
233 sub C_string {
234   my($string) = @_;
235
236   $string =~ s[\\][\\\\]g;
237   $string;
238 }
239
240 =head2 C<valid_proto_string()>
241
242 =over 4
243
244 =item * Purpose
245
246 Validate prototype string.
247
248 =item * Arguments
249
250 String needing checking.
251
252 =item * Return Value
253
254 Upon success, returns the same string passed as argument.
255
256 Upon failure, returns C<0>.
257
258 =back
259
260 =cut
261
262 sub valid_proto_string {
263   my($string) = @_;
264
265   if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
266     return $string;
267   }
268
269   return 0;
270 }
271
272 =head2 C<process_typemaps()>
273
274 =over 4
275
276 =item * Purpose
277
278 Process all typemap files.
279
280 =item * Arguments
281
282   my $typemaps_object = process_typemaps( $args{typemap}, $pwd );
283       
284 List of two elements:  C<typemap> element from C<%args>; current working
285 directory.
286
287 =item * Return Value
288
289 Upon success, returns an L<ExtUtils::Typemaps> object.
290
291 =back
292
293 =cut
294
295 sub process_typemaps {
296   my ($tmap, $pwd) = @_;
297
298   my @tm = ref $tmap ? @{$tmap} : ($tmap);
299
300   foreach my $typemap (@tm) {
301     die "Can't find $typemap in $pwd\n" unless -r $typemap;
302   }
303
304   push @tm, standard_typemap_locations( \@INC );
305
306   require ExtUtils::Typemaps;
307   my $typemap = ExtUtils::Typemaps->new;
308   foreach my $typemap_loc (@tm) {
309     next unless -f $typemap_loc;
310     # skip directories, binary files etc.
311     warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
312       unless -T $typemap_loc;
313
314     $typemap->merge(file => $typemap_loc, replace => 1);
315   }
316
317   return $typemap;
318 }
319
320 =head2 C<make_targetable()>
321
322 =over 4
323
324 =item * Purpose
325
326 Populate C<%targetable>.  This constitutes a refinement of the output of
327 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
328
329 =item * Arguments
330
331   %targetable = make_targetable($output_expr_ref);
332       
333 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
334
335 =item * Return Value
336
337 Hash.
338
339 =back
340
341 =cut
342
343 sub make_targetable {
344   my $output_expr_ref = shift;
345
346   our $bal; # ()-balanced
347   $bal = qr[
348     (?:
349       (?>[^()]+)
350       |
351       \( (??{ $bal }) \)
352     )*
353   ]x;
354
355   # matches variations on (SV*)
356   my $sv_cast = qr[
357     (?:
358       \( \s* SV \s* \* \s* \) \s*
359     )?
360   ]x;
361
362   my $size = qr[ # Third arg (to setpvn)
363     , \s* (??{ $bal })
364   ]x;
365
366   my %targetable;
367   foreach my $key (keys %{ $output_expr_ref }) {
368     # We can still bootstrap compile 're', because in code re.pm is
369     # available to miniperl, and does not attempt to load the XS code.
370     use re 'eval';
371
372     my ($type, $with_size, $arg, $sarg) =
373       ($output_expr_ref->{$key} =~
374         m[^
375           \s+
376           sv_set([iunp])v(n)?    # Type, is_setpvn
377           \s*
378           \( \s*
379             $sv_cast \$arg \s* , \s*
380             ( (??{ $bal }) )    # Set from
381           ( (??{ $size }) )?    # Possible sizeof set-from
382           \) \s* ; \s* $
383         ]x
384     );
385     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
386   }
387   return %targetable;
388 }
389
390 =head2 C<map_type()>
391
392 =over 4
393
394 =item * Purpose
395
396 Performs a mapping at several places inside C<PARAGRAPH> loop.
397
398 =item * Arguments
399
400   $type = map_type($self, $type, $varname);
401
402 List of three arguments.
403
404 =item * Return Value
405
406 String holding augmented version of second argument.
407
408 =back
409
410 =cut
411
412 sub map_type {
413   my ($self, $type, $varname) = @_;
414
415   # C++ has :: in types too so skip this
416   $type =~ tr/:/_/ unless $self->{hiertype};
417   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
418   if ($varname) {
419     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
420       (substr $type, pos $type, 0) = " $varname ";
421     }
422     else {
423       $type .= "\t$varname";
424     }
425   }
426   return $type;
427 }
428
429 =head2 C<standard_XS_defs()>
430
431 =over 4
432
433 =item * Purpose
434
435 Writes to the C<.c> output file certain preprocessor directives and function
436 headers needed in all such files.
437
438 =item * Arguments
439
440 None.
441
442 =item * Return Value
443
444 Returns true.
445
446 =back
447
448 =cut
449
450 sub standard_XS_defs {
451   print <<"EOF";
452 #ifndef PERL_UNUSED_VAR
453 #  define PERL_UNUSED_VAR(var) if (0) var = var
454 #endif
455
456 /* Starting from 5.15.2, XS(name) defines a static function (==internal)
457  * and the XS_EXTERNAL macro is used for functions that must not be static
458  * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
459  * macro defined, the best we can do is assume XS is the same.
460  */
461 #ifndef XS_EXTERNAL
462 #  define XS_EXTERNAL(name) XS(name)
463 #endif
464 EOF
465
466   print <<"EOF";
467 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
468 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
469
470 /* prototype to pass -Wmissing-prototypes */
471 STATIC void
472 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
473
474 STATIC void
475 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
476 {
477     const GV *const gv = CvGV(cv);
478
479     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
480
481     if (gv) {
482         const char *const gvname = GvNAME(gv);
483         const HV *const stash = GvSTASH(gv);
484         const char *const hvname = stash ? HvNAME(stash) : NULL;
485
486         if (hvname)
487             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
488         else
489             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
490     } else {
491         /* Pants. I don't think that it should be possible to get here. */
492         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
493     }
494 }
495 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
496
497 #ifdef PERL_IMPLICIT_CONTEXT
498 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
499 #else
500 #define croak_xs_usage        S_croak_xs_usage
501 #endif
502
503 #endif
504
505 /* NOTE: the prototype of newXSproto() is different in versions of perls,
506  * so we define a portable version of newXSproto()
507  */
508 #ifdef newXS_flags
509 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
510 #else
511 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
512 #endif /* !defined(newXS_flags) */
513
514 EOF
515   return 1;
516 }
517
518 =head2 C<assign_func_args()>
519
520 =over 4
521
522 =item * Purpose
523
524 Perform assignment to the C<func_args> attribute.
525
526 =item * Arguments
527
528   $string = assign_func_args($self, $argsref, $class);
529
530 List of three elements.  Second is an array reference; third is a string.
531
532 =item * Return Value
533
534 String.
535
536 =back
537
538 =cut
539
540 sub assign_func_args {
541   my ($self, $argsref, $class) = @_;
542   my @func_args = @{$argsref};
543   shift @func_args if defined($class);
544
545   for my $arg (@func_args) {
546     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
547   }
548   return join(", ", @func_args);
549 }
550
551 =head2 C<analyze_preprocessor_statements()>
552
553 =over 4
554
555 =item * Purpose
556
557 Within each function inside each Xsub, print to the F<.c> output file certain
558 preprocessor statements.
559
560 =item * Arguments
561
562       ( $self, $XSS_work_idx, $BootCode_ref ) =
563         analyze_preprocessor_statements(
564           $self, $statement, $XSS_work_idx, $BootCode_ref
565         );
566
567 List of four elements.
568
569 =item * Return Value
570
571 Modifed values of three of the arguments passed to the function.  In
572 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
573
574 =back
575
576 =cut
577
578 sub analyze_preprocessor_statements {
579   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
580
581   if ($statement eq 'if') {
582     $XSS_work_idx = @{ $self->{XSStack} };
583     push(@{ $self->{XSStack} }, {type => 'if'});
584   }
585   else {
586     $self->death("Error: `$statement' with no matching `if'")
587       if $self->{XSStack}->[-1]{type} ne 'if';
588     if ($self->{XSStack}->[-1]{varname}) {
589       push(@{ $self->{InitFileCode} }, "#endif\n");
590       push(@{ $BootCode_ref },     "#endif");
591     }
592
593     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
594     if ($statement ne 'endif') {
595       # Hide the functions defined in other #if branches, and reset.
596       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
597       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
598     }
599     else {
600       my($tmp) = pop(@{ $self->{XSStack} });
601       0 while (--$XSS_work_idx
602            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
603       # Keep all new defined functions
604       push(@fns, keys %{$tmp->{other_functions}});
605       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
606     }
607   }
608   return ($self, $XSS_work_idx, $BootCode_ref);
609 }
610
611 =head2 C<set_cond()>
612
613 =over 4
614
615 =item * Purpose
616
617 =item * Arguments
618
619 =item * Return Value
620
621 =back
622
623 =cut
624
625 sub set_cond {
626   my ($ellipsis, $min_args, $num_args) = @_;
627   my $cond;
628   if ($ellipsis) {
629     $cond = ($min_args ? qq(items < $min_args) : 0);
630   }
631   elsif ($min_args == $num_args) {
632     $cond = qq(items != $min_args);
633   }
634   else {
635     $cond = qq(items < $min_args || items > $num_args);
636   }
637   return $cond;
638 }
639
640 =head2 C<current_line_number()>
641
642 =over 4
643
644 =item * Purpose
645
646 Figures out the current line number in the XS file.
647
648 =item * Arguments
649
650 C<$self>
651
652 =item * Return Value
653
654 The current line number.
655
656 =back
657
658 =cut
659
660 sub current_line_number {
661   my $self = shift;
662   my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
663   return $line_number;
664 }
665
666 =head2 C<Warn()>
667
668 =over 4
669
670 =item * Purpose
671
672 =item * Arguments
673
674 =item * Return Value
675
676 =back
677
678 =cut
679
680 sub Warn {
681   my $self = shift;
682   my $warn_line_number = $self->current_line_number();
683   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
684 }
685
686 =head2 C<blurt()>
687
688 =over 4
689
690 =item * Purpose
691
692 =item * Arguments
693
694 =item * Return Value
695
696 =back
697
698 =cut
699
700 sub blurt {
701   my $self = shift;
702   $self->Warn(@_);
703   $self->{errors}++
704 }
705
706 =head2 C<death()>
707
708 =over 4
709
710 =item * Purpose
711
712 =item * Arguments
713
714 =item * Return Value
715
716 =back
717
718 =cut
719
720 sub death {
721   my $self = shift;
722   $self->Warn(@_);
723   exit 1;
724 }
725
726 =head2 C<check_conditional_preprocessor_statements()>
727
728 =over 4
729
730 =item * Purpose
731
732 =item * Arguments
733
734 =item * Return Value
735
736 =back
737
738 =cut
739
740 sub check_conditional_preprocessor_statements {
741   my ($self) = @_;
742   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
743   if (@cpp) {
744     my $cpplevel;
745     for my $cpp (@cpp) {
746       if ($cpp =~ /^\#\s*if/) {
747         $cpplevel++;
748       }
749       elsif (!$cpplevel) {
750         $self->Warn("Warning: #else/elif/endif without #if in this function");
751         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
752           if $self->{XSStack}->[-1]{type} eq 'if';
753         return;
754       }
755       elsif ($cpp =~ /^\#\s*endif/) {
756         $cpplevel--;
757       }
758     }
759     $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
760   }
761 }
762
763 1;
764
765 # vim: ts=2 sw=2 et: