Commit | Line | Data |
af6c647e |
1 | package ExtUtils::Constant; |
8ac27563 |
2 | use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS); |
7783f9f6 |
3 | $VERSION = '0.14'; |
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)], |
0552bf3a |
15 | ); |
16 | # Generates wrapper code to make the values of the constants FOO BAR BAZ |
17 | # available to perl |
af6c647e |
18 | |
19 | =head1 DESCRIPTION |
20 | |
21 | ExtUtils::Constant facilitates generating C and XS wrapper code to allow |
22 | perl modules to AUTOLOAD constants defined in C library header files. |
23 | It is principally used by the C<h2xs> utility, on which this code is based. |
24 | It doesn't contain the routines to scan header files to extract these |
25 | constants. |
26 | |
27 | =head1 USAGE |
28 | |
0552bf3a |
29 | Generally one only needs to call the C<WriteConstants> function, and then |
30 | |
1cb0fb50 |
31 | #include "const-c.inc" |
0552bf3a |
32 | |
33 | in the C section of C<Foo.xs> |
34 | |
1cb0fb50 |
35 | INCLUDE const-xs.inc |
0552bf3a |
36 | |
37 | in the XS section of C<Foo.xs>. |
38 | |
39 | For greater flexibility use C<constant_types()>, C<C_constant> and |
40 | C<XS_constant>, with which C<WriteConstants> is implemented. |
af6c647e |
41 | |
42 | Currently this module understands the following types. h2xs may only know |
43 | a subset. The sizes of the numeric types are chosen by the C<Configure> |
44 | script at compile time. |
45 | |
46 | =over 4 |
47 | |
48 | =item IV |
49 | |
50 | signed integer, at least 32 bits. |
51 | |
52 | =item UV |
53 | |
54 | unsigned integer, the same size as I<IV> |
55 | |
56 | =item NV |
57 | |
58 | floating point type, probably C<double>, possibly C<long double> |
59 | |
60 | =item PV |
61 | |
62 | NUL terminated string, length will be determined with C<strlen> |
63 | |
64 | =item PVN |
65 | |
66 | A fixed length thing, given as a [pointer, length] pair. If you know the |
67 | length of a string at compile time you may use this instead of I<PV> |
68 | |
9a7df4f2 |
69 | =item SV |
cea00dc5 |
70 | |
71 | A B<mortal> SV. |
72 | |
3414cef0 |
73 | =item YES |
74 | |
75 | Truth. (C<PL_sv_yes>) The value is not needed (and ignored). |
76 | |
77 | =item NO |
78 | |
79 | Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). |
80 | |
81 | =item UNDEF |
82 | |
83 | C<undef>. The value of the macro is not needed. |
84 | |
af6c647e |
85 | =back |
86 | |
87 | =head1 FUNCTIONS |
88 | |
89 | =over 4 |
90 | |
91 | =cut |
92 | |
d7f97632 |
93 | if ($] >= 5.006) { |
94 | eval "use warnings; 1" or die $@; |
95 | } |
af6c647e |
96 | use strict; |
4f2c4fd8 |
97 | use vars '$is_perl56'; |
af6c647e |
98 | use Carp; |
99 | |
4f2c4fd8 |
100 | $is_perl56 = ($] < 5.007 && $] > 5.005_50); |
101 | |
af6c647e |
102 | use Exporter; |
af6c647e |
103 | use Text::Wrap; |
104 | $Text::Wrap::huge = 'overflow'; |
105 | $Text::Wrap::columns = 80; |
106 | |
107 | @ISA = 'Exporter'; |
af6c647e |
108 | |
109 | %EXPORT_TAGS = ( 'all' => [ qw( |
110 | XS_constant constant_types return_clause memEQ_clause C_stringify |
9a7df4f2 |
111 | C_constant autoload WriteConstants WriteMakefileSnippet |
af6c647e |
112 | ) ] ); |
113 | |
114 | @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
115 | |
6557ab03 |
116 | # '' is used as a flag to indicate non-ascii macro names, and hence the need |
117 | # to pass in the utf8 on/off flag. |
af6c647e |
118 | %XS_Constant = ( |
6557ab03 |
119 | '' => '', |
cea00dc5 |
120 | IV => 'PUSHi(iv)', |
121 | UV => 'PUSHu((UV)iv)', |
122 | NV => 'PUSHn(nv)', |
123 | PV => 'PUSHp(pv, strlen(pv))', |
124 | PVN => 'PUSHp(pv, iv)', |
125 | SV => 'PUSHs(sv)', |
126 | YES => 'PUSHs(&PL_sv_yes)', |
127 | NO => 'PUSHs(&PL_sv_no)', |
19d75eda |
128 | UNDEF => '', # implicit undef |
af6c647e |
129 | ); |
130 | |
131 | %XS_TypeSet = ( |
cea00dc5 |
132 | IV => '*iv_return =', |
133 | UV => '*iv_return = (IV)', |
134 | NV => '*nv_return =', |
135 | PV => '*pv_return =', |
136 | PVN => ['*pv_return =', '*iv_return = (IV)'], |
137 | SV => '*sv_return = ', |
19d75eda |
138 | YES => undef, |
139 | NO => undef, |
140 | UNDEF => undef, |
af6c647e |
141 | ); |
142 | |
143 | |
144 | =item C_stringify NAME |
145 | |
6557ab03 |
146 | A function which returns a 7 bit ASCII correctly \ escaped version of the |
147 | string passed suitable for C's "" or ''. It will die if passed Unicode |
148 | characters. |
af6c647e |
149 | |
150 | =cut |
151 | |
152 | # Hopefully make a happy C identifier. |
153 | sub C_stringify { |
154 | local $_ = shift; |
6d79cad2 |
155 | return unless defined $_; |
4f2c4fd8 |
156 | # grr 5.6.1 |
157 | confess "Wide character in '$_' intended as a C identifier" |
158 | if tr/\0-\377// != length; |
159 | # grr 5.6.1 moreso because its regexps will break on data that happens to |
160 | # be utf8, which includes my 8 bit test cases. |
161 | $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56; |
af6c647e |
162 | s/\\/\\\\/g; |
163 | s/([\"\'])/\\$1/g; # Grr. fix perl mode. |
6d79cad2 |
164 | s/\n/\\n/g; # Ensure newlines don't end up in octal |
165 | s/\r/\\r/g; |
3414cef0 |
166 | s/\t/\\t/g; |
167 | s/\f/\\f/g; |
168 | s/\a/\\a/g; |
6557ab03 |
169 | s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; |
d7f97632 |
170 | unless ($] < 5.006) { |
6557ab03 |
171 | # This will elicit a warning on 5.005_03 about [: :] being reserved unless |
172 | # I cheat |
173 | my $cheat = '([[:^print:]])'; |
174 | s/$cheat/sprintf "\\%03o", ord $1/ge; |
175 | } else { |
176 | require POSIX; |
177 | s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; |
178 | } |
179 | $_; |
180 | } |
181 | |
182 | =item perl_stringify NAME |
183 | |
184 | A function which returns a 7 bit ASCII correctly \ escaped version of the |
185 | string passed suitable for a perl "" string. |
186 | |
187 | =cut |
188 | |
189 | # Hopefully make a happy perl identifier. |
190 | sub perl_stringify { |
191 | local $_ = shift; |
192 | return unless defined $_; |
193 | s/\\/\\\\/g; |
194 | s/([\"\'])/\\$1/g; # Grr. fix perl mode. |
195 | s/\n/\\n/g; # Ensure newlines don't end up in octal |
196 | s/\r/\\r/g; |
197 | s/\t/\\t/g; |
198 | s/\f/\\f/g; |
199 | s/\a/\\a/g; |
6557ab03 |
200 | unless ($] < 5.006) { |
4f2c4fd8 |
201 | if ($] > 5.007) { |
202 | s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; |
203 | } else { |
204 | # Grr 5.6.1. And I don't think I can use utf8; to force the regexp |
205 | # because 5.005_03 will fail. |
206 | # This is grim, but I also can't split on // |
207 | my $copy; |
208 | foreach my $index (0 .. length ($_) - 1) { |
209 | my $char = substr ($_, $index, 1); |
210 | $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; |
211 | } |
212 | $_ = $copy; |
213 | } |
6557ab03 |
214 | # This will elicit a warning on 5.005_03 about [: :] being reserved unless |
d7f97632 |
215 | # I cheat |
216 | my $cheat = '([[:^print:]])'; |
217 | s/$cheat/sprintf "\\%03o", ord $1/ge; |
218 | } else { |
4f2c4fd8 |
219 | # Turns out "\x{}" notation only arrived with 5.6 |
220 | s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; |
d7f97632 |
221 | require POSIX; |
222 | s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; |
223 | } |
af6c647e |
224 | $_; |
225 | } |
226 | |
227 | =item constant_types |
228 | |
229 | A function returning a single scalar with C<#define> definitions for the |
230 | constants used internally between the generated C and XS functions. |
231 | |
232 | =cut |
233 | |
234 | sub constant_types () { |
235 | my $start = 1; |
236 | my @lines; |
237 | push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; |
238 | push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; |
239 | foreach (sort keys %XS_Constant) { |
6557ab03 |
240 | next if $_ eq ''; |
af6c647e |
241 | push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; |
242 | } |
243 | push @lines, << 'EOT'; |
244 | |
245 | #ifndef NVTYPE |
246 | typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ |
247 | #endif |
d7f97632 |
248 | #ifndef aTHX_ |
249 | #define aTHX_ /* 5.6 or later define this for threading support. */ |
250 | #endif |
251 | #ifndef pTHX_ |
252 | #define pTHX_ /* 5.6 or later define this for threading support. */ |
253 | #endif |
af6c647e |
254 | EOT |
255 | |
256 | return join '', @lines; |
257 | } |
258 | |
259 | =item memEQ_clause NAME, CHECKED_AT, INDENT |
260 | |
261 | A function to return a suitable C C<if> statement to check whether I<NAME> |
262 | is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it |
263 | is used to avoid C<memEQ> for short names, or to generate a comment to |
264 | highlight the position of the character in the C<switch> statement. |
265 | |
7783f9f6 |
266 | If I<CHECKED_AT> is a reference to a scalar, then instead it gives |
267 | the characters pre-checked at the beginning, (and the number of chars by |
268 | which the C variable name has been advanced. These need to be chopped from |
269 | the front of I<NAME>). |
270 | |
af6c647e |
271 | =cut |
272 | |
273 | sub memEQ_clause { |
274 | # if (memEQ(name, "thingy", 6)) { |
275 | # Which could actually be a character comparison or even "" |
276 | my ($name, $checked_at, $indent) = @_; |
277 | $indent = ' ' x ($indent || 4); |
7783f9f6 |
278 | my $front_chop; |
279 | if (ref $checked_at) { |
280 | # regexp won't work on 5.6.1 without use utf8; in turn that won't work |
281 | # on 5.005_03. |
282 | substr ($name, 0, length $$checked_at,) = ''; |
283 | $front_chop = C_stringify ($$checked_at); |
284 | undef $checked_at; |
285 | } |
af6c647e |
286 | my $len = length $name; |
287 | |
288 | if ($len < 2) { |
289 | return $indent . "{\n" if (defined $checked_at and $checked_at == 0); |
290 | # We didn't switch, drop through to the code for the 2 character string |
291 | $checked_at = 1; |
292 | } |
293 | if ($len < 3 and defined $checked_at) { |
294 | my $check; |
295 | if ($checked_at == 1) { |
296 | $check = 0; |
297 | } elsif ($checked_at == 0) { |
298 | $check = 1; |
299 | } |
300 | if (defined $check) { |
301 | my $char = C_stringify (substr $name, $check, 1); |
302 | return $indent . "if (name[$check] == '$char') {\n"; |
303 | } |
304 | } |
7783f9f6 |
305 | if (($len == 2 and !defined $checked_at) |
306 | or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { |
307 | my $char1 = C_stringify (substr $name, 0, 1); |
308 | my $char2 = C_stringify (substr $name, 1, 1); |
309 | return $indent . "if (name[0] == '$char1' && name[1] == '$char2') {\n"; |
310 | } |
311 | if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { |
312 | my $char1 = C_stringify (substr $name, 0, 1); |
313 | my $char2 = C_stringify (substr $name, 2, 1); |
314 | return $indent . "if (name[0] == '$char1' && name[2] == '$char2') {\n"; |
315 | } |
316 | |
317 | my $pointer = '^'; |
318 | my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; |
319 | if ($have_checked_last) { |
320 | # Checked at the last character, so no need to memEQ it. |
321 | $pointer = C_stringify (chop $name); |
322 | $len--; |
323 | } |
324 | |
af6c647e |
325 | $name = C_stringify ($name); |
326 | my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n"; |
7783f9f6 |
327 | # Put a little ^ under the letter we checked at |
328 | # Screws up for non printable and non-7 bit stuff, but that's too hard to |
329 | # get right. |
330 | if (defined $checked_at) { |
331 | $body .= $indent . "/* ". (' ' x $checked_at) . $pointer |
332 | . (' ' x ($len - $checked_at + length $len)) . " */\n"; |
333 | } elsif (defined $front_chop) { |
334 | $body .= $indent . "/* $front_chop" |
335 | . (' ' x ($len + 1 + length $len)) . " */\n"; |
336 | } |
af6c647e |
337 | return $body; |
338 | } |
339 | |
cea00dc5 |
340 | =item assign INDENT, TYPE, PRE, POST, VALUE... |
6d79cad2 |
341 | |
342 | A function to return a suitable assignment clause. If I<TYPE> is aggregate |
343 | (eg I<PVN> expects both pointer and length) then there should be multiple |
cea00dc5 |
344 | I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets |
6557ab03 |
345 | of C code to proceed and follow the assignment. I<PRE> will be at the start |
cea00dc5 |
346 | of a block, so variables may be defined in it. |
6d79cad2 |
347 | |
348 | =cut |
349 | |
350 | # Hmm. value undef to to NOTDEF? value () to do NOTFOUND? |
351 | |
352 | sub assign { |
353 | my $indent = shift; |
354 | my $type = shift; |
cea00dc5 |
355 | my $pre = shift; |
356 | my $post = shift || ''; |
6d79cad2 |
357 | my $clause; |
cea00dc5 |
358 | my $close; |
359 | if ($pre) { |
360 | chomp $pre; |
361 | $clause = $indent . "{\n$pre"; |
362 | $clause .= ";" unless $pre =~ /;$/; |
363 | $clause .= "\n"; |
364 | $close = "$indent}\n"; |
365 | $indent .= " "; |
366 | } |
6557ab03 |
367 | confess "undef \$type" unless defined $type; |
368 | confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type}; |
3414cef0 |
369 | my $typeset = $XS_TypeSet{$type}; |
6d79cad2 |
370 | if (ref $typeset) { |
371 | die "Type $type is aggregate, but only single value given" |
372 | if @_ == 1; |
373 | foreach (0 .. $#$typeset) { |
374 | $clause .= $indent . "$typeset->[$_] $_[$_];\n"; |
375 | } |
3414cef0 |
376 | } elsif (defined $typeset) { |
6d79cad2 |
377 | die "Aggregate value given for type $type" |
378 | if @_ > 1; |
379 | $clause .= $indent . "$typeset $_[0];\n"; |
380 | } |
cea00dc5 |
381 | chomp $post; |
382 | if (length $post) { |
383 | $clause .= "$post"; |
384 | $clause .= ";" unless $post =~ /;$/; |
385 | $clause .= "\n"; |
a2c454fa |
386 | } |
6d79cad2 |
387 | $clause .= "${indent}return PERL_constant_IS$type;\n"; |
cea00dc5 |
388 | $clause .= $close if $close; |
6d79cad2 |
389 | return $clause; |
390 | } |
391 | |
5dc6f178 |
392 | =item return_clause |
393 | |
6557ab03 |
394 | return_clause ITEM, INDENT |
af6c647e |
395 | |
6557ab03 |
396 | A function to return a suitable C<#ifdef> clause. I<ITEM> is a hashref |
397 | (as passed to C<C_constant> and C<match_clause>. I<INDENT> is the number |
398 | of spaces to indent, defaulting to 6. |
af6c647e |
399 | |
400 | =cut |
401 | |
6557ab03 |
402 | sub return_clause ($$) { |
af6c647e |
403 | ##ifdef thingy |
404 | # *iv_return = thingy; |
405 | # return PERL_constant_ISIV; |
406 | ##else |
407 | # return PERL_constant_NOTDEF; |
408 | ##endif |
6557ab03 |
409 | my ($item, $indent) = @_; |
410 | |
411 | my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post, $type) |
412 | = @$item{qw (name value macro default pre post def_pre def_post type)}; |
413 | $value = $name unless defined $value; |
414 | $macro = $name unless defined $macro; |
415 | |
af6c647e |
416 | $macro = $value unless defined $macro; |
417 | $indent = ' ' x ($indent || 6); |
6557ab03 |
418 | unless ($type) { |
419 | # use Data::Dumper; print STDERR Dumper ($item); |
420 | confess "undef \$type"; |
421 | } |
af6c647e |
422 | |
6d79cad2 |
423 | my $clause; |
af6c647e |
424 | |
6d79cad2 |
425 | ##ifdef thingy |
426 | if (ref $macro) { |
427 | $clause = $macro->[0]; |
72f7b9a1 |
428 | } elsif ($macro ne "1") { |
6d79cad2 |
429 | $clause = "#ifdef $macro\n"; |
af6c647e |
430 | } |
6d79cad2 |
431 | |
432 | # *iv_return = thingy; |
433 | # return PERL_constant_ISIV; |
cea00dc5 |
434 | $clause .= assign ($indent, $type, $pre, $post, |
435 | ref $value ? @$value : $value); |
6d79cad2 |
436 | |
72f7b9a1 |
437 | if (ref $macro or $macro ne "1") { |
438 | ##else |
439 | $clause .= "#else\n"; |
a2c454fa |
440 | |
72f7b9a1 |
441 | # return PERL_constant_NOTDEF; |
442 | if (!defined $default) { |
443 | $clause .= "${indent}return PERL_constant_NOTDEF;\n"; |
444 | } else { |
445 | my @default = ref $default ? @$default : $default; |
446 | $type = shift @default; |
447 | $clause .= assign ($indent, $type, $def_pre, $def_post, @default); |
448 | } |
6d79cad2 |
449 | |
72f7b9a1 |
450 | ##endif |
451 | if (ref $macro) { |
452 | $clause .= $macro->[1]; |
453 | } else { |
454 | $clause .= "#endif\n"; |
455 | } |
6d79cad2 |
456 | } |
6557ab03 |
457 | return $clause; |
458 | } |
459 | |
460 | =pod |
461 | |
462 | XXX document me |
463 | |
464 | =cut |
465 | |
466 | sub match_clause { |
467 | # $offset defined if we have checked an offset. |
468 | my ($item, $offset, $indent) = @_; |
469 | $indent = ' ' x ($indent || 4); |
470 | my $body = ''; |
471 | my ($no, $yes, $either, $name, $inner_indent); |
472 | if (ref $item eq 'ARRAY') { |
473 | ($yes, $no) = @$item; |
474 | $either = $yes || $no; |
475 | confess "$item is $either expecting hashref in [0] || [1]" |
476 | unless ref $either eq 'HASH'; |
477 | $name = $either->{name}; |
478 | } else { |
479 | confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" |
480 | if $item->{utf8}; |
481 | $name = $item->{name}; |
482 | $inner_indent = $indent; |
483 | } |
484 | |
485 | $body .= memEQ_clause ($name, $offset, length $indent); |
486 | if ($yes) { |
487 | $body .= $indent . " if (utf8) {\n"; |
488 | } elsif ($no) { |
489 | $body .= $indent . " if (!utf8) {\n"; |
490 | } |
491 | if ($either) { |
492 | $body .= return_clause ($either, 4 + length $indent); |
493 | if ($yes and $no) { |
494 | $body .= $indent . " } else {\n"; |
495 | $body .= return_clause ($no, 4 + length $indent); |
496 | } |
4f2c4fd8 |
497 | $body .= $indent . " }\n"; |
6557ab03 |
498 | } else { |
499 | $body .= return_clause ($item, 2 + length $indent); |
500 | } |
501 | $body .= $indent . "}\n"; |
af6c647e |
502 | } |
503 | |
8ac27563 |
504 | =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM... |
505 | |
506 | An internal function to generate a suitable C<switch> clause, called by |
507 | C<C_constant> I<ITEM>s are in the hash ref format as given in the description |
508 | of C<C_constant>, and must all have the names of the same length, given by |
509 | I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash, |
510 | keyed by name, values being the hashrefs in the I<ITEM> list. |
511 | (No parameters are modified, and there can be keys in the I<ITEMHASH> that |
512 | are not in the list of I<ITEM>s without causing problems). |
513 | |
514 | =cut |
515 | |
516 | sub switch_clause { |
517 | my ($indent, $comment, $namelen, $items, @items) = @_; |
518 | $indent = ' ' x ($indent || 2); |
a2c454fa |
519 | |
8ac27563 |
520 | my @names = sort map {$_->{name}} @items; |
521 | my $leader = $indent . '/* '; |
522 | my $follower = ' ' x length $leader; |
523 | my $body = $indent . "/* Names all of length $namelen. */\n"; |
524 | if ($comment) { |
525 | $body = wrap ($leader, $follower, $comment) . "\n"; |
526 | $leader = $follower; |
527 | } |
6557ab03 |
528 | my @safe_names = @names; |
529 | foreach (@safe_names) { |
4f2c4fd8 |
530 | confess sprintf "Name '$_' is length %d, not $namelen", length |
531 | unless length == $namelen; |
532 | # Argh. 5.6.1 |
533 | # next unless tr/A-Za-z0-9_//c; |
534 | next if tr/A-Za-z0-9_// == length; |
6557ab03 |
535 | $_ = '"' . perl_stringify ($_) . '"'; |
536 | # Ensure that the enclosing C comment doesn't end |
537 | # by turning */ into *" . "/ |
538 | s!\*\/!\*"."/!gs; |
539 | # gcc -Wall doesn't like finding /* inside a comment |
540 | s!\/\*!/"."\*!gs; |
541 | } |
542 | $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; |
8ac27563 |
543 | # Figure out what to switch on. |
544 | # (RMS, Spread of jump table, Position, Hashref) |
545 | my @best = (1e38, ~0); |
7783f9f6 |
546 | # Prefer the last character over the others. (As it lets us shortern the |
547 | # memEQ clause at no cost). |
548 | foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { |
8ac27563 |
549 | my ($min, $max) = (~0, 0); |
550 | my %spread; |
4f2c4fd8 |
551 | if ($is_perl56) { |
552 | # Need proper Unicode preserving hash keys for bytes in range 128-255 |
553 | # here too, for some reason. grr 5.6.1 yet again. |
554 | tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; |
555 | } |
8ac27563 |
556 | foreach (@names) { |
557 | my $char = substr $_, $i, 1; |
558 | my $ord = ord $char; |
4f2c4fd8 |
559 | confess "char $ord is out of range" if $ord > 255; |
a2c454fa |
560 | $max = $ord if $ord > $max; |
8ac27563 |
561 | $min = $ord if $ord < $min; |
562 | push @{$spread{$char}}, $_; |
563 | # warn "$_ $char"; |
564 | } |
565 | # I'm going to pick the character to split on that minimises the root |
566 | # mean square of the number of names in each case. Normally this should |
567 | # be the one with the most keys, but it may pick a 7 where the 8 has |
568 | # one long linear search. I'm not sure if RMS or just sum of squares is |
569 | # actually better. |
570 | # $max and $min are for the tie-breaker if the root mean squares match. |
571 | # Assuming that the compiler may be building a jump table for the |
572 | # switch() then try to minimise the size of that jump table. |
573 | # Finally use < not <= so that if it still ties the earliest part of |
574 | # the string wins. Because if that passes but the memEQ fails, it may |
575 | # only need the start of the string to bin the choice. |
576 | # I think. But I'm micro-optimising. :-) |
7783f9f6 |
577 | # OK. Trump that. Now favour the last character of the string, before the |
578 | # rest. |
8ac27563 |
579 | my $ss; |
580 | $ss += @$_ * @$_ foreach values %spread; |
581 | my $rms = sqrt ($ss / keys %spread); |
582 | if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { |
583 | @best = ($rms, $max - $min, $i, \%spread); |
584 | } |
585 | } |
7783f9f6 |
586 | confess "Internal error. Failed to pick a switch point for @names" |
8ac27563 |
587 | unless defined $best[2]; |
588 | # use Data::Dumper; print Dumper (@best); |
589 | my ($offset, $best) = @best[2,3]; |
590 | $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; |
7783f9f6 |
591 | |
592 | my $do_front_chop = $offset == 0 && $namelen > 2; |
593 | if ($do_front_chop) { |
594 | $body .= $indent . "switch (*name++) {\n"; |
595 | } else { |
596 | $body .= $indent . "switch (name[$offset]) {\n"; |
597 | } |
8ac27563 |
598 | foreach my $char (sort keys %$best) { |
4f2c4fd8 |
599 | confess sprintf "'$char' is %d bytes long, not 1", length $char |
600 | if length ($char) != 1; |
601 | confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; |
8ac27563 |
602 | $body .= $indent . "case '" . C_stringify ($char) . "':\n"; |
603 | foreach my $name (sort @{$best->{$char}}) { |
604 | my $thisone = $items->{$name}; |
6557ab03 |
605 | # warn "You are here"; |
7783f9f6 |
606 | if ($do_front_chop) { |
607 | $body .= match_clause ($thisone, \$char, 2 + length $indent); |
608 | } else { |
609 | $body .= match_clause ($thisone, $offset, 2 + length $indent); |
610 | } |
8ac27563 |
611 | } |
612 | $body .= $indent . " break;\n"; |
613 | } |
614 | $body .= $indent . "}\n"; |
615 | return $body; |
616 | } |
617 | |
af6c647e |
618 | =item params WHAT |
619 | |
620 | An internal function. I<WHAT> should be a hashref of types the constant |
72f7b9a1 |
621 | function will return. I<params> returns a hashref keyed IV NV PV SV to show |
622 | which combination of pointers will be needed in the C argument list. |
af6c647e |
623 | |
624 | =cut |
625 | |
626 | sub params { |
627 | my $what = shift; |
628 | foreach (sort keys %$what) { |
629 | warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; |
630 | } |
72f7b9a1 |
631 | my $params = {}; |
6557ab03 |
632 | $params->{''} = 1 if $what->{''}; |
72f7b9a1 |
633 | $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; |
634 | $params->{NV} = 1 if $what->{NV}; |
635 | $params->{PV} = 1 if $what->{PV} || $what->{PVN}; |
636 | $params->{SV} = 1 if $what->{SV}; |
637 | return $params; |
af6c647e |
638 | } |
639 | |
a2c454fa |
640 | =item dump_names |
0addb26a |
641 | |
9a7df4f2 |
642 | dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM... |
6d79cad2 |
643 | |
644 | An internal function to generate the embedded perl code that will regenerate |
9a7df4f2 |
645 | the constant subroutines. I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the |
646 | same as for C_constant. I<INDENT> is treated as number of spaces to indent |
647 | by. I<OPTIONS> is a hashref of options. Currently only C<declare_types> is |
648 | recognised. If the value is true a C<$types> is always declared in the perl |
649 | code generated, if defined and false never declared, and if undefined C<$types> |
650 | is only declared if the values in I<TYPES> as passed in cannot be inferred from |
651 | I<DEFAULT_TYPES> and the I<ITEM>s. |
6d79cad2 |
652 | |
653 | =cut |
654 | |
655 | sub dump_names { |
9a7df4f2 |
656 | my ($default_type, $what, $indent, $options, @items) = @_; |
657 | my $declare_types = $options->{declare_types}; |
658 | $indent = ' ' x ($indent || 0); |
659 | |
660 | my $result; |
661 | my (@simple, @complex, %used_types); |
6d79cad2 |
662 | foreach (@items) { |
9a7df4f2 |
663 | my $type; |
664 | if (ref $_) { |
665 | $type = $_->{type} || $default_type; |
6557ab03 |
666 | if ($_->{utf8}) { |
667 | # For simplicity always skip the bytes case, and reconstitute this entry |
668 | # from its utf8 twin. |
669 | next if $_->{utf8} eq 'no'; |
670 | # Copy the hashref, as we don't want to mess with the caller's hashref. |
671 | $_ = {%$_}; |
4f2c4fd8 |
672 | unless ($is_perl56) { |
673 | utf8::decode ($_->{name}); |
674 | } else { |
675 | $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; |
676 | } |
6557ab03 |
677 | delete $_->{utf8}; |
678 | } |
9a7df4f2 |
679 | } else { |
680 | $_ = {name=>$_}; |
681 | $type = $default_type; |
682 | } |
683 | $used_types{$type}++; |
4f2c4fd8 |
684 | if ($type eq $default_type |
685 | # grr 5.6.1 |
686 | and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) |
6d79cad2 |
687 | and !defined ($_->{macro}) and !defined ($_->{value}) |
cea00dc5 |
688 | and !defined ($_->{default}) and !defined ($_->{pre}) |
689 | and !defined ($_->{post}) and !defined ($_->{def_pre}) |
690 | and !defined ($_->{def_post})) { |
6d79cad2 |
691 | # It's the default type, and the name consists only of A-Za-z0-9_ |
692 | push @simple, $_->{name}; |
693 | } else { |
694 | push @complex, $_; |
695 | } |
696 | } |
6d79cad2 |
697 | |
9a7df4f2 |
698 | if (!defined $declare_types) { |
699 | # Do they pass in any types we weren't already using? |
700 | foreach (keys %$what) { |
701 | next if $used_types{$_}; |
702 | $declare_types++; # Found one in $what that wasn't used. |
703 | last; # And one is enough to terminate this loop |
704 | } |
705 | } |
706 | if ($declare_types) { |
707 | $result = $indent . 'my $types = {map {($_, 1)} qw(' |
708 | . join (" ", sort keys %$what) . ")};\n"; |
709 | } |
710 | $result .= wrap ($indent . "my \@names = (qw(", |
711 | $indent . " ", join (" ", sort @simple) . ")"); |
6d79cad2 |
712 | if (@complex) { |
713 | foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { |
6557ab03 |
714 | my $name = perl_stringify $item->{name}; |
9a7df4f2 |
715 | my $line = ",\n$indent {name=>\"$name\""; |
6d79cad2 |
716 | $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; |
cea00dc5 |
717 | foreach my $thing (qw (macro value default pre post def_pre def_post)) { |
718 | my $value = $item->{$thing}; |
719 | if (defined $value) { |
720 | if (ref $value) { |
721 | $line .= ", $thing=>[\"" |
6557ab03 |
722 | . join ('", "', map {perl_stringify $_} @$value) . '"]'; |
cea00dc5 |
723 | } else { |
6557ab03 |
724 | $line .= ", $thing=>\"" . perl_stringify($value) . "\""; |
cea00dc5 |
725 | } |
6d79cad2 |
726 | } |
727 | } |
728 | $line .= "}"; |
729 | # Ensure that the enclosing C comment doesn't end |
730 | # by turning */ into *" . "/ |
731 | $line =~ s!\*\/!\*" . "/!gs; |
3414cef0 |
732 | # gcc -Wall doesn't like finding /* inside a comment |
733 | $line =~ s!\/\*!/" . "\*!gs; |
6d79cad2 |
734 | $result .= $line; |
735 | } |
736 | } |
737 | $result .= ");\n"; |
738 | |
9a7df4f2 |
739 | $result; |
740 | } |
741 | |
742 | |
743 | =item dogfood |
744 | |
745 | dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... |
746 | |
747 | An internal function to generate the embedded perl code that will regenerate |
748 | the constant subroutines. Parameters are the same as for C_constant. |
749 | |
750 | =cut |
751 | |
752 | sub dogfood { |
753 | my ($package, $subname, $default_type, $what, $indent, $breakout, @items) |
754 | = @_; |
755 | my $result = <<"EOT"; |
756 | /* When generated this function returned values for the list of names given |
757 | in this section of perl code. Rather than manually editing these functions |
758 | to add or remove constants, which would result in this comment and section |
759 | of code becoming inaccurate, we recommend that you edit this section of |
760 | code, and use it to regenerate a new set of constant functions which you |
761 | then use to replace the originals. |
762 | |
763 | Regenerate these constant functions by feeding this entire source file to |
764 | perl -x |
765 | |
766 | #!$^X -w |
767 | use ExtUtils::Constant qw (constant_types C_constant XS_constant); |
768 | |
769 | EOT |
770 | $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items); |
6d79cad2 |
771 | $result .= <<'EOT'; |
772 | |
773 | print constant_types(); # macro defs |
774 | EOT |
6557ab03 |
775 | $package = perl_stringify($package); |
6d79cad2 |
776 | $result .= |
777 | "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; |
778 | # The form of the indent parameter isn't defined. (Yet) |
779 | if (defined $indent) { |
780 | require Data::Dumper; |
781 | $Data::Dumper::Terse=1; |
8ac27563 |
782 | $Data::Dumper::Terse=1; # Not used once. :-) |
6d79cad2 |
783 | chomp ($indent = Data::Dumper::Dumper ($indent)); |
784 | $result .= $indent; |
785 | } else { |
786 | $result .= 'undef'; |
787 | } |
8ac27563 |
788 | $result .= ", $breakout" . ', @names) ) { |
6d79cad2 |
789 | print $_, "\n"; # C constant subs |
790 | } |
791 | print "#### XS Section:\n"; |
792 | print XS_constant ("' . $package . '", $types); |
793 | __END__ |
794 | */ |
795 | |
796 | '; |
a2c454fa |
797 | |
6d79cad2 |
798 | $result; |
799 | } |
800 | |
a2c454fa |
801 | =item C_constant |
0addb26a |
802 | |
8ac27563 |
803 | C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... |
af6c647e |
804 | |
805 | A function that returns a B<list> of C subroutine definitions that return |
806 | the value and type of constants when passed the name by the XS wrapper. |
807 | I<ITEM...> gives a list of constant names. Each can either be a string, |
808 | which is taken as a C macro name, or a reference to a hash with the following |
809 | keys |
810 | |
811 | =over 8 |
812 | |
813 | =item name |
814 | |
815 | The name of the constant, as seen by the perl code. |
816 | |
817 | =item type |
818 | |
819 | The type of the constant (I<IV>, I<NV> etc) |
820 | |
821 | =item value |
822 | |
823 | A C expression for the value of the constant, or a list of C expressions if |
824 | the type is aggregate. This defaults to the I<name> if not given. |
825 | |
826 | =item macro |
827 | |
828 | The C pre-processor macro to use in the C<#ifdef>. This defaults to the |
6d79cad2 |
829 | I<name>, and is mainly used if I<value> is an C<enum>. If a reference an |
830 | array is passed then the first element is used in place of the C<#ifdef> |
831 | line, and the second element in place of the C<#endif>. This allows |
832 | pre-processor constructions such as |
833 | |
834 | #if defined (foo) |
835 | #if !defined (bar) |
836 | ... |
837 | #endif |
838 | #endif |
839 | |
840 | to be used to determine if a constant is to be defined. |
841 | |
72f7b9a1 |
842 | A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> |
843 | test is omitted. |
844 | |
6d79cad2 |
845 | =item default |
846 | |
847 | Default value to use (instead of C<croak>ing with "your vendor has not |
848 | defined...") to return if the macro isn't defined. Specify a reference to |
849 | an array with type followed by value(s). |
af6c647e |
850 | |
cea00dc5 |
851 | =item pre |
852 | |
853 | C code to use before the assignment of the value of the constant. This allows |
854 | you to use temporary variables to extract a value from part of a C<struct> |
855 | and return this as I<value>. This C code is places at the start of a block, |
856 | so you can declare variables in it. |
857 | |
858 | =item post |
859 | |
860 | C code to place between the assignment of value (to a temporary) and the |
861 | return from the function. This allows you to clear up anything in I<pre>. |
862 | Rarely needed. |
863 | |
864 | =item def_pre |
865 | =item def_post |
866 | |
867 | Equivalents of I<pre> and I<post> for the default value. |
868 | |
6557ab03 |
869 | =item utf8 |
870 | |
871 | Generated internally. Is zero or undefined if name is 7 bit ASCII, |
872 | "no" if the name is 8 bit (and so should only match if SvUTF8() is false), |
873 | "yes" if the name is utf8 encoded. |
874 | |
875 | The internals automatically clone any name with characters 128-255 but none |
876 | 256+ (ie one that could be either in bytes or utf8) into a second entry |
877 | which is utf8 encoded. |
878 | |
af6c647e |
879 | =back |
880 | |
6d79cad2 |
881 | I<PACKAGE> is the name of the package, and is only used in comments inside the |
882 | generated C code. |
883 | |
884 | The next 5 arguments can safely be given as C<undef>, and are mainly used |
af6c647e |
885 | for recursion. I<SUBNAME> defaults to C<constant> if undefined. |
886 | |
887 | I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their |
888 | type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma |
889 | separated list of types that the C subroutine C<constant> will generate or as |
890 | a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not |
891 | present, as will any types given in the list of I<ITEM>s. The resultant list |
892 | should be the same list of types that C<XS_constant> is given. [Otherwise |
893 | C<XS_constant> and C<C_constant> may differ in the number of parameters to the |
894 | constant function. I<INDENT> is currently unused and ignored. In future it may |
895 | be used to pass in information used to change the C indentation style used.] |
896 | The best way to maintain consistency is to pass in a hash reference and let |
897 | this function update it. |
898 | |
8ac27563 |
899 | I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there |
900 | are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code |
901 | to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for |
902 | example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is |
903 | 3. A single C<ITEM> is always inlined. |
af6c647e |
904 | |
905 | =cut |
906 | |
8ac27563 |
907 | # The parameter now BREAKOUT was previously documented as: |
908 | # |
909 | # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of |
910 | # this length, and that the constant name passed in by perl is checked and |
911 | # also of this length. It is used during recursion, and should be C<undef> |
912 | # unless the caller has checked all the lengths during code generation, and |
913 | # the generated subroutine is only to be called with a name of this length. |
914 | # |
915 | # As you can see it now performs this function during recursion by being a |
916 | # scalar reference. |
917 | |
af6c647e |
918 | sub C_constant { |
8ac27563 |
919 | my ($package, $subname, $default_type, $what, $indent, $breakout, @items) |
920 | = @_; |
6d79cad2 |
921 | $package ||= 'Foo'; |
af6c647e |
922 | $subname ||= 'constant'; |
923 | # I'm not using this. But a hashref could be used for full formatting without |
924 | # breaking this API |
6d79cad2 |
925 | # $indent ||= 0; |
72f7b9a1 |
926 | |
927 | my ($namelen, $items); |
928 | if (ref $breakout) { |
929 | # We are called recursively. We trust @items to be normalised, $what to |
930 | # be a hashref, and pinch %$items from our parent to save recalculation. |
931 | ($namelen, $items) = @$breakout; |
932 | } else { |
4f2c4fd8 |
933 | if ($is_perl56) { |
934 | # Need proper Unicode preserving hash keys. |
935 | $items = {}; |
936 | tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; |
937 | } |
72f7b9a1 |
938 | $breakout ||= 3; |
939 | $default_type ||= 'IV'; |
940 | if (!ref $what) { |
941 | # Convert line of the form IV,UV,NV to hash |
942 | $what = {map {$_ => 1} split /,\s*/, ($what || '')}; |
943 | # Figure out what types we're dealing with, and assign all unknowns to the |
944 | # default type |
af6c647e |
945 | } |
6557ab03 |
946 | my @new_items; |
947 | foreach my $orig (@items) { |
948 | my ($name, $item); |
949 | if (ref $orig) { |
72f7b9a1 |
950 | # Make a copy which is a normalised version of the ref passed in. |
6557ab03 |
951 | $name = $orig->{name}; |
952 | my ($type, $macro, $value) = @$orig{qw (type macro value)}; |
72f7b9a1 |
953 | $type ||= $default_type; |
954 | $what->{$type} = 1; |
6557ab03 |
955 | $item = {name=>$name, type=>$type}; |
72f7b9a1 |
956 | |
957 | undef $macro if defined $macro and $macro eq $name; |
6557ab03 |
958 | $item->{macro} = $macro if defined $macro; |
72f7b9a1 |
959 | undef $value if defined $value and $value eq $name; |
6557ab03 |
960 | $item->{value} = $value if defined $value; |
72f7b9a1 |
961 | foreach my $key (qw(default pre post def_pre def_post)) { |
962 | my $value = $orig->{$key}; |
6557ab03 |
963 | $item->{$key} = $value if defined $value; |
72f7b9a1 |
964 | # warn "$key $value"; |
965 | } |
966 | } else { |
6557ab03 |
967 | $name = $orig; |
968 | $item = {name=>$name, type=>$default_type}; |
72f7b9a1 |
969 | $what->{$default_type} = 1; |
970 | } |
6557ab03 |
971 | warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}}; |
4f2c4fd8 |
972 | # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c |
973 | # doesn't work. Upgrade to 5.8 |
974 | # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { |
975 | if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50) { |
6557ab03 |
976 | # No characters outside 7 bit ASCII. |
977 | if (exists $items->{$name}) { |
978 | die "Multiple definitions for macro $name"; |
979 | } |
980 | $items->{$name} = $item; |
981 | } else { |
982 | # No characters outside 8 bit. This is hardest. |
983 | if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { |
984 | confess "Unexpected ASCII definition for macro $name"; |
985 | } |
4f2c4fd8 |
986 | # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; |
987 | # if ($name !~ tr/\0-\377//c) { |
988 | if ($name =~ tr/\0-\377// == length $name) { |
989 | # if ($] < 5.007) { |
990 | # $name = pack "C*", unpack "U*", $name; |
991 | # } |
6557ab03 |
992 | $item->{utf8} = 'no'; |
993 | $items->{$name}[1] = $item; |
994 | push @new_items, $item; |
995 | # Copy item, to create the utf8 variant. |
996 | $item = {%$item}; |
997 | } |
998 | # Encode the name as utf8 bytes. |
4f2c4fd8 |
999 | unless ($is_perl56) { |
1000 | utf8::encode($name); |
1001 | } else { |
1002 | # warn "Was >$name< " . length ${name}; |
1003 | $name = pack 'C*', unpack 'C*', $name . pack 'U*'; |
1004 | # warn "Now '${name}' " . length ${name}; |
1005 | } |
6557ab03 |
1006 | if ($items->{$name}[0]) { |
1007 | die "Multiple definitions for macro $name"; |
1008 | } |
1009 | $item->{utf8} = 'yes'; |
1010 | $item->{name} = $name; |
1011 | $items->{$name}[0] = $item; |
1012 | # We have need for the utf8 flag. |
1013 | $what->{''} = 1; |
72f7b9a1 |
1014 | } |
6557ab03 |
1015 | push @new_items, $item; |
af6c647e |
1016 | } |
6557ab03 |
1017 | @items = @new_items; |
1018 | # use Data::Dumper; print Dumper @items; |
af6c647e |
1019 | } |
72f7b9a1 |
1020 | my $params = params ($what); |
af6c647e |
1021 | |
a2c454fa |
1022 | my ($body, @subs) = "static int\n$subname (pTHX_ const char *name"; |
af6c647e |
1023 | $body .= ", STRLEN len" unless defined $namelen; |
6557ab03 |
1024 | $body .= ", int utf8" if $params->{''}; |
72f7b9a1 |
1025 | $body .= ", IV *iv_return" if $params->{IV}; |
1026 | $body .= ", NV *nv_return" if $params->{NV}; |
1027 | $body .= ", const char **pv_return" if $params->{PV}; |
1028 | $body .= ", SV **sv_return" if $params->{SV}; |
af6c647e |
1029 | $body .= ") {\n"; |
1030 | |
6d79cad2 |
1031 | if (defined $namelen) { |
1032 | # We are a child subroutine. Print the simple description |
8ac27563 |
1033 | my $comment = 'When generated this function returned values for the list' |
1034 | . ' of names given here. However, subsequent manual editing may have' |
1035 | . ' added or removed some.'; |
72f7b9a1 |
1036 | $body .= switch_clause (2, $comment, $namelen, $items, @items); |
af6c647e |
1037 | } else { |
1038 | # We are the top level. |
1039 | $body .= " /* Initially switch on the length of the name. */\n"; |
9a7df4f2 |
1040 | $body .= dogfood ($package, $subname, $default_type, $what, $indent, |
1041 | $breakout, @items); |
af6c647e |
1042 | $body .= " switch (len) {\n"; |
1043 | # Need to group names of the same length |
1044 | my @by_length; |
1045 | foreach (@items) { |
1046 | push @{$by_length[length $_->{name}]}, $_; |
1047 | } |
1048 | foreach my $i (0 .. $#by_length) { |
1049 | next unless $by_length[$i]; # None of this length |
1050 | $body .= " case $i:\n"; |
1051 | if (@{$by_length[$i]} == 1) { |
4f2c4fd8 |
1052 | my $only_thing = $by_length[$i]->[0]; |
1053 | if ($only_thing->{utf8}) { |
1054 | if ($only_thing->{utf8} eq 'yes') { |
1055 | # With utf8 on flag item is passed in element 0 |
1056 | $body .= match_clause ([$only_thing]); |
1057 | } else { |
1058 | # With utf8 off flag item is passed in element 1 |
1059 | $body .= match_clause ([undef, $only_thing]); |
1060 | } |
1061 | } else { |
1062 | $body .= match_clause ($only_thing); |
1063 | } |
8ac27563 |
1064 | } elsif (@{$by_length[$i]} < $breakout) { |
72f7b9a1 |
1065 | $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]}); |
af6c647e |
1066 | } else { |
72f7b9a1 |
1067 | # Only use the minimal set of parameters actually needed by the types |
1068 | # of the names of this length. |
1069 | my $what = {}; |
1070 | foreach (@{$by_length[$i]}) { |
1071 | $what->{$_->{type}} = 1; |
6557ab03 |
1072 | $what->{''} = 1 if $_->{utf8}; |
72f7b9a1 |
1073 | } |
1074 | $params = params ($what); |
1075 | push @subs, C_constant ($package, "${subname}_$i", $default_type, $what, |
1076 | $indent, [$i, $items], @{$by_length[$i]}); |
a2c454fa |
1077 | $body .= " return ${subname}_$i (aTHX_ name"; |
6557ab03 |
1078 | $body .= ", utf8" if $params->{''}; |
72f7b9a1 |
1079 | $body .= ", iv_return" if $params->{IV}; |
1080 | $body .= ", nv_return" if $params->{NV}; |
1081 | $body .= ", pv_return" if $params->{PV}; |
1082 | $body .= ", sv_return" if $params->{SV}; |
af6c647e |
1083 | $body .= ");\n"; |
1084 | } |
1085 | $body .= " break;\n"; |
1086 | } |
1087 | $body .= " }\n"; |
1088 | } |
1089 | $body .= " return PERL_constant_NOTFOUND;\n}\n"; |
1090 | return (@subs, $body); |
1091 | } |
1092 | |
1093 | =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME |
1094 | |
1095 | A function to generate the XS code to implement the perl subroutine |
1096 | I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. |
1097 | This XS code is a wrapper around a C subroutine usually generated by |
1098 | C<C_constant>, and usually named C<constant>. |
1099 | |
1100 | I<TYPES> should be given either as a comma separated list of types that the |
1101 | C subroutine C<constant> will generate or as a reference to a hash. It should |
1102 | be the same list of types as C<C_constant> was given. |
1103 | [Otherwise C<XS_constant> and C<C_constant> may have different ideas about |
1104 | the number of parameters passed to the C function C<constant>] |
1105 | |
1106 | You can call the perl visible subroutine something other than C<constant> if |
d1be9408 |
1107 | you give the parameter I<SUBNAME>. The C subroutine it calls defaults to |
af6c647e |
1108 | the name of the perl visible subroutine, unless you give the parameter |
1109 | I<C_SUBNAME>. |
1110 | |
1111 | =cut |
1112 | |
1113 | sub XS_constant { |
1114 | my $package = shift; |
1115 | my $what = shift; |
1116 | my $subname = shift; |
1117 | my $C_subname = shift; |
1118 | $subname ||= 'constant'; |
1119 | $C_subname ||= $subname; |
1120 | |
1121 | if (!ref $what) { |
1122 | # Convert line of the form IV,UV,NV to hash |
1123 | $what = {map {$_ => 1} split /,\s*/, ($what)}; |
1124 | } |
72f7b9a1 |
1125 | my $params = params ($what); |
af6c647e |
1126 | my $type; |
1127 | |
1128 | my $xs = <<"EOT"; |
1129 | void |
1130 | $subname(sv) |
1131 | PREINIT: |
1132 | #ifdef dXSTARG |
1133 | dXSTARG; /* Faster if we have it. */ |
1134 | #else |
1135 | dTARGET; |
1136 | #endif |
1137 | STRLEN len; |
1138 | int type; |
1139 | EOT |
1140 | |
72f7b9a1 |
1141 | if ($params->{IV}) { |
af6c647e |
1142 | $xs .= " IV iv;\n"; |
1143 | } else { |
1144 | $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; |
1145 | } |
72f7b9a1 |
1146 | if ($params->{NV}) { |
af6c647e |
1147 | $xs .= " NV nv;\n"; |
1148 | } else { |
1149 | $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; |
1150 | } |
72f7b9a1 |
1151 | if ($params->{PV}) { |
af6c647e |
1152 | $xs .= " const char *pv;\n"; |
1153 | } else { |
1154 | $xs .= |
1155 | " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; |
1156 | } |
1157 | |
1158 | $xs .= << 'EOT'; |
1159 | INPUT: |
1160 | SV * sv; |
1161 | const char * s = SvPV(sv, len); |
6557ab03 |
1162 | EOT |
1163 | if ($params->{''}) { |
1164 | $xs .= << 'EOT'; |
1165 | INPUT: |
1166 | int utf8 = SvUTF8(sv); |
1167 | EOT |
1168 | } |
1169 | $xs .= << 'EOT'; |
af6c647e |
1170 | PPCODE: |
1171 | EOT |
1172 | |
72f7b9a1 |
1173 | if ($params->{IV} xor $params->{NV}) { |
af6c647e |
1174 | $xs .= << "EOT"; |
a2c454fa |
1175 | /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); |
af6c647e |
1176 | if you need to return both NVs and IVs */ |
1177 | EOT |
1178 | } |
a2c454fa |
1179 | $xs .= " type = $C_subname(aTHX_ s, len"; |
6557ab03 |
1180 | $xs .= ', utf8' if $params->{''}; |
72f7b9a1 |
1181 | $xs .= ', &iv' if $params->{IV}; |
1182 | $xs .= ', &nv' if $params->{NV}; |
1183 | $xs .= ', &pv' if $params->{PV}; |
1184 | $xs .= ', &sv' if $params->{SV}; |
af6c647e |
1185 | $xs .= ");\n"; |
1186 | |
1187 | $xs .= << "EOT"; |
1188 | /* Return 1 or 2 items. First is error message, or undef if no error. |
1189 | Second, if present, is found value */ |
1190 | switch (type) { |
1191 | case PERL_constant_NOTFOUND: |
1192 | sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); |
6d79cad2 |
1193 | PUSHs(sv); |
af6c647e |
1194 | break; |
1195 | case PERL_constant_NOTDEF: |
1196 | sv = sv_2mortal(newSVpvf( |
8ac27563 |
1197 | "Your vendor has not defined $package macro %s, used", s)); |
6d79cad2 |
1198 | PUSHs(sv); |
af6c647e |
1199 | break; |
1200 | EOT |
1201 | |
1202 | foreach $type (sort keys %XS_Constant) { |
6557ab03 |
1203 | # '' marks utf8 flag needed. |
1204 | next if $type eq ''; |
af6c647e |
1205 | $xs .= "\t/* Uncomment this if you need to return ${type}s\n" |
1206 | unless $what->{$type}; |
8ac27563 |
1207 | $xs .= " case PERL_constant_IS$type:\n"; |
1208 | if (length $XS_Constant{$type}) { |
1209 | $xs .= << "EOT"; |
af6c647e |
1210 | EXTEND(SP, 1); |
1211 | PUSHs(&PL_sv_undef); |
1212 | $XS_Constant{$type}; |
af6c647e |
1213 | EOT |
8ac27563 |
1214 | } else { |
1215 | # Do nothing. return (), which will be correctly interpreted as |
1216 | # (undef, undef) |
1217 | } |
1218 | $xs .= " break;\n"; |
af6c647e |
1219 | unless ($what->{$type}) { |
1220 | chop $xs; # Yes, another need for chop not chomp. |
1221 | $xs .= " */\n"; |
1222 | } |
1223 | } |
1224 | $xs .= << "EOT"; |
1225 | default: |
1226 | sv = sv_2mortal(newSVpvf( |
8ac27563 |
1227 | "Unexpected return type %d while processing $package macro %s, used", |
af6c647e |
1228 | type, s)); |
6d79cad2 |
1229 | PUSHs(sv); |
af6c647e |
1230 | } |
1231 | EOT |
1232 | |
1233 | return $xs; |
1234 | } |
1235 | |
1236 | |
6d79cad2 |
1237 | =item autoload PACKAGE, VERSION, AUTOLOADER |
af6c647e |
1238 | |
1239 | A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> |
1240 | I<VERSION> is the perl version the code should be backwards compatible with. |
6d79cad2 |
1241 | It defaults to the version of perl running the subroutine. If I<AUTOLOADER> |
1242 | is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all |
1243 | names that the constant() routine doesn't recognise. |
af6c647e |
1244 | |
1245 | =cut |
1246 | |
6d79cad2 |
1247 | # ' # Grr. syntax highlighters that don't grok pod. |
1248 | |
af6c647e |
1249 | sub autoload { |
6d79cad2 |
1250 | my ($module, $compat_version, $autoloader) = @_; |
af6c647e |
1251 | $compat_version ||= $]; |
1252 | croak "Can't maintain compatibility back as far as version $compat_version" |
1253 | if $compat_version < 5; |
6d79cad2 |
1254 | my $func = "sub AUTOLOAD {\n" |
1255 | . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" |
1256 | . " # XS function."; |
1257 | $func .= " If a constant is not found then control is passed\n" |
1258 | . " # to the AUTOLOAD in AutoLoader." if $autoloader; |
1259 | |
1260 | |
1261 | $func .= "\n\n" |
1262 | . " my \$constname;\n"; |
a2c454fa |
1263 | $func .= |
6d79cad2 |
1264 | " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); |
1265 | |
1266 | $func .= <<"EOT"; |
af6c647e |
1267 | (\$constname = \$AUTOLOAD) =~ s/.*:://; |
1268 | croak "&${module}::constant not defined" if \$constname eq 'constant'; |
1269 | my (\$error, \$val) = constant(\$constname); |
6d79cad2 |
1270 | EOT |
1271 | |
1272 | if ($autoloader) { |
1273 | $func .= <<'EOT'; |
1274 | if ($error) { |
1275 | if ($error =~ /is not a valid/) { |
1276 | $AutoLoader::AUTOLOAD = $AUTOLOAD; |
af6c647e |
1277 | goto &AutoLoader::AUTOLOAD; |
1278 | } else { |
6d79cad2 |
1279 | croak $error; |
af6c647e |
1280 | } |
1281 | } |
6d79cad2 |
1282 | EOT |
1283 | } else { |
1284 | $func .= |
1285 | " if (\$error) { croak \$error; }\n"; |
1286 | } |
1287 | |
1288 | $func .= <<'END'; |
af6c647e |
1289 | { |
1290 | no strict 'refs'; |
1291 | # Fixed between 5.005_53 and 5.005_61 |
6d79cad2 |
1292 | #XXX if ($] >= 5.00561) { |
1293 | #XXX *$AUTOLOAD = sub () { $val }; |
af6c647e |
1294 | #XXX } |
1295 | #XXX else { |
6d79cad2 |
1296 | *$AUTOLOAD = sub { $val }; |
af6c647e |
1297 | #XXX } |
1298 | } |
6d79cad2 |
1299 | goto &$AUTOLOAD; |
af6c647e |
1300 | } |
1301 | |
1302 | END |
1303 | |
6d79cad2 |
1304 | return $func; |
af6c647e |
1305 | } |
0552bf3a |
1306 | |
1307 | |
9a7df4f2 |
1308 | =item WriteMakefileSnippet |
1309 | |
1310 | WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] |
1311 | |
d1be9408 |
1312 | A function to generate perl code for Makefile.PL that will regenerate |
9a7df4f2 |
1313 | the constant subroutines. Parameters are named as passed to C<WriteConstants>, |
1314 | with the addition of C<INDENT> to specify the number of leading spaces |
1315 | (default 2). |
1316 | |
1317 | Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and |
1318 | C<XS_FILE> are recognised. |
1319 | |
1320 | =cut |
1321 | |
1322 | sub WriteMakefileSnippet { |
1323 | my %args = @_; |
1324 | my $indent = $args{INDENT} || 2; |
1325 | |
1326 | my $result = <<"EOT"; |
1327 | ExtUtils::Constant::WriteConstants( |
1328 | NAME => '$args{NAME}', |
1329 | NAMES => \\\@names, |
1330 | DEFAULT_TYPE => '$args{DEFAULT_TYPE}', |
1331 | EOT |
1332 | foreach (qw (C_FILE XS_FILE)) { |
1333 | next unless exists $args{$_}; |
1334 | $result .= sprintf " %-12s => '%s',\n", |
1335 | $_, $args{$_}; |
1336 | } |
1337 | $result .= <<'EOT'; |
1338 | ); |
1339 | EOT |
1340 | |
1341 | $result =~ s/^/' 'x$indent/gem; |
1342 | return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef, |
1343 | @{$args{NAMES}}) |
1344 | . $result; |
1345 | } |
1346 | |
0552bf3a |
1347 | =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] |
1348 | |
1349 | Writes a file of C code and a file of XS code which you should C<#include> |
1350 | and C<INCLUDE> in the C and XS sections respectively of your module's XS |
4f2c4fd8 |
1351 | code. You probably want to do this in your C<Makefile.PL>, so that you can |
0552bf3a |
1352 | easily edit the list of constants without touching the rest of your module. |
1353 | The attributes supported are |
1354 | |
1355 | =over 4 |
1356 | |
1357 | =item NAME |
1358 | |
1359 | Name of the module. This must be specified |
1360 | |
1361 | =item DEFAULT_TYPE |
1362 | |
1363 | The default type for the constants. If not specified C<IV> is assumed. |
1364 | |
1365 | =item BREAKOUT_AT |
1366 | |
1367 | The names of the constants are grouped by length. Generate child subroutines |
1368 | for each group with this number or more names in. |
1369 | |
1370 | =item NAMES |
1371 | |
1372 | An array of constants' names, either scalars containing names, or hashrefs |
1373 | as detailed in L<"C_constant">. |
1374 | |
1375 | =item C_FILE |
1376 | |
1377 | The name of the file to write containing the C code. The default is |
1cb0fb50 |
1378 | C<const-c.inc>. The C<-> in the name ensures that the file can't be |
1379 | mistaken for anything related to a legitimate perl package name, and |
1380 | not naming the file C<.c> avoids having to override Makefile.PL's |
1381 | C<.xs> to C<.c> rules. |
0552bf3a |
1382 | |
1383 | =item XS_FILE |
1384 | |
1385 | The name of the file to write containing the XS code. The default is |
1cb0fb50 |
1386 | C<const-xs.inc>. |
0552bf3a |
1387 | |
1388 | =item SUBNAME |
1389 | |
1390 | The perl visible name of the XS subroutine generated which will return the |
9a7df4f2 |
1391 | constants. The default is C<constant>. |
0552bf3a |
1392 | |
1393 | =item C_SUBNAME |
1394 | |
1395 | The name of the C subroutine generated which will return the constants. |
1396 | The default is I<SUBNAME>. Child subroutines have C<_> and the name |
1397 | length appended, so constants with 10 character names would be in |
1398 | C<constant_10> with the default I<XS_SUBNAME>. |
1399 | |
1400 | =back |
1401 | |
1402 | =cut |
1403 | |
1404 | sub WriteConstants { |
1405 | my %ARGS = |
1406 | ( # defaults |
1cb0fb50 |
1407 | C_FILE => 'const-c.inc', |
1408 | XS_FILE => 'const-xs.inc', |
0552bf3a |
1409 | SUBNAME => 'constant', |
1410 | DEFAULT_TYPE => 'IV', |
1411 | @_); |
1412 | |
1413 | $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0' |
1414 | |
1415 | croak "Module name not specified" unless length $ARGS{NAME}; |
1416 | |
1417 | open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; |
1418 | open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; |
1419 | |
1420 | # As this subroutine is intended to make code that isn't edited, there's no |
1421 | # need for the user to specify any types that aren't found in the list of |
1422 | # names. |
1423 | my $types = {}; |
1424 | |
1425 | print $c_fh constant_types(); # macro defs |
1426 | print $c_fh "\n"; |
1427 | |
4f2c4fd8 |
1428 | # indent is still undef. Until anyone implements indent style rules with it. |
0552bf3a |
1429 | foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE}, |
1430 | $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) { |
1431 | print $c_fh $_, "\n"; # C constant subs |
1432 | } |
1433 | print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, |
1434 | $ARGS{C_SUBNAME}); |
1435 | |
1436 | close $c_fh or warn "Error closing $ARGS{C_FILE}: $!"; |
1437 | close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!"; |
1438 | } |
1439 | |
4f2c4fd8 |
1440 | package ExtUtils::Constant::Aaargh56Hash; |
1441 | # A support module (hack) to provide sane Unicode hash keys on 5.6.x perl |
1442 | use strict; |
1443 | require Tie::Hash if $ExtUtils::Constant::is_perl56; |
1444 | use vars '@ISA'; |
1445 | @ISA = 'Tie::StdHash'; |
1446 | |
1447 | #my $a; |
1448 | # Storing the values as concatenated BER encoded numbers is actually going to |
1449 | # be terser than using UTF8 :-) |
1450 | # And the tests are slightly faster. Ops are bad, m'kay |
1451 | sub to_key {pack "w*", unpack "U*", ($_[0] . pack "U*")}; |
1452 | sub from_key {defined $_[0] ? pack "U*", unpack 'w*', $_[0] : undef}; |
1453 | |
1454 | sub STORE { $_[0]->{to_key($_[1])} = $_[2] } |
1455 | sub FETCH { $_[0]->{to_key($_[1])} } |
1456 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; from_key (each %{$_[0]}) } |
1457 | sub NEXTKEY { from_key (each %{$_[0]}) } |
1458 | sub EXISTS { exists $_[0]->{to_key($_[1])} } |
1459 | sub DELETE { delete $_[0]->{to_key($_[1])} } |
1460 | |
1461 | #END {warn "$a accesses";} |
af6c647e |
1462 | 1; |
1463 | __END__ |
1464 | |
1465 | =back |
1466 | |
1467 | =head1 AUTHOR |
1468 | |
1469 | Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and |
1470 | others |
1471 | |
1472 | =cut |