1package ExtUtils::Constant::XS;
2
3use strict;
4use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
5use Carp;
6use ExtUtils::Constant::Utils 'perl_stringify';
7require ExtUtils::Constant::Base;
8
9
10@ISA = qw(ExtUtils::Constant::Base Exporter);
11@EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
12
13$VERSION = '0.03';
14
15$is_perl56 = ($] < 5.007 && $] > 5.005_50);
16
17=head1 NAME
18
19ExtUtils::Constant::XS - generate C code for XS modules' constants.
20
21=head1 SYNOPSIS
22
23    require ExtUtils::Constant::XS;
24
25=head1 DESCRIPTION
26
27ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
28code for XS modules' constants.
29
30=head1 BUGS
31
32Nothing is documented.
33
34Probably others.
35
36=head1 AUTHOR
37
38Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
39others
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
70sub 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
82typedef 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
90EOT
91
92  return join '', @lines;
93}
94
95sub valid_type {
96  my ($self, $type) = @_;
97  return exists $XS_TypeSet{$type};
98}
99
100# This might actually be a return statement
101sub 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
118sub 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
125sub return_statement_for_notdef {
126  # my ($self) = @_;
127  "return PERL_constant_NOTDEF;";
128}
129
130sub return_statement_for_notfound {
131  # my ($self) = @_;
132  "return PERL_constant_NOTFOUND;";
133}
134
135sub default_type {
136  'IV';
137}
138
139sub macro_from_name {
140  my ($self, $item) = @_;
141  my $macro = $item->{name};
142  $macro = $item->{value} unless defined $macro;
143  $macro;
144}
145
146sub macro_from_item {
147  my ($self, $item) = @_;
148  my $macro = $item->{macro};
149  $macro = $self->macro_from_name($item) unless defined $macro;
150  $macro;
151}
152
153# Keep to the traditional perl source macro
154sub memEQ {
155  "memEQ";
156}
157
158sub params {
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{$_};
162  }
163  my $params = {};
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};
169  return $params;
170}
171
172
173sub C_constant_prefix_param {
174  "aTHX_ ";
175}
176
177sub C_constant_prefix_param_defintion {
178  "pTHX_ ";
179}
180
181sub namelen_param_definition {
182  'STRLEN ' . $_[0] -> namelen_param;
183}
184
185sub C_constant_other_params_defintion {
186  my ($self, $params) = @_;
187  my $body = '';
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};
193  $body;
194}
195
196sub C_constant_other_params {
197  my ($self, $params) = @_;
198  my $body = '';
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};
204  $body;
205}
206
207sub dogfood {
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.
218
219     Regenerate these constant functions by feeding this entire source file to
220     perl -x
221
222#!$^X -w
223use ExtUtils::Constant qw (constant_types C_constant XS_constant);
224
225EOT
226  $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
227				 indent=>0, declare_types=>1},
228				@items);
229  $result .= <<'EOT';
230
231print constant_types(), "\n"; # macro defs
232EOT
233  $package = perl_stringify($package);
234  $result .=
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));
242    $result .= $indent;
243  } else {
244    $result .= 'undef';
245  }
246  $result .= ", $breakout" . ', @names) ) {
247    print $_, "\n"; # C constant subs
248}
249print "\n#### XS Section:\n";
250print XS_constant ("' . $package . '", $types);
251__END__
252   */
253
254';
255
256  $result;
257}
258
2591;
260