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 $@;
101 $Text::Wrap::huge = 'overflow';
102 $Text::Wrap::columns = 80;
106 %EXPORT_TAGS = ( 'all' => [ qw(
107 XS_constant constant_types return_clause memEQ_clause C_stringify
108 C_constant autoload WriteConstants WriteMakefileSnippet
111 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
113 # '' is used as a flag to indicate non-ascii macro names, and hence the need
114 # to pass in the utf8 on/off flag.
118 UV => 'PUSHu((UV)iv)',
120 PV => 'PUSHp(pv, strlen(pv))',
121 PVN => 'PUSHp(pv, iv)',
123 YES => 'PUSHs(&PL_sv_yes)',
124 NO => 'PUSHs(&PL_sv_no)',
125 UNDEF => '', # implicit undef
129 IV => '*iv_return =',
130 UV => '*iv_return = (IV)',
131 NV => '*nv_return =',
132 PV => '*pv_return =',
133 PVN => ['*pv_return =', '*iv_return = (IV)'],
134 SV => '*sv_return = ',
141 =item C_stringify NAME
143 A function which returns a 7 bit ASCII correctly \ escaped version of the
144 string passed suitable for C's "" or ''. It will die if passed Unicode
149 # Hopefully make a happy C identifier.
152 return unless defined $_;
153 confess "Wide character in '$_' intended as a C identifier" if tr/\0-\377//c;
155 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
156 s/\n/\\n/g; # Ensure newlines don't end up in octal
161 s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
162 unless ($] < 5.006) {
163 # This will elicit a warning on 5.005_03 about [: :] being reserved unless
165 my $cheat = '([[:^print:]])';
166 s/$cheat/sprintf "\\%03o", ord $1/ge;
169 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
174 =item perl_stringify NAME
176 A function which returns a 7 bit ASCII correctly \ escaped version of the
177 string passed suitable for a perl "" string.
181 # Hopefully make a happy perl identifier.
184 return unless defined $_;
186 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
187 s/\n/\\n/g; # Ensure newlines don't end up in octal
192 s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
193 unless ($] < 5.006) {
194 # This will elicit a warning on 5.005_03 about [: :] being reserved unless
196 my $cheat = '([[:^print:]])';
197 s/$cheat/sprintf "\\%03o", ord $1/ge;
200 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
207 A function returning a single scalar with C<#define> definitions for the
208 constants used internally between the generated C and XS functions.
212 sub constant_types () {
215 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
216 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
217 foreach (sort keys %XS_Constant) {
219 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
221 push @lines, << 'EOT';
224 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
227 #define aTHX_ /* 5.6 or later define this for threading support. */
230 #define pTHX_ /* 5.6 or later define this for threading support. */
234 return join '', @lines;
237 =item memEQ_clause NAME, CHECKED_AT, INDENT
239 A function to return a suitable C C<if> statement to check whether I<NAME>
240 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
241 is used to avoid C<memEQ> for short names, or to generate a comment to
242 highlight the position of the character in the C<switch> statement.
247 # if (memEQ(name, "thingy", 6)) {
248 # Which could actually be a character comparison or even ""
249 my ($name, $checked_at, $indent) = @_;
250 $indent = ' ' x ($indent || 4);
251 my $len = length $name;
254 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
255 # We didn't switch, drop through to the code for the 2 character string
258 if ($len < 3 and defined $checked_at) {
260 if ($checked_at == 1) {
262 } elsif ($checked_at == 0) {
265 if (defined $check) {
266 my $char = C_stringify (substr $name, $check, 1);
267 return $indent . "if (name[$check] == '$char') {\n";
270 # Could optimise a memEQ on 3 to 2 single character checks here
271 $name = C_stringify ($name);
272 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
273 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
274 . (' ' x ($len - $checked_at + length $len)) . " */\n"
275 if defined $checked_at;
279 =item assign INDENT, TYPE, PRE, POST, VALUE...
281 A function to return a suitable assignment clause. If I<TYPE> is aggregate
282 (eg I<PVN> expects both pointer and length) then there should be multiple
283 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
284 of C code to proceed and follow the assignment. I<PRE> will be at the start
285 of a block, so variables may be defined in it.
289 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
295 my $post = shift || '';
300 $clause = $indent . "{\n$pre";
301 $clause .= ";" unless $pre =~ /;$/;
303 $close = "$indent}\n";
306 confess "undef \$type" unless defined $type;
307 confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
308 my $typeset = $XS_TypeSet{$type};
310 die "Type $type is aggregate, but only single value given"
312 foreach (0 .. $#$typeset) {
313 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
315 } elsif (defined $typeset) {
316 die "Aggregate value given for type $type"
318 $clause .= $indent . "$typeset $_[0];\n";
323 $clause .= ";" unless $post =~ /;$/;
326 $clause .= "${indent}return PERL_constant_IS$type;\n";
327 $clause .= $close if $close;
333 return_clause ITEM, INDENT
335 A function to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
336 (as passed to C<C_constant> and C<match_clause>. I<INDENT> is the number
337 of spaces to indent, defaulting to 6.
341 sub return_clause ($$) {
343 # *iv_return = thingy;
344 # return PERL_constant_ISIV;
346 # return PERL_constant_NOTDEF;
348 my ($item, $indent) = @_;
350 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post, $type)
351 = @$item{qw (name value macro default pre post def_pre def_post type)};
352 $value = $name unless defined $value;
353 $macro = $name unless defined $macro;
355 $macro = $value unless defined $macro;
356 $indent = ' ' x ($indent || 6);
358 # use Data::Dumper; print STDERR Dumper ($item);
359 confess "undef \$type";
366 $clause = $macro->[0];
367 } elsif ($macro ne "1") {
368 $clause = "#ifdef $macro\n";
371 # *iv_return = thingy;
372 # return PERL_constant_ISIV;
373 $clause .= assign ($indent, $type, $pre, $post,
374 ref $value ? @$value : $value);
376 if (ref $macro or $macro ne "1") {
378 $clause .= "#else\n";
380 # return PERL_constant_NOTDEF;
381 if (!defined $default) {
382 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
384 my @default = ref $default ? @$default : $default;
385 $type = shift @default;
386 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
391 $clause .= $macro->[1];
393 $clause .= "#endif\n";
406 # $offset defined if we have checked an offset.
407 my ($item, $offset, $indent) = @_;
408 $indent = ' ' x ($indent || 4);
410 my ($no, $yes, $either, $name, $inner_indent);
411 if (ref $item eq 'ARRAY') {
412 ($yes, $no) = @$item;
413 $either = $yes || $no;
414 confess "$item is $either expecting hashref in [0] || [1]"
415 unless ref $either eq 'HASH';
416 $name = $either->{name};
418 confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
420 $name = $item->{name};
421 $inner_indent = $indent;
424 $body .= memEQ_clause ($name, $offset, length $indent);
426 $body .= $indent . " if (utf8) {\n";
428 $body .= $indent . " if (!utf8) {\n";
431 $body .= return_clause ($either, 4 + length $indent);
433 $body .= $indent . " } else {\n";
434 $body .= return_clause ($no, 4 + length $indent);
436 $body .= $indent . " }";
438 $body .= return_clause ($item, 2 + length $indent);
440 $body .= $indent . "}\n";
443 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
445 An internal function to generate a suitable C<switch> clause, called by
446 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
447 of C<C_constant>, and must all have the names of the same length, given by
448 I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
449 keyed by name, values being the hashrefs in the I<ITEM> list.
450 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
451 are not in the list of I<ITEM>s without causing problems).
456 my ($indent, $comment, $namelen, $items, @items) = @_;
457 $indent = ' ' x ($indent || 2);
459 my @names = sort map {$_->{name}} @items;
460 my $leader = $indent . '/* ';
461 my $follower = ' ' x length $leader;
462 my $body = $indent . "/* Names all of length $namelen. */\n";
464 $body = wrap ($leader, $follower, $comment) . "\n";
467 my @safe_names = @names;
468 foreach (@safe_names) {
469 next unless tr/A-Za-z0-9_//c;
470 $_ = '"' . perl_stringify ($_) . '"';
471 # Ensure that the enclosing C comment doesn't end
472 # by turning */ into *" . "/
474 # gcc -Wall doesn't like finding /* inside a comment
477 $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
478 # Figure out what to switch on.
479 # (RMS, Spread of jump table, Position, Hashref)
480 my @best = (1e38, ~0);
481 foreach my $i (0 .. ($namelen - 1)) {
482 my ($min, $max) = (~0, 0);
485 my $char = substr $_, $i, 1;
487 $max = $ord if $ord > $max;
488 $min = $ord if $ord < $min;
489 push @{$spread{$char}}, $_;
492 # I'm going to pick the character to split on that minimises the root
493 # mean square of the number of names in each case. Normally this should
494 # be the one with the most keys, but it may pick a 7 where the 8 has
495 # one long linear search. I'm not sure if RMS or just sum of squares is
497 # $max and $min are for the tie-breaker if the root mean squares match.
498 # Assuming that the compiler may be building a jump table for the
499 # switch() then try to minimise the size of that jump table.
500 # Finally use < not <= so that if it still ties the earliest part of
501 # the string wins. Because if that passes but the memEQ fails, it may
502 # only need the start of the string to bin the choice.
503 # I think. But I'm micro-optimising. :-)
505 $ss += @$_ * @$_ foreach values %spread;
506 my $rms = sqrt ($ss / keys %spread);
507 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
508 @best = ($rms, $max - $min, $i, \%spread);
511 die "Internal error. Failed to pick a switch point for @names"
512 unless defined $best[2];
513 # use Data::Dumper; print Dumper (@best);
514 my ($offset, $best) = @best[2,3];
515 $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
516 $body .= $indent . "switch (name[$offset]) {\n";
517 foreach my $char (sort keys %$best) {
518 $body .= $indent . "case '" . C_stringify ($char) . "':\n";
519 foreach my $name (sort @{$best->{$char}}) {
520 my $thisone = $items->{$name};
521 # warn "You are here";
522 $body .= match_clause ($thisone, $offset, 2 + length $indent);
524 $body .= $indent . " break;\n";
526 $body .= $indent . "}\n";
532 An internal function. I<WHAT> should be a hashref of types the constant
533 function will return. I<params> returns a hashref keyed IV NV PV SV to show
534 which combination of pointers will be needed in the C argument list.
540 foreach (sort keys %$what) {
541 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
544 $params->{''} = 1 if $what->{''};
545 $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
546 $params->{NV} = 1 if $what->{NV};
547 $params->{PV} = 1 if $what->{PV} || $what->{PVN};
548 $params->{SV} = 1 if $what->{SV};
554 dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
556 An internal function to generate the embedded perl code that will regenerate
557 the constant subroutines. I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the
558 same as for C_constant. I<INDENT> is treated as number of spaces to indent
559 by. I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
560 recognised. If the value is true a C<$types> is always declared in the perl
561 code generated, if defined and false never declared, and if undefined C<$types>
562 is only declared if the values in I<TYPES> as passed in cannot be inferred from
563 I<DEFAULT_TYPES> and the I<ITEM>s.
568 my ($default_type, $what, $indent, $options, @items) = @_;
569 my $declare_types = $options->{declare_types};
570 $indent = ' ' x ($indent || 0);
573 my (@simple, @complex, %used_types);
577 $type = $_->{type} || $default_type;
579 # For simplicity always skip the bytes case, and reconstitute this entry
580 # from its utf8 twin.
581 next if $_->{utf8} eq 'no';
582 # Copy the hashref, as we don't want to mess with the caller's hashref.
584 utf8::decode ($_->{name});
589 $type = $default_type;
591 $used_types{$type}++;
592 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
593 and !defined ($_->{macro}) and !defined ($_->{value})
594 and !defined ($_->{default}) and !defined ($_->{pre})
595 and !defined ($_->{post}) and !defined ($_->{def_pre})
596 and !defined ($_->{def_post})) {
597 # It's the default type, and the name consists only of A-Za-z0-9_
598 push @simple, $_->{name};
604 if (!defined $declare_types) {
605 # Do they pass in any types we weren't already using?
606 foreach (keys %$what) {
607 next if $used_types{$_};
608 $declare_types++; # Found one in $what that wasn't used.
609 last; # And one is enough to terminate this loop
612 if ($declare_types) {
613 $result = $indent . 'my $types = {map {($_, 1)} qw('
614 . join (" ", sort keys %$what) . ")};\n";
616 $result .= wrap ($indent . "my \@names = (qw(",
617 $indent . " ", join (" ", sort @simple) . ")");
619 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
620 my $name = perl_stringify $item->{name};
621 my $line = ",\n$indent {name=>\"$name\"";
622 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
623 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
624 my $value = $item->{$thing};
625 if (defined $value) {
627 $line .= ", $thing=>[\""
628 . join ('", "', map {perl_stringify $_} @$value) . '"]';
630 $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
635 # Ensure that the enclosing C comment doesn't end
636 # by turning */ into *" . "/
637 $line =~ s!\*\/!\*" . "/!gs;
638 # gcc -Wall doesn't like finding /* inside a comment
639 $line =~ s!\/\*!/" . "\*!gs;
651 dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
653 An internal function to generate the embedded perl code that will regenerate
654 the constant subroutines. Parameters are the same as for C_constant.
659 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
661 my $result = <<"EOT";
662 /* When generated this function returned values for the list of names given
663 in this section of perl code. Rather than manually editing these functions
664 to add or remove constants, which would result in this comment and section
665 of code becoming inaccurate, we recommend that you edit this section of
666 code, and use it to regenerate a new set of constant functions which you
667 then use to replace the originals.
669 Regenerate these constant functions by feeding this entire source file to
673 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
676 $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
679 print constant_types(); # macro defs
681 $package = perl_stringify($package);
683 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
684 # The form of the indent parameter isn't defined. (Yet)
685 if (defined $indent) {
686 require Data::Dumper;
687 $Data::Dumper::Terse=1;
688 $Data::Dumper::Terse=1; # Not used once. :-)
689 chomp ($indent = Data::Dumper::Dumper ($indent));
694 $result .= ", $breakout" . ', @names) ) {
695 print $_, "\n"; # C constant subs
697 print "#### XS Section:\n";
698 print XS_constant ("' . $package . '", $types);
709 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
711 A function that returns a B<list> of C subroutine definitions that return
712 the value and type of constants when passed the name by the XS wrapper.
713 I<ITEM...> gives a list of constant names. Each can either be a string,
714 which is taken as a C macro name, or a reference to a hash with the following
721 The name of the constant, as seen by the perl code.
725 The type of the constant (I<IV>, I<NV> etc)
729 A C expression for the value of the constant, or a list of C expressions if
730 the type is aggregate. This defaults to the I<name> if not given.
734 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
735 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
736 array is passed then the first element is used in place of the C<#ifdef>
737 line, and the second element in place of the C<#endif>. This allows
738 pre-processor constructions such as
746 to be used to determine if a constant is to be defined.
748 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
753 Default value to use (instead of C<croak>ing with "your vendor has not
754 defined...") to return if the macro isn't defined. Specify a reference to
755 an array with type followed by value(s).
759 C code to use before the assignment of the value of the constant. This allows
760 you to use temporary variables to extract a value from part of a C<struct>
761 and return this as I<value>. This C code is places at the start of a block,
762 so you can declare variables in it.
766 C code to place between the assignment of value (to a temporary) and the
767 return from the function. This allows you to clear up anything in I<pre>.
773 Equivalents of I<pre> and I<post> for the default value.
777 Generated internally. Is zero or undefined if name is 7 bit ASCII,
778 "no" if the name is 8 bit (and so should only match if SvUTF8() is false),
779 "yes" if the name is utf8 encoded.
781 The internals automatically clone any name with characters 128-255 but none
782 256+ (ie one that could be either in bytes or utf8) into a second entry
783 which is utf8 encoded.
787 I<PACKAGE> is the name of the package, and is only used in comments inside the
790 The next 5 arguments can safely be given as C<undef>, and are mainly used
791 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
793 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
794 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
795 separated list of types that the C subroutine C<constant> will generate or as
796 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
797 present, as will any types given in the list of I<ITEM>s. The resultant list
798 should be the same list of types that C<XS_constant> is given. [Otherwise
799 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
800 constant function. I<INDENT> is currently unused and ignored. In future it may
801 be used to pass in information used to change the C indentation style used.]
802 The best way to maintain consistency is to pass in a hash reference and let
803 this function update it.
805 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
806 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
807 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
808 example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
809 3. A single C<ITEM> is always inlined.
813 # The parameter now BREAKOUT was previously documented as:
815 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
816 # this length, and that the constant name passed in by perl is checked and
817 # also of this length. It is used during recursion, and should be C<undef>
818 # unless the caller has checked all the lengths during code generation, and
819 # the generated subroutine is only to be called with a name of this length.
821 # As you can see it now performs this function during recursion by being a
825 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
828 $subname ||= 'constant';
829 # I'm not using this. But a hashref could be used for full formatting without
833 my ($namelen, $items);
835 # We are called recursively. We trust @items to be normalised, $what to
836 # be a hashref, and pinch %$items from our parent to save recalculation.
837 ($namelen, $items) = @$breakout;
840 $default_type ||= 'IV';
842 # Convert line of the form IV,UV,NV to hash
843 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
844 # Figure out what types we're dealing with, and assign all unknowns to the
848 foreach my $orig (@items) {
851 # Make a copy which is a normalised version of the ref passed in.
852 $name = $orig->{name};
853 my ($type, $macro, $value) = @$orig{qw (type macro value)};
854 $type ||= $default_type;
856 $item = {name=>$name, type=>$type};
858 undef $macro if defined $macro and $macro eq $name;
859 $item->{macro} = $macro if defined $macro;
860 undef $value if defined $value and $value eq $name;
861 $item->{value} = $value if defined $value;
862 foreach my $key (qw(default pre post def_pre def_post)) {
863 my $value = $orig->{$key};
864 $item->{$key} = $value if defined $value;
865 # warn "$key $value";
869 $item = {name=>$name, type=>$default_type};
870 $what->{$default_type} = 1;
872 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}};
873 if ($name !~ tr/\0-\177//c) {
874 # No characters outside 7 bit ASCII.
875 if (exists $items->{$name}) {
876 die "Multiple definitions for macro $name";
878 $items->{$name} = $item;
880 # No characters outside 8 bit. This is hardest.
881 if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
882 confess "Unexpected ASCII definition for macro $name";
884 if ($name !~ tr/\0-\377//c) {
885 $item->{utf8} = 'no';
886 $items->{$name}[1] = $item;
887 push @new_items, $item;
888 # Copy item, to create the utf8 variant.
891 # Encode the name as utf8 bytes.
893 if ($items->{$name}[0]) {
894 die "Multiple definitions for macro $name";
896 $item->{utf8} = 'yes';
897 $item->{name} = $name;
898 $items->{$name}[0] = $item;
899 # We have need for the utf8 flag.
902 push @new_items, $item;
905 # use Data::Dumper; print Dumper @items;
907 my $params = params ($what);
909 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
910 $body .= ", STRLEN len" unless defined $namelen;
911 $body .= ", int utf8" if $params->{''};
912 $body .= ", IV *iv_return" if $params->{IV};
913 $body .= ", NV *nv_return" if $params->{NV};
914 $body .= ", const char **pv_return" if $params->{PV};
915 $body .= ", SV **sv_return" if $params->{SV};
918 if (defined $namelen) {
919 # We are a child subroutine. Print the simple description
920 my $comment = 'When generated this function returned values for the list'
921 . ' of names given here. However, subsequent manual editing may have'
922 . ' added or removed some.';
923 $body .= switch_clause (2, $comment, $namelen, $items, @items);
925 # We are the top level.
926 $body .= " /* Initially switch on the length of the name. */\n";
927 $body .= dogfood ($package, $subname, $default_type, $what, $indent,
929 $body .= " switch (len) {\n";
930 # Need to group names of the same length
933 push @{$by_length[length $_->{name}]}, $_;
935 foreach my $i (0 .. $#by_length) {
936 next unless $by_length[$i]; # None of this length
937 $body .= " case $i:\n";
938 if (@{$by_length[$i]} == 1) {
939 $body .= match_clause ($by_length[$i]->[0]);
940 } elsif (@{$by_length[$i]} < $breakout) {
941 $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
943 # Only use the minimal set of parameters actually needed by the types
944 # of the names of this length.
946 foreach (@{$by_length[$i]}) {
947 $what->{$_->{type}} = 1;
948 $what->{''} = 1 if $_->{utf8};
950 $params = params ($what);
951 push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
952 $indent, [$i, $items], @{$by_length[$i]});
953 $body .= " return ${subname}_$i (aTHX_ name";
954 $body .= ", utf8" if $params->{''};
955 $body .= ", iv_return" if $params->{IV};
956 $body .= ", nv_return" if $params->{NV};
957 $body .= ", pv_return" if $params->{PV};
958 $body .= ", sv_return" if $params->{SV};
961 $body .= " break;\n";
965 $body .= " return PERL_constant_NOTFOUND;\n}\n";
966 return (@subs, $body);
969 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
971 A function to generate the XS code to implement the perl subroutine
972 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
973 This XS code is a wrapper around a C subroutine usually generated by
974 C<C_constant>, and usually named C<constant>.
976 I<TYPES> should be given either as a comma separated list of types that the
977 C subroutine C<constant> will generate or as a reference to a hash. It should
978 be the same list of types as C<C_constant> was given.
979 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
980 the number of parameters passed to the C function C<constant>]
982 You can call the perl visible subroutine something other than C<constant> if
983 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
984 the name of the perl visible subroutine, unless you give the parameter
993 my $C_subname = shift;
994 $subname ||= 'constant';
995 $C_subname ||= $subname;
998 # Convert line of the form IV,UV,NV to hash
999 $what = {map {$_ => 1} split /,\s*/, ($what)};
1001 my $params = params ($what);
1009 dXSTARG; /* Faster if we have it. */
1017 if ($params->{IV}) {
1020 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
1022 if ($params->{NV}) {
1025 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
1027 if ($params->{PV}) {
1028 $xs .= " const char *pv;\n";
1031 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
1037 const char * s = SvPV(sv, len);
1039 if ($params->{''}) {
1042 int utf8 = SvUTF8(sv);
1049 if ($params->{IV} xor $params->{NV}) {
1051 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
1052 if you need to return both NVs and IVs */
1055 $xs .= " type = $C_subname(aTHX_ s, len";
1056 $xs .= ', utf8' if $params->{''};
1057 $xs .= ', &iv' if $params->{IV};
1058 $xs .= ', &nv' if $params->{NV};
1059 $xs .= ', &pv' if $params->{PV};
1060 $xs .= ', &sv' if $params->{SV};
1064 /* Return 1 or 2 items. First is error message, or undef if no error.
1065 Second, if present, is found value */
1067 case PERL_constant_NOTFOUND:
1068 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
1071 case PERL_constant_NOTDEF:
1072 sv = sv_2mortal(newSVpvf(
1073 "Your vendor has not defined $package macro %s, used", s));
1078 foreach $type (sort keys %XS_Constant) {
1079 # '' marks utf8 flag needed.
1080 next if $type eq '';
1081 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
1082 unless $what->{$type};
1083 $xs .= " case PERL_constant_IS$type:\n";
1084 if (length $XS_Constant{$type}) {
1087 PUSHs(&PL_sv_undef);
1088 $XS_Constant{$type};
1091 # Do nothing. return (), which will be correctly interpreted as
1095 unless ($what->{$type}) {
1096 chop $xs; # Yes, another need for chop not chomp.
1102 sv = sv_2mortal(newSVpvf(
1103 "Unexpected return type %d while processing $package macro %s, used",
1113 =item autoload PACKAGE, VERSION, AUTOLOADER
1115 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
1116 I<VERSION> is the perl version the code should be backwards compatible with.
1117 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
1118 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
1119 names that the constant() routine doesn't recognise.
1123 # ' # Grr. syntax highlighters that don't grok pod.
1126 my ($module, $compat_version, $autoloader) = @_;
1127 $compat_version ||= $];
1128 croak "Can't maintain compatibility back as far as version $compat_version"
1129 if $compat_version < 5;
1130 my $func = "sub AUTOLOAD {\n"
1131 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
1132 . " # XS function.";
1133 $func .= " If a constant is not found then control is passed\n"
1134 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
1138 . " my \$constname;\n";
1140 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
1143 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1144 croak "&${module}::constant not defined" if \$constname eq 'constant';
1145 my (\$error, \$val) = constant(\$constname);
1151 if ($error =~ /is not a valid/) {
1152 $AutoLoader::AUTOLOAD = $AUTOLOAD;
1153 goto &AutoLoader::AUTOLOAD;
1161 " if (\$error) { croak \$error; }\n";
1167 # Fixed between 5.005_53 and 5.005_61
1168 #XXX if ($] >= 5.00561) {
1169 #XXX *$AUTOLOAD = sub () { $val };
1172 *$AUTOLOAD = sub { $val };
1184 =item WriteMakefileSnippet
1186 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
1188 A function to generate perl code for Makefile.PL that will regenerate
1189 the constant subroutines. Parameters are named as passed to C<WriteConstants>,
1190 with the addition of C<INDENT> to specify the number of leading spaces
1193 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
1194 C<XS_FILE> are recognised.
1198 sub WriteMakefileSnippet {
1200 my $indent = $args{INDENT} || 2;
1202 my $result = <<"EOT";
1203 ExtUtils::Constant::WriteConstants(
1204 NAME => '$args{NAME}',
1206 DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
1208 foreach (qw (C_FILE XS_FILE)) {
1209 next unless exists $args{$_};
1210 $result .= sprintf " %-12s => '%s',\n",
1217 $result =~ s/^/' 'x$indent/gem;
1218 return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
1223 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
1225 Writes a file of C code and a file of XS code which you should C<#include>
1226 and C<INCLUDE> in the C and XS sections respectively of your module's XS
1227 code. You probaby want to do this in your C<Makefile.PL>, so that you can
1228 easily edit the list of constants without touching the rest of your module.
1229 The attributes supported are
1235 Name of the module. This must be specified
1239 The default type for the constants. If not specified C<IV> is assumed.
1243 The names of the constants are grouped by length. Generate child subroutines
1244 for each group with this number or more names in.
1248 An array of constants' names, either scalars containing names, or hashrefs
1249 as detailed in L<"C_constant">.
1253 The name of the file to write containing the C code. The default is
1254 C<const-c.inc>. The C<-> in the name ensures that the file can't be
1255 mistaken for anything related to a legitimate perl package name, and
1256 not naming the file C<.c> avoids having to override Makefile.PL's
1257 C<.xs> to C<.c> rules.
1261 The name of the file to write containing the XS code. The default is
1266 The perl visible name of the XS subroutine generated which will return the
1267 constants. The default is C<constant>.
1271 The name of the C subroutine generated which will return the constants.
1272 The default is I<SUBNAME>. Child subroutines have C<_> and the name
1273 length appended, so constants with 10 character names would be in
1274 C<constant_10> with the default I<XS_SUBNAME>.
1280 sub WriteConstants {
1283 C_FILE => 'const-c.inc',
1284 XS_FILE => 'const-xs.inc',
1285 SUBNAME => 'constant',
1286 DEFAULT_TYPE => 'IV',
1289 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1291 croak "Module name not specified" unless length $ARGS{NAME};
1293 open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1294 open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1296 # As this subroutine is intended to make code that isn't edited, there's no
1297 # need for the user to specify any types that aren't found in the list of
1301 print $c_fh constant_types(); # macro defs
1304 # indent is still undef. Until anyone implents indent style rules with it.
1305 foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1306 $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1307 print $c_fh $_, "\n"; # C constant subs
1309 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1312 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1313 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1323 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and