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