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.01';
14
15$is_perl56 = ($] < 5.007 && $] > 5.005_50);
16
17=head1 NAME
18
19ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
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
146# Keep to the traditional perl source macro
147sub memEQ {
148  "memEQ";
149}
150
151sub 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
166sub C_constant_prefix_param {
167  "aTHX_ ";
168}
169
170sub C_constant_prefix_param_defintion {
171  "pTHX_ ";
172}
173
174sub namelen_param_definition {
175  'STRLEN ' . $_[0] -> namelen_param;
176}
177
178sub 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
189sub 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
200sub 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
216use ExtUtils::Constant qw (constant_types C_constant XS_constant);
217
218EOT
219  $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
220				 indent=>0, declare_types=>1},
221				@items);
222  $result .= <<'EOT';
223
224print constant_types(); # macro defs
225EOT
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}
242print "#### XS Section:\n";
243print XS_constant ("' . $package . '", $types);
244__END__
245   */
246
247';
248
249  $result;
250}
251
2521;
253