Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | package ExtUtils::Constant::XS; |
2 | ||
3 | use strict; | |
4 | use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56); | |
5 | use Carp; | |
6 | use ExtUtils::Constant::Utils 'perl_stringify'; | |
7 | require ExtUtils::Constant::Base; | |
8 | ||
9 | ||
10 | @ISA = qw(ExtUtils::Constant::Base Exporter); | |
11 | @EXPORT_OK = qw(%XS_Constant %XS_TypeSet); | |
12 | ||
13 | $VERSION = '0.01'; | |
14 | ||
15 | $is_perl56 = ($] < 5.007 && $] > 5.005_50); | |
16 | ||
17 | =head1 NAME | |
18 | ||
19 | ExtUtils::Constant::Base - base class for ExtUtils::Constant objects | |
20 | ||
21 | =head1 SYNOPSIS | |
22 | ||
23 | require ExtUtils::Constant::XS; | |
24 | ||
25 | =head1 DESCRIPTION | |
26 | ||
27 | ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C | |
28 | code for XS modules' constants. | |
29 | ||
30 | =head1 BUGS | |
31 | ||
32 | Nothing is documented. | |
33 | ||
34 | Probably others. | |
35 | ||
36 | =head1 AUTHOR | |
37 | ||
38 | Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and | |
39 | others | |
40 | ||
41 | =cut | |
42 | ||
43 | # '' is used as a flag to indicate non-ascii macro names, and hence the need | |
44 | # to pass in the utf8 on/off flag. | |
45 | %XS_Constant = ( | |
46 | '' => '', | |
47 | IV => 'PUSHi(iv)', | |
48 | UV => 'PUSHu((UV)iv)', | |
49 | NV => 'PUSHn(nv)', | |
50 | PV => 'PUSHp(pv, strlen(pv))', | |
51 | PVN => 'PUSHp(pv, iv)', | |
52 | SV => 'PUSHs(sv)', | |
53 | YES => 'PUSHs(&PL_sv_yes)', | |
54 | NO => 'PUSHs(&PL_sv_no)', | |
55 | UNDEF => '', # implicit undef | |
56 | ); | |
57 | ||
58 | %XS_TypeSet = ( | |
59 | IV => '*iv_return = ', | |
60 | UV => '*iv_return = (IV)', | |
61 | NV => '*nv_return = ', | |
62 | PV => '*pv_return = ', | |
63 | PVN => ['*pv_return = ', '*iv_return = (IV)'], | |
64 | SV => '*sv_return = ', | |
65 | YES => undef, | |
66 | NO => undef, | |
67 | UNDEF => undef, | |
68 | ); | |
69 | ||
70 | sub header { | |
71 | my $start = 1; | |
72 | my @lines; | |
73 | push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; | |
74 | push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; | |
75 | foreach (sort keys %XS_Constant) { | |
76 | next if $_ eq ''; | |
77 | push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; | |
78 | } | |
79 | push @lines, << 'EOT'; | |
80 | ||
81 | #ifndef NVTYPE | |
82 | typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ | |
83 | #endif | |
84 | #ifndef aTHX_ | |
85 | #define aTHX_ /* 5.6 or later define this for threading support. */ | |
86 | #endif | |
87 | #ifndef pTHX_ | |
88 | #define pTHX_ /* 5.6 or later define this for threading support. */ | |
89 | #endif | |
90 | EOT | |
91 | ||
92 | return join '', @lines; | |
93 | } | |
94 | ||
95 | sub valid_type { | |
96 | my ($self, $type) = @_; | |
97 | return exists $XS_TypeSet{$type}; | |
98 | } | |
99 | ||
100 | # This might actually be a return statement | |
101 | sub assignment_clause_for_type { | |
102 | my $self = shift; | |
103 | my $args = shift; | |
104 | my $type = $args->{type}; | |
105 | my $typeset = $XS_TypeSet{$type}; | |
106 | if (ref $typeset) { | |
107 | die "Type $type is aggregate, but only single value given" | |
108 | if @_ == 1; | |
109 | return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset; | |
110 | } elsif (defined $typeset) { | |
111 | confess "Aggregate value given for type $type" | |
112 | if @_ > 1; | |
113 | return "$typeset$_[0];"; | |
114 | } | |
115 | return (); | |
116 | } | |
117 | ||
118 | sub return_statement_for_type { | |
119 | my ($self, $type) = @_; | |
120 | # In the future may pass in an options hash | |
121 | $type = $type->{type} if ref $type; | |
122 | "return PERL_constant_IS$type;"; | |
123 | } | |
124 | ||
125 | sub return_statement_for_notdef { | |
126 | # my ($self) = @_; | |
127 | "return PERL_constant_NOTDEF;"; | |
128 | } | |
129 | ||
130 | sub return_statement_for_notfound { | |
131 | # my ($self) = @_; | |
132 | "return PERL_constant_NOTFOUND;"; | |
133 | } | |
134 | ||
135 | sub default_type { | |
136 | 'IV'; | |
137 | } | |
138 | ||
139 | sub macro_from_name { | |
140 | my ($self, $item) = @_; | |
141 | my $macro = $item->{name}; | |
142 | $macro = $item->{value} unless defined $macro; | |
143 | $macro; | |
144 | } | |
145 | ||
146 | # Keep to the traditional perl source macro | |
147 | sub memEQ { | |
148 | "memEQ"; | |
149 | } | |
150 | ||
151 | sub params { | |
152 | my ($self, $what) = @_; | |
153 | foreach (sort keys %$what) { | |
154 | warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; | |
155 | } | |
156 | my $params = {}; | |
157 | $params->{''} = 1 if $what->{''}; | |
158 | $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; | |
159 | $params->{NV} = 1 if $what->{NV}; | |
160 | $params->{PV} = 1 if $what->{PV} || $what->{PVN}; | |
161 | $params->{SV} = 1 if $what->{SV}; | |
162 | return $params; | |
163 | } | |
164 | ||
165 | ||
166 | sub C_constant_prefix_param { | |
167 | "aTHX_ "; | |
168 | } | |
169 | ||
170 | sub C_constant_prefix_param_defintion { | |
171 | "pTHX_ "; | |
172 | } | |
173 | ||
174 | sub namelen_param_definition { | |
175 | 'STRLEN ' . $_[0] -> namelen_param; | |
176 | } | |
177 | ||
178 | sub C_constant_other_params_defintion { | |
179 | my ($self, $params) = @_; | |
180 | my $body = ''; | |
181 | $body .= ", int utf8" if $params->{''}; | |
182 | $body .= ", IV *iv_return" if $params->{IV}; | |
183 | $body .= ", NV *nv_return" if $params->{NV}; | |
184 | $body .= ", const char **pv_return" if $params->{PV}; | |
185 | $body .= ", SV **sv_return" if $params->{SV}; | |
186 | $body; | |
187 | } | |
188 | ||
189 | sub C_constant_other_params { | |
190 | my ($self, $params) = @_; | |
191 | my $body = ''; | |
192 | $body .= ", utf8" if $params->{''}; | |
193 | $body .= ", iv_return" if $params->{IV}; | |
194 | $body .= ", nv_return" if $params->{NV}; | |
195 | $body .= ", pv_return" if $params->{PV}; | |
196 | $body .= ", sv_return" if $params->{SV}; | |
197 | $body; | |
198 | } | |
199 | ||
200 | sub dogfood { | |
201 | my ($self, $args, @items) = @_; | |
202 | my ($package, $subname, $default_type, $what, $indent, $breakout) = | |
203 | @{$args}{qw(package subname default_type what indent breakout)}; | |
204 | my $result = <<"EOT"; | |
205 | /* When generated this function returned values for the list of names given | |
206 | in this section of perl code. Rather than manually editing these functions | |
207 | to add or remove constants, which would result in this comment and section | |
208 | of code becoming inaccurate, we recommend that you edit this section of | |
209 | code, and use it to regenerate a new set of constant functions which you | |
210 | then use to replace the originals. | |
211 | ||
212 | Regenerate these constant functions by feeding this entire source file to | |
213 | perl -x | |
214 | ||
215 | #!$^X -w | |
216 | use ExtUtils::Constant qw (constant_types C_constant XS_constant); | |
217 | ||
218 | EOT | |
219 | $result .= $self->dump_names ({default_type=>$default_type, what=>$what, | |
220 | indent=>0, declare_types=>1}, | |
221 | @items); | |
222 | $result .= <<'EOT'; | |
223 | ||
224 | print constant_types(); # macro defs | |
225 | EOT | |
226 | $package = perl_stringify($package); | |
227 | $result .= | |
228 | "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; | |
229 | # The form of the indent parameter isn't defined. (Yet) | |
230 | if (defined $indent) { | |
231 | require Data::Dumper; | |
232 | $Data::Dumper::Terse=1; | |
233 | $Data::Dumper::Terse=1; # Not used once. :-) | |
234 | chomp ($indent = Data::Dumper::Dumper ($indent)); | |
235 | $result .= $indent; | |
236 | } else { | |
237 | $result .= 'undef'; | |
238 | } | |
239 | $result .= ", $breakout" . ', @names) ) { | |
240 | print $_, "\n"; # C constant subs | |
241 | } | |
242 | print "#### XS Section:\n"; | |
243 | print XS_constant ("' . $package . '", $types); | |
244 | __END__ | |
245 | */ | |
246 | ||
247 | '; | |
248 | ||
249 | $result; | |
250 | } | |
251 | ||
252 | 1; |