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