This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d29cae4e828e8bac20900b826e77ec9cf7ff39ff
[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   $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, not constant)
116
117 =cut
118
119 sub targetable {
120   my $self = shift;
121   return $self->{targetable} if exists $self->{targetable};
122
123   our $bal; # ()-balanced
124   $bal = qr[
125     (?:
126       (?>[^()]+)
127       |
128       \( (??{ $bal }) \)
129     )*
130   ]x;
131
132   # matches variations on (SV*)
133   my $sv_cast = qr[
134     (?:
135       \( \s* SV \s* \* \s* \) \s*
136     )?
137   ]x;
138
139   my $size = qr[ # Third arg (to setpvn)
140     , \s* (??{ $bal })
141   ]x;
142
143   my $code = $self->code;
144
145   # We can still bootstrap compile 're', because in code re.pm is
146   # available to miniperl, and does not attempt to load the XS code.
147   use re 'eval';
148
149   my ($type, $with_size, $arg, $sarg) =
150     ($code =~
151       m[^
152         \s+
153         sv_set([iunp])v(n)?    # Type, is_setpvn
154         \s*
155         \( \s*
156           $sv_cast \$arg \s* , \s*
157           ( (??{ $bal }) )    # Set from
158         ( (??{ $size }) )?    # Possible sizeof set-from
159         \) \s* ; \s* $
160       ]x
161   );
162
163   my $rv = undef;
164   if ($type) {
165     $rv = {
166       type      => $type,
167       with_size => $with_size,
168       what      => $arg,
169       what_size => $sarg,
170     };
171   }
172   $self->{targetable} = $rv;
173   return $rv;
174 }
175
176 =head1 SEE ALSO
177
178 L<ExtUtils::Typemaps>
179
180 =head1 AUTHOR
181
182 Steffen Mueller C<<smueller@cpan.org>>
183
184 =head1 COPYRIGHT & LICENSE
185
186 Copyright 2009-2011 Steffen Mueller
187
188 This program is free software; you can redistribute it and/or
189 modify it under the same terms as Perl itself.
190
191 =cut
192
193 1;
194