This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add targetable method
[perl5.git] / 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