1 package ExtUtils::Constant;
2 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
7 ExtUtils::Constant - generate XS code to import C header constants
11 use ExtUtils::Constant qw (WriteConstants);
14 NAMES => [qw(FOO BAR BAZ)],
16 # Generates wrapper code to make the values of the constants FOO BAR BAZ
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
29 Generally one only needs to call the C<WriteConstants> function, and then
31 #include "const-c.inc"
33 in the C section of C<Foo.xs>
37 in the XS section of C<Foo.xs>.
39 For greater flexibility use C<constant_types()>, C<C_constant> and
40 C<XS_constant>, with which C<WriteConstants> is implemented.
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.
50 signed integer, at least 32 bits.
54 unsigned integer, the same size as I<IV>
58 floating point type, probably C<double>, possibly C<long double>
62 NUL terminated string, length will be determined with C<strlen>
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>
75 Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
79 Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
83 C<undef>. The value of the macro is not needed.
94 eval "use warnings; 1" or die $@;
97 use vars '$is_perl56';
100 $is_perl56 = ($] < 5.007 && $] > 5.005_50);
104 $Text::Wrap::huge = 'overflow';
105 $Text::Wrap::columns = 80;
109 %EXPORT_TAGS = ( 'all' => [ qw(
110 XS_constant constant_types return_clause memEQ_clause C_stringify
111 C_constant autoload WriteConstants WriteMakefileSnippet
114 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
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.
121 UV => 'PUSHu((UV)iv)',
123 PV => 'PUSHp(pv, strlen(pv))',
124 PVN => 'PUSHp(pv, iv)',
126 YES => 'PUSHs(&PL_sv_yes)',
127 NO => 'PUSHs(&PL_sv_no)',
128 UNDEF => '', # implicit undef
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 = ',
144 =item C_stringify NAME
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
152 # Hopefully make a happy C identifier.
155 return unless defined $_;
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;
163 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
164 s/\n/\\n/g; # Ensure newlines don't end up in octal
169 s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
170 unless ($] < 5.006) {
171 # This will elicit a warning on 5.005_03 about [: :] being reserved unless
173 my $cheat = '([[:^print:]])';
174 s/$cheat/sprintf "\\%03o", ord $1/ge;
177 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
182 =item perl_stringify NAME
184 A function which returns a 7 bit ASCII correctly \ escaped version of the
185 string passed suitable for a perl "" string.
189 # Hopefully make a happy perl identifier.
192 return unless defined $_;
194 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
195 s/\n/\\n/g; # Ensure newlines don't end up in octal
200 unless ($] < 5.006) {
202 s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
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 //
208 foreach my $index (0 .. length ($_) - 1) {
209 my $char = substr ($_, $index, 1);
210 $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
214 # This will elicit a warning on 5.005_03 about [: :] being reserved unless
216 my $cheat = '([[:^print:]])';
217 s/$cheat/sprintf "\\%03o", ord $1/ge;
219 # Turns out "\x{}" notation only arrived with 5.6
220 s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
222 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
229 A function returning a single scalar with C<#define> definitions for the
230 constants used internally between the generated C and XS functions.
234 sub constant_types () {
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) {
241 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
243 push @lines, << 'EOT';
246 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
249 #define aTHX_ /* 5.6 or later define this for threading support. */
252 #define pTHX_ /* 5.6 or later define this for threading support. */
256 return join '', @lines;
259 =item memEQ_clause NAME, CHECKED_AT, INDENT
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.
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>).
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);
279 if (ref $checked_at) {
280 # regexp won't work on 5.6.1 without use utf8; in turn that won't work
282 substr ($name, 0, length $$checked_at,) = '';
283 $front_chop = C_stringify ($$checked_at);
286 my $len = length $name;
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
293 if ($len < 3 and defined $checked_at) {
295 if ($checked_at == 1) {
297 } elsif ($checked_at == 0) {
300 if (defined $check) {
301 my $char = C_stringify (substr $name, $check, 1);
302 return $indent . "if (name[$check] == '$char') {\n";
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";
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";
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);
325 $name = C_stringify ($name);
326 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
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
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";
340 =item assign INDENT, TYPE, PRE, POST, VALUE...
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
344 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
345 of C code to proceed and follow the assignment. I<PRE> will be at the start
346 of a block, so variables may be defined in it.
350 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
356 my $post = shift || '';
361 $clause = $indent . "{\n$pre";
362 $clause .= ";" unless $pre =~ /;$/;
364 $close = "$indent}\n";
367 confess "undef \$type" unless defined $type;
368 confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
369 my $typeset = $XS_TypeSet{$type};
371 die "Type $type is aggregate, but only single value given"
373 foreach (0 .. $#$typeset) {
374 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
376 } elsif (defined $typeset) {
377 die "Aggregate value given for type $type"
379 $clause .= $indent . "$typeset $_[0];\n";
384 $clause .= ";" unless $post =~ /;$/;
387 $clause .= "${indent}return PERL_constant_IS$type;\n";
388 $clause .= $close if $close;
394 return_clause ITEM, INDENT
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.
402 sub return_clause ($$) {
404 # *iv_return = thingy;
405 # return PERL_constant_ISIV;
407 # return PERL_constant_NOTDEF;
409 my ($item, $indent) = @_;
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;
416 $macro = $value unless defined $macro;
417 $indent = ' ' x ($indent || 6);
419 # use Data::Dumper; print STDERR Dumper ($item);
420 confess "undef \$type";
427 $clause = $macro->[0];
428 } elsif ($macro ne "1") {
429 $clause = "#ifdef $macro\n";
432 # *iv_return = thingy;
433 # return PERL_constant_ISIV;
434 $clause .= assign ($indent, $type, $pre, $post,
435 ref $value ? @$value : $value);
437 if (ref $macro or $macro ne "1") {
439 $clause .= "#else\n";
441 # return PERL_constant_NOTDEF;
442 if (!defined $default) {
443 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
445 my @default = ref $default ? @$default : $default;
446 $type = shift @default;
447 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
452 $clause .= $macro->[1];
454 $clause .= "#endif\n";
467 # $offset defined if we have checked an offset.
468 my ($item, $offset, $indent) = @_;
469 $indent = ' ' x ($indent || 4);
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};
479 confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
481 $name = $item->{name};
482 $inner_indent = $indent;
485 $body .= memEQ_clause ($name, $offset, length $indent);
487 $body .= $indent . " if (utf8) {\n";
489 $body .= $indent . " if (!utf8) {\n";
492 $body .= return_clause ($either, 4 + length $indent);
494 $body .= $indent . " } else {\n";
495 $body .= return_clause ($no, 4 + length $indent);
497 $body .= $indent . " }\n";
499 $body .= return_clause ($item, 2 + length $indent);
501 $body .= $indent . "}\n";
504 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
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).
517 my ($indent, $comment, $namelen, $items, @items) = @_;
518 $indent = ' ' x ($indent || 2);
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";
525 $body = wrap ($leader, $follower, $comment) . "\n";
528 my @safe_names = @names;
529 foreach (@safe_names) {
530 confess sprintf "Name '$_' is length %d, not $namelen", length
531 unless length == $namelen;
533 # next unless tr/A-Za-z0-9_//c;
534 next if tr/A-Za-z0-9_// == length;
535 $_ = '"' . perl_stringify ($_) . '"';
536 # Ensure that the enclosing C comment doesn't end
537 # by turning */ into *" . "/
539 # gcc -Wall doesn't like finding /* inside a comment
542 $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
543 # Figure out what to switch on.
544 # (RMS, Spread of jump table, Position, Hashref)
545 my @best = (1e38, ~0);
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)) {
549 my ($min, $max) = (~0, 0);
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';
557 my $char = substr $_, $i, 1;
559 confess "char $ord is out of range" if $ord > 255;
560 $max = $ord if $ord > $max;
561 $min = $ord if $ord < $min;
562 push @{$spread{$char}}, $_;
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
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. :-)
577 # OK. Trump that. Now favour the last character of the string, before the
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);
586 confess "Internal error. Failed to pick a switch point for @names"
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";
592 my $do_front_chop = $offset == 0 && $namelen > 2;
593 if ($do_front_chop) {
594 $body .= $indent . "switch (*name++) {\n";
596 $body .= $indent . "switch (name[$offset]) {\n";
598 foreach my $char (sort keys %$best) {
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;
602 $body .= $indent . "case '" . C_stringify ($char) . "':\n";
603 foreach my $name (sort @{$best->{$char}}) {
604 my $thisone = $items->{$name};
605 # warn "You are here";
606 if ($do_front_chop) {
607 $body .= match_clause ($thisone, \$char, 2 + length $indent);
609 $body .= match_clause ($thisone, $offset, 2 + length $indent);
612 $body .= $indent . " break;\n";
614 $body .= $indent . "}\n";
620 An internal function. I<WHAT> should be a hashref of types the constant
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.
628 foreach (sort keys %$what) {
629 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
632 $params->{''} = 1 if $what->{''};
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};
642 dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
644 An internal function to generate the embedded perl code that will regenerate
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.
656 my ($default_type, $what, $indent, $options, @items) = @_;
657 my $declare_types = $options->{declare_types};
658 $indent = ' ' x ($indent || 0);
661 my (@simple, @complex, %used_types);
665 $type = $_->{type} || $default_type;
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.
672 unless ($is_perl56) {
673 utf8::decode ($_->{name});
675 $_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
681 $type = $default_type;
683 $used_types{$type}++;
684 if ($type eq $default_type
686 and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
687 and !defined ($_->{macro}) and !defined ($_->{value})
688 and !defined ($_->{default}) and !defined ($_->{pre})
689 and !defined ($_->{post}) and !defined ($_->{def_pre})
690 and !defined ($_->{def_post})) {
691 # It's the default type, and the name consists only of A-Za-z0-9_
692 push @simple, $_->{name};
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
706 if ($declare_types) {
707 $result = $indent . 'my $types = {map {($_, 1)} qw('
708 . join (" ", sort keys %$what) . ")};\n";
710 $result .= wrap ($indent . "my \@names = (qw(",
711 $indent . " ", join (" ", sort @simple) . ")");
713 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
714 my $name = perl_stringify $item->{name};
715 my $line = ",\n$indent {name=>\"$name\"";
716 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
717 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
718 my $value = $item->{$thing};
719 if (defined $value) {
721 $line .= ", $thing=>[\""
722 . join ('", "', map {perl_stringify $_} @$value) . '"]';
724 $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
729 # Ensure that the enclosing C comment doesn't end
730 # by turning */ into *" . "/
731 $line =~ s!\*\/!\*" . "/!gs;
732 # gcc -Wall doesn't like finding /* inside a comment
733 $line =~ s!\/\*!/" . "\*!gs;
745 dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
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.
753 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
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.
763 Regenerate these constant functions by feeding this entire source file to
767 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
770 $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
773 print constant_types(); # macro defs
775 $package = perl_stringify($package);
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;
782 $Data::Dumper::Terse=1; # Not used once. :-)
783 chomp ($indent = Data::Dumper::Dumper ($indent));
788 $result .= ", $breakout" . ', @names) ) {
789 print $_, "\n"; # C constant subs
791 print "#### XS Section:\n";
792 print XS_constant ("' . $package . '", $types);
803 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
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
815 The name of the constant, as seen by the perl code.
819 The type of the constant (I<IV>, I<NV> etc)
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.
828 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
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
840 to be used to determine if a constant is to be defined.
842 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
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).
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.
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>.
867 Equivalents of I<pre> and I<post> for the default value.
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.
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.
881 I<PACKAGE> is the name of the package, and is only used in comments inside the
884 The next 5 arguments can safely be given as C<undef>, and are mainly used
885 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
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.
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.
907 # The parameter now BREAKOUT was previously documented as:
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.
915 # As you can see it now performs this function during recursion by being a
919 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
922 $subname ||= 'constant';
923 # I'm not using this. But a hashref could be used for full formatting without
927 my ($namelen, $items);
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;
934 # Need proper Unicode preserving hash keys.
936 tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
939 $default_type ||= 'IV';
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
947 foreach my $orig (@items) {
950 # Make a copy which is a normalised version of the ref passed in.
951 $name = $orig->{name};
952 my ($type, $macro, $value) = @$orig{qw (type macro value)};
953 $type ||= $default_type;
955 $item = {name=>$name, type=>$type};
957 undef $macro if defined $macro and $macro eq $name;
958 $item->{macro} = $macro if defined $macro;
959 undef $value if defined $value and $value eq $name;
960 $item->{value} = $value if defined $value;
961 foreach my $key (qw(default pre post def_pre def_post)) {
962 my $value = $orig->{$key};
963 $item->{$key} = $value if defined $value;
964 # warn "$key $value";
968 $item = {name=>$name, type=>$default_type};
969 $what->{$default_type} = 1;
971 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}};
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) {
976 # No characters outside 7 bit ASCII.
977 if (exists $items->{$name}) {
978 die "Multiple definitions for macro $name";
980 $items->{$name} = $item;
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";
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) {
990 # $name = pack "C*", unpack "U*", $name;
992 $item->{utf8} = 'no';
993 $items->{$name}[1] = $item;
994 push @new_items, $item;
995 # Copy item, to create the utf8 variant.
998 # Encode the name as utf8 bytes.
999 unless ($is_perl56) {
1000 utf8::encode($name);
1002 # warn "Was >$name< " . length ${name};
1003 $name = pack 'C*', unpack 'C*', $name . pack 'U*';
1004 # warn "Now '${name}' " . length ${name};
1006 if ($items->{$name}[0]) {
1007 die "Multiple definitions for macro $name";
1009 $item->{utf8} = 'yes';
1010 $item->{name} = $name;
1011 $items->{$name}[0] = $item;
1012 # We have need for the utf8 flag.
1015 push @new_items, $item;
1017 @items = @new_items;
1018 # use Data::Dumper; print Dumper @items;
1020 my $params = params ($what);
1022 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
1023 $body .= ", STRLEN len" unless defined $namelen;
1024 $body .= ", int utf8" if $params->{''};
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};
1031 if (defined $namelen) {
1032 # We are a child subroutine. Print the simple description
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.';
1036 $body .= switch_clause (2, $comment, $namelen, $items, @items);
1038 # We are the top level.
1039 $body .= " /* Initially switch on the length of the name. */\n";
1040 $body .= dogfood ($package, $subname, $default_type, $what, $indent,
1042 $body .= " switch (len) {\n";
1043 # Need to group names of the same length
1046 push @{$by_length[length $_->{name}]}, $_;
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) {
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]);
1058 # With utf8 off flag item is passed in element 1
1059 $body .= match_clause ([undef, $only_thing]);
1062 $body .= match_clause ($only_thing);
1064 } elsif (@{$by_length[$i]} < $breakout) {
1065 $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
1067 # Only use the minimal set of parameters actually needed by the types
1068 # of the names of this length.
1070 foreach (@{$by_length[$i]}) {
1071 $what->{$_->{type}} = 1;
1072 $what->{''} = 1 if $_->{utf8};
1074 $params = params ($what);
1075 push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
1076 $indent, [$i, $items], @{$by_length[$i]});
1077 $body .= " return ${subname}_$i (aTHX_ name";
1078 $body .= ", utf8" if $params->{''};
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};
1085 $body .= " break;\n";
1089 $body .= " return PERL_constant_NOTFOUND;\n}\n";
1090 return (@subs, $body);
1093 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
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>.
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>]
1106 You can call the perl visible subroutine something other than C<constant> if
1107 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
1108 the name of the perl visible subroutine, unless you give the parameter
1114 my $package = shift;
1116 my $subname = shift;
1117 my $C_subname = shift;
1118 $subname ||= 'constant';
1119 $C_subname ||= $subname;
1122 # Convert line of the form IV,UV,NV to hash
1123 $what = {map {$_ => 1} split /,\s*/, ($what)};
1125 my $params = params ($what);
1133 dXSTARG; /* Faster if we have it. */
1141 if ($params->{IV}) {
1144 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
1146 if ($params->{NV}) {
1149 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
1151 if ($params->{PV}) {
1152 $xs .= " const char *pv;\n";
1155 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
1161 const char * s = SvPV(sv, len);
1163 if ($params->{''}) {
1166 int utf8 = SvUTF8(sv);
1173 if ($params->{IV} xor $params->{NV}) {
1175 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
1176 if you need to return both NVs and IVs */
1179 $xs .= " type = $C_subname(aTHX_ s, len";
1180 $xs .= ', utf8' if $params->{''};
1181 $xs .= ', &iv' if $params->{IV};
1182 $xs .= ', &nv' if $params->{NV};
1183 $xs .= ', &pv' if $params->{PV};
1184 $xs .= ', &sv' if $params->{SV};
1188 /* Return 1 or 2 items. First is error message, or undef if no error.
1189 Second, if present, is found value */
1191 case PERL_constant_NOTFOUND:
1192 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
1195 case PERL_constant_NOTDEF:
1196 sv = sv_2mortal(newSVpvf(
1197 "Your vendor has not defined $package macro %s, used", s));
1202 foreach $type (sort keys %XS_Constant) {
1203 # '' marks utf8 flag needed.
1204 next if $type eq '';
1205 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
1206 unless $what->{$type};
1207 $xs .= " case PERL_constant_IS$type:\n";
1208 if (length $XS_Constant{$type}) {
1211 PUSHs(&PL_sv_undef);
1212 $XS_Constant{$type};
1215 # Do nothing. return (), which will be correctly interpreted as
1219 unless ($what->{$type}) {
1220 chop $xs; # Yes, another need for chop not chomp.
1226 sv = sv_2mortal(newSVpvf(
1227 "Unexpected return type %d while processing $package macro %s, used",
1237 =item autoload PACKAGE, VERSION, AUTOLOADER
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.
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.
1247 # ' # Grr. syntax highlighters that don't grok pod.
1250 my ($module, $compat_version, $autoloader) = @_;
1251 $compat_version ||= $];
1252 croak "Can't maintain compatibility back as far as version $compat_version"
1253 if $compat_version < 5;
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;
1262 . " my \$constname;\n";
1264 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
1267 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1268 croak "&${module}::constant not defined" if \$constname eq 'constant';
1269 my (\$error, \$val) = constant(\$constname);
1275 if ($error =~ /is not a valid/) {
1276 $AutoLoader::AUTOLOAD = $AUTOLOAD;
1277 goto &AutoLoader::AUTOLOAD;
1285 " if (\$error) { croak \$error; }\n";
1291 # Fixed between 5.005_53 and 5.005_61
1292 #XXX if ($] >= 5.00561) {
1293 #XXX *$AUTOLOAD = sub () { $val };
1296 *$AUTOLOAD = sub { $val };
1308 =item WriteMakefileSnippet
1310 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
1312 A function to generate perl code for Makefile.PL that will regenerate
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
1317 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
1318 C<XS_FILE> are recognised.
1322 sub WriteMakefileSnippet {
1324 my $indent = $args{INDENT} || 2;
1326 my $result = <<"EOT";
1327 ExtUtils::Constant::WriteConstants(
1328 NAME => '$args{NAME}',
1330 DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
1332 foreach (qw (C_FILE XS_FILE)) {
1333 next unless exists $args{$_};
1334 $result .= sprintf " %-12s => '%s',\n",
1341 $result =~ s/^/' 'x$indent/gem;
1342 return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
1347 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
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
1351 code. You probably want to do this in your C<Makefile.PL>, so that you can
1352 easily edit the list of constants without touching the rest of your module.
1353 The attributes supported are
1359 Name of the module. This must be specified
1363 The default type for the constants. If not specified C<IV> is assumed.
1367 The names of the constants are grouped by length. Generate child subroutines
1368 for each group with this number or more names in.
1372 An array of constants' names, either scalars containing names, or hashrefs
1373 as detailed in L<"C_constant">.
1377 The name of the file to write containing the C code. The default is
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.
1385 The name of the file to write containing the XS code. The default is
1390 The perl visible name of the XS subroutine generated which will return the
1391 constants. The default is C<constant>.
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>.
1404 sub WriteConstants {
1407 C_FILE => 'const-c.inc',
1408 XS_FILE => 'const-xs.inc',
1409 SUBNAME => 'constant',
1410 DEFAULT_TYPE => 'IV',
1413 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1415 croak "Module name not specified" unless length $ARGS{NAME};
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}: $!";
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
1425 print $c_fh constant_types(); # macro defs
1428 # indent is still undef. Until anyone implements indent style rules with it.
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
1433 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1436 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1437 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1440 package ExtUtils::Constant::Aaargh56Hash;
1441 # A support module (hack) to provide sane Unicode hash keys on 5.6.x perl
1443 require Tie::Hash if $ExtUtils::Constant::is_perl56;
1445 @ISA = 'Tie::StdHash';
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};
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])} }
1461 #END {warn "$a accesses";}
1469 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and