dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm

   1 package ExtUtils::Typemaps::OutputMap;
   2 use 5.006001;
   3 use strict;
   4 use warnings;
   5 our $VERSION = '3.21';
   6
   7 =head1 NAME
   8
   9 ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap
  10
  11 =head1 SYNOPSIS
  12
  13   use ExtUtils::Typemaps;
  14   ...
  15   my $output = $typemap->get_output_map('T_NV');
  16   my $code = $output->code();
  17   $output->code("...");
  18
  19 =head1 DESCRIPTION
  20
  21 Refer to L<ExtUtils::Typemaps> for details.
  22
  23 =head1 METHODS
  24
  25 =cut
  26
  27 =head2 new
  28
  29 Requires C<xstype> and C<code> parameters.
  30
  31 =cut
  32
  33 sub new {
  34   my $prot = shift;
  35   my $class = ref($prot)||$prot;
  36   my %args = @_;
  37
  38   if (!ref($prot)) {
  39     if (not defined $args{xstype} or not defined $args{code}) {
  40       die("Need xstype and code parameters");
  41     }
  42   }
  43
  44   my $self = bless(
  45     (ref($prot) ? {%$prot} : {})
  46     => $class
  47   );
  48
  49   $self->{xstype} = $args{xstype} if defined $args{xstype};
  50   $self->{code} = $args{code} if defined $args{code};
  51   $self->{code} =~ s/^(?=\S)/\t/mg;
  52
  53   return $self;
  54 }
  55
  56 =head2 code
  57
  58 Returns or sets the OUTPUT mapping code for this entry.
  59
  60 =cut
  61
  62 sub code {
  63   $_[0]->{code} = $_[1] if @_ > 1;
  64   return $_[0]->{code};
  65 }
  66
  67 =head2 xstype
  68
  69 Returns the name of the XS type of the OUTPUT map.
  70
  71 =cut
  72
  73 sub xstype {
  74   return $_[0]->{xstype};
  75 }
  76
  77 =head2 cleaned_code
  78
  79 Returns a cleaned-up copy of the code to which certain transformations
  80 have been applied to make it more ANSI compliant.
  81
  82 =cut
  83
  84 sub cleaned_code {
  85   my $self = shift;
  86   my $code = $self->code;
  87
  88   # Move C pre-processor instructions to column 1 to be strictly ANSI
  89   # conformant. Some pre-processors are fussy about this.
  90   $code =~ s/^\s+#/#/mg;
  91   $code =~ s/\s*\z/\n/;
  92
  93   return $code;
  94 }
  95
  96 =head2 targetable
  97
  98 This is an obscure but effective optimization that used to
  99 live in C<ExtUtils::ParseXS> directly. Not implementing it
 100 should never result in incorrect use of typemaps, just less
 101 efficient code.
 102
 103 In a nutshell, this will check whether the output code
 104 involves calling C<sv_setiv>, C<sv_setuv>, C<sv_setnv>, C<sv_setpv> or
 105 C<sv_setpvn> to set the special C<$arg> placeholder to a new value
 106 B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
 107 eligible for using the C<TARG>-related macros to optimize this.
 108 Thus the name of the method: C<targetable>.
 109
 110 If this optimization is applicable, C<ExtUtils::ParseXS> will
 111 emit a C<dXSTARG;> definition at the start of the generate XSUB code,
 112 and type (see below) dependent code to set C<TARG> and push it on
 113 the stack at the end of the generated XSUB code.
 114
 115 If the optimization can not be applied, this returns undef.
 116 If it can be applied, this method returns a hash reference containing
 117 the following information:
 118
 119   type:      Any of the characters i, u, n, p
 120   with_size: Bool indicating whether this is the sv_setpvn variant
 121   what:      The code that actually evaluates to the output scalar
 122   what_size: If "with_size", this has the string length (as code,
 123              not constant, including leading comma)
 124
 125 =cut
 126
 127 sub targetable {
 128   my $self = shift;
 129   return $self->{targetable} if exists $self->{targetable};
 130
 131   our $bal; # ()-balanced
 132   $bal = qr[
 133     (?:
 134       (?>[^()]+)
 135       |
 136       \( (??{ $bal }) \)
 137     )*
 138   ]x;
 139   my $bal_no_comma = qr[
 140     (?:
 141       (?>[^(),]+)
 142       |
 143       \( (??{ $bal }) \)
 144     )+
 145   ]x;
 146
 147   # matches variations on (SV*)
 148   my $sv_cast = qr[
 149     (?:
 150       \( \s* SV \s* \* \s* \) \s*
 151     )?
 152   ]x;
 153
 154   my $size = qr[ # Third arg (to setpvn)
 155     , \s* (??{ $bal })
 156   ]xo;
 157
 158   my $code = $self->code;
 159
 160   # We can still bootstrap compile 're', because in code re.pm is
 161   # available to miniperl, and does not attempt to load the XS code.
 162   use re 'eval';
 163
 164   my ($type, $with_size, $arg, $sarg) =
 165     ($code =~
 166       m[^
 167         \s+
 168         sv_set([iunp])v(n)?    # Type, is_setpvn
 169         \s*
 170         \( \s*
 171           $sv_cast \$arg \s* , \s*
 172           ( $bal_no_comma )    # Set from
 173           ( $size )?           # Possible sizeof set-from
 174         \s* \) \s* ; \s* $
 175       ]xo
 176   );
 177
 178   my $rv = undef;
 179   if ($type) {
 180     $rv = {
 181       type      => $type,
 182       with_size => $with_size,
 183       what      => $arg,
 184       what_size => $sarg,
 185     };
 186   }
 187   $self->{targetable} = $rv;
 188   return $rv;
 189 }
 190
 191 =head1 SEE ALSO
 192
 193 L<ExtUtils::Typemaps>
 194
 195 =head1 AUTHOR
 196
 197 Steffen Mueller C<<smueller@cpan.org>>
 198
 199 =head1 COPYRIGHT & LICENSE
 200
 201 Copyright 2009, 2010, 2011, 2012 Steffen Mueller
 202
 203 This program is free software; you can redistribute it and/or
 204 modify it under the same terms as Perl itself.
 205
 206 =cut
 207
 208 1;
 209