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