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>
66 require 5.006; # I think, for [:cntrl:] in REGEXP
72 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
74 $Text::Wrap::huge = 'overflow';
75 $Text::Wrap::columns = 80;
80 %EXPORT_TAGS = ( 'all' => [ qw(
81 XS_constant constant_types return_clause memEQ_clause C_stringify
85 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
89 UV => 'PUSHu((UV)iv)',
91 PV => 'PUSHp(pv, strlen(pv))',
92 PVN => 'PUSHp(pv, iv)'
97 UV => '*iv_return = (IV)',
100 PVN => ['*pv_return =', '*iv_return = (IV)']
104 =item C_stringify NAME
106 A function which returns a correctly \ escaped version of the string passed
107 suitable for C's "" or ''. It will also be valid as a perl "" string.
111 # Hopefully make a happy C identifier.
114 return unless defined $_;
116 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
117 s/\n/\\n/g; # Ensure newlines don't end up in octal
119 s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
120 s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:]
126 A function returning a single scalar with C<#define> definitions for the
127 constants used internally between the generated C and XS functions.
131 sub constant_types () {
134 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
135 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
136 foreach (sort keys %XS_Constant) {
137 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
139 push @lines, << 'EOT';
142 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
146 return join '', @lines;
149 =item memEQ_clause NAME, CHECKED_AT, INDENT
151 A function to return a suitable C C<if> statement to check whether I<NAME>
152 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
153 is used to avoid C<memEQ> for short names, or to generate a comment to
154 highlight the position of the character in the C<switch> statement.
159 # if (memEQ(name, "thingy", 6)) {
160 # Which could actually be a character comparison or even ""
161 my ($name, $checked_at, $indent) = @_;
162 $indent = ' ' x ($indent || 4);
163 my $len = length $name;
166 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
167 # We didn't switch, drop through to the code for the 2 character string
170 if ($len < 3 and defined $checked_at) {
172 if ($checked_at == 1) {
174 } elsif ($checked_at == 0) {
177 if (defined $check) {
178 my $char = C_stringify (substr $name, $check, 1);
179 return $indent . "if (name[$check] == '$char') {\n";
182 # Could optimise a memEQ on 3 to 2 single character checks here
183 $name = C_stringify ($name);
184 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
185 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
186 . (' ' x ($len - $checked_at + length $len)) . " */\n"
187 if defined $checked_at;
191 =item assign INDENT, TYPE, VALUE...
193 A function to return a suitable assignment clause. If I<TYPE> is aggregate
194 (eg I<PVN> expects both pointer and length) then there should be multiple
195 I<VALUE>s for the components.
199 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
204 my $typeset = $XS_TypeSet{$type};
206 die "Can't generate code for type $type" unless defined $typeset;
208 die "Type $type is aggregate, but only single value given"
210 foreach (0 .. $#$typeset) {
211 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
214 die "Aggregate value given for type $type"
216 $clause .= $indent . "$typeset $_[0];\n";
218 $clause .= "${indent}return PERL_constant_IS$type;\n";
222 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
224 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
225 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
226 pointer and length) then I<VALUE> should be a reference to an array of
227 values in the order expected by the type. C<C_constant> will always call
228 this function with I<MACRO> defined, defaulting to the constant's name.
229 I<DEFAULT> if defined is an array reference giving default type and and
230 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
234 sub return_clause ($$$$$) {
236 # *iv_return = thingy;
237 # return PERL_constant_ISIV;
239 # return PERL_constant_NOTDEF;
241 my ($value, $type, $indent, $macro, $default) = @_;
242 $macro = $value unless defined $macro;
243 $indent = ' ' x ($indent || 6);
249 $clause = $macro->[0];
251 $clause = "#ifdef $macro\n";
254 # *iv_return = thingy;
255 # return PERL_constant_ISIV;
256 $clause .= assign ($indent, $type, ref $value ? @$value : $value);
259 $clause .= "#else\n";
261 # return PERL_constant_NOTDEF;
262 if (!defined $default) {
263 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
265 $clause .= assign ($indent, ref $default ? @$default : $default);
270 $clause .= $macro->[1];
272 $clause .= "#endif\n";
279 An internal function. I<WHAT> should be a hashref of types the constant
280 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
281 $use_pv> to show which combination of pointers will be needed in the C
288 foreach (sort keys %$what) {
289 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
291 my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
292 my $use_nv = $what->{NV};
293 my $use_pv = $what->{PV} || $what->{PVN};
294 return ($use_iv, $use_nv, $use_pv);
297 =item dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
299 An internal function to generate the embedded perl code that will regenerate
300 the constant subroutines. Parameters are the same as for C_constant, except
301 that there is no NAMELEN.
306 my ($package, $subname, $default_type, $what, $indent, @items) = @_;
307 my (@simple, @complex);
309 my $type = $_->{type} || $default_type;
310 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
311 and !defined ($_->{macro}) and !defined ($_->{value})
312 and !defined ($_->{default})) {
313 # It's the default type, and the name consists only of A-Za-z0-9_
314 push @simple, $_->{name};
319 my $result = <<"EOT";
320 /* When generated this function returned values for the list of names given
321 in this section of perl code. Rather than manually editing these functions
322 to add or remove constants, which would result in this comment and section
323 of code becoming inaccurate, we recommend that you edit this section of
324 code, and use it to regenerate a new set of constant functions which you
325 then use to replace the originals.
327 Regenerate these constant functions by feeding this entire source file to
331 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
334 $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
336 $result .= wrap ("my \@names = (qw(",
337 " ", join (" ", sort @simple) . ")");
339 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
340 my $name = C_stringify $item->{name};
341 my ($macro, $value, $default) = @$item{qw (macro value default)};
342 my $line = ",\n {name=>\"$name\"";
343 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
344 if (defined $macro) {
346 $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
349 $line .= ", macro=>\"" . C_stringify($macro) . "\"";
352 if (defined $value) {
354 $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
357 $line .= ", value=>\"" . C_stringify($value) . "\"";
360 if (defined $default) {
362 $line .= ', default=>["'. join ('", "', map {C_stringify $_}
366 $line .= ", default=>\"" . C_stringify($default) . "\"";
370 # Ensure that the enclosing C comment doesn't end
371 # by turning */ into *" . "/
372 $line =~ s!\*\/!\*" . "/!gs;
380 print constant_types(); # macro defs
382 $package = C_stringify($package);
384 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
385 # The form of the indent parameter isn't defined. (Yet)
386 if (defined $indent) {
387 require Data::Dumper;
388 $Data::Dumper::Terse=1;
389 chomp ($indent = Data::Dumper::Dumper ($indent));
394 $result .= ', undef, @names) ) {
395 print $_, "\n"; # C constant subs
397 print "#### XS Section:\n";
398 print XS_constant ("' . $package . '", $types);
407 =item C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
409 A function that returns a B<list> of C subroutine definitions that return
410 the value and type of constants when passed the name by the XS wrapper.
411 I<ITEM...> gives a list of constant names. Each can either be a string,
412 which is taken as a C macro name, or a reference to a hash with the following
419 The name of the constant, as seen by the perl code.
423 The type of the constant (I<IV>, I<NV> etc)
427 A C expression for the value of the constant, or a list of C expressions if
428 the type is aggregate. This defaults to the I<name> if not given.
432 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
433 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
434 array is passed then the first element is used in place of the C<#ifdef>
435 line, and the second element in place of the C<#endif>. This allows
436 pre-processor constructions such as
444 to be used to determine if a constant is to be defined.
448 Default value to use (instead of C<croak>ing with "your vendor has not
449 defined...") to return if the macro isn't defined. Specify a reference to
450 an array with type followed by value(s).
454 I<PACKAGE> is the name of the package, and is only used in comments inside the
457 The next 5 arguments can safely be given as C<undef>, and are mainly used
458 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
460 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
461 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
462 separated list of types that the C subroutine C<constant> will generate or as
463 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
464 present, as will any types given in the list of I<ITEM>s. The resultant list
465 should be the same list of types that C<XS_constant> is given. [Otherwise
466 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
467 constant function. I<INDENT> is currently unused and ignored. In future it may
468 be used to pass in information used to change the C indentation style used.]
469 The best way to maintain consistency is to pass in a hash reference and let
470 this function update it.
472 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
473 this length, and that the constant name passed in by perl is checked and
474 also of this length. It is used during recursion, and should be C<undef>
475 unless the caller has checked all the lengths during code generation, and
476 the generated subroutine is only to be called with a name of this length.
481 my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
483 $subname ||= 'constant';
484 # I'm not using this. But a hashref could be used for full formatting without
487 $default_type ||= 'IV';
489 # Convert line of the form IV,UV,NV to hash
490 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
491 # Figure out what types we're dealing with, and assign all unknowns to the
498 # Make a copy which is a normalised version of the ref passed in.
500 my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
501 $type ||= $default_type;
503 $_ = {name=>$name, type=>$type};
505 undef $macro if defined $macro and $macro eq $name;
506 $_->{macro} = $macro if defined $macro;
507 undef $value if defined $value and $value eq $name;
508 $_->{value} = $value if defined $value;
509 $_->{default} = $default if defined $default;
512 $_ = {name=>$_, type=>$default_type};
513 $what->{$default_type} = 1;
515 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
516 if (exists $items{$name}) {
517 die "Multiple definitions for macro $name";
521 my ($use_iv, $use_nv, $use_pv) = params ($what);
523 my ($body, @subs) = "static int\n$subname (const char *name";
524 $body .= ", STRLEN len" unless defined $namelen;
525 $body .= ", IV *iv_return" if $use_iv;
526 $body .= ", NV *nv_return" if $use_nv;
527 $body .= ", const char **pv_return" if $use_pv;
530 if (defined $namelen) {
531 # We are a child subroutine. Print the simple description
532 my @names = sort map {$_->{name}} @items;
534 /* When generated this function returned values for the list of names given
535 here. However, subsequent manual editing may have added or removed some.
537 . wrap (" ", " ", join (" ", @names) . " */") . "\n";
538 # Figure out what to switch on.
539 # (RMS, Spread of jump table, Position, Hashref)
540 my @best = (1e38, ~0);
541 foreach my $i (0 .. ($namelen - 1)) {
542 my ($min, $max) = (~0, 0);
545 my $char = substr $_, $i, 1;
547 $max = $ord if $ord > $max;
548 $min = $ord if $ord < $min;
549 push @{$spread{$char}}, $_;
552 # I'm going to pick the character to split on that minimises the root
553 # mean square of the number of names in each case. Normally this should
554 # be the one with the most keys, but it may pick a 7 where the 8 has
555 # one long linear search. I'm not sure if RMS or just sum of squares is
557 # $max and $min are for the tie-breaker if the root mean squares match.
558 # Assuming that the compiler may be building a jump table for the
559 # switch() then try to minimise the size of that jump table.
560 # Finally use < not <= so that if it still ties the earliest part of
561 # the string wins. Because if that passes but the memEQ fails, it may
562 # only need the start of the string to bin the choice.
563 # I think. But I'm micro-optimising. :-)
565 $ss += @$_ * @$_ foreach values %spread;
566 my $rms = sqrt ($ss / keys %spread);
567 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
568 @best = ($rms, $max - $min, $i, \%spread);
571 die "Internal error. Failed to pick a switch point for @names"
572 unless defined $best[2];
573 # use Data::Dumper; print Dumper (@best);
574 my ($offset, $best) = @best[2,3];
575 $body .= " /* Names all of length $namelen. */\n";
577 $body .= " /* Offset $offset gives the best switch position. */\n";
578 $body .= " switch (name[$offset]) {\n";
579 foreach my $char (sort keys %$best) {
580 $body .= " case '" . C_stringify ($char) . "':\n";
581 foreach my $name (sort @{$best->{$char}}) {
582 my $thisone = $items{$name};
583 my ($value, $macro, $default) = @$thisone{qw (value macro default)};
584 $value = $name unless defined $value;
585 $macro = $name unless defined $macro;
587 $body .= memEQ_clause ($name, $offset); # We have checked this offset.
588 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
592 $body .= " break;\n";
596 # We are the top level.
597 $body .= " /* Initially switch on the length of the name. */\n";
598 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
600 $body .= " switch (len) {\n";
601 # Need to group names of the same length
604 push @{$by_length[length $_->{name}]}, $_;
606 foreach my $i (0 .. $#by_length) {
607 next unless $by_length[$i]; # None of this length
608 $body .= " case $i:\n";
609 if (@{$by_length[$i]} == 1) {
610 my $thisone = $by_length[$i]->[0];
611 my ($name, $value, $macro, $default)
612 = @$thisone{qw (name value macro default)};
613 $value = $name unless defined $value;
614 $macro = $name unless defined $macro;
616 $body .= memEQ_clause ($name);
617 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
621 push @subs, C_constant ($package, "${subname}_$i", $default_type,
622 $what, $indent, $i, @{$by_length[$i]});
623 $body .= " return ${subname}_$i (name";
624 $body .= ", iv_return" if $use_iv;
625 $body .= ", nv_return" if $use_nv;
626 $body .= ", pv_return" if $use_pv;
629 $body .= " break;\n";
633 $body .= " return PERL_constant_NOTFOUND;\n}\n";
634 return (@subs, $body);
637 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
639 A function to generate the XS code to implement the perl subroutine
640 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
641 This XS code is a wrapper around a C subroutine usually generated by
642 C<C_constant>, and usually named C<constant>.
644 I<TYPES> should be given either as a comma separated list of types that the
645 C subroutine C<constant> will generate or as a reference to a hash. It should
646 be the same list of types as C<C_constant> was given.
647 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
648 the number of parameters passed to the C function C<constant>]
650 You can call the perl visible subroutine something other than C<constant> if
651 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
652 the name of the perl visible subroutine, unless you give the parameter
661 my $C_subname = shift;
662 $subname ||= 'constant';
663 $C_subname ||= $subname;
666 # Convert line of the form IV,UV,NV to hash
667 $what = {map {$_ => 1} split /,\s*/, ($what)};
669 my ($use_iv, $use_nv, $use_pv) = params ($what);
677 dXSTARG; /* Faster if we have it. */
688 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
693 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
696 $xs .= " const char *pv;\n";
699 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
705 const char * s = SvPV(sv, len);
709 if ($use_iv xor $use_nv) {
711 /* Change this to $C_subname(s, len, &iv, &nv);
712 if you need to return both NVs and IVs */
715 $xs .= " type = $C_subname(s, len";
716 $xs .= ', &iv' if $use_iv;
717 $xs .= ', &nv' if $use_nv;
718 $xs .= ', &pv' if $use_pv;
722 /* Return 1 or 2 items. First is error message, or undef if no error.
723 Second, if present, is found value */
725 case PERL_constant_NOTFOUND:
726 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
729 case PERL_constant_NOTDEF:
730 sv = sv_2mortal(newSVpvf(
731 "Your vendor has not defined $package macro %s used", s));
736 foreach $type (sort keys %XS_Constant) {
737 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
738 unless $what->{$type};
740 case PERL_constant_IS$type:
746 unless ($what->{$type}) {
747 chop $xs; # Yes, another need for chop not chomp.
753 sv = sv_2mortal(newSVpvf(
754 "Unexpected return type %d while processing $package macro %s used",
764 =item autoload PACKAGE, VERSION, AUTOLOADER
766 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
767 I<VERSION> is the perl version the code should be backwards compatible with.
768 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
769 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
770 names that the constant() routine doesn't recognise.
774 # ' # Grr. syntax highlighters that don't grok pod.
777 my ($module, $compat_version, $autoloader) = @_;
778 $compat_version ||= $];
779 croak "Can't maintain compatibility back as far as version $compat_version"
780 if $compat_version < 5;
781 my $func = "sub AUTOLOAD {\n"
782 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
784 $func .= " If a constant is not found then control is passed\n"
785 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
789 . " my \$constname;\n";
791 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
794 (\$constname = \$AUTOLOAD) =~ s/.*:://;
795 croak "&${module}::constant not defined" if \$constname eq 'constant';
796 my (\$error, \$val) = constant(\$constname);
802 if ($error =~ /is not a valid/) {
803 $AutoLoader::AUTOLOAD = $AUTOLOAD;
804 goto &AutoLoader::AUTOLOAD;
812 " if (\$error) { croak \$error; }\n";
818 # Fixed between 5.005_53 and 5.005_61
819 #XXX if ($] >= 5.00561) {
820 #XXX *$AUTOLOAD = sub () { $val };
823 *$AUTOLOAD = sub { $val };
840 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and