1 package ExtUtils::Constant::XS;
4 use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
6 use ExtUtils::Constant::Utils 'perl_stringify';
7 require ExtUtils::Constant::Base;
10 @ISA = qw(ExtUtils::Constant::Base Exporter);
11 @EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
15 $is_perl56 = ($] < 5.007 && $] > 5.005_50);
19 ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
23 require ExtUtils::Constant::XS;
27 ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
28 code for XS modules' constants.
32 Nothing is documented.
38 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
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.
48 UV => 'PUSHu((UV)iv)',
50 PV => 'PUSHp(pv, strlen(pv))',
51 PVN => 'PUSHp(pv, iv)',
53 YES => 'PUSHs(&PL_sv_yes)',
54 NO => 'PUSHs(&PL_sv_no)',
55 UNDEF => '', # implicit undef
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 = ',
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) {
77 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
79 push @lines, << 'EOT';
82 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
85 #define aTHX_ /* 5.6 or later define this for threading support. */
88 #define pTHX_ /* 5.6 or later define this for threading support. */
92 return join '', @lines;
96 my ($self, $type) = @_;
97 return exists $XS_TypeSet{$type};
100 # This might actually be a return statement
101 sub assignment_clause_for_type {
104 my $type = $args->{type};
105 my $typeset = $XS_TypeSet{$type};
107 die "Type $type is aggregate, but only single value given"
109 return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
110 } elsif (defined $typeset) {
111 confess "Aggregate value given for type $type"
113 return "$typeset$_[0];";
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;";
125 sub return_statement_for_notdef {
127 "return PERL_constant_NOTDEF;";
130 sub return_statement_for_notfound {
132 "return PERL_constant_NOTFOUND;";
139 sub macro_from_name {
140 my ($self, $item) = @_;
141 my $macro = $item->{name};
142 $macro = $item->{value} unless defined $macro;
146 sub macro_from_item {
147 my ($self, $item) = @_;
148 my $macro = $item->{macro};
149 $macro = $self->macro_from_name($item) unless defined $macro;
153 # Keep to the traditional perl source macro
159 my ($self, $what) = @_;
160 foreach (sort keys %$what) {
161 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
164 $params->{''} = 1 if $what->{''};
165 $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
166 $params->{NV} = 1 if $what->{NV};
167 $params->{PV} = 1 if $what->{PV} || $what->{PVN};
168 $params->{SV} = 1 if $what->{SV};
173 sub C_constant_prefix_param {
177 sub C_constant_prefix_param_defintion {
181 sub namelen_param_definition {
182 'STRLEN ' . $_[0] -> namelen_param;
185 sub C_constant_other_params_defintion {
186 my ($self, $params) = @_;
188 $body .= ", int utf8" if $params->{''};
189 $body .= ", IV *iv_return" if $params->{IV};
190 $body .= ", NV *nv_return" if $params->{NV};
191 $body .= ", const char **pv_return" if $params->{PV};
192 $body .= ", SV **sv_return" if $params->{SV};
196 sub C_constant_other_params {
197 my ($self, $params) = @_;
199 $body .= ", utf8" if $params->{''};
200 $body .= ", iv_return" if $params->{IV};
201 $body .= ", nv_return" if $params->{NV};
202 $body .= ", pv_return" if $params->{PV};
203 $body .= ", sv_return" if $params->{SV};
208 my ($self, $args, @items) = @_;
209 my ($package, $subname, $default_type, $what, $indent, $breakout) =
210 @{$args}{qw(package subname default_type what indent breakout)};
211 my $result = <<"EOT";
212 /* When generated this function returned values for the list of names given
213 in this section of perl code. Rather than manually editing these functions
214 to add or remove constants, which would result in this comment and section
215 of code becoming inaccurate, we recommend that you edit this section of
216 code, and use it to regenerate a new set of constant functions which you
217 then use to replace the originals.
219 Regenerate these constant functions by feeding this entire source file to
223 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
226 $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
227 indent=>0, declare_types=>1},
231 print constant_types(), "\n"; # macro defs
233 $package = perl_stringify($package);
235 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
236 # The form of the indent parameter isn't defined. (Yet)
237 if (defined $indent) {
238 require Data::Dumper;
239 $Data::Dumper::Terse=1;
240 $Data::Dumper::Terse=1; # Not used once. :-)
241 chomp ($indent = Data::Dumper::Dumper ($indent));
246 $result .= ", $breakout" . ', @names) ) {
247 print $_, "\n"; # C constant subs
249 print "\n#### XS Section:\n";
250 print XS_constant ("' . $package . '", $types);