Commit | Line | Data |
---|---|---|
af6c647e | 1 | package ExtUtils::Constant; |
8ac27563 | 2 | use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS); |
d7f97632 | 3 | $VERSION = '0.09'; |
af6c647e NC |
4 | |
5 | =head1 NAME | |
6 | ||
7 | ExtUtils::Constant - generate XS code to import C header constants | |
8 | ||
9 | =head1 SYNOPSIS | |
10 | ||
0552bf3a NC |
11 | use ExtUtils::Constant qw (WriteConstants); |
12 | WriteConstants( | |
13 | NAME => 'Foo', | |
14 | NAMES => [qw(FOO BAR BAZ)], | |
15 | C_FILE => 'constants.c', | |
16 | XS_FILE => 'constants.xs', | |
17 | ); | |
18 | # Generates wrapper code to make the values of the constants FOO BAR BAZ | |
19 | # available to perl | |
af6c647e NC |
20 | |
21 | =head1 DESCRIPTION | |
22 | ||
23 | ExtUtils::Constant facilitates generating C and XS wrapper code to allow | |
24 | perl modules to AUTOLOAD constants defined in C library header files. | |
25 | It is principally used by the C<h2xs> utility, on which this code is based. | |
26 | It doesn't contain the routines to scan header files to extract these | |
27 | constants. | |
28 | ||
29 | =head1 USAGE | |
30 | ||
0552bf3a NC |
31 | Generally one only needs to call the C<WriteConstants> function, and then |
32 | ||
33 | #include "constants.c" | |
34 | ||
35 | in the C section of C<Foo.xs> | |
36 | ||
37 | INCLUDE constants.xs | |
38 | ||
39 | in the XS section of C<Foo.xs>. | |
40 | ||
41 | For greater flexibility use C<constant_types()>, C<C_constant> and | |
42 | C<XS_constant>, with which C<WriteConstants> is implemented. | |
af6c647e NC |
43 | |
44 | Currently this module understands the following types. h2xs may only know | |
45 | a subset. The sizes of the numeric types are chosen by the C<Configure> | |
46 | script at compile time. | |
47 | ||
48 | =over 4 | |
49 | ||
50 | =item IV | |
51 | ||
52 | signed integer, at least 32 bits. | |
53 | ||
54 | =item UV | |
55 | ||
56 | unsigned integer, the same size as I<IV> | |
57 | ||
58 | =item NV | |
59 | ||
60 | floating point type, probably C<double>, possibly C<long double> | |
61 | ||
62 | =item PV | |
63 | ||
64 | NUL terminated string, length will be determined with C<strlen> | |
65 | ||
66 | =item PVN | |
67 | ||
68 | A fixed length thing, given as a [pointer, length] pair. If you know the | |
69 | length of a string at compile time you may use this instead of I<PV> | |
70 | ||
cea00dc5 NC |
71 | =item PVN |
72 | ||
73 | A B<mortal> SV. | |
74 | ||
3414cef0 NC |
75 | =item YES |
76 | ||
77 | Truth. (C<PL_sv_yes>) The value is not needed (and ignored). | |
78 | ||
79 | =item NO | |
80 | ||
81 | Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). | |
82 | ||
83 | =item UNDEF | |
84 | ||
85 | C<undef>. The value of the macro is not needed. | |
86 | ||
af6c647e NC |
87 | =back |
88 | ||
89 | =head1 FUNCTIONS | |
90 | ||
91 | =over 4 | |
92 | ||
93 | =cut | |
94 | ||
d7f97632 NC |
95 | if ($] >= 5.006) { |
96 | eval "use warnings; 1" or die $@; | |
97 | } | |
af6c647e NC |
98 | use strict; |
99 | use Carp; | |
100 | ||
101 | use Exporter; | |
af6c647e NC |
102 | use Text::Wrap; |
103 | $Text::Wrap::huge = 'overflow'; | |
104 | $Text::Wrap::columns = 80; | |
105 | ||
106 | @ISA = 'Exporter'; | |
af6c647e NC |
107 | |
108 | %EXPORT_TAGS = ( 'all' => [ qw( | |
109 | XS_constant constant_types return_clause memEQ_clause C_stringify | |
0552bf3a | 110 | C_constant autoload WriteConstants |
af6c647e NC |
111 | ) ] ); |
112 | ||
113 | @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | |
114 | ||
115 | %XS_Constant = ( | |
cea00dc5 NC |
116 | IV => 'PUSHi(iv)', |
117 | UV => 'PUSHu((UV)iv)', | |
118 | NV => 'PUSHn(nv)', | |
119 | PV => 'PUSHp(pv, strlen(pv))', | |
120 | PVN => 'PUSHp(pv, iv)', | |
121 | SV => 'PUSHs(sv)', | |
122 | YES => 'PUSHs(&PL_sv_yes)', | |
123 | NO => 'PUSHs(&PL_sv_no)', | |
19d75eda | 124 | UNDEF => '', # implicit undef |
af6c647e NC |
125 | ); |
126 | ||
127 | %XS_TypeSet = ( | |
cea00dc5 NC |
128 | IV => '*iv_return =', |
129 | UV => '*iv_return = (IV)', | |
130 | NV => '*nv_return =', | |
131 | PV => '*pv_return =', | |
132 | PVN => ['*pv_return =', '*iv_return = (IV)'], | |
133 | SV => '*sv_return = ', | |
19d75eda JH |
134 | YES => undef, |
135 | NO => undef, | |
136 | UNDEF => undef, | |
af6c647e NC |
137 | ); |
138 | ||
139 | ||
140 | =item C_stringify NAME | |
141 | ||
142 | A function which returns a correctly \ escaped version of the string passed | |
6d79cad2 | 143 | suitable for C's "" or ''. It will also be valid as a perl "" string. |
af6c647e NC |
144 | |
145 | =cut | |
146 | ||
147 | # Hopefully make a happy C identifier. | |
148 | sub C_stringify { | |
149 | local $_ = shift; | |
6d79cad2 | 150 | return unless defined $_; |
af6c647e NC |
151 | s/\\/\\\\/g; |
152 | s/([\"\'])/\\$1/g; # Grr. fix perl mode. | |
6d79cad2 NC |
153 | s/\n/\\n/g; # Ensure newlines don't end up in octal |
154 | s/\r/\\r/g; | |
3414cef0 NC |
155 | s/\t/\\t/g; |
156 | s/\f/\\f/g; | |
157 | s/\a/\\a/g; | |
d7f97632 NC |
158 | unless ($] < 5.006) { |
159 | # This will elict a warning on 5.005_03 about [: :] being reserved unless | |
160 | # I cheat | |
161 | my $cheat = '([[:^print:]])'; | |
162 | s/$cheat/sprintf "\\%03o", ord $1/ge; | |
163 | } else { | |
164 | require POSIX; | |
165 | s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; | |
166 | } | |
af6c647e NC |
167 | $_; |
168 | } | |
169 | ||
170 | =item constant_types | |
171 | ||
172 | A function returning a single scalar with C<#define> definitions for the | |
173 | constants used internally between the generated C and XS functions. | |
174 | ||
175 | =cut | |
176 | ||
177 | sub constant_types () { | |
178 | my $start = 1; | |
179 | my @lines; | |
180 | push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; | |
181 | push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; | |
182 | foreach (sort keys %XS_Constant) { | |
183 | push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; | |
184 | } | |
185 | push @lines, << 'EOT'; | |
186 | ||
187 | #ifndef NVTYPE | |
188 | typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ | |
189 | #endif | |
d7f97632 NC |
190 | #ifndef aTHX_ |
191 | #define aTHX_ /* 5.6 or later define this for threading support. */ | |
192 | #endif | |
193 | #ifndef pTHX_ | |
194 | #define pTHX_ /* 5.6 or later define this for threading support. */ | |
195 | #endif | |
af6c647e NC |
196 | EOT |
197 | ||
198 | return join '', @lines; | |
199 | } | |
200 | ||
201 | =item memEQ_clause NAME, CHECKED_AT, INDENT | |
202 | ||
203 | A function to return a suitable C C<if> statement to check whether I<NAME> | |
204 | is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it | |
205 | is used to avoid C<memEQ> for short names, or to generate a comment to | |
206 | highlight the position of the character in the C<switch> statement. | |
207 | ||
208 | =cut | |
209 | ||
210 | sub memEQ_clause { | |
211 | # if (memEQ(name, "thingy", 6)) { | |
212 | # Which could actually be a character comparison or even "" | |
213 | my ($name, $checked_at, $indent) = @_; | |
214 | $indent = ' ' x ($indent || 4); | |
215 | my $len = length $name; | |
216 | ||
217 | if ($len < 2) { | |
218 | return $indent . "{\n" if (defined $checked_at and $checked_at == 0); | |
219 | # We didn't switch, drop through to the code for the 2 character string | |
220 | $checked_at = 1; | |
221 | } | |
222 | if ($len < 3 and defined $checked_at) { | |
223 | my $check; | |
224 | if ($checked_at == 1) { | |
225 | $check = 0; | |
226 | } elsif ($checked_at == 0) { | |
227 | $check = 1; | |
228 | } | |
229 | if (defined $check) { | |
230 | my $char = C_stringify (substr $name, $check, 1); | |
231 | return $indent . "if (name[$check] == '$char') {\n"; | |
232 | } | |
233 | } | |
234 | # Could optimise a memEQ on 3 to 2 single character checks here | |
235 | $name = C_stringify ($name); | |
236 | my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n"; | |
237 | $body .= $indent . "/* ". (' ' x $checked_at) . '^' | |
238 | . (' ' x ($len - $checked_at + length $len)) . " */\n" | |
239 | if defined $checked_at; | |
240 | return $body; | |
241 | } | |
242 | ||
cea00dc5 | 243 | =item assign INDENT, TYPE, PRE, POST, VALUE... |
6d79cad2 NC |
244 | |
245 | A function to return a suitable assignment clause. If I<TYPE> is aggregate | |
246 | (eg I<PVN> expects both pointer and length) then there should be multiple | |
cea00dc5 NC |
247 | I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets |
248 | of C code to preceed and follow the assignment. I<PRE> will be at the start | |
249 | of a block, so variables may be defined in it. | |
6d79cad2 NC |
250 | |
251 | =cut | |
252 | ||
253 | # Hmm. value undef to to NOTDEF? value () to do NOTFOUND? | |
254 | ||
255 | sub assign { | |
256 | my $indent = shift; | |
257 | my $type = shift; | |
cea00dc5 NC |
258 | my $pre = shift; |
259 | my $post = shift || ''; | |
6d79cad2 | 260 | my $clause; |
cea00dc5 NC |
261 | my $close; |
262 | if ($pre) { | |
263 | chomp $pre; | |
264 | $clause = $indent . "{\n$pre"; | |
265 | $clause .= ";" unless $pre =~ /;$/; | |
266 | $clause .= "\n"; | |
267 | $close = "$indent}\n"; | |
268 | $indent .= " "; | |
269 | } | |
3414cef0 NC |
270 | die "Can't generate code for type $type" unless exists $XS_TypeSet{$type}; |
271 | my $typeset = $XS_TypeSet{$type}; | |
6d79cad2 NC |
272 | if (ref $typeset) { |
273 | die "Type $type is aggregate, but only single value given" | |
274 | if @_ == 1; | |
275 | foreach (0 .. $#$typeset) { | |
276 | $clause .= $indent . "$typeset->[$_] $_[$_];\n"; | |
277 | } | |
3414cef0 | 278 | } elsif (defined $typeset) { |
6d79cad2 NC |
279 | die "Aggregate value given for type $type" |
280 | if @_ > 1; | |
281 | $clause .= $indent . "$typeset $_[0];\n"; | |
282 | } | |
cea00dc5 NC |
283 | chomp $post; |
284 | if (length $post) { | |
285 | $clause .= "$post"; | |
286 | $clause .= ";" unless $post =~ /;$/; | |
287 | $clause .= "\n"; | |
a2c454fa | 288 | } |
6d79cad2 | 289 | $clause .= "${indent}return PERL_constant_IS$type;\n"; |
cea00dc5 | 290 | $clause .= $close if $close; |
6d79cad2 NC |
291 | return $clause; |
292 | } | |
293 | ||
5dc6f178 JH |
294 | =item return_clause |
295 | ||
296 | return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST | |
af6c647e NC |
297 | |
298 | A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to | |
6d79cad2 | 299 | I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both |
af6c647e | 300 | pointer and length) then I<VALUE> should be a reference to an array of |
6d79cad2 NC |
301 | values in the order expected by the type. C<C_constant> will always call |
302 | this function with I<MACRO> defined, defaulting to the constant's name. | |
303 | I<DEFAULT> if defined is an array reference giving default type and and | |
304 | value(s) if the clause generated by I<MACRO> doesn't evaluate to true. | |
cea00dc5 NC |
305 | The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed |
306 | and follow the value, and the default value. | |
af6c647e NC |
307 | |
308 | =cut | |
309 | ||
cea00dc5 | 310 | sub return_clause ($$$$$$$$$) { |
af6c647e NC |
311 | ##ifdef thingy |
312 | # *iv_return = thingy; | |
313 | # return PERL_constant_ISIV; | |
314 | ##else | |
315 | # return PERL_constant_NOTDEF; | |
316 | ##endif | |
cea00dc5 NC |
317 | my ($value, $type, $indent, $macro, $default, $pre, $post, |
318 | $def_pre, $def_post) = @_; | |
af6c647e NC |
319 | $macro = $value unless defined $macro; |
320 | $indent = ' ' x ($indent || 6); | |
321 | ||
6d79cad2 | 322 | my $clause; |
af6c647e | 323 | |
6d79cad2 NC |
324 | ##ifdef thingy |
325 | if (ref $macro) { | |
326 | $clause = $macro->[0]; | |
72f7b9a1 | 327 | } elsif ($macro ne "1") { |
6d79cad2 | 328 | $clause = "#ifdef $macro\n"; |
af6c647e | 329 | } |
6d79cad2 NC |
330 | |
331 | # *iv_return = thingy; | |
332 | # return PERL_constant_ISIV; | |
cea00dc5 NC |
333 | $clause .= assign ($indent, $type, $pre, $post, |
334 | ref $value ? @$value : $value); | |
6d79cad2 | 335 | |
72f7b9a1 NC |
336 | if (ref $macro or $macro ne "1") { |
337 | ##else | |
338 | $clause .= "#else\n"; | |
a2c454fa | 339 | |
72f7b9a1 NC |
340 | # return PERL_constant_NOTDEF; |
341 | if (!defined $default) { | |
342 | $clause .= "${indent}return PERL_constant_NOTDEF;\n"; | |
343 | } else { | |
344 | my @default = ref $default ? @$default : $default; | |
345 | $type = shift @default; | |
346 | $clause .= assign ($indent, $type, $def_pre, $def_post, @default); | |
347 | } | |
6d79cad2 | 348 | |
72f7b9a1 NC |
349 | ##endif |
350 | if (ref $macro) { | |
351 | $clause .= $macro->[1]; | |
352 | } else { | |
353 | $clause .= "#endif\n"; | |
354 | } | |
6d79cad2 NC |
355 | } |
356 | return $clause | |
af6c647e NC |
357 | } |
358 | ||
8ac27563 NC |
359 | =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM... |
360 | ||
361 | An internal function to generate a suitable C<switch> clause, called by | |
362 | C<C_constant> I<ITEM>s are in the hash ref format as given in the description | |
363 | of C<C_constant>, and must all have the names of the same length, given by | |
364 | I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash, | |
365 | keyed by name, values being the hashrefs in the I<ITEM> list. | |
366 | (No parameters are modified, and there can be keys in the I<ITEMHASH> that | |
367 | are not in the list of I<ITEM>s without causing problems). | |
368 | ||
369 | =cut | |
370 | ||
371 | sub switch_clause { | |
372 | my ($indent, $comment, $namelen, $items, @items) = @_; | |
373 | $indent = ' ' x ($indent || 2); | |
a2c454fa | 374 | |
8ac27563 NC |
375 | my @names = sort map {$_->{name}} @items; |
376 | my $leader = $indent . '/* '; | |
377 | my $follower = ' ' x length $leader; | |
378 | my $body = $indent . "/* Names all of length $namelen. */\n"; | |
379 | if ($comment) { | |
380 | $body = wrap ($leader, $follower, $comment) . "\n"; | |
381 | $leader = $follower; | |
382 | } | |
383 | $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n"; | |
384 | # Figure out what to switch on. | |
385 | # (RMS, Spread of jump table, Position, Hashref) | |
386 | my @best = (1e38, ~0); | |
387 | foreach my $i (0 .. ($namelen - 1)) { | |
388 | my ($min, $max) = (~0, 0); | |
389 | my %spread; | |
390 | foreach (@names) { | |
391 | my $char = substr $_, $i, 1; | |
392 | my $ord = ord $char; | |
a2c454fa | 393 | $max = $ord if $ord > $max; |
8ac27563 NC |
394 | $min = $ord if $ord < $min; |
395 | push @{$spread{$char}}, $_; | |
396 | # warn "$_ $char"; | |
397 | } | |
398 | # I'm going to pick the character to split on that minimises the root | |
399 | # mean square of the number of names in each case. Normally this should | |
400 | # be the one with the most keys, but it may pick a 7 where the 8 has | |
401 | # one long linear search. I'm not sure if RMS or just sum of squares is | |
402 | # actually better. | |
403 | # $max and $min are for the tie-breaker if the root mean squares match. | |
404 | # Assuming that the compiler may be building a jump table for the | |
405 | # switch() then try to minimise the size of that jump table. | |
406 | # Finally use < not <= so that if it still ties the earliest part of | |
407 | # the string wins. Because if that passes but the memEQ fails, it may | |
408 | # only need the start of the string to bin the choice. | |
409 | # I think. But I'm micro-optimising. :-) | |
410 | my $ss; | |
411 | $ss += @$_ * @$_ foreach values %spread; | |
412 | my $rms = sqrt ($ss / keys %spread); | |
413 | if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { | |
414 | @best = ($rms, $max - $min, $i, \%spread); | |
415 | } | |
416 | } | |
417 | die "Internal error. Failed to pick a switch point for @names" | |
418 | unless defined $best[2]; | |
419 | # use Data::Dumper; print Dumper (@best); | |
420 | my ($offset, $best) = @best[2,3]; | |
421 | $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; | |
422 | $body .= $indent . "switch (name[$offset]) {\n"; | |
423 | foreach my $char (sort keys %$best) { | |
424 | $body .= $indent . "case '" . C_stringify ($char) . "':\n"; | |
425 | foreach my $name (sort @{$best->{$char}}) { | |
426 | my $thisone = $items->{$name}; | |
cea00dc5 NC |
427 | my ($value, $macro, $default, $pre, $post, $def_pre, $def_post) |
428 | = @$thisone{qw (value macro default pre post def_pre def_post)}; | |
8ac27563 NC |
429 | $value = $name unless defined $value; |
430 | $macro = $name unless defined $macro; | |
431 | ||
432 | # We have checked this offset. | |
433 | $body .= memEQ_clause ($name, $offset, 2 + length $indent); | |
434 | $body .= return_clause ($value, $thisone->{type}, 4 + length $indent, | |
cea00dc5 NC |
435 | $macro, $default, $pre, $post, |
436 | $def_pre, $def_post); | |
8ac27563 NC |
437 | $body .= $indent . " }\n"; |
438 | } | |
439 | $body .= $indent . " break;\n"; | |
440 | } | |
441 | $body .= $indent . "}\n"; | |
442 | return $body; | |
443 | } | |
444 | ||
af6c647e NC |
445 | =item params WHAT |
446 | ||
447 | An internal function. I<WHAT> should be a hashref of types the constant | |
72f7b9a1 NC |
448 | function will return. I<params> returns a hashref keyed IV NV PV SV to show |
449 | which combination of pointers will be needed in the C argument list. | |
af6c647e NC |
450 | |
451 | =cut | |
452 | ||
453 | sub params { | |
454 | my $what = shift; | |
455 | foreach (sort keys %$what) { | |
456 | warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; | |
457 | } | |
72f7b9a1 NC |
458 | my $params = {}; |
459 | $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; | |
460 | $params->{NV} = 1 if $what->{NV}; | |
461 | $params->{PV} = 1 if $what->{PV} || $what->{PVN}; | |
462 | $params->{SV} = 1 if $what->{SV}; | |
463 | return $params; | |
af6c647e NC |
464 | } |
465 | ||
a2c454fa | 466 | =item dump_names |
0addb26a | 467 | |
8ac27563 | 468 | dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... |
6d79cad2 NC |
469 | |
470 | An internal function to generate the embedded perl code that will regenerate | |
8ac27563 | 471 | the constant subroutines. Parameters are the same as for C_constant. |
6d79cad2 NC |
472 | |
473 | =cut | |
474 | ||
475 | sub dump_names { | |
8ac27563 NC |
476 | my ($package, $subname, $default_type, $what, $indent, $breakout, @items) |
477 | = @_; | |
6d79cad2 NC |
478 | my (@simple, @complex); |
479 | foreach (@items) { | |
480 | my $type = $_->{type} || $default_type; | |
481 | if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c) | |
482 | and !defined ($_->{macro}) and !defined ($_->{value}) | |
cea00dc5 NC |
483 | and !defined ($_->{default}) and !defined ($_->{pre}) |
484 | and !defined ($_->{post}) and !defined ($_->{def_pre}) | |
485 | and !defined ($_->{def_post})) { | |
6d79cad2 NC |
486 | # It's the default type, and the name consists only of A-Za-z0-9_ |
487 | push @simple, $_->{name}; | |
488 | } else { | |
489 | push @complex, $_; | |
490 | } | |
491 | } | |
492 | my $result = <<"EOT"; | |
493 | /* When generated this function returned values for the list of names given | |
494 | in this section of perl code. Rather than manually editing these functions | |
495 | to add or remove constants, which would result in this comment and section | |
496 | of code becoming inaccurate, we recommend that you edit this section of | |
497 | code, and use it to regenerate a new set of constant functions which you | |
498 | then use to replace the originals. | |
499 | ||
500 | Regenerate these constant functions by feeding this entire source file to | |
501 | perl -x | |
502 | ||
503 | #!$^X -w | |
504 | use ExtUtils::Constant qw (constant_types C_constant XS_constant); | |
505 | ||
506 | EOT | |
8ac27563 NC |
507 | $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what) |
508 | . ")};\n"; | |
6d79cad2 NC |
509 | $result .= wrap ("my \@names = (qw(", |
510 | " ", join (" ", sort @simple) . ")"); | |
511 | if (@complex) { | |
512 | foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { | |
513 | my $name = C_stringify $item->{name}; | |
6d79cad2 NC |
514 | my $line = ",\n {name=>\"$name\""; |
515 | $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; | |
cea00dc5 NC |
516 | foreach my $thing (qw (macro value default pre post def_pre def_post)) { |
517 | my $value = $item->{$thing}; | |
518 | if (defined $value) { | |
519 | if (ref $value) { | |
520 | $line .= ", $thing=>[\"" | |
521 | . join ('", "', map {C_stringify $_} @$value) . '"]'; | |
522 | } else { | |
523 | $line .= ", $thing=>\"" . C_stringify($value) . "\""; | |
524 | } | |
6d79cad2 NC |
525 | } |
526 | } | |
527 | $line .= "}"; | |
528 | # Ensure that the enclosing C comment doesn't end | |
529 | # by turning */ into *" . "/ | |
530 | $line =~ s!\*\/!\*" . "/!gs; | |
3414cef0 NC |
531 | # gcc -Wall doesn't like finding /* inside a comment |
532 | $line =~ s!\/\*!/" . "\*!gs; | |
6d79cad2 NC |
533 | $result .= $line; |
534 | } | |
535 | } | |
536 | $result .= ");\n"; | |
537 | ||
538 | $result .= <<'EOT'; | |
539 | ||
540 | print constant_types(); # macro defs | |
541 | EOT | |
542 | $package = C_stringify($package); | |
543 | $result .= | |
544 | "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; | |
545 | # The form of the indent parameter isn't defined. (Yet) | |
546 | if (defined $indent) { | |
547 | require Data::Dumper; | |
548 | $Data::Dumper::Terse=1; | |
8ac27563 | 549 | $Data::Dumper::Terse=1; # Not used once. :-) |
6d79cad2 NC |
550 | chomp ($indent = Data::Dumper::Dumper ($indent)); |
551 | $result .= $indent; | |
552 | } else { | |
553 | $result .= 'undef'; | |
554 | } | |
8ac27563 | 555 | $result .= ", $breakout" . ', @names) ) { |
6d79cad2 NC |
556 | print $_, "\n"; # C constant subs |
557 | } | |
558 | print "#### XS Section:\n"; | |
559 | print XS_constant ("' . $package . '", $types); | |
560 | __END__ | |
561 | */ | |
562 | ||
563 | '; | |
a2c454fa | 564 | |
6d79cad2 NC |
565 | $result; |
566 | } | |
567 | ||
a2c454fa | 568 | =item C_constant |
0addb26a | 569 | |
8ac27563 | 570 | C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... |
af6c647e NC |
571 | |
572 | A function that returns a B<list> of C subroutine definitions that return | |
573 | the value and type of constants when passed the name by the XS wrapper. | |
574 | I<ITEM...> gives a list of constant names. Each can either be a string, | |
575 | which is taken as a C macro name, or a reference to a hash with the following | |
576 | keys | |
577 | ||
578 | =over 8 | |
579 | ||
580 | =item name | |
581 | ||
582 | The name of the constant, as seen by the perl code. | |
583 | ||
584 | =item type | |
585 | ||
586 | The type of the constant (I<IV>, I<NV> etc) | |
587 | ||
588 | =item value | |
589 | ||
590 | A C expression for the value of the constant, or a list of C expressions if | |
591 | the type is aggregate. This defaults to the I<name> if not given. | |
592 | ||
593 | =item macro | |
594 | ||
595 | The C pre-processor macro to use in the C<#ifdef>. This defaults to the | |
6d79cad2 NC |
596 | I<name>, and is mainly used if I<value> is an C<enum>. If a reference an |
597 | array is passed then the first element is used in place of the C<#ifdef> | |
598 | line, and the second element in place of the C<#endif>. This allows | |
599 | pre-processor constructions such as | |
600 | ||
601 | #if defined (foo) | |
602 | #if !defined (bar) | |
603 | ... | |
604 | #endif | |
605 | #endif | |
606 | ||
607 | to be used to determine if a constant is to be defined. | |
608 | ||
72f7b9a1 NC |
609 | A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> |
610 | test is omitted. | |
611 | ||
6d79cad2 NC |
612 | =item default |
613 | ||
614 | Default value to use (instead of C<croak>ing with "your vendor has not | |
615 | defined...") to return if the macro isn't defined. Specify a reference to | |
616 | an array with type followed by value(s). | |
af6c647e | 617 | |
cea00dc5 NC |
618 | =item pre |
619 | ||
620 | C code to use before the assignment of the value of the constant. This allows | |
621 | you to use temporary variables to extract a value from part of a C<struct> | |
622 | and return this as I<value>. This C code is places at the start of a block, | |
623 | so you can declare variables in it. | |
624 | ||
625 | =item post | |
626 | ||
627 | C code to place between the assignment of value (to a temporary) and the | |
628 | return from the function. This allows you to clear up anything in I<pre>. | |
629 | Rarely needed. | |
630 | ||
631 | =item def_pre | |
632 | =item def_post | |
633 | ||
634 | Equivalents of I<pre> and I<post> for the default value. | |
635 | ||
af6c647e NC |
636 | =back |
637 | ||
6d79cad2 NC |
638 | I<PACKAGE> is the name of the package, and is only used in comments inside the |
639 | generated C code. | |
640 | ||
641 | The next 5 arguments can safely be given as C<undef>, and are mainly used | |
af6c647e NC |
642 | for recursion. I<SUBNAME> defaults to C<constant> if undefined. |
643 | ||
644 | I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their | |
645 | type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma | |
646 | separated list of types that the C subroutine C<constant> will generate or as | |
647 | a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not | |
648 | present, as will any types given in the list of I<ITEM>s. The resultant list | |
649 | should be the same list of types that C<XS_constant> is given. [Otherwise | |
650 | C<XS_constant> and C<C_constant> may differ in the number of parameters to the | |
651 | constant function. I<INDENT> is currently unused and ignored. In future it may | |
652 | be used to pass in information used to change the C indentation style used.] | |
653 | The best way to maintain consistency is to pass in a hash reference and let | |
654 | this function update it. | |
655 | ||
8ac27563 NC |
656 | I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there |
657 | are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code | |
658 | to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for | |
659 | example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is | |
660 | 3. A single C<ITEM> is always inlined. | |
af6c647e NC |
661 | |
662 | =cut | |
663 | ||
8ac27563 NC |
664 | # The parameter now BREAKOUT was previously documented as: |
665 | # | |
666 | # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of | |
667 | # this length, and that the constant name passed in by perl is checked and | |
668 | # also of this length. It is used during recursion, and should be C<undef> | |
669 | # unless the caller has checked all the lengths during code generation, and | |
670 | # the generated subroutine is only to be called with a name of this length. | |
671 | # | |
672 | # As you can see it now performs this function during recursion by being a | |
673 | # scalar reference. | |
674 | ||
af6c647e | 675 | sub C_constant { |
8ac27563 NC |
676 | my ($package, $subname, $default_type, $what, $indent, $breakout, @items) |
677 | = @_; | |
6d79cad2 | 678 | $package ||= 'Foo'; |
af6c647e NC |
679 | $subname ||= 'constant'; |
680 | # I'm not using this. But a hashref could be used for full formatting without | |
681 | # breaking this API | |
6d79cad2 | 682 | # $indent ||= 0; |
72f7b9a1 NC |
683 | |
684 | my ($namelen, $items); | |
685 | if (ref $breakout) { | |
686 | # We are called recursively. We trust @items to be normalised, $what to | |
687 | # be a hashref, and pinch %$items from our parent to save recalculation. | |
688 | ($namelen, $items) = @$breakout; | |
689 | } else { | |
690 | $breakout ||= 3; | |
691 | $default_type ||= 'IV'; | |
692 | if (!ref $what) { | |
693 | # Convert line of the form IV,UV,NV to hash | |
694 | $what = {map {$_ => 1} split /,\s*/, ($what || '')}; | |
695 | # Figure out what types we're dealing with, and assign all unknowns to the | |
696 | # default type | |
af6c647e | 697 | } |
72f7b9a1 NC |
698 | foreach (@items) { |
699 | my $name; | |
700 | if (ref $_) { | |
701 | my $orig = $_; | |
702 | # Make a copy which is a normalised version of the ref passed in. | |
703 | $name = $_->{name}; | |
704 | my ($type, $macro, $value) = @$_{qw (type macro value)}; | |
705 | $type ||= $default_type; | |
706 | $what->{$type} = 1; | |
707 | $_ = {name=>$name, type=>$type}; | |
708 | ||
709 | undef $macro if defined $macro and $macro eq $name; | |
710 | $_->{macro} = $macro if defined $macro; | |
711 | undef $value if defined $value and $value eq $name; | |
712 | $_->{value} = $value if defined $value; | |
713 | foreach my $key (qw(default pre post def_pre def_post)) { | |
714 | my $value = $orig->{$key}; | |
715 | $_->{$key} = $value if defined $value; | |
716 | # warn "$key $value"; | |
717 | } | |
718 | } else { | |
719 | $name = $_; | |
720 | $_ = {name=>$_, type=>$default_type}; | |
721 | $what->{$default_type} = 1; | |
722 | } | |
723 | warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}}; | |
724 | if (exists $items->{$name}) { | |
725 | die "Multiple definitions for macro $name"; | |
726 | } | |
727 | $items->{$name} = $_; | |
af6c647e | 728 | } |
af6c647e | 729 | } |
72f7b9a1 | 730 | my $params = params ($what); |
af6c647e | 731 | |
a2c454fa | 732 | my ($body, @subs) = "static int\n$subname (pTHX_ const char *name"; |
af6c647e | 733 | $body .= ", STRLEN len" unless defined $namelen; |
72f7b9a1 NC |
734 | $body .= ", IV *iv_return" if $params->{IV}; |
735 | $body .= ", NV *nv_return" if $params->{NV}; | |
736 | $body .= ", const char **pv_return" if $params->{PV}; | |
737 | $body .= ", SV **sv_return" if $params->{SV}; | |
af6c647e NC |
738 | $body .= ") {\n"; |
739 | ||
6d79cad2 NC |
740 | if (defined $namelen) { |
741 | # We are a child subroutine. Print the simple description | |
8ac27563 NC |
742 | my $comment = 'When generated this function returned values for the list' |
743 | . ' of names given here. However, subsequent manual editing may have' | |
744 | . ' added or removed some.'; | |
72f7b9a1 | 745 | $body .= switch_clause (2, $comment, $namelen, $items, @items); |
af6c647e NC |
746 | } else { |
747 | # We are the top level. | |
748 | $body .= " /* Initially switch on the length of the name. */\n"; | |
6d79cad2 | 749 | $body .= dump_names ($package, $subname, $default_type, $what, $indent, |
8ac27563 | 750 | $breakout, @items); |
af6c647e NC |
751 | $body .= " switch (len) {\n"; |
752 | # Need to group names of the same length | |
753 | my @by_length; | |
754 | foreach (@items) { | |
755 | push @{$by_length[length $_->{name}]}, $_; | |
756 | } | |
757 | foreach my $i (0 .. $#by_length) { | |
758 | next unless $by_length[$i]; # None of this length | |
759 | $body .= " case $i:\n"; | |
760 | if (@{$by_length[$i]} == 1) { | |
761 | my $thisone = $by_length[$i]->[0]; | |
cea00dc5 NC |
762 | my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post) |
763 | = @$thisone{qw (name value macro default pre post def_pre def_post)}; | |
af6c647e NC |
764 | $value = $name unless defined $value; |
765 | $macro = $name unless defined $macro; | |
766 | ||
767 | $body .= memEQ_clause ($name); | |
6d79cad2 | 768 | $body .= return_clause ($value, $thisone->{type}, undef, $macro, |
cea00dc5 | 769 | $default, $pre, $post, $def_pre, $def_post); |
af6c647e | 770 | $body .= " }\n"; |
8ac27563 | 771 | } elsif (@{$by_length[$i]} < $breakout) { |
72f7b9a1 | 772 | $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]}); |
af6c647e | 773 | } else { |
72f7b9a1 NC |
774 | # Only use the minimal set of parameters actually needed by the types |
775 | # of the names of this length. | |
776 | my $what = {}; | |
777 | foreach (@{$by_length[$i]}) { | |
778 | $what->{$_->{type}} = 1; | |
779 | } | |
780 | $params = params ($what); | |
781 | push @subs, C_constant ($package, "${subname}_$i", $default_type, $what, | |
782 | $indent, [$i, $items], @{$by_length[$i]}); | |
a2c454fa | 783 | $body .= " return ${subname}_$i (aTHX_ name"; |
72f7b9a1 NC |
784 | $body .= ", iv_return" if $params->{IV}; |
785 | $body .= ", nv_return" if $params->{NV}; | |
786 | $body .= ", pv_return" if $params->{PV}; | |
787 | $body .= ", sv_return" if $params->{SV}; | |
af6c647e NC |
788 | $body .= ");\n"; |
789 | } | |
790 | $body .= " break;\n"; | |
791 | } | |
792 | $body .= " }\n"; | |
793 | } | |
794 | $body .= " return PERL_constant_NOTFOUND;\n}\n"; | |
795 | return (@subs, $body); | |
796 | } | |
797 | ||
798 | =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME | |
799 | ||
800 | A function to generate the XS code to implement the perl subroutine | |
801 | I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. | |
802 | This XS code is a wrapper around a C subroutine usually generated by | |
803 | C<C_constant>, and usually named C<constant>. | |
804 | ||
805 | I<TYPES> should be given either as a comma separated list of types that the | |
806 | C subroutine C<constant> will generate or as a reference to a hash. It should | |
807 | be the same list of types as C<C_constant> was given. | |
808 | [Otherwise C<XS_constant> and C<C_constant> may have different ideas about | |
809 | the number of parameters passed to the C function C<constant>] | |
810 | ||
811 | You can call the perl visible subroutine something other than C<constant> if | |
812 | you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the | |
813 | the name of the perl visible subroutine, unless you give the parameter | |
814 | I<C_SUBNAME>. | |
815 | ||
816 | =cut | |
817 | ||
818 | sub XS_constant { | |
819 | my $package = shift; | |
820 | my $what = shift; | |
821 | my $subname = shift; | |
822 | my $C_subname = shift; | |
823 | $subname ||= 'constant'; | |
824 | $C_subname ||= $subname; | |
825 | ||
826 | if (!ref $what) { | |
827 | # Convert line of the form IV,UV,NV to hash | |
828 | $what = {map {$_ => 1} split /,\s*/, ($what)}; | |
829 | } | |
72f7b9a1 | 830 | my $params = params ($what); |
af6c647e NC |
831 | my $type; |
832 | ||
833 | my $xs = <<"EOT"; | |
834 | void | |
835 | $subname(sv) | |
836 | PREINIT: | |
837 | #ifdef dXSTARG | |
838 | dXSTARG; /* Faster if we have it. */ | |
839 | #else | |
840 | dTARGET; | |
841 | #endif | |
842 | STRLEN len; | |
843 | int type; | |
844 | EOT | |
845 | ||
72f7b9a1 | 846 | if ($params->{IV}) { |
af6c647e NC |
847 | $xs .= " IV iv;\n"; |
848 | } else { | |
849 | $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; | |
850 | } | |
72f7b9a1 | 851 | if ($params->{NV}) { |
af6c647e NC |
852 | $xs .= " NV nv;\n"; |
853 | } else { | |
854 | $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; | |
855 | } | |
72f7b9a1 | 856 | if ($params->{PV}) { |
af6c647e NC |
857 | $xs .= " const char *pv;\n"; |
858 | } else { | |
859 | $xs .= | |
860 | " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; | |
861 | } | |
862 | ||
863 | $xs .= << 'EOT'; | |
864 | INPUT: | |
865 | SV * sv; | |
866 | const char * s = SvPV(sv, len); | |
867 | PPCODE: | |
868 | EOT | |
869 | ||
72f7b9a1 | 870 | if ($params->{IV} xor $params->{NV}) { |
af6c647e | 871 | $xs .= << "EOT"; |
a2c454fa | 872 | /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); |
af6c647e NC |
873 | if you need to return both NVs and IVs */ |
874 | EOT | |
875 | } | |
a2c454fa | 876 | $xs .= " type = $C_subname(aTHX_ s, len"; |
72f7b9a1 NC |
877 | $xs .= ', &iv' if $params->{IV}; |
878 | $xs .= ', &nv' if $params->{NV}; | |
879 | $xs .= ', &pv' if $params->{PV}; | |
880 | $xs .= ', &sv' if $params->{SV}; | |
af6c647e NC |
881 | $xs .= ");\n"; |
882 | ||
883 | $xs .= << "EOT"; | |
884 | /* Return 1 or 2 items. First is error message, or undef if no error. | |
885 | Second, if present, is found value */ | |
886 | switch (type) { | |
887 | case PERL_constant_NOTFOUND: | |
888 | sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); | |
6d79cad2 | 889 | PUSHs(sv); |
af6c647e NC |
890 | break; |
891 | case PERL_constant_NOTDEF: | |
892 | sv = sv_2mortal(newSVpvf( | |
8ac27563 | 893 | "Your vendor has not defined $package macro %s, used", s)); |
6d79cad2 | 894 | PUSHs(sv); |
af6c647e NC |
895 | break; |
896 | EOT | |
897 | ||
898 | foreach $type (sort keys %XS_Constant) { | |
899 | $xs .= "\t/* Uncomment this if you need to return ${type}s\n" | |
900 | unless $what->{$type}; | |
8ac27563 NC |
901 | $xs .= " case PERL_constant_IS$type:\n"; |
902 | if (length $XS_Constant{$type}) { | |
903 | $xs .= << "EOT"; | |
af6c647e NC |
904 | EXTEND(SP, 1); |
905 | PUSHs(&PL_sv_undef); | |
906 | $XS_Constant{$type}; | |
af6c647e | 907 | EOT |
8ac27563 NC |
908 | } else { |
909 | # Do nothing. return (), which will be correctly interpreted as | |
910 | # (undef, undef) | |
911 | } | |
912 | $xs .= " break;\n"; | |
af6c647e NC |
913 | unless ($what->{$type}) { |
914 | chop $xs; # Yes, another need for chop not chomp. | |
915 | $xs .= " */\n"; | |
916 | } | |
917 | } | |
918 | $xs .= << "EOT"; | |
919 | default: | |
920 | sv = sv_2mortal(newSVpvf( | |
8ac27563 | 921 | "Unexpected return type %d while processing $package macro %s, used", |
af6c647e | 922 | type, s)); |
6d79cad2 | 923 | PUSHs(sv); |
af6c647e NC |
924 | } |
925 | EOT | |
926 | ||
927 | return $xs; | |
928 | } | |
929 | ||
930 | ||
6d79cad2 | 931 | =item autoload PACKAGE, VERSION, AUTOLOADER |
af6c647e NC |
932 | |
933 | A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> | |
934 | I<VERSION> is the perl version the code should be backwards compatible with. | |
6d79cad2 NC |
935 | It defaults to the version of perl running the subroutine. If I<AUTOLOADER> |
936 | is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all | |
937 | names that the constant() routine doesn't recognise. | |
af6c647e NC |
938 | |
939 | =cut | |
940 | ||
6d79cad2 NC |
941 | # ' # Grr. syntax highlighters that don't grok pod. |
942 | ||
af6c647e | 943 | sub autoload { |
6d79cad2 | 944 | my ($module, $compat_version, $autoloader) = @_; |
af6c647e NC |
945 | $compat_version ||= $]; |
946 | croak "Can't maintain compatibility back as far as version $compat_version" | |
947 | if $compat_version < 5; | |
6d79cad2 NC |
948 | my $func = "sub AUTOLOAD {\n" |
949 | . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" | |
950 | . " # XS function."; | |
951 | $func .= " If a constant is not found then control is passed\n" | |
952 | . " # to the AUTOLOAD in AutoLoader." if $autoloader; | |
953 | ||
954 | ||
955 | $func .= "\n\n" | |
956 | . " my \$constname;\n"; | |
a2c454fa | 957 | $func .= |
6d79cad2 NC |
958 | " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); |
959 | ||
960 | $func .= <<"EOT"; | |
af6c647e NC |
961 | (\$constname = \$AUTOLOAD) =~ s/.*:://; |
962 | croak "&${module}::constant not defined" if \$constname eq 'constant'; | |
963 | my (\$error, \$val) = constant(\$constname); | |
6d79cad2 NC |
964 | EOT |
965 | ||
966 | if ($autoloader) { | |
967 | $func .= <<'EOT'; | |
968 | if ($error) { | |
969 | if ($error =~ /is not a valid/) { | |
970 | $AutoLoader::AUTOLOAD = $AUTOLOAD; | |
af6c647e NC |
971 | goto &AutoLoader::AUTOLOAD; |
972 | } else { | |
6d79cad2 | 973 | croak $error; |
af6c647e NC |
974 | } |
975 | } | |
6d79cad2 NC |
976 | EOT |
977 | } else { | |
978 | $func .= | |
979 | " if (\$error) { croak \$error; }\n"; | |
980 | } | |
981 | ||
982 | $func .= <<'END'; | |
af6c647e NC |
983 | { |
984 | no strict 'refs'; | |
985 | # Fixed between 5.005_53 and 5.005_61 | |
6d79cad2 NC |
986 | #XXX if ($] >= 5.00561) { |
987 | #XXX *$AUTOLOAD = sub () { $val }; | |
af6c647e NC |
988 | #XXX } |
989 | #XXX else { | |
6d79cad2 | 990 | *$AUTOLOAD = sub { $val }; |
af6c647e NC |
991 | #XXX } |
992 | } | |
6d79cad2 | 993 | goto &$AUTOLOAD; |
af6c647e NC |
994 | } |
995 | ||
996 | END | |
997 | ||
6d79cad2 | 998 | return $func; |
af6c647e | 999 | } |
0552bf3a NC |
1000 | |
1001 | ||
1002 | =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] | |
1003 | ||
1004 | Writes a file of C code and a file of XS code which you should C<#include> | |
1005 | and C<INCLUDE> in the C and XS sections respectively of your module's XS | |
1006 | code. You probaby want to do this in your C<Makefile.PL>, so that you can | |
1007 | easily edit the list of constants without touching the rest of your module. | |
1008 | The attributes supported are | |
1009 | ||
1010 | =over 4 | |
1011 | ||
1012 | =item NAME | |
1013 | ||
1014 | Name of the module. This must be specified | |
1015 | ||
1016 | =item DEFAULT_TYPE | |
1017 | ||
1018 | The default type for the constants. If not specified C<IV> is assumed. | |
1019 | ||
1020 | =item BREAKOUT_AT | |
1021 | ||
1022 | The names of the constants are grouped by length. Generate child subroutines | |
1023 | for each group with this number or more names in. | |
1024 | ||
1025 | =item NAMES | |
1026 | ||
1027 | An array of constants' names, either scalars containing names, or hashrefs | |
1028 | as detailed in L<"C_constant">. | |
1029 | ||
1030 | =item C_FILE | |
1031 | ||
1032 | The name of the file to write containing the C code. The default is | |
1033 | C<constants.c>. | |
1034 | ||
1035 | =item XS_FILE | |
1036 | ||
1037 | The name of the file to write containing the XS code. The default is | |
1038 | C<constants.xs>. | |
1039 | ||
1040 | =item SUBNAME | |
1041 | ||
1042 | The perl visible name of the XS subroutine generated which will return the | |
1043 | constants. The default is C<constant>. | |
1044 | ||
1045 | =item C_SUBNAME | |
1046 | ||
1047 | The name of the C subroutine generated which will return the constants. | |
1048 | The default is I<SUBNAME>. Child subroutines have C<_> and the name | |
1049 | length appended, so constants with 10 character names would be in | |
1050 | C<constant_10> with the default I<XS_SUBNAME>. | |
1051 | ||
1052 | =back | |
1053 | ||
1054 | =cut | |
1055 | ||
1056 | sub WriteConstants { | |
1057 | my %ARGS = | |
1058 | ( # defaults | |
1059 | C_FILE => 'constants.c', | |
1060 | XS_FILE => 'constants.xs', | |
1061 | SUBNAME => 'constant', | |
1062 | DEFAULT_TYPE => 'IV', | |
1063 | @_); | |
1064 | ||
1065 | $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0' | |
1066 | ||
1067 | croak "Module name not specified" unless length $ARGS{NAME}; | |
1068 | ||
1069 | open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; | |
1070 | open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; | |
1071 | ||
1072 | # As this subroutine is intended to make code that isn't edited, there's no | |
1073 | # need for the user to specify any types that aren't found in the list of | |
1074 | # names. | |
1075 | my $types = {}; | |
1076 | ||
1077 | print $c_fh constant_types(); # macro defs | |
1078 | print $c_fh "\n"; | |
1079 | ||
1080 | # indent is still undef. Until anyone implents indent style rules with it. | |
1081 | foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE}, | |
1082 | $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) { | |
1083 | print $c_fh $_, "\n"; # C constant subs | |
1084 | } | |
1085 | print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, | |
1086 | $ARGS{C_SUBNAME}); | |
1087 | ||
1088 | close $c_fh or warn "Error closing $ARGS{C_FILE}: $!"; | |
1089 | close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!"; | |
1090 | } | |
1091 | ||
af6c647e NC |
1092 | 1; |
1093 | __END__ | |
1094 | ||
1095 | =back | |
1096 | ||
1097 | =head1 AUTHOR | |
1098 | ||
1099 | Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and | |
1100 | others | |
1101 | ||
1102 | =cut |