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.
95 require 5.006; # I think, for [:cntrl:] in REGEXP
102 $Text::Wrap::huge = 'overflow';
103 $Text::Wrap::columns = 80;
107 %EXPORT_TAGS = ( 'all' => [ qw(
108 XS_constant constant_types return_clause memEQ_clause C_stringify
109 C_constant autoload WriteConstants
112 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
116 UV => 'PUSHu((UV)iv)',
118 PV => 'PUSHp(pv, strlen(pv))',
119 PVN => 'PUSHp(pv, iv)',
121 YES => 'PUSHs(&PL_sv_yes)',
122 NO => 'PUSHs(&PL_sv_no)',
123 UNDEF => '', # implicit undef
127 IV => '*iv_return =',
128 UV => '*iv_return = (IV)',
129 NV => '*nv_return =',
130 PV => '*pv_return =',
131 PVN => ['*pv_return =', '*iv_return = (IV)'],
132 SV => '*sv_return = ',
139 =item C_stringify NAME
141 A function which returns a correctly \ escaped version of the string passed
142 suitable for C's "" or ''. It will also be valid as a perl "" string.
146 # Hopefully make a happy C identifier.
149 return unless defined $_;
151 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
152 s/\n/\\n/g; # Ensure newlines don't end up in octal
157 s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
158 s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:]
164 A function returning a single scalar with C<#define> definitions for the
165 constants used internally between the generated C and XS functions.
169 sub constant_types () {
172 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
173 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
174 foreach (sort keys %XS_Constant) {
175 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
177 push @lines, << 'EOT';
180 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
184 return join '', @lines;
187 =item memEQ_clause NAME, CHECKED_AT, INDENT
189 A function to return a suitable C C<if> statement to check whether I<NAME>
190 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
191 is used to avoid C<memEQ> for short names, or to generate a comment to
192 highlight the position of the character in the C<switch> statement.
197 # if (memEQ(name, "thingy", 6)) {
198 # Which could actually be a character comparison or even ""
199 my ($name, $checked_at, $indent) = @_;
200 $indent = ' ' x ($indent || 4);
201 my $len = length $name;
204 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
205 # We didn't switch, drop through to the code for the 2 character string
208 if ($len < 3 and defined $checked_at) {
210 if ($checked_at == 1) {
212 } elsif ($checked_at == 0) {
215 if (defined $check) {
216 my $char = C_stringify (substr $name, $check, 1);
217 return $indent . "if (name[$check] == '$char') {\n";
220 # Could optimise a memEQ on 3 to 2 single character checks here
221 $name = C_stringify ($name);
222 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
223 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
224 . (' ' x ($len - $checked_at + length $len)) . " */\n"
225 if defined $checked_at;
229 =item assign INDENT, TYPE, PRE, POST, VALUE...
231 A function to return a suitable assignment clause. If I<TYPE> is aggregate
232 (eg I<PVN> expects both pointer and length) then there should be multiple
233 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
234 of C code to preceed and follow the assignment. I<PRE> will be at the start
235 of a block, so variables may be defined in it.
239 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
245 my $post = shift || '';
250 $clause = $indent . "{\n$pre";
251 $clause .= ";" unless $pre =~ /;$/;
253 $close = "$indent}\n";
256 die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
257 my $typeset = $XS_TypeSet{$type};
259 die "Type $type is aggregate, but only single value given"
261 foreach (0 .. $#$typeset) {
262 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
264 } elsif (defined $typeset) {
265 die "Aggregate value given for type $type"
267 $clause .= $indent . "$typeset $_[0];\n";
272 $clause .= ";" unless $post =~ /;$/;
275 $clause .= "${indent}return PERL_constant_IS$type;\n";
276 $clause .= $close if $close;
280 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
282 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
283 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
284 pointer and length) then I<VALUE> should be a reference to an array of
285 values in the order expected by the type. C<C_constant> will always call
286 this function with I<MACRO> defined, defaulting to the constant's name.
287 I<DEFAULT> if defined is an array reference giving default type and and
288 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
289 The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
290 and follow the value, and the default value.
294 sub return_clause ($$$$$$$$$) {
296 # *iv_return = thingy;
297 # return PERL_constant_ISIV;
299 # return PERL_constant_NOTDEF;
301 my ($value, $type, $indent, $macro, $default, $pre, $post,
302 $def_pre, $def_post) = @_;
303 $macro = $value unless defined $macro;
304 $indent = ' ' x ($indent || 6);
310 $clause = $macro->[0];
312 $clause = "#ifdef $macro\n";
315 # *iv_return = thingy;
316 # return PERL_constant_ISIV;
317 $clause .= assign ($indent, $type, $pre, $post,
318 ref $value ? @$value : $value);
321 $clause .= "#else\n";
323 # return PERL_constant_NOTDEF;
324 if (!defined $default) {
325 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
327 my @default = ref $default ? @$default : $default;
328 $type = shift @default;
329 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
334 $clause .= $macro->[1];
336 $clause .= "#endif\n";
341 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
343 An internal function to generate a suitable C<switch> clause, called by
344 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
345 of C<C_constant>, and must all have the names of the same length, given by
346 I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
347 keyed by name, values being the hashrefs in the I<ITEM> list.
348 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
349 are not in the list of I<ITEM>s without causing problems).
354 my ($indent, $comment, $namelen, $items, @items) = @_;
355 $indent = ' ' x ($indent || 2);
357 my @names = sort map {$_->{name}} @items;
358 my $leader = $indent . '/* ';
359 my $follower = ' ' x length $leader;
360 my $body = $indent . "/* Names all of length $namelen. */\n";
362 $body = wrap ($leader, $follower, $comment) . "\n";
365 $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
366 # Figure out what to switch on.
367 # (RMS, Spread of jump table, Position, Hashref)
368 my @best = (1e38, ~0);
369 foreach my $i (0 .. ($namelen - 1)) {
370 my ($min, $max) = (~0, 0);
373 my $char = substr $_, $i, 1;
375 $max = $ord if $ord > $max;
376 $min = $ord if $ord < $min;
377 push @{$spread{$char}}, $_;
380 # I'm going to pick the character to split on that minimises the root
381 # mean square of the number of names in each case. Normally this should
382 # be the one with the most keys, but it may pick a 7 where the 8 has
383 # one long linear search. I'm not sure if RMS or just sum of squares is
385 # $max and $min are for the tie-breaker if the root mean squares match.
386 # Assuming that the compiler may be building a jump table for the
387 # switch() then try to minimise the size of that jump table.
388 # Finally use < not <= so that if it still ties the earliest part of
389 # the string wins. Because if that passes but the memEQ fails, it may
390 # only need the start of the string to bin the choice.
391 # I think. But I'm micro-optimising. :-)
393 $ss += @$_ * @$_ foreach values %spread;
394 my $rms = sqrt ($ss / keys %spread);
395 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
396 @best = ($rms, $max - $min, $i, \%spread);
399 die "Internal error. Failed to pick a switch point for @names"
400 unless defined $best[2];
401 # use Data::Dumper; print Dumper (@best);
402 my ($offset, $best) = @best[2,3];
403 $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
404 $body .= $indent . "switch (name[$offset]) {\n";
405 foreach my $char (sort keys %$best) {
406 $body .= $indent . "case '" . C_stringify ($char) . "':\n";
407 foreach my $name (sort @{$best->{$char}}) {
408 my $thisone = $items->{$name};
409 my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
410 = @$thisone{qw (value macro default pre post def_pre def_post)};
411 $value = $name unless defined $value;
412 $macro = $name unless defined $macro;
414 # We have checked this offset.
415 $body .= memEQ_clause ($name, $offset, 2 + length $indent);
416 $body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
417 $macro, $default, $pre, $post,
418 $def_pre, $def_post);
419 $body .= $indent . " }\n";
421 $body .= $indent . " break;\n";
423 $body .= $indent . "}\n";
429 An internal function. I<WHAT> should be a hashref of types the constant
430 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
431 $use_pv, $use_sv> to show which combination of pointers will be needed in the
438 foreach (sort keys %$what) {
439 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
441 my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
442 my $use_nv = $what->{NV};
443 my $use_pv = $what->{PV} || $what->{PVN};
444 my $use_sv = $what->{SV};
445 return ($use_iv, $use_nv, $use_pv, $use_sv);
450 dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
452 An internal function to generate the embedded perl code that will regenerate
453 the constant subroutines. Parameters are the same as for C_constant.
458 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
460 my (@simple, @complex);
462 my $type = $_->{type} || $default_type;
463 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
464 and !defined ($_->{macro}) and !defined ($_->{value})
465 and !defined ($_->{default}) and !defined ($_->{pre})
466 and !defined ($_->{post}) and !defined ($_->{def_pre})
467 and !defined ($_->{def_post})) {
468 # It's the default type, and the name consists only of A-Za-z0-9_
469 push @simple, $_->{name};
474 my $result = <<"EOT";
475 /* When generated this function returned values for the list of names given
476 in this section of perl code. Rather than manually editing these functions
477 to add or remove constants, which would result in this comment and section
478 of code becoming inaccurate, we recommend that you edit this section of
479 code, and use it to regenerate a new set of constant functions which you
480 then use to replace the originals.
482 Regenerate these constant functions by feeding this entire source file to
486 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
489 $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what)
491 $result .= wrap ("my \@names = (qw(",
492 " ", join (" ", sort @simple) . ")");
494 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
495 my $name = C_stringify $item->{name};
496 my $line = ",\n {name=>\"$name\"";
497 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
498 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
499 my $value = $item->{$thing};
500 if (defined $value) {
502 $line .= ", $thing=>[\""
503 . join ('", "', map {C_stringify $_} @$value) . '"]';
505 $line .= ", $thing=>\"" . C_stringify($value) . "\"";
510 # Ensure that the enclosing C comment doesn't end
511 # by turning */ into *" . "/
512 $line =~ s!\*\/!\*" . "/!gs;
513 # gcc -Wall doesn't like finding /* inside a comment
514 $line =~ s!\/\*!/" . "\*!gs;
522 print constant_types(); # macro defs
524 $package = C_stringify($package);
526 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
527 # The form of the indent parameter isn't defined. (Yet)
528 if (defined $indent) {
529 require Data::Dumper;
530 $Data::Dumper::Terse=1;
531 $Data::Dumper::Terse=1; # Not used once. :-)
532 chomp ($indent = Data::Dumper::Dumper ($indent));
537 $result .= ", $breakout" . ', @names) ) {
538 print $_, "\n"; # C constant subs
540 print "#### XS Section:\n";
541 print XS_constant ("' . $package . '", $types);
552 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
554 A function that returns a B<list> of C subroutine definitions that return
555 the value and type of constants when passed the name by the XS wrapper.
556 I<ITEM...> gives a list of constant names. Each can either be a string,
557 which is taken as a C macro name, or a reference to a hash with the following
564 The name of the constant, as seen by the perl code.
568 The type of the constant (I<IV>, I<NV> etc)
572 A C expression for the value of the constant, or a list of C expressions if
573 the type is aggregate. This defaults to the I<name> if not given.
577 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
578 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
579 array is passed then the first element is used in place of the C<#ifdef>
580 line, and the second element in place of the C<#endif>. This allows
581 pre-processor constructions such as
589 to be used to determine if a constant is to be defined.
593 Default value to use (instead of C<croak>ing with "your vendor has not
594 defined...") to return if the macro isn't defined. Specify a reference to
595 an array with type followed by value(s).
599 C code to use before the assignment of the value of the constant. This allows
600 you to use temporary variables to extract a value from part of a C<struct>
601 and return this as I<value>. This C code is places at the start of a block,
602 so you can declare variables in it.
606 C code to place between the assignment of value (to a temporary) and the
607 return from the function. This allows you to clear up anything in I<pre>.
613 Equivalents of I<pre> and I<post> for the default value.
617 I<PACKAGE> is the name of the package, and is only used in comments inside the
620 The next 5 arguments can safely be given as C<undef>, and are mainly used
621 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
623 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
624 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
625 separated list of types that the C subroutine C<constant> will generate or as
626 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
627 present, as will any types given in the list of I<ITEM>s. The resultant list
628 should be the same list of types that C<XS_constant> is given. [Otherwise
629 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
630 constant function. I<INDENT> is currently unused and ignored. In future it may
631 be used to pass in information used to change the C indentation style used.]
632 The best way to maintain consistency is to pass in a hash reference and let
633 this function update it.
635 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
636 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
637 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
638 example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
639 3. A single C<ITEM> is always inlined.
643 # The parameter now BREAKOUT was previously documented as:
645 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
646 # this length, and that the constant name passed in by perl is checked and
647 # also of this length. It is used during recursion, and should be C<undef>
648 # unless the caller has checked all the lengths during code generation, and
649 # the generated subroutine is only to be called with a name of this length.
651 # As you can see it now performs this function during recursion by being a
655 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
659 $namelen = $$breakout;
664 $subname ||= 'constant';
665 # I'm not using this. But a hashref could be used for full formatting without
668 $default_type ||= 'IV';
670 # Convert line of the form IV,UV,NV to hash
671 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
672 # Figure out what types we're dealing with, and assign all unknowns to the
680 # Make a copy which is a normalised version of the ref passed in.
682 my ($type, $macro, $value) = @$_{qw (type macro value)};
683 $type ||= $default_type;
685 $_ = {name=>$name, type=>$type};
687 undef $macro if defined $macro and $macro eq $name;
688 $_->{macro} = $macro if defined $macro;
689 undef $value if defined $value and $value eq $name;
690 $_->{value} = $value if defined $value;
691 foreach my $key (qw(default pre post def_pre def_post)) {
692 my $value = $orig->{$key};
693 $_->{$key} = $value if defined $value;
694 # warn "$key $value";
698 $_ = {name=>$_, type=>$default_type};
699 $what->{$default_type} = 1;
701 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
702 if (exists $items{$name}) {
703 die "Multiple definitions for macro $name";
707 my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
709 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
710 $body .= ", STRLEN len" unless defined $namelen;
711 $body .= ", IV *iv_return" if $use_iv;
712 $body .= ", NV *nv_return" if $use_nv;
713 $body .= ", const char **pv_return" if $use_pv;
714 $body .= ", SV **sv_return" if $use_sv;
717 if (defined $namelen) {
718 # We are a child subroutine. Print the simple description
719 my $comment = 'When generated this function returned values for the list'
720 . ' of names given here. However, subsequent manual editing may have'
721 . ' added or removed some.';
722 $body .= switch_clause (2, $comment, $namelen, \%items, @items);
724 # We are the top level.
725 $body .= " /* Initially switch on the length of the name. */\n";
726 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
728 $body .= " switch (len) {\n";
729 # Need to group names of the same length
732 push @{$by_length[length $_->{name}]}, $_;
734 foreach my $i (0 .. $#by_length) {
735 next unless $by_length[$i]; # None of this length
736 $body .= " case $i:\n";
737 if (@{$by_length[$i]} == 1) {
738 my $thisone = $by_length[$i]->[0];
739 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
740 = @$thisone{qw (name value macro default pre post def_pre def_post)};
741 $value = $name unless defined $value;
742 $macro = $name unless defined $macro;
744 $body .= memEQ_clause ($name);
745 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
746 $default, $pre, $post, $def_pre, $def_post);
748 } elsif (@{$by_length[$i]} < $breakout) {
749 $body .= switch_clause (4, '', $i, \%items, @{$by_length[$i]});
751 push @subs, C_constant ($package, "${subname}_$i", $default_type,
752 $what, $indent, \$i, @{$by_length[$i]});
753 $body .= " return ${subname}_$i (aTHX_ name";
754 $body .= ", iv_return" if $use_iv;
755 $body .= ", nv_return" if $use_nv;
756 $body .= ", pv_return" if $use_pv;
757 $body .= ", sv_return" if $use_sv;
760 $body .= " break;\n";
764 $body .= " return PERL_constant_NOTFOUND;\n}\n";
765 return (@subs, $body);
768 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
770 A function to generate the XS code to implement the perl subroutine
771 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
772 This XS code is a wrapper around a C subroutine usually generated by
773 C<C_constant>, and usually named C<constant>.
775 I<TYPES> should be given either as a comma separated list of types that the
776 C subroutine C<constant> will generate or as a reference to a hash. It should
777 be the same list of types as C<C_constant> was given.
778 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
779 the number of parameters passed to the C function C<constant>]
781 You can call the perl visible subroutine something other than C<constant> if
782 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
783 the name of the perl visible subroutine, unless you give the parameter
792 my $C_subname = shift;
793 $subname ||= 'constant';
794 $C_subname ||= $subname;
797 # Convert line of the form IV,UV,NV to hash
798 $what = {map {$_ => 1} split /,\s*/, ($what)};
800 my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
808 dXSTARG; /* Faster if we have it. */
819 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
824 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
827 $xs .= " const char *pv;\n";
830 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
836 const char * s = SvPV(sv, len);
840 if ($use_iv xor $use_nv) {
842 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
843 if you need to return both NVs and IVs */
846 $xs .= " type = $C_subname(aTHX_ s, len";
847 $xs .= ', &iv' if $use_iv;
848 $xs .= ', &nv' if $use_nv;
849 $xs .= ', &pv' if $use_pv;
850 $xs .= ', &sv' if $use_sv;
854 /* Return 1 or 2 items. First is error message, or undef if no error.
855 Second, if present, is found value */
857 case PERL_constant_NOTFOUND:
858 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
861 case PERL_constant_NOTDEF:
862 sv = sv_2mortal(newSVpvf(
863 "Your vendor has not defined $package macro %s, used", s));
868 foreach $type (sort keys %XS_Constant) {
869 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
870 unless $what->{$type};
871 $xs .= " case PERL_constant_IS$type:\n";
872 if (length $XS_Constant{$type}) {
879 # Do nothing. return (), which will be correctly interpreted as
883 unless ($what->{$type}) {
884 chop $xs; # Yes, another need for chop not chomp.
890 sv = sv_2mortal(newSVpvf(
891 "Unexpected return type %d while processing $package macro %s, used",
901 =item autoload PACKAGE, VERSION, AUTOLOADER
903 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
904 I<VERSION> is the perl version the code should be backwards compatible with.
905 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
906 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
907 names that the constant() routine doesn't recognise.
911 # ' # Grr. syntax highlighters that don't grok pod.
914 my ($module, $compat_version, $autoloader) = @_;
915 $compat_version ||= $];
916 croak "Can't maintain compatibility back as far as version $compat_version"
917 if $compat_version < 5;
918 my $func = "sub AUTOLOAD {\n"
919 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
921 $func .= " If a constant is not found then control is passed\n"
922 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
926 . " my \$constname;\n";
928 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
931 (\$constname = \$AUTOLOAD) =~ s/.*:://;
932 croak "&${module}::constant not defined" if \$constname eq 'constant';
933 my (\$error, \$val) = constant(\$constname);
939 if ($error =~ /is not a valid/) {
940 $AutoLoader::AUTOLOAD = $AUTOLOAD;
941 goto &AutoLoader::AUTOLOAD;
949 " if (\$error) { croak \$error; }\n";
955 # Fixed between 5.005_53 and 5.005_61
956 #XXX if ($] >= 5.00561) {
957 #XXX *$AUTOLOAD = sub () { $val };
960 *$AUTOLOAD = sub { $val };
972 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
974 Writes a file of C code and a file of XS code which you should C<#include>
975 and C<INCLUDE> in the C and XS sections respectively of your module's XS
976 code. You probaby want to do this in your C<Makefile.PL>, so that you can
977 easily edit the list of constants without touching the rest of your module.
978 The attributes supported are
984 Name of the module. This must be specified
988 The default type for the constants. If not specified C<IV> is assumed.
992 The names of the constants are grouped by length. Generate child subroutines
993 for each group with this number or more names in.
997 An array of constants' names, either scalars containing names, or hashrefs
998 as detailed in L<"C_constant">.
1002 The name of the file to write containing the C code. The default is
1007 The name of the file to write containing the XS code. The default is
1012 The perl visible name of the XS subroutine generated which will return the
1013 constants. The default is C<constant>.
1017 The name of the C subroutine generated which will return the constants.
1018 The default is I<SUBNAME>. Child subroutines have C<_> and the name
1019 length appended, so constants with 10 character names would be in
1020 C<constant_10> with the default I<XS_SUBNAME>.
1026 sub WriteConstants {
1029 C_FILE => 'constants.c',
1030 XS_FILE => 'constants.xs',
1031 SUBNAME => 'constant',
1032 DEFAULT_TYPE => 'IV',
1035 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1037 croak "Module name not specified" unless length $ARGS{NAME};
1039 open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1040 open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1042 # As this subroutine is intended to make code that isn't edited, there's no
1043 # need for the user to specify any types that aren't found in the list of
1047 print $c_fh constant_types(); # macro defs
1050 # indent is still undef. Until anyone implents indent style rules with it.
1051 foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1052 $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1053 print $c_fh $_, "\n"; # C constant subs
1055 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1058 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1059 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1069 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and