1 package ExtUtils::Constant;
5 ExtUtils::Constant - generate XS code to import C header constants
9 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
10 print constant_types(); # macro defs
11 foreach (C_constant ("Foo", undef, "IV", undef, undef, undef,
13 print $_, "\n"; # C constant subs
15 print "MODULE = Foo PACKAGE = Foo\n";
16 print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
20 ExtUtils::Constant facilitates generating C and XS wrapper code to allow
21 perl modules to AUTOLOAD constants defined in C library header files.
22 It is principally used by the C<h2xs> utility, on which this code is based.
23 It doesn't contain the routines to scan header files to extract these
28 Generally one only needs to call the 3 functions shown in the synopsis,
29 C<constant_types()>, C<C_constant> and C<XS_constant>.
31 Currently this module understands the following types. h2xs may only know
32 a subset. The sizes of the numeric types are chosen by the C<Configure>
33 script at compile time.
39 signed integer, at least 32 bits.
43 unsigned integer, the same size as I<IV>
47 floating point type, probably C<double>, possibly C<long double>
51 NUL terminated string, length will be determined with C<strlen>
55 A fixed length thing, given as a [pointer, length] pair. If you know the
56 length of a string at compile time you may use this instead of I<PV>
60 Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
64 Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
68 C<undef>. The value of the macro is not needed.
78 require 5.006; # I think, for [:cntrl:] in REGEXP
84 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
86 $Text::Wrap::huge = 'overflow';
87 $Text::Wrap::columns = 80;
92 %EXPORT_TAGS = ( 'all' => [ qw(
93 XS_constant constant_types return_clause memEQ_clause C_stringify
97 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
101 UV => 'PUSHu((UV)iv)',
103 PV => 'PUSHp(pv, strlen(pv))',
104 PVN => 'PUSHp(pv, iv)',
105 YES => 'PUSHs(&PL_sv_yes)',
106 NO => 'PUSHs(&PL_sv_no)',
107 UNDEF => '' # implicit undef
111 IV => '*iv_return =',
112 UV => '*iv_return = (IV)',
113 NV => '*nv_return =',
114 PV => '*pv_return =',
115 PVN => ['*pv_return =', '*iv_return = (IV)'],
116 YES => undef, NO => undef, UNDEF => undef
120 =item C_stringify NAME
122 A function which returns a correctly \ escaped version of the string passed
123 suitable for C's "" or ''. It will also be valid as a perl "" string.
127 # Hopefully make a happy C identifier.
130 return unless defined $_;
132 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
133 s/\n/\\n/g; # Ensure newlines don't end up in octal
138 s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
139 s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:]
145 A function returning a single scalar with C<#define> definitions for the
146 constants used internally between the generated C and XS functions.
150 sub constant_types () {
153 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
154 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
155 foreach (sort keys %XS_Constant) {
156 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
158 push @lines, << 'EOT';
161 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
165 return join '', @lines;
168 =item memEQ_clause NAME, CHECKED_AT, INDENT
170 A function to return a suitable C C<if> statement to check whether I<NAME>
171 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
172 is used to avoid C<memEQ> for short names, or to generate a comment to
173 highlight the position of the character in the C<switch> statement.
178 # if (memEQ(name, "thingy", 6)) {
179 # Which could actually be a character comparison or even ""
180 my ($name, $checked_at, $indent) = @_;
181 $indent = ' ' x ($indent || 4);
182 my $len = length $name;
185 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
186 # We didn't switch, drop through to the code for the 2 character string
189 if ($len < 3 and defined $checked_at) {
191 if ($checked_at == 1) {
193 } elsif ($checked_at == 0) {
196 if (defined $check) {
197 my $char = C_stringify (substr $name, $check, 1);
198 return $indent . "if (name[$check] == '$char') {\n";
201 # Could optimise a memEQ on 3 to 2 single character checks here
202 $name = C_stringify ($name);
203 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
204 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
205 . (' ' x ($len - $checked_at + length $len)) . " */\n"
206 if defined $checked_at;
210 =item assign INDENT, TYPE, VALUE...
212 A function to return a suitable assignment clause. If I<TYPE> is aggregate
213 (eg I<PVN> expects both pointer and length) then there should be multiple
214 I<VALUE>s for the components.
218 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
224 die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
225 my $typeset = $XS_TypeSet{$type};
227 die "Type $type is aggregate, but only single value given"
229 foreach (0 .. $#$typeset) {
230 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
232 } elsif (defined $typeset) {
233 die "Aggregate value given for type $type"
235 $clause .= $indent . "$typeset $_[0];\n";
237 $clause .= "${indent}return PERL_constant_IS$type;\n";
241 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
243 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
244 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
245 pointer and length) then I<VALUE> should be a reference to an array of
246 values in the order expected by the type. C<C_constant> will always call
247 this function with I<MACRO> defined, defaulting to the constant's name.
248 I<DEFAULT> if defined is an array reference giving default type and and
249 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
253 sub return_clause ($$$$$) {
255 # *iv_return = thingy;
256 # return PERL_constant_ISIV;
258 # return PERL_constant_NOTDEF;
260 my ($value, $type, $indent, $macro, $default) = @_;
261 $macro = $value unless defined $macro;
262 $indent = ' ' x ($indent || 6);
268 $clause = $macro->[0];
270 $clause = "#ifdef $macro\n";
273 # *iv_return = thingy;
274 # return PERL_constant_ISIV;
275 $clause .= assign ($indent, $type, ref $value ? @$value : $value);
278 $clause .= "#else\n";
280 # return PERL_constant_NOTDEF;
281 if (!defined $default) {
282 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
284 $clause .= assign ($indent, ref $default ? @$default : $default);
289 $clause .= $macro->[1];
291 $clause .= "#endif\n";
298 An internal function. I<WHAT> should be a hashref of types the constant
299 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
300 $use_pv> to show which combination of pointers will be needed in the C
307 foreach (sort keys %$what) {
308 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
310 my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
311 my $use_nv = $what->{NV};
312 my $use_pv = $what->{PV} || $what->{PVN};
313 return ($use_iv, $use_nv, $use_pv);
318 dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
320 An internal function to generate the embedded perl code that will regenerate
321 the constant subroutines. Parameters are the same as for C_constant, except
322 that there is no NAMELEN.
327 my ($package, $subname, $default_type, $what, $indent, @items) = @_;
328 my (@simple, @complex);
330 my $type = $_->{type} || $default_type;
331 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
332 and !defined ($_->{macro}) and !defined ($_->{value})
333 and !defined ($_->{default})) {
334 # It's the default type, and the name consists only of A-Za-z0-9_
335 push @simple, $_->{name};
340 my $result = <<"EOT";
341 /* When generated this function returned values for the list of names given
342 in this section of perl code. Rather than manually editing these functions
343 to add or remove constants, which would result in this comment and section
344 of code becoming inaccurate, we recommend that you edit this section of
345 code, and use it to regenerate a new set of constant functions which you
346 then use to replace the originals.
348 Regenerate these constant functions by feeding this entire source file to
352 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
355 $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
357 $result .= wrap ("my \@names = (qw(",
358 " ", join (" ", sort @simple) . ")");
360 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
361 my $name = C_stringify $item->{name};
362 my ($macro, $value, $default) = @$item{qw (macro value default)};
363 my $line = ",\n {name=>\"$name\"";
364 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
365 if (defined $macro) {
367 $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
370 $line .= ", macro=>\"" . C_stringify($macro) . "\"";
373 if (defined $value) {
375 $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
378 $line .= ", value=>\"" . C_stringify($value) . "\"";
381 if (defined $default) {
383 $line .= ', default=>["'. join ('", "', map {C_stringify $_}
387 $line .= ", default=>\"" . C_stringify($default) . "\"";
391 # Ensure that the enclosing C comment doesn't end
392 # by turning */ into *" . "/
393 $line =~ s!\*\/!\*" . "/!gs;
394 # gcc -Wall doesn't like finding /* inside a comment
395 $line =~ s!\/\*!/" . "\*!gs;
403 print constant_types(); # macro defs
405 $package = C_stringify($package);
407 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
408 # The form of the indent parameter isn't defined. (Yet)
409 if (defined $indent) {
410 require Data::Dumper;
411 $Data::Dumper::Terse=1;
412 chomp ($indent = Data::Dumper::Dumper ($indent));
417 $result .= ', undef, @names) ) {
418 print $_, "\n"; # C constant subs
420 print "#### XS Section:\n";
421 print XS_constant ("' . $package . '", $types);
432 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
434 A function that returns a B<list> of C subroutine definitions that return
435 the value and type of constants when passed the name by the XS wrapper.
436 I<ITEM...> gives a list of constant names. Each can either be a string,
437 which is taken as a C macro name, or a reference to a hash with the following
444 The name of the constant, as seen by the perl code.
448 The type of the constant (I<IV>, I<NV> etc)
452 A C expression for the value of the constant, or a list of C expressions if
453 the type is aggregate. This defaults to the I<name> if not given.
457 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
458 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
459 array is passed then the first element is used in place of the C<#ifdef>
460 line, and the second element in place of the C<#endif>. This allows
461 pre-processor constructions such as
469 to be used to determine if a constant is to be defined.
473 Default value to use (instead of C<croak>ing with "your vendor has not
474 defined...") to return if the macro isn't defined. Specify a reference to
475 an array with type followed by value(s).
479 I<PACKAGE> is the name of the package, and is only used in comments inside the
482 The next 5 arguments can safely be given as C<undef>, and are mainly used
483 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
485 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
486 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
487 separated list of types that the C subroutine C<constant> will generate or as
488 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
489 present, as will any types given in the list of I<ITEM>s. The resultant list
490 should be the same list of types that C<XS_constant> is given. [Otherwise
491 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
492 constant function. I<INDENT> is currently unused and ignored. In future it may
493 be used to pass in information used to change the C indentation style used.]
494 The best way to maintain consistency is to pass in a hash reference and let
495 this function update it.
497 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
498 this length, and that the constant name passed in by perl is checked and
499 also of this length. It is used during recursion, and should be C<undef>
500 unless the caller has checked all the lengths during code generation, and
501 the generated subroutine is only to be called with a name of this length.
506 my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
508 $subname ||= 'constant';
509 # I'm not using this. But a hashref could be used for full formatting without
512 $default_type ||= 'IV';
514 # Convert line of the form IV,UV,NV to hash
515 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
516 # Figure out what types we're dealing with, and assign all unknowns to the
523 # Make a copy which is a normalised version of the ref passed in.
525 my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
526 $type ||= $default_type;
528 $_ = {name=>$name, type=>$type};
530 undef $macro if defined $macro and $macro eq $name;
531 $_->{macro} = $macro if defined $macro;
532 undef $value if defined $value and $value eq $name;
533 $_->{value} = $value if defined $value;
534 $_->{default} = $default if defined $default;
537 $_ = {name=>$_, type=>$default_type};
538 $what->{$default_type} = 1;
540 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
541 if (exists $items{$name}) {
542 die "Multiple definitions for macro $name";
546 my ($use_iv, $use_nv, $use_pv) = params ($what);
548 my ($body, @subs) = "static int\n$subname (const char *name";
549 $body .= ", STRLEN len" unless defined $namelen;
550 $body .= ", IV *iv_return" if $use_iv;
551 $body .= ", NV *nv_return" if $use_nv;
552 $body .= ", const char **pv_return" if $use_pv;
555 if (defined $namelen) {
556 # We are a child subroutine. Print the simple description
557 my @names = sort map {$_->{name}} @items;
559 /* When generated this function returned values for the list of names given
560 here. However, subsequent manual editing may have added or removed some.
562 . wrap (" ", " ", join (" ", @names) . " */") . "\n";
563 # Figure out what to switch on.
564 # (RMS, Spread of jump table, Position, Hashref)
565 my @best = (1e38, ~0);
566 foreach my $i (0 .. ($namelen - 1)) {
567 my ($min, $max) = (~0, 0);
570 my $char = substr $_, $i, 1;
572 $max = $ord if $ord > $max;
573 $min = $ord if $ord < $min;
574 push @{$spread{$char}}, $_;
577 # I'm going to pick the character to split on that minimises the root
578 # mean square of the number of names in each case. Normally this should
579 # be the one with the most keys, but it may pick a 7 where the 8 has
580 # one long linear search. I'm not sure if RMS or just sum of squares is
582 # $max and $min are for the tie-breaker if the root mean squares match.
583 # Assuming that the compiler may be building a jump table for the
584 # switch() then try to minimise the size of that jump table.
585 # Finally use < not <= so that if it still ties the earliest part of
586 # the string wins. Because if that passes but the memEQ fails, it may
587 # only need the start of the string to bin the choice.
588 # I think. But I'm micro-optimising. :-)
590 $ss += @$_ * @$_ foreach values %spread;
591 my $rms = sqrt ($ss / keys %spread);
592 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
593 @best = ($rms, $max - $min, $i, \%spread);
596 die "Internal error. Failed to pick a switch point for @names"
597 unless defined $best[2];
598 # use Data::Dumper; print Dumper (@best);
599 my ($offset, $best) = @best[2,3];
600 $body .= " /* Names all of length $namelen. */\n";
602 $body .= " /* Offset $offset gives the best switch position. */\n";
603 $body .= " switch (name[$offset]) {\n";
604 foreach my $char (sort keys %$best) {
605 $body .= " case '" . C_stringify ($char) . "':\n";
606 foreach my $name (sort @{$best->{$char}}) {
607 my $thisone = $items{$name};
608 my ($value, $macro, $default) = @$thisone{qw (value macro default)};
609 $value = $name unless defined $value;
610 $macro = $name unless defined $macro;
612 $body .= memEQ_clause ($name, $offset); # We have checked this offset.
613 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
617 $body .= " break;\n";
621 # We are the top level.
622 $body .= " /* Initially switch on the length of the name. */\n";
623 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
625 $body .= " switch (len) {\n";
626 # Need to group names of the same length
629 push @{$by_length[length $_->{name}]}, $_;
631 foreach my $i (0 .. $#by_length) {
632 next unless $by_length[$i]; # None of this length
633 $body .= " case $i:\n";
634 if (@{$by_length[$i]} == 1) {
635 my $thisone = $by_length[$i]->[0];
636 my ($name, $value, $macro, $default)
637 = @$thisone{qw (name value macro default)};
638 $value = $name unless defined $value;
639 $macro = $name unless defined $macro;
641 $body .= memEQ_clause ($name);
642 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
646 push @subs, C_constant ($package, "${subname}_$i", $default_type,
647 $what, $indent, $i, @{$by_length[$i]});
648 $body .= " return ${subname}_$i (name";
649 $body .= ", iv_return" if $use_iv;
650 $body .= ", nv_return" if $use_nv;
651 $body .= ", pv_return" if $use_pv;
654 $body .= " break;\n";
658 $body .= " return PERL_constant_NOTFOUND;\n}\n";
659 return (@subs, $body);
662 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
664 A function to generate the XS code to implement the perl subroutine
665 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
666 This XS code is a wrapper around a C subroutine usually generated by
667 C<C_constant>, and usually named C<constant>.
669 I<TYPES> should be given either as a comma separated list of types that the
670 C subroutine C<constant> will generate or as a reference to a hash. It should
671 be the same list of types as C<C_constant> was given.
672 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
673 the number of parameters passed to the C function C<constant>]
675 You can call the perl visible subroutine something other than C<constant> if
676 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
677 the name of the perl visible subroutine, unless you give the parameter
686 my $C_subname = shift;
687 $subname ||= 'constant';
688 $C_subname ||= $subname;
691 # Convert line of the form IV,UV,NV to hash
692 $what = {map {$_ => 1} split /,\s*/, ($what)};
694 my ($use_iv, $use_nv, $use_pv) = params ($what);
702 dXSTARG; /* Faster if we have it. */
713 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
718 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
721 $xs .= " const char *pv;\n";
724 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
730 const char * s = SvPV(sv, len);
734 if ($use_iv xor $use_nv) {
736 /* Change this to $C_subname(s, len, &iv, &nv);
737 if you need to return both NVs and IVs */
740 $xs .= " type = $C_subname(s, len";
741 $xs .= ', &iv' if $use_iv;
742 $xs .= ', &nv' if $use_nv;
743 $xs .= ', &pv' if $use_pv;
747 /* Return 1 or 2 items. First is error message, or undef if no error.
748 Second, if present, is found value */
750 case PERL_constant_NOTFOUND:
751 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
754 case PERL_constant_NOTDEF:
755 sv = sv_2mortal(newSVpvf(
756 "Your vendor has not defined $package macro %s used", s));
761 foreach $type (sort keys %XS_Constant) {
762 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
763 unless $what->{$type};
765 case PERL_constant_IS$type:
771 unless ($what->{$type}) {
772 chop $xs; # Yes, another need for chop not chomp.
778 sv = sv_2mortal(newSVpvf(
779 "Unexpected return type %d while processing $package macro %s used",
789 =item autoload PACKAGE, VERSION, AUTOLOADER
791 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
792 I<VERSION> is the perl version the code should be backwards compatible with.
793 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
794 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
795 names that the constant() routine doesn't recognise.
799 # ' # Grr. syntax highlighters that don't grok pod.
802 my ($module, $compat_version, $autoloader) = @_;
803 $compat_version ||= $];
804 croak "Can't maintain compatibility back as far as version $compat_version"
805 if $compat_version < 5;
806 my $func = "sub AUTOLOAD {\n"
807 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
809 $func .= " If a constant is not found then control is passed\n"
810 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
814 . " my \$constname;\n";
816 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
819 (\$constname = \$AUTOLOAD) =~ s/.*:://;
820 croak "&${module}::constant not defined" if \$constname eq 'constant';
821 my (\$error, \$val) = constant(\$constname);
827 if ($error =~ /is not a valid/) {
828 $AutoLoader::AUTOLOAD = $AUTOLOAD;
829 goto &AutoLoader::AUTOLOAD;
837 " if (\$error) { croak \$error; }\n";
843 # Fixed between 5.005_53 and 5.005_61
844 #XXX if ($] >= 5.00561) {
845 #XXX *$AUTOLOAD = sub () { $val };
848 *$AUTOLOAD = sub { $val };
865 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and