1616b0dc5278184c501206fde7d546a1dcb10d7b
[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 EOF
457
458   print <<"EOF";
459 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
460 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
461
462 /* prototype to pass -Wmissing-prototypes */
463 STATIC void
464 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
465
466 STATIC void
467 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
468 {
469     const GV *const gv = CvGV(cv);
470
471     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
472
473     if (gv) {
474         const char *const gvname = GvNAME(gv);
475         const HV *const stash = GvSTASH(gv);
476         const char *const hvname = stash ? HvNAME(stash) : NULL;
477
478         if (hvname)
479             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
480         else
481             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
482     } else {
483         /* Pants. I don't think that it should be possible to get here. */
484         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
485     }
486 }
487 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
488
489 #ifdef PERL_IMPLICIT_CONTEXT
490 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
491 #else
492 #define croak_xs_usage        S_croak_xs_usage
493 #endif
494
495 #endif
496
497 /* NOTE: the prototype of newXSproto() is different in versions of perls,
498  * so we define a portable version of newXSproto()
499  */
500 #ifdef newXS_flags
501 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
502 #else
503 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
504 #endif /* !defined(newXS_flags) */
505
506 EOF
507   return 1;
508 }
509
510 =head2 C<assign_func_args()>
511
512 =over 4
513
514 =item * Purpose
515
516 Perform assignment to the C<func_args> attribute.
517
518 =item * Arguments
519
520   $string = assign_func_args($self, $argsref, $class);
521
522 List of three elements.  Second is an array reference; third is a string.
523
524 =item * Return Value
525
526 String.
527
528 =back
529
530 =cut
531
532 sub assign_func_args {
533   my ($self, $argsref, $class) = @_;
534   my @func_args = @{$argsref};
535   shift @func_args if defined($class);
536
537   for my $arg (@func_args) {
538     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
539   }
540   return join(", ", @func_args);
541 }
542
543 =head2 C<analyze_preprocessor_statements()>
544
545 =over 4
546
547 =item * Purpose
548
549 Within each function inside each Xsub, print to the F<.c> output file certain
550 preprocessor statements.
551
552 =item * Arguments
553
554       ( $self, $XSS_work_idx, $BootCode_ref ) =
555         analyze_preprocessor_statements(
556           $self, $statement, $XSS_work_idx, $BootCode_ref
557         );
558
559 List of four elements.
560
561 =item * Return Value
562
563 Modifed values of three of the arguments passed to the function.  In
564 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
565
566 =back
567
568 =cut
569
570 sub analyze_preprocessor_statements {
571   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
572
573   if ($statement eq 'if') {
574     $XSS_work_idx = @{ $self->{XSStack} };
575     push(@{ $self->{XSStack} }, {type => 'if'});
576   }
577   else {
578     $self->death("Error: `$statement' with no matching `if'")
579       if $self->{XSStack}->[-1]{type} ne 'if';
580     if ($self->{XSStack}->[-1]{varname}) {
581       push(@{ $self->{InitFileCode} }, "#endif\n");
582       push(@{ $BootCode_ref },     "#endif");
583     }
584
585     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
586     if ($statement ne 'endif') {
587       # Hide the functions defined in other #if branches, and reset.
588       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
589       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
590     }
591     else {
592       my($tmp) = pop(@{ $self->{XSStack} });
593       0 while (--$XSS_work_idx
594            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
595       # Keep all new defined functions
596       push(@fns, keys %{$tmp->{other_functions}});
597       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
598     }
599   }
600   return ($self, $XSS_work_idx, $BootCode_ref);
601 }
602
603 =head2 C<set_cond()>
604
605 =over 4
606
607 =item * Purpose
608
609 =item * Arguments
610
611 =item * Return Value
612
613 =back
614
615 =cut
616
617 sub set_cond {
618   my ($ellipsis, $min_args, $num_args) = @_;
619   my $cond;
620   if ($ellipsis) {
621     $cond = ($min_args ? qq(items < $min_args) : 0);
622   }
623   elsif ($min_args == $num_args) {
624     $cond = qq(items != $min_args);
625   }
626   else {
627     $cond = qq(items < $min_args || items > $num_args);
628   }
629   return $cond;
630 }
631
632 =head2 C<current_line_number()>
633
634 =over 4
635
636 =item * Purpose
637
638 Figures out the current line number in the XS file.
639
640 =item * Arguments
641
642 C<$self>
643
644 =item * Return Value
645
646 The current line number.
647
648 =back
649
650 =cut
651
652 sub current_line_number {
653   my $self = shift;
654   my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
655   return $line_number;
656 }
657
658 =head2 C<Warn()>
659
660 =over 4
661
662 =item * Purpose
663
664 =item * Arguments
665
666 =item * Return Value
667
668 =back
669
670 =cut
671
672 sub Warn {
673   my $self = shift;
674   my $warn_line_number = $self->current_line_number();
675   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
676 }
677
678 =head2 C<blurt()>
679
680 =over 4
681
682 =item * Purpose
683
684 =item * Arguments
685
686 =item * Return Value
687
688 =back
689
690 =cut
691
692 sub blurt {
693   my $self = shift;
694   $self->Warn(@_);
695   $self->{errors}++
696 }
697
698 =head2 C<death()>
699
700 =over 4
701
702 =item * Purpose
703
704 =item * Arguments
705
706 =item * Return Value
707
708 =back
709
710 =cut
711
712 sub death {
713   my $self = shift;
714   $self->Warn(@_);
715   exit 1;
716 }
717
718 =head2 C<check_conditional_preprocessor_statements()>
719
720 =over 4
721
722 =item * Purpose
723
724 =item * Arguments
725
726 =item * Return Value
727
728 =back
729
730 =cut
731
732 sub check_conditional_preprocessor_statements {
733   my ($self) = @_;
734   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
735   if (@cpp) {
736     my $cpplevel;
737     for my $cpp (@cpp) {
738       if ($cpp =~ /^\#\s*if/) {
739         $cpplevel++;
740       }
741       elsif (!$cpplevel) {
742         $self->Warn("Warning: #else/elif/endif without #if in this function");
743         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
744           if $self->{XSStack}->[-1]{type} eq 'if';
745         return;
746       }
747       elsif ($cpp =~ /^\#\s*endif/) {
748         $cpplevel--;
749       }
750     }
751     $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
752   }
753 }
754
755 1;
756
757 # vim: ts=2 sw=2 et: