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'} } );
115 UV => 'PUSHu((UV)iv)',
117 PV => 'PUSHp(pv, strlen(pv))',
118 PVN => 'PUSHp(pv, iv)',
120 YES => 'PUSHs(&PL_sv_yes)',
121 NO => 'PUSHs(&PL_sv_no)',
122 UNDEF => '', # implicit undef
126 IV => '*iv_return =',
127 UV => '*iv_return = (IV)',
128 NV => '*nv_return =',
129 PV => '*pv_return =',
130 PVN => ['*pv_return =', '*iv_return = (IV)'],
131 SV => '*sv_return = ',
138 =item C_stringify NAME
140 A function which returns a correctly \ escaped version of the string passed
141 suitable for C's "" or ''. It will also be valid as a perl "" string.
145 # Hopefully make a happy C identifier.
148 return unless defined $_;
150 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
151 s/\n/\\n/g; # Ensure newlines don't end up in octal
156 unless ($] < 5.006) {
157 # This will elict a warning on 5.005_03 about [: :] being reserved unless
159 my $cheat = '([[:^print:]])';
160 s/$cheat/sprintf "\\%03o", ord $1/ge;
163 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
170 A function returning a single scalar with C<#define> definitions for the
171 constants used internally between the generated C and XS functions.
175 sub constant_types () {
178 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
179 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
180 foreach (sort keys %XS_Constant) {
181 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
183 push @lines, << 'EOT';
186 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
189 #define aTHX_ /* 5.6 or later define this for threading support. */
192 #define pTHX_ /* 5.6 or later define this for threading support. */
196 return join '', @lines;
199 =item memEQ_clause NAME, CHECKED_AT, INDENT
201 A function to return a suitable C C<if> statement to check whether I<NAME>
202 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
203 is used to avoid C<memEQ> for short names, or to generate a comment to
204 highlight the position of the character in the C<switch> statement.
209 # if (memEQ(name, "thingy", 6)) {
210 # Which could actually be a character comparison or even ""
211 my ($name, $checked_at, $indent) = @_;
212 $indent = ' ' x ($indent || 4);
213 my $len = length $name;
216 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
217 # We didn't switch, drop through to the code for the 2 character string
220 if ($len < 3 and defined $checked_at) {
222 if ($checked_at == 1) {
224 } elsif ($checked_at == 0) {
227 if (defined $check) {
228 my $char = C_stringify (substr $name, $check, 1);
229 return $indent . "if (name[$check] == '$char') {\n";
232 # Could optimise a memEQ on 3 to 2 single character checks here
233 $name = C_stringify ($name);
234 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
235 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
236 . (' ' x ($len - $checked_at + length $len)) . " */\n"
237 if defined $checked_at;
241 =item assign INDENT, TYPE, PRE, POST, VALUE...
243 A function to return a suitable assignment clause. If I<TYPE> is aggregate
244 (eg I<PVN> expects both pointer and length) then there should be multiple
245 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
246 of C code to preceed and follow the assignment. I<PRE> will be at the start
247 of a block, so variables may be defined in it.
251 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
257 my $post = shift || '';
262 $clause = $indent . "{\n$pre";
263 $clause .= ";" unless $pre =~ /;$/;
265 $close = "$indent}\n";
268 die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
269 my $typeset = $XS_TypeSet{$type};
271 die "Type $type is aggregate, but only single value given"
273 foreach (0 .. $#$typeset) {
274 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
276 } elsif (defined $typeset) {
277 die "Aggregate value given for type $type"
279 $clause .= $indent . "$typeset $_[0];\n";
284 $clause .= ";" unless $post =~ /;$/;
287 $clause .= "${indent}return PERL_constant_IS$type;\n";
288 $clause .= $close if $close;
294 return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
296 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
297 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
298 pointer and length) then I<VALUE> should be a reference to an array of
299 values in the order expected by the type. C<C_constant> will always call
300 this function with I<MACRO> defined, defaulting to the constant's name.
301 I<DEFAULT> if defined is an array reference giving default type and
302 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
303 The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
304 and follow the value, and the default value.
308 sub return_clause ($$$$$$$$$) {
310 # *iv_return = thingy;
311 # return PERL_constant_ISIV;
313 # return PERL_constant_NOTDEF;
315 my ($value, $type, $indent, $macro, $default, $pre, $post,
316 $def_pre, $def_post) = @_;
317 $macro = $value unless defined $macro;
318 $indent = ' ' x ($indent || 6);
324 $clause = $macro->[0];
325 } elsif ($macro ne "1") {
326 $clause = "#ifdef $macro\n";
329 # *iv_return = thingy;
330 # return PERL_constant_ISIV;
331 $clause .= assign ($indent, $type, $pre, $post,
332 ref $value ? @$value : $value);
334 if (ref $macro or $macro ne "1") {
336 $clause .= "#else\n";
338 # return PERL_constant_NOTDEF;
339 if (!defined $default) {
340 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
342 my @default = ref $default ? @$default : $default;
343 $type = shift @default;
344 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
349 $clause .= $macro->[1];
351 $clause .= "#endif\n";
357 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
359 An internal function to generate a suitable C<switch> clause, called by
360 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
361 of C<C_constant>, and must all have the names of the same length, given by
362 I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
363 keyed by name, values being the hashrefs in the I<ITEM> list.
364 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
365 are not in the list of I<ITEM>s without causing problems).
370 my ($indent, $comment, $namelen, $items, @items) = @_;
371 $indent = ' ' x ($indent || 2);
373 my @names = sort map {$_->{name}} @items;
374 my $leader = $indent . '/* ';
375 my $follower = ' ' x length $leader;
376 my $body = $indent . "/* Names all of length $namelen. */\n";
378 $body = wrap ($leader, $follower, $comment) . "\n";
381 $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
382 # Figure out what to switch on.
383 # (RMS, Spread of jump table, Position, Hashref)
384 my @best = (1e38, ~0);
385 foreach my $i (0 .. ($namelen - 1)) {
386 my ($min, $max) = (~0, 0);
389 my $char = substr $_, $i, 1;
391 $max = $ord if $ord > $max;
392 $min = $ord if $ord < $min;
393 push @{$spread{$char}}, $_;
396 # I'm going to pick the character to split on that minimises the root
397 # mean square of the number of names in each case. Normally this should
398 # be the one with the most keys, but it may pick a 7 where the 8 has
399 # one long linear search. I'm not sure if RMS or just sum of squares is
401 # $max and $min are for the tie-breaker if the root mean squares match.
402 # Assuming that the compiler may be building a jump table for the
403 # switch() then try to minimise the size of that jump table.
404 # Finally use < not <= so that if it still ties the earliest part of
405 # the string wins. Because if that passes but the memEQ fails, it may
406 # only need the start of the string to bin the choice.
407 # I think. But I'm micro-optimising. :-)
409 $ss += @$_ * @$_ foreach values %spread;
410 my $rms = sqrt ($ss / keys %spread);
411 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
412 @best = ($rms, $max - $min, $i, \%spread);
415 die "Internal error. Failed to pick a switch point for @names"
416 unless defined $best[2];
417 # use Data::Dumper; print Dumper (@best);
418 my ($offset, $best) = @best[2,3];
419 $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
420 $body .= $indent . "switch (name[$offset]) {\n";
421 foreach my $char (sort keys %$best) {
422 $body .= $indent . "case '" . C_stringify ($char) . "':\n";
423 foreach my $name (sort @{$best->{$char}}) {
424 my $thisone = $items->{$name};
425 my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
426 = @$thisone{qw (value macro default pre post def_pre def_post)};
427 $value = $name unless defined $value;
428 $macro = $name unless defined $macro;
430 # We have checked this offset.
431 $body .= memEQ_clause ($name, $offset, 2 + length $indent);
432 $body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
433 $macro, $default, $pre, $post,
434 $def_pre, $def_post);
435 $body .= $indent . " }\n";
437 $body .= $indent . " break;\n";
439 $body .= $indent . "}\n";
445 An internal function. I<WHAT> should be a hashref of types the constant
446 function will return. I<params> returns a hashref keyed IV NV PV SV to show
447 which combination of pointers will be needed in the C argument list.
453 foreach (sort keys %$what) {
454 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
457 $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
458 $params->{NV} = 1 if $what->{NV};
459 $params->{PV} = 1 if $what->{PV} || $what->{PVN};
460 $params->{SV} = 1 if $what->{SV};
466 dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
468 An internal function to generate the embedded perl code that will regenerate
469 the constant subroutines. I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the
470 same as for C_constant. I<INDENT> is treated as number of spaces to indent
471 by. I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
472 recognised. If the value is true a C<$types> is always declared in the perl
473 code generated, if defined and false never declared, and if undefined C<$types>
474 is only declared if the values in I<TYPES> as passed in cannot be inferred from
475 I<DEFAULT_TYPES> and the I<ITEM>s.
480 my ($default_type, $what, $indent, $options, @items) = @_;
481 my $declare_types = $options->{declare_types};
482 $indent = ' ' x ($indent || 0);
485 my (@simple, @complex, %used_types);
489 $type = $_->{type} || $default_type;
492 $type = $default_type;
494 $used_types{$type}++;
495 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
496 and !defined ($_->{macro}) and !defined ($_->{value})
497 and !defined ($_->{default}) and !defined ($_->{pre})
498 and !defined ($_->{post}) and !defined ($_->{def_pre})
499 and !defined ($_->{def_post})) {
500 # It's the default type, and the name consists only of A-Za-z0-9_
501 push @simple, $_->{name};
507 if (!defined $declare_types) {
508 # Do they pass in any types we weren't already using?
509 foreach (keys %$what) {
510 next if $used_types{$_};
511 $declare_types++; # Found one in $what that wasn't used.
512 last; # And one is enough to terminate this loop
515 if ($declare_types) {
516 $result = $indent . 'my $types = {map {($_, 1)} qw('
517 . join (" ", sort keys %$what) . ")};\n";
519 $result .= wrap ($indent . "my \@names = (qw(",
520 $indent . " ", join (" ", sort @simple) . ")");
522 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
523 my $name = C_stringify $item->{name};
524 my $line = ",\n$indent {name=>\"$name\"";
525 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
526 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
527 my $value = $item->{$thing};
528 if (defined $value) {
530 $line .= ", $thing=>[\""
531 . join ('", "', map {C_stringify $_} @$value) . '"]';
533 $line .= ", $thing=>\"" . C_stringify($value) . "\"";
538 # Ensure that the enclosing C comment doesn't end
539 # by turning */ into *" . "/
540 $line =~ s!\*\/!\*" . "/!gs;
541 # gcc -Wall doesn't like finding /* inside a comment
542 $line =~ s!\/\*!/" . "\*!gs;
554 dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
556 An internal function to generate the embedded perl code that will regenerate
557 the constant subroutines. Parameters are the same as for C_constant.
562 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
564 my $result = <<"EOT";
565 /* When generated this function returned values for the list of names given
566 in this section of perl code. Rather than manually editing these functions
567 to add or remove constants, which would result in this comment and section
568 of code becoming inaccurate, we recommend that you edit this section of
569 code, and use it to regenerate a new set of constant functions which you
570 then use to replace the originals.
572 Regenerate these constant functions by feeding this entire source file to
576 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
579 $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
582 print constant_types(); # macro defs
584 $package = C_stringify($package);
586 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
587 # The form of the indent parameter isn't defined. (Yet)
588 if (defined $indent) {
589 require Data::Dumper;
590 $Data::Dumper::Terse=1;
591 $Data::Dumper::Terse=1; # Not used once. :-)
592 chomp ($indent = Data::Dumper::Dumper ($indent));
597 $result .= ", $breakout" . ', @names) ) {
598 print $_, "\n"; # C constant subs
600 print "#### XS Section:\n";
601 print XS_constant ("' . $package . '", $types);
612 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
614 A function that returns a B<list> of C subroutine definitions that return
615 the value and type of constants when passed the name by the XS wrapper.
616 I<ITEM...> gives a list of constant names. Each can either be a string,
617 which is taken as a C macro name, or a reference to a hash with the following
624 The name of the constant, as seen by the perl code.
628 The type of the constant (I<IV>, I<NV> etc)
632 A C expression for the value of the constant, or a list of C expressions if
633 the type is aggregate. This defaults to the I<name> if not given.
637 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
638 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
639 array is passed then the first element is used in place of the C<#ifdef>
640 line, and the second element in place of the C<#endif>. This allows
641 pre-processor constructions such as
649 to be used to determine if a constant is to be defined.
651 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
656 Default value to use (instead of C<croak>ing with "your vendor has not
657 defined...") to return if the macro isn't defined. Specify a reference to
658 an array with type followed by value(s).
662 C code to use before the assignment of the value of the constant. This allows
663 you to use temporary variables to extract a value from part of a C<struct>
664 and return this as I<value>. This C code is places at the start of a block,
665 so you can declare variables in it.
669 C code to place between the assignment of value (to a temporary) and the
670 return from the function. This allows you to clear up anything in I<pre>.
676 Equivalents of I<pre> and I<post> for the default value.
680 I<PACKAGE> is the name of the package, and is only used in comments inside the
683 The next 5 arguments can safely be given as C<undef>, and are mainly used
684 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
686 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
687 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
688 separated list of types that the C subroutine C<constant> will generate or as
689 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
690 present, as will any types given in the list of I<ITEM>s. The resultant list
691 should be the same list of types that C<XS_constant> is given. [Otherwise
692 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
693 constant function. I<INDENT> is currently unused and ignored. In future it may
694 be used to pass in information used to change the C indentation style used.]
695 The best way to maintain consistency is to pass in a hash reference and let
696 this function update it.
698 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
699 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
700 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
701 example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
702 3. A single C<ITEM> is always inlined.
706 # The parameter now BREAKOUT was previously documented as:
708 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
709 # this length, and that the constant name passed in by perl is checked and
710 # also of this length. It is used during recursion, and should be C<undef>
711 # unless the caller has checked all the lengths during code generation, and
712 # the generated subroutine is only to be called with a name of this length.
714 # As you can see it now performs this function during recursion by being a
718 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
721 $subname ||= 'constant';
722 # I'm not using this. But a hashref could be used for full formatting without
726 my ($namelen, $items);
728 # We are called recursively. We trust @items to be normalised, $what to
729 # be a hashref, and pinch %$items from our parent to save recalculation.
730 ($namelen, $items) = @$breakout;
733 $default_type ||= 'IV';
735 # Convert line of the form IV,UV,NV to hash
736 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
737 # Figure out what types we're dealing with, and assign all unknowns to the
744 # Make a copy which is a normalised version of the ref passed in.
746 my ($type, $macro, $value) = @$_{qw (type macro value)};
747 $type ||= $default_type;
749 $_ = {name=>$name, type=>$type};
751 undef $macro if defined $macro and $macro eq $name;
752 $_->{macro} = $macro if defined $macro;
753 undef $value if defined $value and $value eq $name;
754 $_->{value} = $value if defined $value;
755 foreach my $key (qw(default pre post def_pre def_post)) {
756 my $value = $orig->{$key};
757 $_->{$key} = $value if defined $value;
758 # warn "$key $value";
762 $_ = {name=>$_, type=>$default_type};
763 $what->{$default_type} = 1;
765 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
766 if (exists $items->{$name}) {
767 die "Multiple definitions for macro $name";
769 $items->{$name} = $_;
772 my $params = params ($what);
774 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
775 $body .= ", STRLEN len" unless defined $namelen;
776 $body .= ", IV *iv_return" if $params->{IV};
777 $body .= ", NV *nv_return" if $params->{NV};
778 $body .= ", const char **pv_return" if $params->{PV};
779 $body .= ", SV **sv_return" if $params->{SV};
782 if (defined $namelen) {
783 # We are a child subroutine. Print the simple description
784 my $comment = 'When generated this function returned values for the list'
785 . ' of names given here. However, subsequent manual editing may have'
786 . ' added or removed some.';
787 $body .= switch_clause (2, $comment, $namelen, $items, @items);
789 # We are the top level.
790 $body .= " /* Initially switch on the length of the name. */\n";
791 $body .= dogfood ($package, $subname, $default_type, $what, $indent,
793 $body .= " switch (len) {\n";
794 # Need to group names of the same length
797 push @{$by_length[length $_->{name}]}, $_;
799 foreach my $i (0 .. $#by_length) {
800 next unless $by_length[$i]; # None of this length
801 $body .= " case $i:\n";
802 if (@{$by_length[$i]} == 1) {
803 my $thisone = $by_length[$i]->[0];
804 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
805 = @$thisone{qw (name value macro default pre post def_pre def_post)};
806 $value = $name unless defined $value;
807 $macro = $name unless defined $macro;
809 $body .= memEQ_clause ($name);
810 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
811 $default, $pre, $post, $def_pre, $def_post);
813 } elsif (@{$by_length[$i]} < $breakout) {
814 $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
816 # Only use the minimal set of parameters actually needed by the types
817 # of the names of this length.
819 foreach (@{$by_length[$i]}) {
820 $what->{$_->{type}} = 1;
822 $params = params ($what);
823 push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
824 $indent, [$i, $items], @{$by_length[$i]});
825 $body .= " return ${subname}_$i (aTHX_ name";
826 $body .= ", iv_return" if $params->{IV};
827 $body .= ", nv_return" if $params->{NV};
828 $body .= ", pv_return" if $params->{PV};
829 $body .= ", sv_return" if $params->{SV};
832 $body .= " break;\n";
836 $body .= " return PERL_constant_NOTFOUND;\n}\n";
837 return (@subs, $body);
840 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
842 A function to generate the XS code to implement the perl subroutine
843 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
844 This XS code is a wrapper around a C subroutine usually generated by
845 C<C_constant>, and usually named C<constant>.
847 I<TYPES> should be given either as a comma separated list of types that the
848 C subroutine C<constant> will generate or as a reference to a hash. It should
849 be the same list of types as C<C_constant> was given.
850 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
851 the number of parameters passed to the C function C<constant>]
853 You can call the perl visible subroutine something other than C<constant> if
854 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
855 the name of the perl visible subroutine, unless you give the parameter
864 my $C_subname = shift;
865 $subname ||= 'constant';
866 $C_subname ||= $subname;
869 # Convert line of the form IV,UV,NV to hash
870 $what = {map {$_ => 1} split /,\s*/, ($what)};
872 my $params = params ($what);
880 dXSTARG; /* Faster if we have it. */
891 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
896 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
899 $xs .= " const char *pv;\n";
902 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
908 const char * s = SvPV(sv, len);
912 if ($params->{IV} xor $params->{NV}) {
914 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
915 if you need to return both NVs and IVs */
918 $xs .= " type = $C_subname(aTHX_ s, len";
919 $xs .= ', &iv' if $params->{IV};
920 $xs .= ', &nv' if $params->{NV};
921 $xs .= ', &pv' if $params->{PV};
922 $xs .= ', &sv' if $params->{SV};
926 /* Return 1 or 2 items. First is error message, or undef if no error.
927 Second, if present, is found value */
929 case PERL_constant_NOTFOUND:
930 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
933 case PERL_constant_NOTDEF:
934 sv = sv_2mortal(newSVpvf(
935 "Your vendor has not defined $package macro %s, used", s));
940 foreach $type (sort keys %XS_Constant) {
941 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
942 unless $what->{$type};
943 $xs .= " case PERL_constant_IS$type:\n";
944 if (length $XS_Constant{$type}) {
951 # Do nothing. return (), which will be correctly interpreted as
955 unless ($what->{$type}) {
956 chop $xs; # Yes, another need for chop not chomp.
962 sv = sv_2mortal(newSVpvf(
963 "Unexpected return type %d while processing $package macro %s, used",
973 =item autoload PACKAGE, VERSION, AUTOLOADER
975 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
976 I<VERSION> is the perl version the code should be backwards compatible with.
977 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
978 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
979 names that the constant() routine doesn't recognise.
983 # ' # Grr. syntax highlighters that don't grok pod.
986 my ($module, $compat_version, $autoloader) = @_;
987 $compat_version ||= $];
988 croak "Can't maintain compatibility back as far as version $compat_version"
989 if $compat_version < 5;
990 my $func = "sub AUTOLOAD {\n"
991 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
993 $func .= " If a constant is not found then control is passed\n"
994 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
998 . " my \$constname;\n";
1000 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
1003 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1004 croak "&${module}::constant not defined" if \$constname eq 'constant';
1005 my (\$error, \$val) = constant(\$constname);
1011 if ($error =~ /is not a valid/) {
1012 $AutoLoader::AUTOLOAD = $AUTOLOAD;
1013 goto &AutoLoader::AUTOLOAD;
1021 " if (\$error) { croak \$error; }\n";
1027 # Fixed between 5.005_53 and 5.005_61
1028 #XXX if ($] >= 5.00561) {
1029 #XXX *$AUTOLOAD = sub () { $val };
1032 *$AUTOLOAD = sub { $val };
1044 =item WriteMakefileSnippet
1046 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
1048 A function to generate perl code for Makefile.PL that will regenerate
1049 the constant subroutines. Parameters are named as passed to C<WriteConstants>,
1050 with the addition of C<INDENT> to specify the number of leading spaces
1053 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
1054 C<XS_FILE> are recognised.
1058 sub WriteMakefileSnippet {
1060 my $indent = $args{INDENT} || 2;
1062 my $result = <<"EOT";
1063 ExtUtils::Constant::WriteConstants(
1064 NAME => '$args{NAME}',
1066 DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
1068 foreach (qw (C_FILE XS_FILE)) {
1069 next unless exists $args{$_};
1070 $result .= sprintf " %-12s => '%s',\n",
1077 $result =~ s/^/' 'x$indent/gem;
1078 return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
1083 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
1085 Writes a file of C code and a file of XS code which you should C<#include>
1086 and C<INCLUDE> in the C and XS sections respectively of your module's XS
1087 code. You probaby want to do this in your C<Makefile.PL>, so that you can
1088 easily edit the list of constants without touching the rest of your module.
1089 The attributes supported are
1095 Name of the module. This must be specified
1099 The default type for the constants. If not specified C<IV> is assumed.
1103 The names of the constants are grouped by length. Generate child subroutines
1104 for each group with this number or more names in.
1108 An array of constants' names, either scalars containing names, or hashrefs
1109 as detailed in L<"C_constant">.
1113 The name of the file to write containing the C code. The default is
1114 C<const-c.inc>. The C<-> in the name ensures that the file can't be
1115 mistaken for anything related to a legitimate perl package name, and
1116 not naming the file C<.c> avoids having to override Makefile.PL's
1117 C<.xs> to C<.c> rules.
1121 The name of the file to write containing the XS code. The default is
1126 The perl visible name of the XS subroutine generated which will return the
1127 constants. The default is C<constant>.
1131 The name of the C subroutine generated which will return the constants.
1132 The default is I<SUBNAME>. Child subroutines have C<_> and the name
1133 length appended, so constants with 10 character names would be in
1134 C<constant_10> with the default I<XS_SUBNAME>.
1140 sub WriteConstants {
1143 C_FILE => 'const-c.inc',
1144 XS_FILE => 'const-xs.inc',
1145 SUBNAME => 'constant',
1146 DEFAULT_TYPE => 'IV',
1149 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1151 croak "Module name not specified" unless length $ARGS{NAME};
1153 open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1154 open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1156 # As this subroutine is intended to make code that isn't edited, there's no
1157 # need for the user to specify any types that aren't found in the list of
1161 print $c_fh constant_types(); # macro defs
1164 # indent is still undef. Until anyone implents indent style rules with it.
1165 foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1166 $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1167 print $c_fh $_, "\n"; # C constant subs
1169 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1172 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1173 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1183 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and