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