Documentation fix
[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 our (@ISA, @EXPORT_OK);
9 @ISA = qw(Exporter);
10 @EXPORT_OK = qw(
11   standard_typemap_locations
12   trim_whitespace
13   tidy_type
14   C_string
15   valid_proto_string
16   process_typemaps
17   process_single_typemap
18   make_targetable
19   map_type
20   standard_XS_defs
21   assign_func_args
22   analyze_preprocessor_statements
23   set_cond
24   Warn
25   blurt
26   death
27   check_conditional_preprocessor_statements
28 );
29
30 =head1 NAME
31
32 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
33
34 =head1 SYNOPSIS
35
36   use ExtUtils::ParseXS::Utilities qw(
37     standard_typemap_locations
38     trim_whitespace
39     tidy_type
40     C_string
41     valid_proto_string
42     process_typemaps
43     process_single_typemap
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 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
283     process_typemaps( $args{typemap}, $pwd );
284       
285 List of two elements:  C<typemap> element from C<%args>; current working
286 directory.
287
288 =item * Return Value
289
290 Upon success, returns a list of four hash references.  (This will probably be
291 refactored.)  Here is a I<rough> description of what is in these hashrefs:
292
293 =over 4
294
295 =item * C<$type_kind_ref>
296
297   {
298     'char **' => 'T_PACKEDARRAY',
299     'bool_t' => 'T_IV',
300     'AV *' => 'T_AVREF',
301     'InputStream' => 'T_IN',
302     'double' => 'T_DOUBLE',
303     # ...
304   }
305
306 Keys:  C types.  Values:  XS types identifiers
307
308 =item * C<$proto_letter_ref>
309
310   {
311     'char **' => '$',
312     'bool_t' => '$',
313     'AV *' => '$',
314     'InputStream' => '$',
315     'double' => '$',
316     # ...
317   }
318
319 Keys: C types.  Values. Corresponding prototype letters.
320
321 =item * C<$input_expr_ref>
322
323   {
324     'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
325   ',
326     'T_OUT' => '        $var = IoOFP(sv_2io($arg))
327   ',
328     'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) {
329     # ...
330   }
331
332 Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
333 will be written to C source code (F<.c>) files.   The strings are C code, but
334 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
335 by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
336
337 =item * C<$output_expr_ref>
338
339   {
340     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
341                 $var.context.value().size());
342   ',
343     'T_OUT' => '        {
344             GV *gv = newGVgen("$Package");
345             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
346                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
347             else
348                 $arg = &PL_sv_undef;
349         }
350   ',
351     # ...
352   }
353
354 Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
355 will be written to C source code (F<.c>) files.   The strings are C code, but
356 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
357 by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
358
359 =back
360
361 =back
362
363 =cut
364
365 sub process_typemaps {
366   my ($tmap, $pwd) = @_;
367
368   my @tm = ref $tmap ? @{$tmap} : ($tmap);
369
370   foreach my $typemap (@tm) {
371     die "Can't find $typemap in $pwd\n" unless -r $typemap;
372   }
373
374   push @tm, standard_typemap_locations( \@INC );
375
376   my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
377     = ( {}, {}, {}, {} );
378
379   foreach my $typemap (@tm) {
380     next unless -f $typemap;
381     # skip directories, binary files etc.
382     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
383       unless -T $typemap;
384     ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
385       process_single_typemap( $typemap,
386         $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
387   }
388   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
389 }
390
391 =head2 C<process_single_typemap()>
392
393 =over 4
394
395 =item * Purpose
396
397 Process a single typemap within C<process_typemaps()>.
398
399 =item * Arguments
400
401     ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
402       process_single_typemap( $typemap,
403         $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
404
405 List of five elements:  The individual typemap needing processing and four
406 references.
407
408 =item * Return Value
409
410 List of four references -- modified versions of those passed in as arguments.
411
412 =back
413
414 =cut
415
416 sub process_single_typemap {
417   my ($typemap,
418     $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
419   open my $TYPEMAP, '<', $typemap
420     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
421   my $mode = 'Typemap';
422   my $junk = "";
423   my $current = \$junk;
424   while (<$TYPEMAP>) {
425     # skip comments
426     next if /^\s*#/;
427     if (/^INPUT\s*$/) {
428       $mode = 'Input';   $current = \$junk;  next;
429     }
430     if (/^OUTPUT\s*$/) {
431       $mode = 'Output';  $current = \$junk;  next;
432     }
433     if (/^TYPEMAP\s*$/) {
434       $mode = 'Typemap'; $current = \$junk;  next;
435     }
436     if ($mode eq 'Typemap') {
437       chomp;
438       my $logged_line = $_;
439       trim_whitespace($_);
440       # skip blank lines
441       next if /^$/;
442       my($type,$kind, $proto) =
443         m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
444           or warn(
445             "Warning: File '$typemap' Line $.  '$logged_line' " .
446             "TYPEMAP entry needs 2 or 3 columns\n"
447           ),
448           next;
449       $type = tidy_type($type);
450       $type_kind_ref->{$type} = $kind;
451       # prototype defaults to '$'
452       $proto = "\$" unless $proto;
453       $proto_letter_ref->{$type} = C_string($proto);
454     }
455     elsif (/^\s/) {
456       $$current .= $_;
457     }
458     elsif ($mode eq 'Input') {
459       s/\s+$//;
460       $input_expr_ref->{$_} = '';
461       $current = \$input_expr_ref->{$_};
462     }
463     else {
464       s/\s+$//;
465       $output_expr_ref->{$_} = '';
466       $current = \$output_expr_ref->{$_};
467     }
468   }
469   close $TYPEMAP;
470   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
471 }
472
473 =head2 C<make_targetable()>
474
475 =over 4
476
477 =item * Purpose
478
479 Populate C<%targetable>.  This constitutes a refinement of the output of
480 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
481
482 =item * Arguments
483
484   %targetable = make_targetable($output_expr_ref);
485       
486 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
487
488 =item * Return Value
489
490 Hash.
491
492 =back
493
494 =cut
495
496 sub make_targetable {
497   my $output_expr_ref = shift;
498   my ($cast, $size);
499   our $bal;
500   $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
501   $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
502   $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
503
504   my %targetable;
505   foreach my $key (keys %{ $output_expr_ref }) {
506     # We can still bootstrap compile 're', because in code re.pm is
507     # available to miniperl, and does not attempt to load the XS code.
508     use re 'eval';
509
510     my ($t, $with_size, $arg, $sarg) =
511       ($output_expr_ref->{$key} =~
512         m[^ \s+ sv_set ( [iunp] ) v (n)?    # Type, is_setpvn
513           \s* \( \s* $cast \$arg \s* ,
514           \s* ( (??{ $bal }) )    # Set from
515           ( (??{ $size }) )?    # Possible sizeof set-from
516           \) \s* ; \s* $
517         ]x
518     );
519     $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
520   }
521   return %targetable;
522 }
523
524 =head2 C<map_type()>
525
526 =over 4
527
528 =item * Purpose
529
530 Performs a mapping at several places inside C<PARAGRAPH> loop.
531
532 =item * Arguments
533
534   $type = map_type($self, $type, $varname);
535
536 List of three arguments.
537
538 =item * Return Value
539
540 String holding augmented version of second argument.
541
542 =back
543
544 =cut
545
546 sub map_type {
547   my ($self, $type, $varname) = @_;
548
549   # C++ has :: in types too so skip this
550   $type =~ tr/:/_/ unless $self->{hiertype};
551   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
552   if ($varname) {
553     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
554       (substr $type, pos $type, 0) = " $varname ";
555     }
556     else {
557       $type .= "\t$varname";
558     }
559   }
560   return $type;
561 }
562
563 =head2 C<standard_XS_defs()>
564
565 =over 4
566
567 =item * Purpose
568
569 Writes to the C<.c> output file certain preprocessor directives and function
570 headers needed in all such files.
571
572 =item * Arguments
573
574 None.
575
576 =item * Return Value
577
578 Implicitly returns true when final C<print> statement completes.
579
580 =back
581
582 =cut
583
584 sub standard_XS_defs {
585   print <<"EOF";
586 #ifndef PERL_UNUSED_VAR
587 #  define PERL_UNUSED_VAR(var) if (0) var = var
588 #endif
589
590 EOF
591
592   print <<"EOF";
593 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
594 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
595
596 /* prototype to pass -Wmissing-prototypes */
597 STATIC void
598 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
599
600 STATIC void
601 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
602 {
603     const GV *const gv = CvGV(cv);
604
605     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
606
607     if (gv) {
608         const char *const gvname = GvNAME(gv);
609         const HV *const stash = GvSTASH(gv);
610         const char *const hvname = stash ? HvNAME(stash) : NULL;
611
612         if (hvname)
613             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
614         else
615             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
616     } else {
617         /* Pants. I don't think that it should be possible to get here. */
618         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
619     }
620 }
621 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
622
623 #ifdef PERL_IMPLICIT_CONTEXT
624 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
625 #else
626 #define croak_xs_usage        S_croak_xs_usage
627 #endif
628
629 #endif
630
631 /* NOTE: the prototype of newXSproto() is different in versions of perls,
632  * so we define a portable version of newXSproto()
633  */
634 #ifdef newXS_flags
635 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
636 #else
637 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
638 #endif /* !defined(newXS_flags) */
639
640 EOF
641 }
642
643 =head2 C<assign_func_args()>
644
645 =over 4
646
647 =item * Purpose
648
649 Perform assignment to the C<func_args> attribute.
650
651 =item * Arguments
652
653   $string = assign_func_args($self, $argsref, $class);
654
655 List of three elements.  Second is an array reference; third is a string.
656
657 =item * Return Value
658
659 String.
660
661 =back
662
663 =cut
664
665 sub assign_func_args {
666   my ($self, $argsref, $class) = @_;
667   my @func_args = @{$argsref};
668   shift @func_args if defined($class);
669
670   for my $arg (@func_args) {
671     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
672   }
673   return join(", ", @func_args);
674 }
675
676 =head2 C<analyze_preprocessor_statements()>
677
678 =over 4
679
680 =item * Purpose
681
682 Within each function inside each Xsub, print to the F<.c> output file certain
683 preprocessor statements.
684
685 =item * Arguments
686
687       ( $self, $XSS_work_idx, $BootCode_ref ) =
688         analyze_preprocessor_statements(
689           $self, $statement, $XSS_work_idx, $BootCode_ref
690         );
691
692 List of four elements.
693
694 =item * Return Value
695
696 Modifed values of three of the arguments passed to the function.  In
697 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
698
699 =back
700
701 =cut
702
703 sub analyze_preprocessor_statements {
704   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
705
706   if ($statement eq 'if') {
707     $XSS_work_idx = @{ $self->{XSStack} };
708     push(@{ $self->{XSStack} }, {type => 'if'});
709   }
710   else {
711     death ("Error: `$statement' with no matching `if'")
712       if $self->{XSStack}->[-1]{type} ne 'if';
713     if ($self->{XSStack}->[-1]{varname}) {
714       push(@{ $self->{InitFileCode} }, "#endif\n");
715       push(@{ $BootCode_ref },     "#endif");
716     }
717
718     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
719     if ($statement ne 'endif') {
720       # Hide the functions defined in other #if branches, and reset.
721       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
722       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
723     }
724     else {
725       my($tmp) = pop(@{ $self->{XSStack} });
726       0 while (--$XSS_work_idx
727            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
728       # Keep all new defined functions
729       push(@fns, keys %{$tmp->{other_functions}});
730       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
731     }
732   }
733   return ($self, $XSS_work_idx, $BootCode_ref);
734 }
735
736 =head2 C<set_cond()>
737
738 =over 4
739
740 =item * Purpose
741
742 =item * Arguments
743
744 =item * Return Value
745
746 =back
747
748 =cut
749
750 sub set_cond {
751   my ($ellipsis, $min_args, $num_args) = @_;
752   my $cond;
753   if ($ellipsis) {
754     $cond = ($min_args ? qq(items < $min_args) : 0);
755   }
756   elsif ($min_args == $num_args) {
757     $cond = qq(items != $min_args);
758   }
759   else {
760     $cond = qq(items < $min_args || items > $num_args);
761   }
762   return $cond;
763 }
764
765 =head2 C<Warn()>
766
767 =over 4
768
769 =item * Purpose
770
771 =item * Arguments
772
773 =item * Return Value
774
775 =back
776
777 =cut
778
779 sub Warn {
780   my $self = shift;
781   # work out the line number
782   my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
783
784   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
785 }
786
787 =head2 C<blurt()>
788
789 =over 4
790
791 =item * Purpose
792
793 =item * Arguments
794
795 =item * Return Value
796
797 =back
798
799 =cut
800
801 sub blurt {
802   my $self = shift;
803   Warn($self, @_);
804   $self->{errors}++
805 }
806
807 =head2 C<death()>
808
809 =over 4
810
811 =item * Purpose
812
813 =item * Arguments
814
815 =item * Return Value
816
817 =back
818
819 =cut
820
821 sub death {
822   my $self = shift;
823   Warn($self, @_);
824   exit 1;
825 }
826
827 =head2 C<check_conditional_preprocessor_statements()>
828
829 =over 4
830
831 =item * Purpose
832
833 =item * Arguments
834
835 =item * Return Value
836
837 =back
838
839 =cut
840
841 sub check_conditional_preprocessor_statements {
842   my ($self) = @_;
843   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
844   if (@cpp) {
845     my $cpplevel;
846     for my $cpp (@cpp) {
847       if ($cpp =~ /^\#\s*if/) {
848         $cpplevel++;
849       }
850       elsif (!$cpplevel) {
851         Warn( $self, "Warning: #else/elif/endif without #if in this function");
852         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
853           if $self->{XSStack}->[-1]{type} eq 'if';
854         return;
855       }
856       elsif ($cpp =~ /^\#\s*endif/) {
857         $cpplevel--;
858       }
859     }
860     Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;
861   }
862 }
863
864 1;
865
866 # vim: ts=2 sw=2 et: