This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid conflicting static / dllexport on legacy perls too
[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
9 our $VERSION = '3.06';
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 );
32
33 =head1 NAME
34
35 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
36
37 =head1 SYNOPSIS
38
39   use ExtUtils::ParseXS::Utilities qw(
40     standard_typemap_locations
41     trim_whitespace
42     tidy_type
43     C_string
44     valid_proto_string
45     process_typemaps
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 $typemaps_object = process_typemaps( $args{typemap}, $pwd );
285       
286 List of two elements:  C<typemap> element from C<%args>; current working
287 directory.
288
289 =item * Return Value
290
291 Upon success, returns an L<ExtUtils::Typemaps> object.
292
293 =back
294
295 =cut
296
297 sub process_typemaps {
298   my ($tmap, $pwd) = @_;
299
300   my @tm = ref $tmap ? @{$tmap} : ($tmap);
301
302   foreach my $typemap (@tm) {
303     die "Can't find $typemap in $pwd\n" unless -r $typemap;
304   }
305
306   push @tm, standard_typemap_locations( \@INC );
307
308   require ExtUtils::Typemaps;
309   my $typemap = ExtUtils::Typemaps->new;
310   foreach my $typemap_loc (@tm) {
311     next unless -f $typemap_loc;
312     # skip directories, binary files etc.
313     warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
314       unless -T $typemap_loc;
315
316     $typemap->merge(file => $typemap_loc, replace => 1);
317   }
318
319   return $typemap;
320 }
321
322 =head2 C<make_targetable()>
323
324 =over 4
325
326 =item * Purpose
327
328 Populate C<%targetable>.  This constitutes a refinement of the output of
329 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
330
331 =item * Arguments
332
333   %targetable = make_targetable($output_expr_ref);
334       
335 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
336
337 =item * Return Value
338
339 Hash.
340
341 =back
342
343 =cut
344
345 sub make_targetable {
346   my $output_expr_ref = shift;
347
348   our $bal; # ()-balanced
349   $bal = qr[
350     (?:
351       (?>[^()]+)
352       |
353       \( (??{ $bal }) \)
354     )*
355   ]x;
356
357   # matches variations on (SV*)
358   my $sv_cast = qr[
359     (?:
360       \( \s* SV \s* \* \s* \) \s*
361     )?
362   ]x;
363
364   my $size = qr[ # Third arg (to setpvn)
365     , \s* (??{ $bal })
366   ]x;
367
368   my %targetable;
369   foreach my $key (keys %{ $output_expr_ref }) {
370     # We can still bootstrap compile 're', because in code re.pm is
371     # available to miniperl, and does not attempt to load the XS code.
372     use re 'eval';
373
374     my ($type, $with_size, $arg, $sarg) =
375       ($output_expr_ref->{$key} =~
376         m[^
377           \s+
378           sv_set([iunp])v(n)?    # Type, is_setpvn
379           \s*
380           \( \s*
381             $sv_cast \$arg \s* , \s*
382             ( (??{ $bal }) )    # Set from
383           ( (??{ $size }) )?    # Possible sizeof set-from
384           \) \s* ; \s* $
385         ]x
386     );
387     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
388   }
389   return %targetable;
390 }
391
392 =head2 C<map_type()>
393
394 =over 4
395
396 =item * Purpose
397
398 Performs a mapping at several places inside C<PARAGRAPH> loop.
399
400 =item * Arguments
401
402   $type = map_type($self, $type, $varname);
403
404 List of three arguments.
405
406 =item * Return Value
407
408 String holding augmented version of second argument.
409
410 =back
411
412 =cut
413
414 sub map_type {
415   my ($self, $type, $varname) = @_;
416
417   # C++ has :: in types too so skip this
418   $type =~ tr/:/_/ unless $self->{hiertype};
419   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
420   if ($varname) {
421     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
422       (substr $type, pos $type, 0) = " $varname ";
423     }
424     else {
425       $type .= "\t$varname";
426     }
427   }
428   return $type;
429 }
430
431 =head2 C<standard_XS_defs()>
432
433 =over 4
434
435 =item * Purpose
436
437 Writes to the C<.c> output file certain preprocessor directives and function
438 headers needed in all such files.
439
440 =item * Arguments
441
442 None.
443
444 =item * Return Value
445
446 Returns true.
447
448 =back
449
450 =cut
451
452 sub standard_XS_defs {
453   print <<"EOF";
454 #ifndef PERL_UNUSED_VAR
455 #  define PERL_UNUSED_VAR(var) if (0) var = var
456 #endif
457
458 #ifndef dVAR
459 #  define dVAR          dNOOP
460 #endif
461
462
463 /* This stuff is not part of the API! You have been warned. */
464 #ifndef PERL_VERSION_DECIMAL
465 #  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
466 #endif
467 #ifndef PERL_DECIMAL_VERSION
468 #  define PERL_DECIMAL_VERSION \\
469           PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
470 #endif
471 #ifndef PERL_VERSION_GE
472 #  define PERL_VERSION_GE(r,v,s) \\
473           (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
474 #endif
475 #ifndef PERL_VERSION_LE
476 #  define PERL_VERSION_LE(r,v,s) \\
477           (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
478 #endif
479
480 /* XS_INTERNAL is the explicit static-linkage variant of the default
481  * XS macro.
482  *
483  * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
484  * "STATIC", ie. it exports XSUB symbols. You probably don't want that
485  * for anything but the BOOT XSUB.
486  *
487  * See XSUB.h in core!
488  */
489
490
491 /* TODO: This might be compatible further back than 5.10.0. */
492 #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
493 #  undef XS_EXTERNAL
494 #  undef XS_INTERNAL
495 #  if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
496 #    define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
497 #    define XS_INTERNAL(name) STATIC XSPROTO(name)
498 #  endif
499 #  if defined(__SYMBIAN32__)
500 #    define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
501 #    define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
502 #  endif
503 #  ifndef XS_EXTERNAL
504 #    if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
505 #      define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
506 #      define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
507 #    else
508 #      ifdef __cplusplus
509 #        define XS_EXTERNAL(name) extern "C" XSPROTO(name)
510 #        define XS_INTERNAL(name) static XSPROTO(name)
511 #      else
512 #        define XS_EXTERNAL(name) XSPROTO(name)
513 #        define XS_INTERNAL(name) STATIC XSPROTO(name)
514 #      endif
515 #    endif
516 #  endif
517 #endif
518
519 /* perl >= 5.10.0 && perl <= 5.15.1 */
520
521
522 /* The XS_EXTERNAL macro is used for functions that must not be static
523  * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
524  * macro defined, the best we can do is assume XS is the same.
525  * Dito for XS_INTERNAL.
526  */
527 #ifndef XS_EXTERNAL
528 #  define XS_EXTERNAL(name) XS(name)
529 #endif
530 #ifndef XS_INTERNAL
531 #  define XS_INTERNAL(name) XS(name)
532 #endif
533
534 /* Now, finally, after all this mess, we want an ExtUtils::ParseXS
535  * internal macro that we're free to redefine for varying linkage due
536  * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
537  * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
538  */
539
540 #undef XS_EUPXS
541 #if defined(PERL_EUPXS_ALWAYS_EXPORT)
542 #  define XS_EUPXS(name) XS_EXTERNAL(name)
543 #else
544    /* default to internal */
545 #  define XS_EUPXS(name) XS_INTERNAL(name)
546 #endif
547
548 EOF
549
550   print <<"EOF";
551 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
552 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
553
554 /* prototype to pass -Wmissing-prototypes */
555 STATIC void
556 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
557
558 STATIC void
559 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
560 {
561     const GV *const gv = CvGV(cv);
562
563     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
564
565     if (gv) {
566         const char *const gvname = GvNAME(gv);
567         const HV *const stash = GvSTASH(gv);
568         const char *const hvname = stash ? HvNAME(stash) : NULL;
569
570         if (hvname)
571             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
572         else
573             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
574     } else {
575         /* Pants. I don't think that it should be possible to get here. */
576         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
577     }
578 }
579 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
580
581 #ifdef PERL_IMPLICIT_CONTEXT
582 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
583 #else
584 #define croak_xs_usage        S_croak_xs_usage
585 #endif
586
587 #endif
588
589 /* NOTE: the prototype of newXSproto() is different in versions of perls,
590  * so we define a portable version of newXSproto()
591  */
592 #ifdef newXS_flags
593 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
594 #else
595 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
596 #endif /* !defined(newXS_flags) */
597
598 EOF
599   return 1;
600 }
601
602 =head2 C<assign_func_args()>
603
604 =over 4
605
606 =item * Purpose
607
608 Perform assignment to the C<func_args> attribute.
609
610 =item * Arguments
611
612   $string = assign_func_args($self, $argsref, $class);
613
614 List of three elements.  Second is an array reference; third is a string.
615
616 =item * Return Value
617
618 String.
619
620 =back
621
622 =cut
623
624 sub assign_func_args {
625   my ($self, $argsref, $class) = @_;
626   my @func_args = @{$argsref};
627   shift @func_args if defined($class);
628
629   for my $arg (@func_args) {
630     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
631   }
632   return join(", ", @func_args);
633 }
634
635 =head2 C<analyze_preprocessor_statements()>
636
637 =over 4
638
639 =item * Purpose
640
641 Within each function inside each Xsub, print to the F<.c> output file certain
642 preprocessor statements.
643
644 =item * Arguments
645
646       ( $self, $XSS_work_idx, $BootCode_ref ) =
647         analyze_preprocessor_statements(
648           $self, $statement, $XSS_work_idx, $BootCode_ref
649         );
650
651 List of four elements.
652
653 =item * Return Value
654
655 Modifed values of three of the arguments passed to the function.  In
656 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
657
658 =back
659
660 =cut
661
662 sub analyze_preprocessor_statements {
663   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
664
665   if ($statement eq 'if') {
666     $XSS_work_idx = @{ $self->{XSStack} };
667     push(@{ $self->{XSStack} }, {type => 'if'});
668   }
669   else {
670     $self->death("Error: '$statement' with no matching 'if'")
671       if $self->{XSStack}->[-1]{type} ne 'if';
672     if ($self->{XSStack}->[-1]{varname}) {
673       push(@{ $self->{InitFileCode} }, "#endif\n");
674       push(@{ $BootCode_ref },     "#endif");
675     }
676
677     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
678     if ($statement ne 'endif') {
679       # Hide the functions defined in other #if branches, and reset.
680       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
681       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
682     }
683     else {
684       my($tmp) = pop(@{ $self->{XSStack} });
685       0 while (--$XSS_work_idx
686            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
687       # Keep all new defined functions
688       push(@fns, keys %{$tmp->{other_functions}});
689       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
690     }
691   }
692   return ($self, $XSS_work_idx, $BootCode_ref);
693 }
694
695 =head2 C<set_cond()>
696
697 =over 4
698
699 =item * Purpose
700
701 =item * Arguments
702
703 =item * Return Value
704
705 =back
706
707 =cut
708
709 sub set_cond {
710   my ($ellipsis, $min_args, $num_args) = @_;
711   my $cond;
712   if ($ellipsis) {
713     $cond = ($min_args ? qq(items < $min_args) : 0);
714   }
715   elsif ($min_args == $num_args) {
716     $cond = qq(items != $min_args);
717   }
718   else {
719     $cond = qq(items < $min_args || items > $num_args);
720   }
721   return $cond;
722 }
723
724 =head2 C<current_line_number()>
725
726 =over 4
727
728 =item * Purpose
729
730 Figures out the current line number in the XS file.
731
732 =item * Arguments
733
734 C<$self>
735
736 =item * Return Value
737
738 The current line number.
739
740 =back
741
742 =cut
743
744 sub current_line_number {
745   my $self = shift;
746   my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
747   return $line_number;
748 }
749
750 =head2 C<Warn()>
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 Warn {
765   my $self = shift;
766   my $warn_line_number = $self->current_line_number();
767   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
768 }
769
770 =head2 C<blurt()>
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 blurt {
785   my $self = shift;
786   $self->Warn(@_);
787   $self->{errors}++
788 }
789
790 =head2 C<death()>
791
792 =over 4
793
794 =item * Purpose
795
796 =item * Arguments
797
798 =item * Return Value
799
800 =back
801
802 =cut
803
804 sub death {
805   my $self = shift;
806   $self->Warn(@_);
807   exit 1;
808 }
809
810 =head2 C<check_conditional_preprocessor_statements()>
811
812 =over 4
813
814 =item * Purpose
815
816 =item * Arguments
817
818 =item * Return Value
819
820 =back
821
822 =cut
823
824 sub check_conditional_preprocessor_statements {
825   my ($self) = @_;
826   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
827   if (@cpp) {
828     my $cpplevel;
829     for my $cpp (@cpp) {
830       if ($cpp =~ /^\#\s*if/) {
831         $cpplevel++;
832       }
833       elsif (!$cpplevel) {
834         $self->Warn("Warning: #else/elif/endif without #if in this function");
835         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
836           if $self->{XSStack}->[-1]{type} eq 'if';
837         return;
838       }
839       elsif ($cpp =~ /^\#\s*endif/) {
840         $cpplevel--;
841       }
842     }
843     $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
844   }
845 }
846
847 1;
848
849 # vim: ts=2 sw=2 et: