This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add method macro_from_item to encapsulate the entire logic for getting
[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 sub 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
154 sub memEQ {
155   "memEQ";
156 }
157
158 sub 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
173 sub C_constant_prefix_param {
174   "aTHX_ ";
175 }
176
177 sub C_constant_prefix_param_defintion {
178   "pTHX_ ";
179 }
180
181 sub namelen_param_definition {
182   'STRLEN ' . $_[0] -> namelen_param;
183 }
184
185 sub 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
196 sub 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
207 sub 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
223 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
224
225 EOT
226   $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
227                                  indent=>0, declare_types=>1},
228                                 @items);
229   $result .= <<'EOT';
230
231 print constant_types(), "\n"; # macro defs
232 EOT
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 }
249 print "\n#### XS Section:\n";
250 print XS_constant ("' . $package . '", $types);
251 __END__
252    */
253
254 ';
255
256   $result;
257 }
258
259 1;