Commit | Line | Data |
af6c647e |
1 | package ExtUtils::Constant; |
2 | |
3 | =head1 NAME |
4 | |
5 | ExtUtils::Constant - generate XS code to import C header constants |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | use ExtUtils::Constant qw (constant_types C_constant XS_constant); |
10 | print constant_types(); # macro defs |
6d79cad2 |
11 | foreach (C_constant ("Foo", undef, "IV", undef, undef, undef, |
12 | @names) ) { |
af6c647e |
13 | print $_, "\n"; # C constant subs |
14 | } |
15 | print "MODULE = Foo PACKAGE = Foo\n"; |
16 | print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | ExtUtils::Constant facilitates generating C and XS wrapper code to allow |
21 | perl modules to AUTOLOAD constants defined in C library header files. |
22 | It is principally used by the C<h2xs> utility, on which this code is based. |
23 | It doesn't contain the routines to scan header files to extract these |
24 | constants. |
25 | |
26 | =head1 USAGE |
27 | |
28 | Generally one only needs to call the 3 functions shown in the synopsis, |
29 | C<constant_types()>, C<C_constant> and C<XS_constant>. |
30 | |
31 | Currently this module understands the following types. h2xs may only know |
32 | a subset. The sizes of the numeric types are chosen by the C<Configure> |
33 | script at compile time. |
34 | |
35 | =over 4 |
36 | |
37 | =item IV |
38 | |
39 | signed integer, at least 32 bits. |
40 | |
41 | =item UV |
42 | |
43 | unsigned integer, the same size as I<IV> |
44 | |
45 | =item NV |
46 | |
47 | floating point type, probably C<double>, possibly C<long double> |
48 | |
49 | =item PV |
50 | |
51 | NUL terminated string, length will be determined with C<strlen> |
52 | |
53 | =item PVN |
54 | |
55 | A fixed length thing, given as a [pointer, length] pair. If you know the |
56 | length of a string at compile time you may use this instead of I<PV> |
57 | |
3414cef0 |
58 | =item YES |
59 | |
60 | Truth. (C<PL_sv_yes>) The value is not needed (and ignored). |
61 | |
62 | =item NO |
63 | |
64 | Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). |
65 | |
66 | =item UNDEF |
67 | |
68 | C<undef>. The value of the macro is not needed. |
69 | |
af6c647e |
70 | =back |
71 | |
72 | =head1 FUNCTIONS |
73 | |
74 | =over 4 |
75 | |
76 | =cut |
77 | |
78 | require 5.006; # I think, for [:cntrl:] in REGEXP |
79 | use warnings; |
80 | use strict; |
81 | use Carp; |
82 | |
83 | use Exporter; |
84 | use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS); |
85 | use Text::Wrap; |
86 | $Text::Wrap::huge = 'overflow'; |
87 | $Text::Wrap::columns = 80; |
88 | |
89 | @ISA = 'Exporter'; |
3414cef0 |
90 | $VERSION = '0.04'; |
af6c647e |
91 | |
92 | %EXPORT_TAGS = ( 'all' => [ qw( |
93 | XS_constant constant_types return_clause memEQ_clause C_stringify |
94 | C_constant autoload |
95 | ) ] ); |
96 | |
97 | @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
98 | |
99 | %XS_Constant = ( |
100 | IV => 'PUSHi(iv)', |
101 | UV => 'PUSHu((UV)iv)', |
102 | NV => 'PUSHn(nv)', |
103 | PV => 'PUSHp(pv, strlen(pv))', |
3414cef0 |
104 | PVN => 'PUSHp(pv, iv)', |
105 | YES => 'PUSHs(&PL_sv_yes)', |
106 | NO => 'PUSHs(&PL_sv_no)', |
19d75eda |
107 | UNDEF => '', # implicit undef |
af6c647e |
108 | ); |
109 | |
110 | %XS_TypeSet = ( |
111 | IV => '*iv_return =', |
112 | UV => '*iv_return = (IV)', |
113 | NV => '*nv_return =', |
114 | PV => '*pv_return =', |
3414cef0 |
115 | PVN => ['*pv_return =', '*iv_return = (IV)'], |
19d75eda |
116 | YES => undef, |
117 | NO => undef, |
118 | UNDEF => undef, |
af6c647e |
119 | ); |
120 | |
121 | |
122 | =item C_stringify NAME |
123 | |
124 | A function which returns a correctly \ escaped version of the string passed |
6d79cad2 |
125 | suitable for C's "" or ''. It will also be valid as a perl "" string. |
af6c647e |
126 | |
127 | =cut |
128 | |
129 | # Hopefully make a happy C identifier. |
130 | sub C_stringify { |
131 | local $_ = shift; |
6d79cad2 |
132 | return unless defined $_; |
af6c647e |
133 | s/\\/\\\\/g; |
134 | s/([\"\'])/\\$1/g; # Grr. fix perl mode. |
6d79cad2 |
135 | s/\n/\\n/g; # Ensure newlines don't end up in octal |
136 | s/\r/\\r/g; |
3414cef0 |
137 | s/\t/\\t/g; |
138 | s/\f/\\f/g; |
139 | s/\a/\\a/g; |
af6c647e |
140 | s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge; |
141 | s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:] |
142 | $_; |
143 | } |
144 | |
145 | =item constant_types |
146 | |
147 | A function returning a single scalar with C<#define> definitions for the |
148 | constants used internally between the generated C and XS functions. |
149 | |
150 | =cut |
151 | |
152 | sub constant_types () { |
153 | my $start = 1; |
154 | my @lines; |
155 | push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; |
156 | push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; |
157 | foreach (sort keys %XS_Constant) { |
158 | push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; |
159 | } |
160 | push @lines, << 'EOT'; |
161 | |
162 | #ifndef NVTYPE |
163 | typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ |
164 | #endif |
165 | EOT |
166 | |
167 | return join '', @lines; |
168 | } |
169 | |
170 | =item memEQ_clause NAME, CHECKED_AT, INDENT |
171 | |
172 | A function to return a suitable C C<if> statement to check whether I<NAME> |
173 | is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it |
174 | is used to avoid C<memEQ> for short names, or to generate a comment to |
175 | highlight the position of the character in the C<switch> statement. |
176 | |
177 | =cut |
178 | |
179 | sub memEQ_clause { |
180 | # if (memEQ(name, "thingy", 6)) { |
181 | # Which could actually be a character comparison or even "" |
182 | my ($name, $checked_at, $indent) = @_; |
183 | $indent = ' ' x ($indent || 4); |
184 | my $len = length $name; |
185 | |
186 | if ($len < 2) { |
187 | return $indent . "{\n" if (defined $checked_at and $checked_at == 0); |
188 | # We didn't switch, drop through to the code for the 2 character string |
189 | $checked_at = 1; |
190 | } |
191 | if ($len < 3 and defined $checked_at) { |
192 | my $check; |
193 | if ($checked_at == 1) { |
194 | $check = 0; |
195 | } elsif ($checked_at == 0) { |
196 | $check = 1; |
197 | } |
198 | if (defined $check) { |
199 | my $char = C_stringify (substr $name, $check, 1); |
200 | return $indent . "if (name[$check] == '$char') {\n"; |
201 | } |
202 | } |
203 | # Could optimise a memEQ on 3 to 2 single character checks here |
204 | $name = C_stringify ($name); |
205 | my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n"; |
206 | $body .= $indent . "/* ". (' ' x $checked_at) . '^' |
207 | . (' ' x ($len - $checked_at + length $len)) . " */\n" |
208 | if defined $checked_at; |
209 | return $body; |
210 | } |
211 | |
6d79cad2 |
212 | =item assign INDENT, TYPE, VALUE... |
213 | |
214 | A function to return a suitable assignment clause. If I<TYPE> is aggregate |
215 | (eg I<PVN> expects both pointer and length) then there should be multiple |
216 | I<VALUE>s for the components. |
217 | |
218 | =cut |
219 | |
220 | # Hmm. value undef to to NOTDEF? value () to do NOTFOUND? |
221 | |
222 | sub assign { |
223 | my $indent = shift; |
224 | my $type = shift; |
6d79cad2 |
225 | my $clause; |
3414cef0 |
226 | die "Can't generate code for type $type" unless exists $XS_TypeSet{$type}; |
227 | my $typeset = $XS_TypeSet{$type}; |
6d79cad2 |
228 | if (ref $typeset) { |
229 | die "Type $type is aggregate, but only single value given" |
230 | if @_ == 1; |
231 | foreach (0 .. $#$typeset) { |
232 | $clause .= $indent . "$typeset->[$_] $_[$_];\n"; |
233 | } |
3414cef0 |
234 | } elsif (defined $typeset) { |
6d79cad2 |
235 | die "Aggregate value given for type $type" |
236 | if @_ > 1; |
237 | $clause .= $indent . "$typeset $_[0];\n"; |
238 | } |
239 | $clause .= "${indent}return PERL_constant_IS$type;\n"; |
240 | return $clause; |
241 | } |
242 | |
243 | =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT |
af6c647e |
244 | |
245 | A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to |
6d79cad2 |
246 | I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both |
af6c647e |
247 | pointer and length) then I<VALUE> should be a reference to an array of |
6d79cad2 |
248 | values in the order expected by the type. C<C_constant> will always call |
249 | this function with I<MACRO> defined, defaulting to the constant's name. |
250 | I<DEFAULT> if defined is an array reference giving default type and and |
251 | value(s) if the clause generated by I<MACRO> doesn't evaluate to true. |
af6c647e |
252 | |
253 | =cut |
254 | |
6d79cad2 |
255 | sub return_clause ($$$$$) { |
af6c647e |
256 | ##ifdef thingy |
257 | # *iv_return = thingy; |
258 | # return PERL_constant_ISIV; |
259 | ##else |
260 | # return PERL_constant_NOTDEF; |
261 | ##endif |
6d79cad2 |
262 | my ($value, $type, $indent, $macro, $default) = @_; |
af6c647e |
263 | $macro = $value unless defined $macro; |
264 | $indent = ' ' x ($indent || 6); |
265 | |
6d79cad2 |
266 | my $clause; |
af6c647e |
267 | |
6d79cad2 |
268 | ##ifdef thingy |
269 | if (ref $macro) { |
270 | $clause = $macro->[0]; |
af6c647e |
271 | } else { |
6d79cad2 |
272 | $clause = "#ifdef $macro\n"; |
af6c647e |
273 | } |
6d79cad2 |
274 | |
275 | # *iv_return = thingy; |
276 | # return PERL_constant_ISIV; |
277 | $clause .= assign ($indent, $type, ref $value ? @$value : $value); |
278 | |
279 | ##else |
280 | $clause .= "#else\n"; |
281 | |
282 | # return PERL_constant_NOTDEF; |
283 | if (!defined $default) { |
284 | $clause .= "${indent}return PERL_constant_NOTDEF;\n"; |
285 | } else { |
286 | $clause .= assign ($indent, ref $default ? @$default : $default); |
287 | } |
288 | |
289 | ##endif |
290 | if (ref $macro) { |
291 | $clause .= $macro->[1]; |
292 | } else { |
293 | $clause .= "#endif\n"; |
294 | } |
295 | return $clause |
af6c647e |
296 | } |
297 | |
298 | =item params WHAT |
299 | |
300 | An internal function. I<WHAT> should be a hashref of types the constant |
301 | function will return. I<params> returns the list of flags C<$use_iv, $use_nv, |
302 | $use_pv> to show which combination of pointers will be needed in the C |
303 | argument list. |
304 | |
305 | =cut |
306 | |
307 | sub params { |
308 | my $what = shift; |
309 | foreach (sort keys %$what) { |
310 | warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; |
311 | } |
312 | my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN}; |
313 | my $use_nv = $what->{NV}; |
314 | my $use_pv = $what->{PV} || $what->{PVN}; |
315 | return ($use_iv, $use_nv, $use_pv); |
316 | } |
317 | |
0addb26a |
318 | =item dump_names |
319 | |
320 | dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM... |
6d79cad2 |
321 | |
322 | An internal function to generate the embedded perl code that will regenerate |
323 | the constant subroutines. Parameters are the same as for C_constant, except |
324 | that there is no NAMELEN. |
325 | |
326 | =cut |
327 | |
328 | sub dump_names { |
329 | my ($package, $subname, $default_type, $what, $indent, @items) = @_; |
330 | my (@simple, @complex); |
331 | foreach (@items) { |
332 | my $type = $_->{type} || $default_type; |
333 | if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c) |
334 | and !defined ($_->{macro}) and !defined ($_->{value}) |
335 | and !defined ($_->{default})) { |
336 | # It's the default type, and the name consists only of A-Za-z0-9_ |
337 | push @simple, $_->{name}; |
338 | } else { |
339 | push @complex, $_; |
340 | } |
341 | } |
342 | my $result = <<"EOT"; |
343 | /* When generated this function returned values for the list of names given |
344 | in this section of perl code. Rather than manually editing these functions |
345 | to add or remove constants, which would result in this comment and section |
346 | of code becoming inaccurate, we recommend that you edit this section of |
347 | code, and use it to regenerate a new set of constant functions which you |
348 | then use to replace the originals. |
349 | |
350 | Regenerate these constant functions by feeding this entire source file to |
351 | perl -x |
352 | |
353 | #!$^X -w |
354 | use ExtUtils::Constant qw (constant_types C_constant XS_constant); |
355 | |
356 | EOT |
357 | $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what) |
358 | . "};\n"; |
359 | $result .= wrap ("my \@names = (qw(", |
360 | " ", join (" ", sort @simple) . ")"); |
361 | if (@complex) { |
362 | foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { |
363 | my $name = C_stringify $item->{name}; |
364 | my ($macro, $value, $default) = @$item{qw (macro value default)}; |
365 | my $line = ",\n {name=>\"$name\""; |
366 | $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; |
367 | if (defined $macro) { |
368 | if (ref $macro) { |
369 | $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro) |
370 | . '"]'; |
371 | } else { |
372 | $line .= ", macro=>\"" . C_stringify($macro) . "\""; |
373 | } |
374 | } |
375 | if (defined $value) { |
376 | if (ref $value) { |
377 | $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value) |
378 | . '"]'; |
379 | } else { |
380 | $line .= ", value=>\"" . C_stringify($value) . "\""; |
381 | } |
382 | } |
383 | if (defined $default) { |
384 | if (ref $default) { |
385 | $line .= ', default=>["'. join ('", "', map {C_stringify $_} |
386 | @$default) |
387 | . '"]'; |
388 | } else { |
389 | $line .= ", default=>\"" . C_stringify($default) . "\""; |
390 | } |
391 | } |
392 | $line .= "}"; |
393 | # Ensure that the enclosing C comment doesn't end |
394 | # by turning */ into *" . "/ |
395 | $line =~ s!\*\/!\*" . "/!gs; |
3414cef0 |
396 | # gcc -Wall doesn't like finding /* inside a comment |
397 | $line =~ s!\/\*!/" . "\*!gs; |
6d79cad2 |
398 | $result .= $line; |
399 | } |
400 | } |
401 | $result .= ");\n"; |
402 | |
403 | $result .= <<'EOT'; |
404 | |
405 | print constant_types(); # macro defs |
406 | EOT |
407 | $package = C_stringify($package); |
408 | $result .= |
409 | "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; |
410 | # The form of the indent parameter isn't defined. (Yet) |
411 | if (defined $indent) { |
412 | require Data::Dumper; |
413 | $Data::Dumper::Terse=1; |
414 | chomp ($indent = Data::Dumper::Dumper ($indent)); |
415 | $result .= $indent; |
416 | } else { |
417 | $result .= 'undef'; |
418 | } |
419 | $result .= ', undef, @names) ) { |
420 | print $_, "\n"; # C constant subs |
421 | } |
422 | print "#### XS Section:\n"; |
423 | print XS_constant ("' . $package . '", $types); |
424 | __END__ |
425 | */ |
426 | |
427 | '; |
428 | |
429 | $result; |
430 | } |
431 | |
0addb26a |
432 | =item C_constant |
433 | |
434 | C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM... |
af6c647e |
435 | |
436 | A function that returns a B<list> of C subroutine definitions that return |
437 | the value and type of constants when passed the name by the XS wrapper. |
438 | I<ITEM...> gives a list of constant names. Each can either be a string, |
439 | which is taken as a C macro name, or a reference to a hash with the following |
440 | keys |
441 | |
442 | =over 8 |
443 | |
444 | =item name |
445 | |
446 | The name of the constant, as seen by the perl code. |
447 | |
448 | =item type |
449 | |
450 | The type of the constant (I<IV>, I<NV> etc) |
451 | |
452 | =item value |
453 | |
454 | A C expression for the value of the constant, or a list of C expressions if |
455 | the type is aggregate. This defaults to the I<name> if not given. |
456 | |
457 | =item macro |
458 | |
459 | The C pre-processor macro to use in the C<#ifdef>. This defaults to the |
6d79cad2 |
460 | I<name>, and is mainly used if I<value> is an C<enum>. If a reference an |
461 | array is passed then the first element is used in place of the C<#ifdef> |
462 | line, and the second element in place of the C<#endif>. This allows |
463 | pre-processor constructions such as |
464 | |
465 | #if defined (foo) |
466 | #if !defined (bar) |
467 | ... |
468 | #endif |
469 | #endif |
470 | |
471 | to be used to determine if a constant is to be defined. |
472 | |
473 | =item default |
474 | |
475 | Default value to use (instead of C<croak>ing with "your vendor has not |
476 | defined...") to return if the macro isn't defined. Specify a reference to |
477 | an array with type followed by value(s). |
af6c647e |
478 | |
479 | =back |
480 | |
6d79cad2 |
481 | I<PACKAGE> is the name of the package, and is only used in comments inside the |
482 | generated C code. |
483 | |
484 | The next 5 arguments can safely be given as C<undef>, and are mainly used |
af6c647e |
485 | for recursion. I<SUBNAME> defaults to C<constant> if undefined. |
486 | |
487 | I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their |
488 | type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma |
489 | separated list of types that the C subroutine C<constant> will generate or as |
490 | a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not |
491 | present, as will any types given in the list of I<ITEM>s. The resultant list |
492 | should be the same list of types that C<XS_constant> is given. [Otherwise |
493 | C<XS_constant> and C<C_constant> may differ in the number of parameters to the |
494 | constant function. I<INDENT> is currently unused and ignored. In future it may |
495 | be used to pass in information used to change the C indentation style used.] |
496 | The best way to maintain consistency is to pass in a hash reference and let |
497 | this function update it. |
498 | |
499 | I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of |
500 | this length, and that the constant name passed in by perl is checked and |
501 | also of this length. It is used during recursion, and should be C<undef> |
502 | unless the caller has checked all the lengths during code generation, and |
503 | the generated subroutine is only to be called with a name of this length. |
504 | |
505 | =cut |
506 | |
507 | sub C_constant { |
6d79cad2 |
508 | my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_; |
509 | $package ||= 'Foo'; |
af6c647e |
510 | $subname ||= 'constant'; |
511 | # I'm not using this. But a hashref could be used for full formatting without |
512 | # breaking this API |
6d79cad2 |
513 | # $indent ||= 0; |
af6c647e |
514 | $default_type ||= 'IV'; |
515 | if (!ref $what) { |
516 | # Convert line of the form IV,UV,NV to hash |
517 | $what = {map {$_ => 1} split /,\s*/, ($what || '')}; |
518 | # Figure out what types we're dealing with, and assign all unknowns to the |
519 | # default type |
520 | } |
521 | my %items; |
522 | foreach (@items) { |
523 | my $name; |
524 | if (ref $_) { |
6d79cad2 |
525 | # Make a copy which is a normalised version of the ref passed in. |
af6c647e |
526 | $name = $_->{name}; |
6d79cad2 |
527 | my ($type, $macro, $value, $default) = @$_{qw (type macro value default)}; |
528 | $type ||= $default_type; |
529 | $what->{$type} = 1; |
530 | $_ = {name=>$name, type=>$type}; |
531 | |
532 | undef $macro if defined $macro and $macro eq $name; |
533 | $_->{macro} = $macro if defined $macro; |
534 | undef $value if defined $value and $value eq $name; |
535 | $_->{value} = $value if defined $value; |
536 | $_->{default} = $default if defined $default; |
af6c647e |
537 | } else { |
538 | $name = $_; |
539 | $_ = {name=>$_, type=>$default_type}; |
540 | $what->{$default_type} = 1; |
541 | } |
542 | warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}}; |
543 | if (exists $items{$name}) { |
544 | die "Multiple definitions for macro $name"; |
545 | } |
546 | $items{$name} = $_; |
547 | } |
548 | my ($use_iv, $use_nv, $use_pv) = params ($what); |
549 | |
550 | my ($body, @subs) = "static int\n$subname (const char *name"; |
551 | $body .= ", STRLEN len" unless defined $namelen; |
552 | $body .= ", IV *iv_return" if $use_iv; |
553 | $body .= ", NV *nv_return" if $use_nv; |
554 | $body .= ", const char **pv_return" if $use_pv; |
555 | $body .= ") {\n"; |
556 | |
6d79cad2 |
557 | if (defined $namelen) { |
558 | # We are a child subroutine. Print the simple description |
559 | my @names = sort map {$_->{name}} @items; |
560 | my $names = << 'EOT' |
af6c647e |
561 | /* When generated this function returned values for the list of names given |
562 | here. However, subsequent manual editing may have added or removed some. |
563 | EOT |
6d79cad2 |
564 | . wrap (" ", " ", join (" ", @names) . " */") . "\n"; |
af6c647e |
565 | # Figure out what to switch on. |
566 | # (RMS, Spread of jump table, Position, Hashref) |
567 | my @best = (1e38, ~0); |
568 | foreach my $i (0 .. ($namelen - 1)) { |
569 | my ($min, $max) = (~0, 0); |
570 | my %spread; |
571 | foreach (@names) { |
572 | my $char = substr $_, $i, 1; |
573 | my $ord = ord $char; |
574 | $max = $ord if $ord > $max; |
575 | $min = $ord if $ord < $min; |
576 | push @{$spread{$char}}, $_; |
577 | # warn "$_ $char"; |
578 | } |
579 | # I'm going to pick the character to split on that minimises the root |
580 | # mean square of the number of names in each case. Normally this should |
581 | # be the one with the most keys, but it may pick a 7 where the 8 has |
582 | # one long linear search. I'm not sure if RMS or just sum of squares is |
583 | # actually better. |
584 | # $max and $min are for the tie-breaker if the root mean squares match. |
585 | # Assuming that the compiler may be building a jump table for the |
586 | # switch() then try to minimise the size of that jump table. |
587 | # Finally use < not <= so that if it still ties the earliest part of |
588 | # the string wins. Because if that passes but the memEQ fails, it may |
589 | # only need the start of the string to bin the choice. |
590 | # I think. But I'm micro-optimising. :-) |
591 | my $ss; |
592 | $ss += @$_ * @$_ foreach values %spread; |
593 | my $rms = sqrt ($ss / keys %spread); |
594 | if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { |
595 | @best = ($rms, $max - $min, $i, \%spread); |
596 | } |
597 | } |
598 | die "Internal error. Failed to pick a switch point for @names" |
599 | unless defined $best[2]; |
600 | # use Data::Dumper; print Dumper (@best); |
601 | my ($offset, $best) = @best[2,3]; |
602 | $body .= " /* Names all of length $namelen. */\n"; |
603 | $body .= $names; |
604 | $body .= " /* Offset $offset gives the best switch position. */\n"; |
605 | $body .= " switch (name[$offset]) {\n"; |
606 | foreach my $char (sort keys %$best) { |
607 | $body .= " case '" . C_stringify ($char) . "':\n"; |
608 | foreach my $name (sort @{$best->{$char}}) { |
609 | my $thisone = $items{$name}; |
6d79cad2 |
610 | my ($value, $macro, $default) = @$thisone{qw (value macro default)}; |
af6c647e |
611 | $value = $name unless defined $value; |
612 | $macro = $name unless defined $macro; |
613 | |
614 | $body .= memEQ_clause ($name, $offset); # We have checked this offset. |
6d79cad2 |
615 | $body .= return_clause ($value, $thisone->{type}, undef, $macro, |
616 | $default); |
af6c647e |
617 | $body .= " }\n"; |
618 | } |
619 | $body .= " break;\n"; |
620 | } |
621 | $body .= " }\n"; |
622 | } else { |
623 | # We are the top level. |
624 | $body .= " /* Initially switch on the length of the name. */\n"; |
6d79cad2 |
625 | $body .= dump_names ($package, $subname, $default_type, $what, $indent, |
626 | @items); |
af6c647e |
627 | $body .= " switch (len) {\n"; |
628 | # Need to group names of the same length |
629 | my @by_length; |
630 | foreach (@items) { |
631 | push @{$by_length[length $_->{name}]}, $_; |
632 | } |
633 | foreach my $i (0 .. $#by_length) { |
634 | next unless $by_length[$i]; # None of this length |
635 | $body .= " case $i:\n"; |
636 | if (@{$by_length[$i]} == 1) { |
637 | my $thisone = $by_length[$i]->[0]; |
6d79cad2 |
638 | my ($name, $value, $macro, $default) |
639 | = @$thisone{qw (name value macro default)}; |
af6c647e |
640 | $value = $name unless defined $value; |
641 | $macro = $name unless defined $macro; |
642 | |
643 | $body .= memEQ_clause ($name); |
6d79cad2 |
644 | $body .= return_clause ($value, $thisone->{type}, undef, $macro, |
645 | $default); |
af6c647e |
646 | $body .= " }\n"; |
647 | } else { |
6d79cad2 |
648 | push @subs, C_constant ($package, "${subname}_$i", $default_type, |
649 | $what, $indent, $i, @{$by_length[$i]}); |
af6c647e |
650 | $body .= " return ${subname}_$i (name"; |
651 | $body .= ", iv_return" if $use_iv; |
652 | $body .= ", nv_return" if $use_nv; |
653 | $body .= ", pv_return" if $use_pv; |
654 | $body .= ");\n"; |
655 | } |
656 | $body .= " break;\n"; |
657 | } |
658 | $body .= " }\n"; |
659 | } |
660 | $body .= " return PERL_constant_NOTFOUND;\n}\n"; |
661 | return (@subs, $body); |
662 | } |
663 | |
664 | =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME |
665 | |
666 | A function to generate the XS code to implement the perl subroutine |
667 | I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. |
668 | This XS code is a wrapper around a C subroutine usually generated by |
669 | C<C_constant>, and usually named C<constant>. |
670 | |
671 | I<TYPES> should be given either as a comma separated list of types that the |
672 | C subroutine C<constant> will generate or as a reference to a hash. It should |
673 | be the same list of types as C<C_constant> was given. |
674 | [Otherwise C<XS_constant> and C<C_constant> may have different ideas about |
675 | the number of parameters passed to the C function C<constant>] |
676 | |
677 | You can call the perl visible subroutine something other than C<constant> if |
678 | you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the |
679 | the name of the perl visible subroutine, unless you give the parameter |
680 | I<C_SUBNAME>. |
681 | |
682 | =cut |
683 | |
684 | sub XS_constant { |
685 | my $package = shift; |
686 | my $what = shift; |
687 | my $subname = shift; |
688 | my $C_subname = shift; |
689 | $subname ||= 'constant'; |
690 | $C_subname ||= $subname; |
691 | |
692 | if (!ref $what) { |
693 | # Convert line of the form IV,UV,NV to hash |
694 | $what = {map {$_ => 1} split /,\s*/, ($what)}; |
695 | } |
696 | my ($use_iv, $use_nv, $use_pv) = params ($what); |
697 | my $type; |
698 | |
699 | my $xs = <<"EOT"; |
700 | void |
701 | $subname(sv) |
702 | PREINIT: |
703 | #ifdef dXSTARG |
704 | dXSTARG; /* Faster if we have it. */ |
705 | #else |
706 | dTARGET; |
707 | #endif |
708 | STRLEN len; |
709 | int type; |
710 | EOT |
711 | |
712 | if ($use_iv) { |
713 | $xs .= " IV iv;\n"; |
714 | } else { |
715 | $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; |
716 | } |
717 | if ($use_nv) { |
718 | $xs .= " NV nv;\n"; |
719 | } else { |
720 | $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; |
721 | } |
722 | if ($use_pv) { |
723 | $xs .= " const char *pv;\n"; |
724 | } else { |
725 | $xs .= |
726 | " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; |
727 | } |
728 | |
729 | $xs .= << 'EOT'; |
730 | INPUT: |
731 | SV * sv; |
732 | const char * s = SvPV(sv, len); |
733 | PPCODE: |
734 | EOT |
735 | |
736 | if ($use_iv xor $use_nv) { |
737 | $xs .= << "EOT"; |
738 | /* Change this to $C_subname(s, len, &iv, &nv); |
739 | if you need to return both NVs and IVs */ |
740 | EOT |
741 | } |
742 | $xs .= " type = $C_subname(s, len"; |
743 | $xs .= ', &iv' if $use_iv; |
744 | $xs .= ', &nv' if $use_nv; |
745 | $xs .= ', &pv' if $use_pv; |
746 | $xs .= ");\n"; |
747 | |
748 | $xs .= << "EOT"; |
749 | /* Return 1 or 2 items. First is error message, or undef if no error. |
750 | Second, if present, is found value */ |
751 | switch (type) { |
752 | case PERL_constant_NOTFOUND: |
753 | sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); |
6d79cad2 |
754 | PUSHs(sv); |
af6c647e |
755 | break; |
756 | case PERL_constant_NOTDEF: |
757 | sv = sv_2mortal(newSVpvf( |
758 | "Your vendor has not defined $package macro %s used", s)); |
6d79cad2 |
759 | PUSHs(sv); |
af6c647e |
760 | break; |
761 | EOT |
762 | |
763 | foreach $type (sort keys %XS_Constant) { |
764 | $xs .= "\t/* Uncomment this if you need to return ${type}s\n" |
765 | unless $what->{$type}; |
766 | $xs .= << "EOT"; |
767 | case PERL_constant_IS$type: |
768 | EXTEND(SP, 1); |
769 | PUSHs(&PL_sv_undef); |
770 | $XS_Constant{$type}; |
771 | break; |
772 | EOT |
773 | unless ($what->{$type}) { |
774 | chop $xs; # Yes, another need for chop not chomp. |
775 | $xs .= " */\n"; |
776 | } |
777 | } |
778 | $xs .= << "EOT"; |
779 | default: |
780 | sv = sv_2mortal(newSVpvf( |
781 | "Unexpected return type %d while processing $package macro %s used", |
782 | type, s)); |
6d79cad2 |
783 | PUSHs(sv); |
af6c647e |
784 | } |
785 | EOT |
786 | |
787 | return $xs; |
788 | } |
789 | |
790 | |
6d79cad2 |
791 | =item autoload PACKAGE, VERSION, AUTOLOADER |
af6c647e |
792 | |
793 | A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> |
794 | I<VERSION> is the perl version the code should be backwards compatible with. |
6d79cad2 |
795 | It defaults to the version of perl running the subroutine. If I<AUTOLOADER> |
796 | is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all |
797 | names that the constant() routine doesn't recognise. |
af6c647e |
798 | |
799 | =cut |
800 | |
6d79cad2 |
801 | # ' # Grr. syntax highlighters that don't grok pod. |
802 | |
af6c647e |
803 | sub autoload { |
6d79cad2 |
804 | my ($module, $compat_version, $autoloader) = @_; |
af6c647e |
805 | $compat_version ||= $]; |
806 | croak "Can't maintain compatibility back as far as version $compat_version" |
807 | if $compat_version < 5; |
6d79cad2 |
808 | my $func = "sub AUTOLOAD {\n" |
809 | . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" |
810 | . " # XS function."; |
811 | $func .= " If a constant is not found then control is passed\n" |
812 | . " # to the AUTOLOAD in AutoLoader." if $autoloader; |
813 | |
814 | |
815 | $func .= "\n\n" |
816 | . " my \$constname;\n"; |
817 | $func .= |
818 | " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); |
819 | |
820 | $func .= <<"EOT"; |
af6c647e |
821 | (\$constname = \$AUTOLOAD) =~ s/.*:://; |
822 | croak "&${module}::constant not defined" if \$constname eq 'constant'; |
823 | my (\$error, \$val) = constant(\$constname); |
6d79cad2 |
824 | EOT |
825 | |
826 | if ($autoloader) { |
827 | $func .= <<'EOT'; |
828 | if ($error) { |
829 | if ($error =~ /is not a valid/) { |
830 | $AutoLoader::AUTOLOAD = $AUTOLOAD; |
af6c647e |
831 | goto &AutoLoader::AUTOLOAD; |
832 | } else { |
6d79cad2 |
833 | croak $error; |
af6c647e |
834 | } |
835 | } |
6d79cad2 |
836 | EOT |
837 | } else { |
838 | $func .= |
839 | " if (\$error) { croak \$error; }\n"; |
840 | } |
841 | |
842 | $func .= <<'END'; |
af6c647e |
843 | { |
844 | no strict 'refs'; |
845 | # Fixed between 5.005_53 and 5.005_61 |
6d79cad2 |
846 | #XXX if ($] >= 5.00561) { |
847 | #XXX *$AUTOLOAD = sub () { $val }; |
af6c647e |
848 | #XXX } |
849 | #XXX else { |
6d79cad2 |
850 | *$AUTOLOAD = sub { $val }; |
af6c647e |
851 | #XXX } |
852 | } |
6d79cad2 |
853 | goto &$AUTOLOAD; |
af6c647e |
854 | } |
855 | |
856 | END |
857 | |
6d79cad2 |
858 | return $func; |
af6c647e |
859 | } |
860 | 1; |
861 | __END__ |
862 | |
863 | =back |
864 | |
865 | =head1 AUTHOR |
866 | |
867 | Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and |
868 | others |
869 | |
870 | =cut |