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