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);
299 dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
301 An internal function to generate the embedded perl code that will regenerate
302 the constant subroutines. Parameters are the same as for C_constant, except
303 that there is no NAMELEN.
308 my ($package, $subname, $default_type, $what, $indent, @items) = @_;
309 my (@simple, @complex);
311 my $type = $_->{type} || $default_type;
312 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
313 and !defined ($_->{macro}) and !defined ($_->{value})
314 and !defined ($_->{default})) {
315 # It's the default type, and the name consists only of A-Za-z0-9_
316 push @simple, $_->{name};
321 my $result = <<"EOT";
322 /* When generated this function returned values for the list of names given
323 in this section of perl code. Rather than manually editing these functions
324 to add or remove constants, which would result in this comment and section
325 of code becoming inaccurate, we recommend that you edit this section of
326 code, and use it to regenerate a new set of constant functions which you
327 then use to replace the originals.
329 Regenerate these constant functions by feeding this entire source file to
333 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
336 $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
338 $result .= wrap ("my \@names = (qw(",
339 " ", join (" ", sort @simple) . ")");
341 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
342 my $name = C_stringify $item->{name};
343 my ($macro, $value, $default) = @$item{qw (macro value default)};
344 my $line = ",\n {name=>\"$name\"";
345 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
346 if (defined $macro) {
348 $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
351 $line .= ", macro=>\"" . C_stringify($macro) . "\"";
354 if (defined $value) {
356 $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
359 $line .= ", value=>\"" . C_stringify($value) . "\"";
362 if (defined $default) {
364 $line .= ', default=>["'. join ('", "', map {C_stringify $_}
368 $line .= ", default=>\"" . C_stringify($default) . "\"";
372 # Ensure that the enclosing C comment doesn't end
373 # by turning */ into *" . "/
374 $line =~ s!\*\/!\*" . "/!gs;
382 print constant_types(); # macro defs
384 $package = C_stringify($package);
386 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
387 # The form of the indent parameter isn't defined. (Yet)
388 if (defined $indent) {
389 require Data::Dumper;
390 $Data::Dumper::Terse=1;
391 chomp ($indent = Data::Dumper::Dumper ($indent));
396 $result .= ', undef, @names) ) {
397 print $_, "\n"; # C constant subs
399 print "#### XS Section:\n";
400 print XS_constant ("' . $package . '", $types);
411 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
413 A function that returns a B<list> of C subroutine definitions that return
414 the value and type of constants when passed the name by the XS wrapper.
415 I<ITEM...> gives a list of constant names. Each can either be a string,
416 which is taken as a C macro name, or a reference to a hash with the following
423 The name of the constant, as seen by the perl code.
427 The type of the constant (I<IV>, I<NV> etc)
431 A C expression for the value of the constant, or a list of C expressions if
432 the type is aggregate. This defaults to the I<name> if not given.
436 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
437 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
438 array is passed then the first element is used in place of the C<#ifdef>
439 line, and the second element in place of the C<#endif>. This allows
440 pre-processor constructions such as
448 to be used to determine if a constant is to be defined.
452 Default value to use (instead of C<croak>ing with "your vendor has not
453 defined...") to return if the macro isn't defined. Specify a reference to
454 an array with type followed by value(s).
458 I<PACKAGE> is the name of the package, and is only used in comments inside the
461 The next 5 arguments can safely be given as C<undef>, and are mainly used
462 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
464 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
465 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
466 separated list of types that the C subroutine C<constant> will generate or as
467 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
468 present, as will any types given in the list of I<ITEM>s. The resultant list
469 should be the same list of types that C<XS_constant> is given. [Otherwise
470 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
471 constant function. I<INDENT> is currently unused and ignored. In future it may
472 be used to pass in information used to change the C indentation style used.]
473 The best way to maintain consistency is to pass in a hash reference and let
474 this function update it.
476 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
477 this length, and that the constant name passed in by perl is checked and
478 also of this length. It is used during recursion, and should be C<undef>
479 unless the caller has checked all the lengths during code generation, and
480 the generated subroutine is only to be called with a name of this length.
485 my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
487 $subname ||= 'constant';
488 # I'm not using this. But a hashref could be used for full formatting without
491 $default_type ||= 'IV';
493 # Convert line of the form IV,UV,NV to hash
494 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
495 # Figure out what types we're dealing with, and assign all unknowns to the
502 # Make a copy which is a normalised version of the ref passed in.
504 my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
505 $type ||= $default_type;
507 $_ = {name=>$name, type=>$type};
509 undef $macro if defined $macro and $macro eq $name;
510 $_->{macro} = $macro if defined $macro;
511 undef $value if defined $value and $value eq $name;
512 $_->{value} = $value if defined $value;
513 $_->{default} = $default if defined $default;
516 $_ = {name=>$_, type=>$default_type};
517 $what->{$default_type} = 1;
519 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
520 if (exists $items{$name}) {
521 die "Multiple definitions for macro $name";
525 my ($use_iv, $use_nv, $use_pv) = params ($what);
527 my ($body, @subs) = "static int\n$subname (const char *name";
528 $body .= ", STRLEN len" unless defined $namelen;
529 $body .= ", IV *iv_return" if $use_iv;
530 $body .= ", NV *nv_return" if $use_nv;
531 $body .= ", const char **pv_return" if $use_pv;
534 if (defined $namelen) {
535 # We are a child subroutine. Print the simple description
536 my @names = sort map {$_->{name}} @items;
538 /* When generated this function returned values for the list of names given
539 here. However, subsequent manual editing may have added or removed some.
541 . wrap (" ", " ", join (" ", @names) . " */") . "\n";
542 # Figure out what to switch on.
543 # (RMS, Spread of jump table, Position, Hashref)
544 my @best = (1e38, ~0);
545 foreach my $i (0 .. ($namelen - 1)) {
546 my ($min, $max) = (~0, 0);
549 my $char = substr $_, $i, 1;
551 $max = $ord if $ord > $max;
552 $min = $ord if $ord < $min;
553 push @{$spread{$char}}, $_;
556 # I'm going to pick the character to split on that minimises the root
557 # mean square of the number of names in each case. Normally this should
558 # be the one with the most keys, but it may pick a 7 where the 8 has
559 # one long linear search. I'm not sure if RMS or just sum of squares is
561 # $max and $min are for the tie-breaker if the root mean squares match.
562 # Assuming that the compiler may be building a jump table for the
563 # switch() then try to minimise the size of that jump table.
564 # Finally use < not <= so that if it still ties the earliest part of
565 # the string wins. Because if that passes but the memEQ fails, it may
566 # only need the start of the string to bin the choice.
567 # I think. But I'm micro-optimising. :-)
569 $ss += @$_ * @$_ foreach values %spread;
570 my $rms = sqrt ($ss / keys %spread);
571 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
572 @best = ($rms, $max - $min, $i, \%spread);
575 die "Internal error. Failed to pick a switch point for @names"
576 unless defined $best[2];
577 # use Data::Dumper; print Dumper (@best);
578 my ($offset, $best) = @best[2,3];
579 $body .= " /* Names all of length $namelen. */\n";
581 $body .= " /* Offset $offset gives the best switch position. */\n";
582 $body .= " switch (name[$offset]) {\n";
583 foreach my $char (sort keys %$best) {
584 $body .= " case '" . C_stringify ($char) . "':\n";
585 foreach my $name (sort @{$best->{$char}}) {
586 my $thisone = $items{$name};
587 my ($value, $macro, $default) = @$thisone{qw (value macro default)};
588 $value = $name unless defined $value;
589 $macro = $name unless defined $macro;
591 $body .= memEQ_clause ($name, $offset); # We have checked this offset.
592 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
596 $body .= " break;\n";
600 # We are the top level.
601 $body .= " /* Initially switch on the length of the name. */\n";
602 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
604 $body .= " switch (len) {\n";
605 # Need to group names of the same length
608 push @{$by_length[length $_->{name}]}, $_;
610 foreach my $i (0 .. $#by_length) {
611 next unless $by_length[$i]; # None of this length
612 $body .= " case $i:\n";
613 if (@{$by_length[$i]} == 1) {
614 my $thisone = $by_length[$i]->[0];
615 my ($name, $value, $macro, $default)
616 = @$thisone{qw (name value macro default)};
617 $value = $name unless defined $value;
618 $macro = $name unless defined $macro;
620 $body .= memEQ_clause ($name);
621 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
625 push @subs, C_constant ($package, "${subname}_$i", $default_type,
626 $what, $indent, $i, @{$by_length[$i]});
627 $body .= " return ${subname}_$i (name";
628 $body .= ", iv_return" if $use_iv;
629 $body .= ", nv_return" if $use_nv;
630 $body .= ", pv_return" if $use_pv;
633 $body .= " break;\n";
637 $body .= " return PERL_constant_NOTFOUND;\n}\n";
638 return (@subs, $body);
641 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
643 A function to generate the XS code to implement the perl subroutine
644 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
645 This XS code is a wrapper around a C subroutine usually generated by
646 C<C_constant>, and usually named C<constant>.
648 I<TYPES> should be given either as a comma separated list of types that the
649 C subroutine C<constant> will generate or as a reference to a hash. It should
650 be the same list of types as C<C_constant> was given.
651 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
652 the number of parameters passed to the C function C<constant>]
654 You can call the perl visible subroutine something other than C<constant> if
655 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
656 the name of the perl visible subroutine, unless you give the parameter
665 my $C_subname = shift;
666 $subname ||= 'constant';
667 $C_subname ||= $subname;
670 # Convert line of the form IV,UV,NV to hash
671 $what = {map {$_ => 1} split /,\s*/, ($what)};
673 my ($use_iv, $use_nv, $use_pv) = params ($what);
681 dXSTARG; /* Faster if we have it. */
692 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
697 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
700 $xs .= " const char *pv;\n";
703 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
709 const char * s = SvPV(sv, len);
713 if ($use_iv xor $use_nv) {
715 /* Change this to $C_subname(s, len, &iv, &nv);
716 if you need to return both NVs and IVs */
719 $xs .= " type = $C_subname(s, len";
720 $xs .= ', &iv' if $use_iv;
721 $xs .= ', &nv' if $use_nv;
722 $xs .= ', &pv' if $use_pv;
726 /* Return 1 or 2 items. First is error message, or undef if no error.
727 Second, if present, is found value */
729 case PERL_constant_NOTFOUND:
730 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
733 case PERL_constant_NOTDEF:
734 sv = sv_2mortal(newSVpvf(
735 "Your vendor has not defined $package macro %s used", s));
740 foreach $type (sort keys %XS_Constant) {
741 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
742 unless $what->{$type};
744 case PERL_constant_IS$type:
750 unless ($what->{$type}) {
751 chop $xs; # Yes, another need for chop not chomp.
757 sv = sv_2mortal(newSVpvf(
758 "Unexpected return type %d while processing $package macro %s used",
768 =item autoload PACKAGE, VERSION, AUTOLOADER
770 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
771 I<VERSION> is the perl version the code should be backwards compatible with.
772 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
773 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
774 names that the constant() routine doesn't recognise.
778 # ' # Grr. syntax highlighters that don't grok pod.
781 my ($module, $compat_version, $autoloader) = @_;
782 $compat_version ||= $];
783 croak "Can't maintain compatibility back as far as version $compat_version"
784 if $compat_version < 5;
785 my $func = "sub AUTOLOAD {\n"
786 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
788 $func .= " If a constant is not found then control is passed\n"
789 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
793 . " my \$constname;\n";
795 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
798 (\$constname = \$AUTOLOAD) =~ s/.*:://;
799 croak "&${module}::constant not defined" if \$constname eq 'constant';
800 my (\$error, \$val) = constant(\$constname);
806 if ($error =~ /is not a valid/) {
807 $AutoLoader::AUTOLOAD = $AUTOLOAD;
808 goto &AutoLoader::AUTOLOAD;
816 " if (\$error) { croak \$error; }\n";
822 # Fixed between 5.005_53 and 5.005_61
823 #XXX if ($] >= 5.00561) {
824 #XXX *$AUTOLOAD = sub () { $val };
827 *$AUTOLOAD = sub { $val };
844 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and