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
CommitLineData
7320491e 1package ExtUtils::Typemaps::OutputMap;
297f4492
S
2use 5.006001;
3use strict;
4use warnings;
a64e87a8 5#use Carp qw(croak);
297f4492
S
6
7=head1 NAME
8
7320491e 9ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap
297f4492
S
10
11=head1 SYNOPSIS
12
7320491e 13 use ExtUtils::Typemaps;
297f4492
S
14 ...
15 my $output = $typemap->get_output_map('T_NV');
16 my $code = $output->code();
17 $output->code("...");
18
19=head1 DESCRIPTION
20
7320491e 21Refer to L<ExtUtils::Typemaps> for details.
297f4492
S
22
23=head1 METHODS
24
25=cut
26
27=head2 new
28
29Requires C<xstype> and C<code> parameters.
30
31=cut
32
33sub 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}) {
a64e87a8 40 die("Need xstype and code parameters");
297f4492
S
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
58Returns or sets the OUTPUT mapping code for this entry.
59
60=cut
61
62sub code {
63 $_[0]->{code} = $_[1] if @_ > 1;
64 return $_[0]->{code};
65}
66
67=head2 xstype
68
69Returns the name of the XS type of the OUTPUT map.
70
71=cut
72
73sub xstype {
74 return $_[0]->{xstype};
75}
76
16b42e0e
S
77=head2 cleaned_code
78
79Returns a cleaned-up copy of the code to which certain transformations
80have been applied to make it more ANSI compliant.
81
82=cut
83
84sub 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
64620e57
S
95=head2 targetable
96
97This is an obscure optimization that used to live in C<ExtUtils::ParseXS>
98directly.
99
100In a nutshell, this will check whether the output code
101involves calling C<set_iv>, C<set_uv>, C<set_nv>, C<set_pv> or C<set_pvn>
102to set the special C<$arg> placeholder to a new value
103B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
104eligible for using the C<TARG>-related macros to optimize this.
105Thus the name of the method: C<targetable>.
106
107If the optimization can not be applied, this returns undef.
108If it can be applied, this method returns a hash reference containing
109the 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
118sub 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
297f4492
S
175=head1 SEE ALSO
176
7320491e 177L<ExtUtils::Typemaps>
297f4492
S
178
179=head1 AUTHOR
180
181Steffen Mueller C<<smueller@cpan.org>>
182
183=head1 COPYRIGHT & LICENSE
184
0b19625b 185Copyright 2009-2011 Steffen Mueller
297f4492
S
186
187This program is free software; you can redistribute it and/or
188modify it under the same terms as Perl itself.
189
190=cut
191
1921;
193