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

   1 package ExtUtils::Typemaps::OutputMap;
   2 use 5.006001;
   3 use strict;
   4 use warnings;
   5 #use Carp qw(croak);
   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 optimization that used to live in C<ExtUtils::ParseXS>
  99 directly.
 100
 101 In a nutshell, this will check whether the output code
 102 involves calling C<set_iv>, C<set_uv>, C<set_nv>, C<set_pv> or C<set_pvn>
 103 to set the special C<$arg> placeholder to a new value
 104 B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
 105 eligible for using the C<TARG>-related macros to optimize this.
 106 Thus the name of the method: C<targetable>.
 107
 108 If the optimization can not be applied, this returns undef.
 109 If it can be applied, this method returns a hash reference containing
 110 the following information:
 111
 112   type:      Any of the characters i, u, n, p
 113   with_size: Bool indicating whether this is the sv_setpvn variant
 114   what:      The code that actually evaluates to the output scalar
 115   what_size: If "with_size", this has the string length (as code,
 116              not constant)
 117
 118 =cut
 119
 120 sub targetable {
 121   my $self = shift;
 122   return $self->{targetable} if exists $self->{targetable};
 123
 124   our $bal; # ()-balanced
 125   $bal = qr[
 126     (?:
 127       (?>[^()]+)
 128       |
 129       \( (??{ $bal }) \)
 130     )*
 131   ]x;
 132
 133   # matches variations on (SV*)
 134   my $sv_cast = qr[
 135     (?:
 136       \( \s* SV \s* \* \s* \) \s*
 137     )?
 138   ]x;
 139
 140   my $size = qr[ # Third arg (to setpvn)
 141     , \s* (??{ $bal })
 142   ]x;
 143
 144   my $code = $self->code;
 145
 146   # We can still bootstrap compile 're', because in code re.pm is
 147   # available to miniperl, and does not attempt to load the XS code.
 148   use re 'eval';
 149
 150   my ($type, $with_size, $arg, $sarg) =
 151     ($code =~
 152       m[^
 153         \s+
 154         sv_set([iunp])v(n)?    # Type, is_setpvn
 155         \s*
 156         \( \s*
 157           $sv_cast \$arg \s* , \s*
 158           ( (??{ $bal }) )    # Set from
 159         ( (??{ $size }) )?    # Possible sizeof set-from
 160         \) \s* ; \s* $
 161       ]x
 162   );
 163
 164   my $rv = undef;
 165   if ($type) {
 166     $rv = {
 167       type      => $type,
 168       with_size => $with_size,
 169       what      => $arg,
 170       what_size => $sarg,
 171     };
 172   }
 173   $self->{targetable} = $rv;
 174   return $rv;
 175 }
 176
 177 =head1 SEE ALSO
 178
 179 L<ExtUtils::Typemaps>
 180
 181 =head1 AUTHOR
 182
 183 Steffen Mueller C<<smueller@cpan.org>>
 184
 185 =head1 COPYRIGHT & LICENSE
 186
 187 Copyright 2009-2011 Steffen Mueller
 188
 189 This program is free software; you can redistribute it and/or
 190 modify it under the same terms as Perl itself.
 191
 192 =cut
 193
 194 1;
 195