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