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