1package ExtUtils::ParseXS::Utilities;
2use strict;
3use warnings;
4use Exporter;
5use File::Spec;
6use ExtUtils::ParseXS::Constants ();
7
8our $VERSION = '3.24';
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(pTHX_ const CV *const cv, const char *const params);
456
457STATIC void
458S_croak_xs_usage(pTHX_ 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(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
471        else
472            Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
473    } else {
474        /* Pants. I don't think that it should be possible to get here. */
475        Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
476    }
477}
478#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
479
480#ifdef PERL_IMPLICIT_CONTEXT
481#define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
482#else
483#define croak_xs_usage        S_croak_xs_usage
484#endif
485
486#endif
487
488/* NOTE: the prototype of newXSproto() is different in versions of perls,
489 * so we define a portable version of newXSproto()
490 */
491#ifdef newXS_flags
492#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
493#else
494#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
495#endif /* !defined(newXS_flags) */
496
497EOF
498  return 1;
499}
500
501=head2 C<assign_func_args()>
502
503=over 4
504
505=item * Purpose
506
507Perform assignment to the C<func_args> attribute.
508
509=item * Arguments
510
511  $string = assign_func_args($self, $argsref, $class);
512
513List of three elements.  Second is an array reference; third is a string.
514
515=item * Return Value
516
517String.
518
519=back
520
521=cut
522
523sub assign_func_args {
524  my ($self, $argsref, $class) = @_;
525  my @func_args = @{$argsref};
526  shift @func_args if defined($class);
527
528  for my $arg (@func_args) {
529    $arg =~ s/^/&/ if $self->{in_out}->{$arg};
530  }
531  return join(", ", @func_args);
532}
533
534=head2 C<analyze_preprocessor_statements()>
535
536=over 4
537
538=item * Purpose
539
540Within each function inside each Xsub, print to the F<.c> output file certain
541preprocessor statements.
542
543=item * Arguments
544
545      ( $self, $XSS_work_idx, $BootCode_ref ) =
546        analyze_preprocessor_statements(
547          $self, $statement, $XSS_work_idx, $BootCode_ref
548        );
549
550List of four elements.
551
552=item * Return Value
553
554Modifed values of three of the arguments passed to the function.  In
555particular, the C<XSStack> and C<InitFileCode> attributes are modified.
556
557=back
558
559=cut
560
561sub analyze_preprocessor_statements {
562  my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
563
564  if ($statement eq 'if') {
565    $XSS_work_idx = @{ $self->{XSStack} };
566    push(@{ $self->{XSStack} }, {type => 'if'});
567  }
568  else {
569    $self->death("Error: '$statement' with no matching 'if'")
570      if $self->{XSStack}->[-1]{type} ne 'if';
571    if ($self->{XSStack}->[-1]{varname}) {
572      push(@{ $self->{InitFileCode} }, "#endif\n");
573      push(@{ $BootCode_ref },     "#endif");
574    }
575
576    my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
577    if ($statement ne 'endif') {
578      # Hide the functions defined in other #if branches, and reset.
579      @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
580      @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
581    }
582    else {
583      my($tmp) = pop(@{ $self->{XSStack} });
584      0 while (--$XSS_work_idx
585           && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
586      # Keep all new defined functions
587      push(@fns, keys %{$tmp->{other_functions}});
588      @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
589    }
590  }
591  return ($self, $XSS_work_idx, $BootCode_ref);
592}
593
594=head2 C<set_cond()>
595
596=over 4
597
598=item * Purpose
599
600=item * Arguments
601
602=item * Return Value
603
604=back
605
606=cut
607
608sub set_cond {
609  my ($ellipsis, $min_args, $num_args) = @_;
610  my $cond;
611  if ($ellipsis) {
612    $cond = ($min_args ? qq(items < $min_args) : 0);
613  }
614  elsif ($min_args == $num_args) {
615    $cond = qq(items != $min_args);
616  }
617  else {
618    $cond = qq(items < $min_args || items > $num_args);
619  }
620  return $cond;
621}
622
623=head2 C<current_line_number()>
624
625=over 4
626
627=item * Purpose
628
629Figures out the current line number in the XS file.
630
631=item * Arguments
632
633C<$self>
634
635=item * Return Value
636
637The current line number.
638
639=back
640
641=cut
642
643sub current_line_number {
644  my $self = shift;
645  my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
646  return $line_number;
647}
648
649=head2 C<Warn()>
650
651=over 4
652
653=item * Purpose
654
655=item * Arguments
656
657=item * Return Value
658
659=back
660
661=cut
662
663sub Warn {
664  my $self = shift;
665  my $warn_line_number = $self->current_line_number();
666  print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
667}
668
669=head2 C<blurt()>
670
671=over 4
672
673=item * Purpose
674
675=item * Arguments
676
677=item * Return Value
678
679=back
680
681=cut
682
683sub blurt {
684  my $self = shift;
685  $self->Warn(@_);
686  $self->{errors}++
687}
688
689=head2 C<death()>
690
691=over 4
692
693=item * Purpose
694
695=item * Arguments
696
697=item * Return Value
698
699=back
700
701=cut
702
703sub death {
704  my $self = shift;
705  $self->Warn(@_);
706  exit 1;
707}
708
709=head2 C<check_conditional_preprocessor_statements()>
710
711=over 4
712
713=item * Purpose
714
715=item * Arguments
716
717=item * Return Value
718
719=back
720
721=cut
722
723sub check_conditional_preprocessor_statements {
724  my ($self) = @_;
725  my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
726  if (@cpp) {
727    my $cpplevel;
728    for my $cpp (@cpp) {
729      if ($cpp =~ /^\#\s*if/) {
730        $cpplevel++;
731      }
732      elsif (!$cpplevel) {
733        $self->Warn("Warning: #else/elif/endif without #if in this function");
734        print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
735          if $self->{XSStack}->[-1]{type} eq 'if';
736        return;
737      }
738      elsif ($cpp =~ /^\#\s*endif/) {
739        $cpplevel--;
740      }
741    }
742    $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
743  }
744}
745
746=head2 C<escape_file_for_line_directive()>
747
748=over 4
749
750=item * Purpose
751
752Escapes a given code source name (typically a file name but can also
753be a command that was read from) so that double-quotes and backslashes are escaped.
754
755=item * Arguments
756
757A string.
758
759=item * Return Value
760
761A string with escapes for double-quotes and backslashes.
762
763=back
764
765=cut
766
767sub escape_file_for_line_directive {
768  my $string = shift;
769  $string =~ s/\\/\\\\/g;
770  $string =~ s/"/\\"/g;
771  return $string;
772}
773
774=head2 C<report_typemap_failure>
775
776=over 4
777
778=item * Purpose
779
780Do error reporting for missing typemaps.
781
782=item * Arguments
783
784The C<ExtUtils::ParseXS> object.
785
786An C<ExtUtils::Typemaps> object.
787
788The string that represents the C type that was not found in the typemap.
789
790Optionally, the string C<death> or C<blurt> to choose
791whether the error is immediately fatal or not. Default: C<blurt>
792
793=item * Return Value
794
795Returns nothing. Depending on the arguments, this
796may call C<death> or C<blurt>, the former of which is
797fatal.
798
799=back
800
801=cut
802
803sub report_typemap_failure {
804  my ($self, $tm, $ctype, $error_method) = @_;
805  $error_method ||= 'blurt';
806
807  my @avail_ctypes = $tm->list_mapped_ctypes;
808
809  my $err = "Could not find a typemap for C type '$ctype'.\n"
810            . "The following C types are mapped by the current typemap:\n'"
811            . join("', '", @avail_ctypes) . "'\n";
812
813  $self->$error_method($err);
814  return();
815}
816
8171;
818
819# vim: ts=2 sw=2 et:
820