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 # Keep to the traditional perl source macro
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{$_};
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};
166 sub C_constant_prefix_param {
170 sub C_constant_prefix_param_defintion {
174 sub namelen_param_definition {
175 'STRLEN ' . $_[0] -> namelen_param;
178 sub C_constant_other_params_defintion {
179 my ($self, $params) = @_;
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};
189 sub C_constant_other_params {
190 my ($self, $params) = @_;
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};
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.
212 Regenerate these constant functions by feeding this entire source file to
216 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
219 $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
220 indent=>0, declare_types=>1},
224 print constant_types(); # macro defs
226 $package = perl_stringify($package);
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));
239 $result .= ", $breakout" . ', @names) ) {
240 print $_, "\n"; # C constant subs
242 print "#### XS Section:\n";
243 print XS_constant ("' . $package . '", $types);