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)],
15 C_FILE => 'constants.c',
16 XS_FILE => 'constants.xs',
18 # Generates wrapper code to make the values of the constants FOO BAR BAZ
23 ExtUtils::Constant facilitates generating C and XS wrapper code to allow
24 perl modules to AUTOLOAD constants defined in C library header files.
25 It is principally used by the C<h2xs> utility, on which this code is based.
26 It doesn't contain the routines to scan header files to extract these
31 Generally one only needs to call the C<WriteConstants> function, and then
33 #include "constants.c"
35 in the C section of C<Foo.xs>
39 in the XS section of C<Foo.xs>.
41 For greater flexibility use C<constant_types()>, C<C_constant> and
42 C<XS_constant>, with which C<WriteConstants> is implemented.
44 Currently this module understands the following types. h2xs may only know
45 a subset. The sizes of the numeric types are chosen by the C<Configure>
46 script at compile time.
52 signed integer, at least 32 bits.
56 unsigned integer, the same size as I<IV>
60 floating point type, probably C<double>, possibly C<long double>
64 NUL terminated string, length will be determined with C<strlen>
68 A fixed length thing, given as a [pointer, length] pair. If you know the
69 length of a string at compile time you may use this instead of I<PV>
77 Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
81 Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
85 C<undef>. The value of the macro is not needed.
96 eval "use warnings; 1" or die $@;
103 $Text::Wrap::huge = 'overflow';
104 $Text::Wrap::columns = 80;
108 %EXPORT_TAGS = ( 'all' => [ qw(
109 XS_constant constant_types return_clause memEQ_clause C_stringify
110 C_constant autoload WriteConstants
113 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
117 UV => 'PUSHu((UV)iv)',
119 PV => 'PUSHp(pv, strlen(pv))',
120 PVN => 'PUSHp(pv, iv)',
122 YES => 'PUSHs(&PL_sv_yes)',
123 NO => 'PUSHs(&PL_sv_no)',
124 UNDEF => '', # implicit undef
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 = ',
140 =item C_stringify NAME
142 A function which returns a correctly \ escaped version of the string passed
143 suitable for C's "" or ''. It will also be valid as a perl "" string.
147 # Hopefully make a happy C identifier.
150 return unless defined $_;
152 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
153 s/\n/\\n/g; # Ensure newlines don't end up in octal
158 unless ($] < 5.006) {
159 # This will elict a warning on 5.005_03 about [: :] being reserved unless
161 my $cheat = '([[:^print:]])';
162 s/$cheat/sprintf "\\%03o", ord $1/ge;
165 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
172 A function returning a single scalar with C<#define> definitions for the
173 constants used internally between the generated C and XS functions.
177 sub constant_types () {
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++;
185 push @lines, << 'EOT';
188 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
191 #define aTHX_ /* 5.6 or later define this for threading support. */
194 #define pTHX_ /* 5.6 or later define this for threading support. */
198 return join '', @lines;
201 =item memEQ_clause NAME, CHECKED_AT, INDENT
203 A function to return a suitable C C<if> statement to check whether I<NAME>
204 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
205 is used to avoid C<memEQ> for short names, or to generate a comment to
206 highlight the position of the character in the C<switch> statement.
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;
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
222 if ($len < 3 and defined $checked_at) {
224 if ($checked_at == 1) {
226 } elsif ($checked_at == 0) {
229 if (defined $check) {
230 my $char = C_stringify (substr $name, $check, 1);
231 return $indent . "if (name[$check] == '$char') {\n";
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;
243 =item assign INDENT, TYPE, PRE, POST, VALUE...
245 A 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
247 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
248 of C code to preceed and follow the assignment. I<PRE> will be at the start
249 of a block, so variables may be defined in it.
253 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
259 my $post = shift || '';
264 $clause = $indent . "{\n$pre";
265 $clause .= ";" unless $pre =~ /;$/;
267 $close = "$indent}\n";
270 die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
271 my $typeset = $XS_TypeSet{$type};
273 die "Type $type is aggregate, but only single value given"
275 foreach (0 .. $#$typeset) {
276 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
278 } elsif (defined $typeset) {
279 die "Aggregate value given for type $type"
281 $clause .= $indent . "$typeset $_[0];\n";
286 $clause .= ";" unless $post =~ /;$/;
289 $clause .= "${indent}return PERL_constant_IS$type;\n";
290 $clause .= $close if $close;
296 return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
298 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
299 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
300 pointer and length) then I<VALUE> should be a reference to an array of
301 values in the order expected by the type. C<C_constant> will always call
302 this function with I<MACRO> defined, defaulting to the constant's name.
303 I<DEFAULT> if defined is an array reference giving default type and and
304 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
305 The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
306 and follow the value, and the default value.
310 sub return_clause ($$$$$$$$$) {
312 # *iv_return = thingy;
313 # return PERL_constant_ISIV;
315 # return PERL_constant_NOTDEF;
317 my ($value, $type, $indent, $macro, $default, $pre, $post,
318 $def_pre, $def_post) = @_;
319 $macro = $value unless defined $macro;
320 $indent = ' ' x ($indent || 6);
326 $clause = $macro->[0];
327 } elsif ($macro ne "1") {
328 $clause = "#ifdef $macro\n";
331 # *iv_return = thingy;
332 # return PERL_constant_ISIV;
333 $clause .= assign ($indent, $type, $pre, $post,
334 ref $value ? @$value : $value);
336 if (ref $macro or $macro ne "1") {
338 $clause .= "#else\n";
340 # return PERL_constant_NOTDEF;
341 if (!defined $default) {
342 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
344 my @default = ref $default ? @$default : $default;
345 $type = shift @default;
346 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
351 $clause .= $macro->[1];
353 $clause .= "#endif\n";
359 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
361 An internal function to generate a suitable C<switch> clause, called by
362 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
363 of C<C_constant>, and must all have the names of the same length, given by
364 I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
365 keyed 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
367 are not in the list of I<ITEM>s without causing problems).
372 my ($indent, $comment, $namelen, $items, @items) = @_;
373 $indent = ' ' x ($indent || 2);
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";
380 $body = wrap ($leader, $follower, $comment) . "\n";
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);
391 my $char = substr $_, $i, 1;
393 $max = $ord if $ord > $max;
394 $min = $ord if $ord < $min;
395 push @{$spread{$char}}, $_;
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
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. :-)
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);
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};
427 my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
428 = @$thisone{qw (value macro default pre post def_pre def_post)};
429 $value = $name unless defined $value;
430 $macro = $name unless defined $macro;
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,
435 $macro, $default, $pre, $post,
436 $def_pre, $def_post);
437 $body .= $indent . " }\n";
439 $body .= $indent . " break;\n";
441 $body .= $indent . "}\n";
447 An internal function. I<WHAT> should be a hashref of types the constant
448 function will return. I<params> returns a hashref keyed IV NV PV SV to show
449 which combination of pointers will be needed in the C argument list.
455 foreach (sort keys %$what) {
456 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
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};
468 dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
470 An internal function to generate the embedded perl code that will regenerate
471 the constant subroutines. Parameters are the same as for C_constant.
476 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
478 my (@simple, @complex);
480 my $type = $_->{type} || $default_type;
481 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
482 and !defined ($_->{macro}) and !defined ($_->{value})
483 and !defined ($_->{default}) and !defined ($_->{pre})
484 and !defined ($_->{post}) and !defined ($_->{def_pre})
485 and !defined ($_->{def_post})) {
486 # It's the default type, and the name consists only of A-Za-z0-9_
487 push @simple, $_->{name};
492 my $result = <<"EOT";
493 /* When generated this function returned values for the list of names given
494 in this section of perl code. Rather than manually editing these functions
495 to add or remove constants, which would result in this comment and section
496 of code becoming inaccurate, we recommend that you edit this section of
497 code, and use it to regenerate a new set of constant functions which you
498 then use to replace the originals.
500 Regenerate these constant functions by feeding this entire source file to
504 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
507 $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what)
509 $result .= wrap ("my \@names = (qw(",
510 " ", join (" ", sort @simple) . ")");
512 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
513 my $name = C_stringify $item->{name};
514 my $line = ",\n {name=>\"$name\"";
515 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
516 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
517 my $value = $item->{$thing};
518 if (defined $value) {
520 $line .= ", $thing=>[\""
521 . join ('", "', map {C_stringify $_} @$value) . '"]';
523 $line .= ", $thing=>\"" . C_stringify($value) . "\"";
528 # Ensure that the enclosing C comment doesn't end
529 # by turning */ into *" . "/
530 $line =~ s!\*\/!\*" . "/!gs;
531 # gcc -Wall doesn't like finding /* inside a comment
532 $line =~ s!\/\*!/" . "\*!gs;
540 print constant_types(); # macro defs
542 $package = C_stringify($package);
544 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
545 # The form of the indent parameter isn't defined. (Yet)
546 if (defined $indent) {
547 require Data::Dumper;
548 $Data::Dumper::Terse=1;
549 $Data::Dumper::Terse=1; # Not used once. :-)
550 chomp ($indent = Data::Dumper::Dumper ($indent));
555 $result .= ", $breakout" . ', @names) ) {
556 print $_, "\n"; # C constant subs
558 print "#### XS Section:\n";
559 print XS_constant ("' . $package . '", $types);
570 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
572 A function that returns a B<list> of C subroutine definitions that return
573 the value and type of constants when passed the name by the XS wrapper.
574 I<ITEM...> gives a list of constant names. Each can either be a string,
575 which is taken as a C macro name, or a reference to a hash with the following
582 The name of the constant, as seen by the perl code.
586 The type of the constant (I<IV>, I<NV> etc)
590 A C expression for the value of the constant, or a list of C expressions if
591 the type is aggregate. This defaults to the I<name> if not given.
595 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
596 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
597 array is passed then the first element is used in place of the C<#ifdef>
598 line, and the second element in place of the C<#endif>. This allows
599 pre-processor constructions such as
607 to be used to determine if a constant is to be defined.
609 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
614 Default value to use (instead of C<croak>ing with "your vendor has not
615 defined...") to return if the macro isn't defined. Specify a reference to
616 an array with type followed by value(s).
620 C code to use before the assignment of the value of the constant. This allows
621 you to use temporary variables to extract a value from part of a C<struct>
622 and return this as I<value>. This C code is places at the start of a block,
623 so you can declare variables in it.
627 C code to place between the assignment of value (to a temporary) and the
628 return from the function. This allows you to clear up anything in I<pre>.
634 Equivalents of I<pre> and I<post> for the default value.
638 I<PACKAGE> is the name of the package, and is only used in comments inside the
641 The next 5 arguments can safely be given as C<undef>, and are mainly used
642 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
644 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
645 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
646 separated list of types that the C subroutine C<constant> will generate or as
647 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
648 present, as will any types given in the list of I<ITEM>s. The resultant list
649 should be the same list of types that C<XS_constant> is given. [Otherwise
650 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
651 constant function. I<INDENT> is currently unused and ignored. In future it may
652 be used to pass in information used to change the C indentation style used.]
653 The best way to maintain consistency is to pass in a hash reference and let
654 this function update it.
656 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
657 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
658 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
659 example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
660 3. A single C<ITEM> is always inlined.
664 # The parameter now BREAKOUT was previously documented as:
666 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
667 # this length, and that the constant name passed in by perl is checked and
668 # also of this length. It is used during recursion, and should be C<undef>
669 # unless the caller has checked all the lengths during code generation, and
670 # the generated subroutine is only to be called with a name of this length.
672 # As you can see it now performs this function during recursion by being a
676 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
679 $subname ||= 'constant';
680 # I'm not using this. But a hashref could be used for full formatting without
684 my ($namelen, $items);
686 # We are called recursively. We trust @items to be normalised, $what to
687 # be a hashref, and pinch %$items from our parent to save recalculation.
688 ($namelen, $items) = @$breakout;
691 $default_type ||= 'IV';
693 # Convert line of the form IV,UV,NV to hash
694 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
695 # Figure out what types we're dealing with, and assign all unknowns to the
702 # Make a copy which is a normalised version of the ref passed in.
704 my ($type, $macro, $value) = @$_{qw (type macro value)};
705 $type ||= $default_type;
707 $_ = {name=>$name, type=>$type};
709 undef $macro if defined $macro and $macro eq $name;
710 $_->{macro} = $macro if defined $macro;
711 undef $value if defined $value and $value eq $name;
712 $_->{value} = $value if defined $value;
713 foreach my $key (qw(default pre post def_pre def_post)) {
714 my $value = $orig->{$key};
715 $_->{$key} = $value if defined $value;
716 # warn "$key $value";
720 $_ = {name=>$_, type=>$default_type};
721 $what->{$default_type} = 1;
723 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
724 if (exists $items->{$name}) {
725 die "Multiple definitions for macro $name";
727 $items->{$name} = $_;
730 my $params = params ($what);
732 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
733 $body .= ", STRLEN len" unless defined $namelen;
734 $body .= ", IV *iv_return" if $params->{IV};
735 $body .= ", NV *nv_return" if $params->{NV};
736 $body .= ", const char **pv_return" if $params->{PV};
737 $body .= ", SV **sv_return" if $params->{SV};
740 if (defined $namelen) {
741 # We are a child subroutine. Print the simple description
742 my $comment = 'When generated this function returned values for the list'
743 . ' of names given here. However, subsequent manual editing may have'
744 . ' added or removed some.';
745 $body .= switch_clause (2, $comment, $namelen, $items, @items);
747 # We are the top level.
748 $body .= " /* Initially switch on the length of the name. */\n";
749 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
751 $body .= " switch (len) {\n";
752 # Need to group names of the same length
755 push @{$by_length[length $_->{name}]}, $_;
757 foreach my $i (0 .. $#by_length) {
758 next unless $by_length[$i]; # None of this length
759 $body .= " case $i:\n";
760 if (@{$by_length[$i]} == 1) {
761 my $thisone = $by_length[$i]->[0];
762 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
763 = @$thisone{qw (name value macro default pre post def_pre def_post)};
764 $value = $name unless defined $value;
765 $macro = $name unless defined $macro;
767 $body .= memEQ_clause ($name);
768 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
769 $default, $pre, $post, $def_pre, $def_post);
771 } elsif (@{$by_length[$i]} < $breakout) {
772 $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
774 # Only use the minimal set of parameters actually needed by the types
775 # of the names of this length.
777 foreach (@{$by_length[$i]}) {
778 $what->{$_->{type}} = 1;
780 $params = params ($what);
781 push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
782 $indent, [$i, $items], @{$by_length[$i]});
783 $body .= " return ${subname}_$i (aTHX_ name";
784 $body .= ", iv_return" if $params->{IV};
785 $body .= ", nv_return" if $params->{NV};
786 $body .= ", pv_return" if $params->{PV};
787 $body .= ", sv_return" if $params->{SV};
790 $body .= " break;\n";
794 $body .= " return PERL_constant_NOTFOUND;\n}\n";
795 return (@subs, $body);
798 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
800 A function to generate the XS code to implement the perl subroutine
801 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
802 This XS code is a wrapper around a C subroutine usually generated by
803 C<C_constant>, and usually named C<constant>.
805 I<TYPES> should be given either as a comma separated list of types that the
806 C subroutine C<constant> will generate or as a reference to a hash. It should
807 be the same list of types as C<C_constant> was given.
808 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
809 the number of parameters passed to the C function C<constant>]
811 You can call the perl visible subroutine something other than C<constant> if
812 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
813 the name of the perl visible subroutine, unless you give the parameter
822 my $C_subname = shift;
823 $subname ||= 'constant';
824 $C_subname ||= $subname;
827 # Convert line of the form IV,UV,NV to hash
828 $what = {map {$_ => 1} split /,\s*/, ($what)};
830 my $params = params ($what);
838 dXSTARG; /* Faster if we have it. */
849 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
854 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
857 $xs .= " const char *pv;\n";
860 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
866 const char * s = SvPV(sv, len);
870 if ($params->{IV} xor $params->{NV}) {
872 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
873 if you need to return both NVs and IVs */
876 $xs .= " type = $C_subname(aTHX_ s, len";
877 $xs .= ', &iv' if $params->{IV};
878 $xs .= ', &nv' if $params->{NV};
879 $xs .= ', &pv' if $params->{PV};
880 $xs .= ', &sv' if $params->{SV};
884 /* Return 1 or 2 items. First is error message, or undef if no error.
885 Second, if present, is found value */
887 case PERL_constant_NOTFOUND:
888 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
891 case PERL_constant_NOTDEF:
892 sv = sv_2mortal(newSVpvf(
893 "Your vendor has not defined $package macro %s, used", s));
898 foreach $type (sort keys %XS_Constant) {
899 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
900 unless $what->{$type};
901 $xs .= " case PERL_constant_IS$type:\n";
902 if (length $XS_Constant{$type}) {
909 # Do nothing. return (), which will be correctly interpreted as
913 unless ($what->{$type}) {
914 chop $xs; # Yes, another need for chop not chomp.
920 sv = sv_2mortal(newSVpvf(
921 "Unexpected return type %d while processing $package macro %s, used",
931 =item autoload PACKAGE, VERSION, AUTOLOADER
933 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
934 I<VERSION> is the perl version the code should be backwards compatible with.
935 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
936 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
937 names that the constant() routine doesn't recognise.
941 # ' # Grr. syntax highlighters that don't grok pod.
944 my ($module, $compat_version, $autoloader) = @_;
945 $compat_version ||= $];
946 croak "Can't maintain compatibility back as far as version $compat_version"
947 if $compat_version < 5;
948 my $func = "sub AUTOLOAD {\n"
949 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
951 $func .= " If a constant is not found then control is passed\n"
952 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
956 . " my \$constname;\n";
958 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
961 (\$constname = \$AUTOLOAD) =~ s/.*:://;
962 croak "&${module}::constant not defined" if \$constname eq 'constant';
963 my (\$error, \$val) = constant(\$constname);
969 if ($error =~ /is not a valid/) {
970 $AutoLoader::AUTOLOAD = $AUTOLOAD;
971 goto &AutoLoader::AUTOLOAD;
979 " if (\$error) { croak \$error; }\n";
985 # Fixed between 5.005_53 and 5.005_61
986 #XXX if ($] >= 5.00561) {
987 #XXX *$AUTOLOAD = sub () { $val };
990 *$AUTOLOAD = sub { $val };
1002 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
1004 Writes a file of C code and a file of XS code which you should C<#include>
1005 and C<INCLUDE> in the C and XS sections respectively of your module's XS
1006 code. You probaby want to do this in your C<Makefile.PL>, so that you can
1007 easily edit the list of constants without touching the rest of your module.
1008 The attributes supported are
1014 Name of the module. This must be specified
1018 The default type for the constants. If not specified C<IV> is assumed.
1022 The names of the constants are grouped by length. Generate child subroutines
1023 for each group with this number or more names in.
1027 An array of constants' names, either scalars containing names, or hashrefs
1028 as detailed in L<"C_constant">.
1032 The name of the file to write containing the C code. The default is
1037 The name of the file to write containing the XS code. The default is
1042 The perl visible name of the XS subroutine generated which will return the
1043 constants. The default is C<constant>.
1047 The name of the C subroutine generated which will return the constants.
1048 The default is I<SUBNAME>. Child subroutines have C<_> and the name
1049 length appended, so constants with 10 character names would be in
1050 C<constant_10> with the default I<XS_SUBNAME>.
1056 sub WriteConstants {
1059 C_FILE => 'constants.c',
1060 XS_FILE => 'constants.xs',
1061 SUBNAME => 'constant',
1062 DEFAULT_TYPE => 'IV',
1065 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1067 croak "Module name not specified" unless length $ARGS{NAME};
1069 open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1070 open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1072 # As this subroutine is intended to make code that isn't edited, there's no
1073 # need for the user to specify any types that aren't found in the list of
1077 print $c_fh constant_types(); # macro defs
1080 # indent is still undef. Until anyone implents indent style rules with it.
1081 foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1082 $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1083 print $c_fh $_, "\n"; # C constant subs
1085 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1088 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1089 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1099 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and