This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c98583a2e1fb567c4ef7d1c2d1435d8f637a3e1f
[perl5.git] / lib / ExtUtils / Constant / XS.pm
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.02';
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(), "\n"; # 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 "\n#### XS Section:\n";
243 print XS_constant ("' . $package . '", $types);
244 __END__
245    */
246
247 ';
248
249   $result;
250 }
251
252 1;