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 (constant_types C_constant XS_constant);
12 print constant_types(); # macro defs
13 foreach (C_constant ("Foo", undef, "IV", undef, undef, undef,
15 print $_, "\n"; # C constant subs
17 print "MODULE = Foo PACKAGE = Foo\n";
18 print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
22 ExtUtils::Constant facilitates generating C and XS wrapper code to allow
23 perl modules to AUTOLOAD constants defined in C library header files.
24 It is principally used by the C<h2xs> utility, on which this code is based.
25 It doesn't contain the routines to scan header files to extract these
30 Generally one only needs to call the 3 functions shown in the synopsis,
31 C<constant_types()>, C<C_constant> and C<XS_constant>.
33 Currently this module understands the following types. h2xs may only know
34 a subset. The sizes of the numeric types are chosen by the C<Configure>
35 script at compile time.
41 signed integer, at least 32 bits.
45 unsigned integer, the same size as I<IV>
49 floating point type, probably C<double>, possibly C<long double>
53 NUL terminated string, length will be determined with C<strlen>
57 A fixed length thing, given as a [pointer, length] pair. If you know the
58 length of a string at compile time you may use this instead of I<PV>
66 Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
70 Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
74 C<undef>. The value of the macro is not needed.
84 require 5.006; # I think, for [:cntrl:] in REGEXP
91 $Text::Wrap::huge = 'overflow';
92 $Text::Wrap::columns = 80;
96 %EXPORT_TAGS = ( 'all' => [ qw(
97 XS_constant constant_types return_clause memEQ_clause C_stringify
101 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
105 UV => 'PUSHu((UV)iv)',
107 PV => 'PUSHp(pv, strlen(pv))',
108 PVN => 'PUSHp(pv, iv)',
110 YES => 'PUSHs(&PL_sv_yes)',
111 NO => 'PUSHs(&PL_sv_no)',
112 UNDEF => '', # implicit undef
116 IV => '*iv_return =',
117 UV => '*iv_return = (IV)',
118 NV => '*nv_return =',
119 PV => '*pv_return =',
120 PVN => ['*pv_return =', '*iv_return = (IV)'],
121 SV => '*sv_return = ',
128 =item C_stringify NAME
130 A function which returns a correctly \ escaped version of the string passed
131 suitable for C's "" or ''. It will also be valid as a perl "" string.
135 # Hopefully make a happy C identifier.
138 return unless defined $_;
140 s/([\"\'])/\\$1/g; # Grr. fix perl mode.
141 s/\n/\\n/g; # Ensure newlines don't end up in octal
146 s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
147 s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:]
153 A function returning a single scalar with C<#define> definitions for the
154 constants used internally between the generated C and XS functions.
158 sub constant_types () {
161 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
162 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
163 foreach (sort keys %XS_Constant) {
164 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
166 push @lines, << 'EOT';
169 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
173 return join '', @lines;
176 =item memEQ_clause NAME, CHECKED_AT, INDENT
178 A function to return a suitable C C<if> statement to check whether I<NAME>
179 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
180 is used to avoid C<memEQ> for short names, or to generate a comment to
181 highlight the position of the character in the C<switch> statement.
186 # if (memEQ(name, "thingy", 6)) {
187 # Which could actually be a character comparison or even ""
188 my ($name, $checked_at, $indent) = @_;
189 $indent = ' ' x ($indent || 4);
190 my $len = length $name;
193 return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
194 # We didn't switch, drop through to the code for the 2 character string
197 if ($len < 3 and defined $checked_at) {
199 if ($checked_at == 1) {
201 } elsif ($checked_at == 0) {
204 if (defined $check) {
205 my $char = C_stringify (substr $name, $check, 1);
206 return $indent . "if (name[$check] == '$char') {\n";
209 # Could optimise a memEQ on 3 to 2 single character checks here
210 $name = C_stringify ($name);
211 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
212 $body .= $indent . "/* ". (' ' x $checked_at) . '^'
213 . (' ' x ($len - $checked_at + length $len)) . " */\n"
214 if defined $checked_at;
218 =item assign INDENT, TYPE, PRE, POST, VALUE...
220 A function to return a suitable assignment clause. If I<TYPE> is aggregate
221 (eg I<PVN> expects both pointer and length) then there should be multiple
222 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
223 of C code to preceed and follow the assignment. I<PRE> will be at the start
224 of a block, so variables may be defined in it.
228 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
234 my $post = shift || '';
239 $clause = $indent . "{\n$pre";
240 $clause .= ";" unless $pre =~ /;$/;
242 $close = "$indent}\n";
245 die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
246 my $typeset = $XS_TypeSet{$type};
248 die "Type $type is aggregate, but only single value given"
250 foreach (0 .. $#$typeset) {
251 $clause .= $indent . "$typeset->[$_] $_[$_];\n";
253 } elsif (defined $typeset) {
254 die "Aggregate value given for type $type"
256 $clause .= $indent . "$typeset $_[0];\n";
261 $clause .= ";" unless $post =~ /;$/;
264 $clause .= "${indent}return PERL_constant_IS$type;\n";
265 $clause .= $close if $close;
269 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
271 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
272 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
273 pointer and length) then I<VALUE> should be a reference to an array of
274 values in the order expected by the type. C<C_constant> will always call
275 this function with I<MACRO> defined, defaulting to the constant's name.
276 I<DEFAULT> if defined is an array reference giving default type and and
277 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
278 The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
279 and follow the value, and the default value.
283 sub return_clause ($$$$$$$$$) {
285 # *iv_return = thingy;
286 # return PERL_constant_ISIV;
288 # return PERL_constant_NOTDEF;
290 my ($value, $type, $indent, $macro, $default, $pre, $post,
291 $def_pre, $def_post) = @_;
292 $macro = $value unless defined $macro;
293 $indent = ' ' x ($indent || 6);
299 $clause = $macro->[0];
301 $clause = "#ifdef $macro\n";
304 # *iv_return = thingy;
305 # return PERL_constant_ISIV;
306 $clause .= assign ($indent, $type, $pre, $post,
307 ref $value ? @$value : $value);
310 $clause .= "#else\n";
312 # return PERL_constant_NOTDEF;
313 if (!defined $default) {
314 $clause .= "${indent}return PERL_constant_NOTDEF;\n";
316 my @default = ref $default ? @$default : $default;
317 $type = shift @default;
318 $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
323 $clause .= $macro->[1];
325 $clause .= "#endif\n";
330 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
332 An internal function to generate a suitable C<switch> clause, called by
333 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
334 of C<C_constant>, and must all have the names of the same length, given by
335 I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
336 keyed by name, values being the hashrefs in the I<ITEM> list.
337 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
338 are not in the list of I<ITEM>s without causing problems).
343 my ($indent, $comment, $namelen, $items, @items) = @_;
344 $indent = ' ' x ($indent || 2);
346 my @names = sort map {$_->{name}} @items;
347 my $leader = $indent . '/* ';
348 my $follower = ' ' x length $leader;
349 my $body = $indent . "/* Names all of length $namelen. */\n";
351 $body = wrap ($leader, $follower, $comment) . "\n";
354 $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
355 # Figure out what to switch on.
356 # (RMS, Spread of jump table, Position, Hashref)
357 my @best = (1e38, ~0);
358 foreach my $i (0 .. ($namelen - 1)) {
359 my ($min, $max) = (~0, 0);
362 my $char = substr $_, $i, 1;
364 $max = $ord if $ord > $max;
365 $min = $ord if $ord < $min;
366 push @{$spread{$char}}, $_;
369 # I'm going to pick the character to split on that minimises the root
370 # mean square of the number of names in each case. Normally this should
371 # be the one with the most keys, but it may pick a 7 where the 8 has
372 # one long linear search. I'm not sure if RMS or just sum of squares is
374 # $max and $min are for the tie-breaker if the root mean squares match.
375 # Assuming that the compiler may be building a jump table for the
376 # switch() then try to minimise the size of that jump table.
377 # Finally use < not <= so that if it still ties the earliest part of
378 # the string wins. Because if that passes but the memEQ fails, it may
379 # only need the start of the string to bin the choice.
380 # I think. But I'm micro-optimising. :-)
382 $ss += @$_ * @$_ foreach values %spread;
383 my $rms = sqrt ($ss / keys %spread);
384 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
385 @best = ($rms, $max - $min, $i, \%spread);
388 die "Internal error. Failed to pick a switch point for @names"
389 unless defined $best[2];
390 # use Data::Dumper; print Dumper (@best);
391 my ($offset, $best) = @best[2,3];
392 $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
393 $body .= $indent . "switch (name[$offset]) {\n";
394 foreach my $char (sort keys %$best) {
395 $body .= $indent . "case '" . C_stringify ($char) . "':\n";
396 foreach my $name (sort @{$best->{$char}}) {
397 my $thisone = $items->{$name};
398 my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
399 = @$thisone{qw (value macro default pre post def_pre def_post)};
400 $value = $name unless defined $value;
401 $macro = $name unless defined $macro;
403 # We have checked this offset.
404 $body .= memEQ_clause ($name, $offset, 2 + length $indent);
405 $body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
406 $macro, $default, $pre, $post,
407 $def_pre, $def_post);
408 $body .= $indent . " }\n";
410 $body .= $indent . " break;\n";
412 $body .= $indent . "}\n";
418 An internal function. I<WHAT> should be a hashref of types the constant
419 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
420 $use_pv> to show which combination of pointers will be needed in the C
427 foreach (sort keys %$what) {
428 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
430 my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
431 my $use_nv = $what->{NV};
432 my $use_pv = $what->{PV} || $what->{PVN};
433 my $use_sv = $what->{SV};
434 return ($use_iv, $use_nv, $use_pv, $use_sv);
439 dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
441 An internal function to generate the embedded perl code that will regenerate
442 the constant subroutines. Parameters are the same as for C_constant.
447 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
449 my (@simple, @complex);
451 my $type = $_->{type} || $default_type;
452 if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
453 and !defined ($_->{macro}) and !defined ($_->{value})
454 and !defined ($_->{default}) and !defined ($_->{pre})
455 and !defined ($_->{post}) and !defined ($_->{def_pre})
456 and !defined ($_->{def_post})) {
457 # It's the default type, and the name consists only of A-Za-z0-9_
458 push @simple, $_->{name};
463 my $result = <<"EOT";
464 /* When generated this function returned values for the list of names given
465 in this section of perl code. Rather than manually editing these functions
466 to add or remove constants, which would result in this comment and section
467 of code becoming inaccurate, we recommend that you edit this section of
468 code, and use it to regenerate a new set of constant functions which you
469 then use to replace the originals.
471 Regenerate these constant functions by feeding this entire source file to
475 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
478 $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what)
480 $result .= wrap ("my \@names = (qw(",
481 " ", join (" ", sort @simple) . ")");
483 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
484 my $name = C_stringify $item->{name};
485 my $line = ",\n {name=>\"$name\"";
486 $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
487 foreach my $thing (qw (macro value default pre post def_pre def_post)) {
488 my $value = $item->{$thing};
489 if (defined $value) {
491 $line .= ", $thing=>[\""
492 . join ('", "', map {C_stringify $_} @$value) . '"]';
494 $line .= ", $thing=>\"" . C_stringify($value) . "\"";
499 # Ensure that the enclosing C comment doesn't end
500 # by turning */ into *" . "/
501 $line =~ s!\*\/!\*" . "/!gs;
502 # gcc -Wall doesn't like finding /* inside a comment
503 $line =~ s!\/\*!/" . "\*!gs;
511 print constant_types(); # macro defs
513 $package = C_stringify($package);
515 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
516 # The form of the indent parameter isn't defined. (Yet)
517 if (defined $indent) {
518 require Data::Dumper;
519 $Data::Dumper::Terse=1;
520 $Data::Dumper::Terse=1; # Not used once. :-)
521 chomp ($indent = Data::Dumper::Dumper ($indent));
526 $result .= ", $breakout" . ', @names) ) {
527 print $_, "\n"; # C constant subs
529 print "#### XS Section:\n";
530 print XS_constant ("' . $package . '", $types);
541 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
543 A function that returns a B<list> of C subroutine definitions that return
544 the value and type of constants when passed the name by the XS wrapper.
545 I<ITEM...> gives a list of constant names. Each can either be a string,
546 which is taken as a C macro name, or a reference to a hash with the following
553 The name of the constant, as seen by the perl code.
557 The type of the constant (I<IV>, I<NV> etc)
561 A C expression for the value of the constant, or a list of C expressions if
562 the type is aggregate. This defaults to the I<name> if not given.
566 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
567 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
568 array is passed then the first element is used in place of the C<#ifdef>
569 line, and the second element in place of the C<#endif>. This allows
570 pre-processor constructions such as
578 to be used to determine if a constant is to be defined.
582 Default value to use (instead of C<croak>ing with "your vendor has not
583 defined...") to return if the macro isn't defined. Specify a reference to
584 an array with type followed by value(s).
588 C code to use before the assignment of the value of the constant. This allows
589 you to use temporary variables to extract a value from part of a C<struct>
590 and return this as I<value>. This C code is places at the start of a block,
591 so you can declare variables in it.
595 C code to place between the assignment of value (to a temporary) and the
596 return from the function. This allows you to clear up anything in I<pre>.
602 Equivalents of I<pre> and I<post> for the default value.
606 I<PACKAGE> is the name of the package, and is only used in comments inside the
609 The next 5 arguments can safely be given as C<undef>, and are mainly used
610 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
612 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
613 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
614 separated list of types that the C subroutine C<constant> will generate or as
615 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
616 present, as will any types given in the list of I<ITEM>s. The resultant list
617 should be the same list of types that C<XS_constant> is given. [Otherwise
618 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
619 constant function. I<INDENT> is currently unused and ignored. In future it may
620 be used to pass in information used to change the C indentation style used.]
621 The best way to maintain consistency is to pass in a hash reference and let
622 this function update it.
624 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
625 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
626 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
627 example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
628 3. A single C<ITEM> is always inlined.
632 # The parameter now BREAKOUT was previously documented as:
634 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
635 # this length, and that the constant name passed in by perl is checked and
636 # also of this length. It is used during recursion, and should be C<undef>
637 # unless the caller has checked all the lengths during code generation, and
638 # the generated subroutine is only to be called with a name of this length.
640 # As you can see it now performs this function during recursion by being a
644 my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
648 $namelen = $$breakout;
653 $subname ||= 'constant';
654 # I'm not using this. But a hashref could be used for full formatting without
657 $default_type ||= 'IV';
659 # Convert line of the form IV,UV,NV to hash
660 $what = {map {$_ => 1} split /,\s*/, ($what || '')};
661 # Figure out what types we're dealing with, and assign all unknowns to the
669 # Make a copy which is a normalised version of the ref passed in.
671 my ($type, $macro, $value) = @$_{qw (type macro value)};
672 $type ||= $default_type;
674 $_ = {name=>$name, type=>$type};
676 undef $macro if defined $macro and $macro eq $name;
677 $_->{macro} = $macro if defined $macro;
678 undef $value if defined $value and $value eq $name;
679 $_->{value} = $value if defined $value;
680 foreach my $key (qw(default pre post def_pre def_post)) {
681 my $value = $orig->{$key};
682 $_->{$key} = $value if defined $value;
683 # warn "$key $value";
687 $_ = {name=>$_, type=>$default_type};
688 $what->{$default_type} = 1;
690 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
691 if (exists $items{$name}) {
692 die "Multiple definitions for macro $name";
696 my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
698 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
699 $body .= ", STRLEN len" unless defined $namelen;
700 $body .= ", IV *iv_return" if $use_iv;
701 $body .= ", NV *nv_return" if $use_nv;
702 $body .= ", const char **pv_return" if $use_pv;
703 $body .= ", SV **sv_return" if $use_sv;
706 if (defined $namelen) {
707 # We are a child subroutine. Print the simple description
708 my $comment = 'When generated this function returned values for the list'
709 . ' of names given here. However, subsequent manual editing may have'
710 . ' added or removed some.';
711 $body .= switch_clause (2, $comment, $namelen, \%items, @items);
713 # We are the top level.
714 $body .= " /* Initially switch on the length of the name. */\n";
715 $body .= dump_names ($package, $subname, $default_type, $what, $indent,
717 $body .= " switch (len) {\n";
718 # Need to group names of the same length
721 push @{$by_length[length $_->{name}]}, $_;
723 foreach my $i (0 .. $#by_length) {
724 next unless $by_length[$i]; # None of this length
725 $body .= " case $i:\n";
726 if (@{$by_length[$i]} == 1) {
727 my $thisone = $by_length[$i]->[0];
728 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
729 = @$thisone{qw (name value macro default pre post def_pre def_post)};
730 $value = $name unless defined $value;
731 $macro = $name unless defined $macro;
733 $body .= memEQ_clause ($name);
734 $body .= return_clause ($value, $thisone->{type}, undef, $macro,
735 $default, $pre, $post, $def_pre, $def_post);
737 } elsif (@{$by_length[$i]} < $breakout) {
738 $body .= switch_clause (4, '', $i, \%items, @{$by_length[$i]});
740 push @subs, C_constant ($package, "${subname}_$i", $default_type,
741 $what, $indent, \$i, @{$by_length[$i]});
742 $body .= " return ${subname}_$i (aTHX_ name";
743 $body .= ", iv_return" if $use_iv;
744 $body .= ", nv_return" if $use_nv;
745 $body .= ", pv_return" if $use_pv;
746 $body .= ", sv_return" if $use_sv;
749 $body .= " break;\n";
753 $body .= " return PERL_constant_NOTFOUND;\n}\n";
754 return (@subs, $body);
757 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
759 A function to generate the XS code to implement the perl subroutine
760 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
761 This XS code is a wrapper around a C subroutine usually generated by
762 C<C_constant>, and usually named C<constant>.
764 I<TYPES> should be given either as a comma separated list of types that the
765 C subroutine C<constant> will generate or as a reference to a hash. It should
766 be the same list of types as C<C_constant> was given.
767 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
768 the number of parameters passed to the C function C<constant>]
770 You can call the perl visible subroutine something other than C<constant> if
771 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
772 the name of the perl visible subroutine, unless you give the parameter
781 my $C_subname = shift;
782 $subname ||= 'constant';
783 $C_subname ||= $subname;
786 # Convert line of the form IV,UV,NV to hash
787 $what = {map {$_ => 1} split /,\s*/, ($what)};
789 my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
797 dXSTARG; /* Faster if we have it. */
808 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
813 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
816 $xs .= " const char *pv;\n";
819 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
825 const char * s = SvPV(sv, len);
829 if ($use_iv xor $use_nv) {
831 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
832 if you need to return both NVs and IVs */
835 $xs .= " type = $C_subname(aTHX_ s, len";
836 $xs .= ', &iv' if $use_iv;
837 $xs .= ', &nv' if $use_nv;
838 $xs .= ', &pv' if $use_pv;
839 $xs .= ', &sv' if $use_sv;
843 /* Return 1 or 2 items. First is error message, or undef if no error.
844 Second, if present, is found value */
846 case PERL_constant_NOTFOUND:
847 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
850 case PERL_constant_NOTDEF:
851 sv = sv_2mortal(newSVpvf(
852 "Your vendor has not defined $package macro %s, used", s));
857 foreach $type (sort keys %XS_Constant) {
858 $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
859 unless $what->{$type};
860 $xs .= " case PERL_constant_IS$type:\n";
861 if (length $XS_Constant{$type}) {
868 # Do nothing. return (), which will be correctly interpreted as
872 unless ($what->{$type}) {
873 chop $xs; # Yes, another need for chop not chomp.
879 sv = sv_2mortal(newSVpvf(
880 "Unexpected return type %d while processing $package macro %s, used",
890 =item autoload PACKAGE, VERSION, AUTOLOADER
892 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
893 I<VERSION> is the perl version the code should be backwards compatible with.
894 It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
895 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
896 names that the constant() routine doesn't recognise.
900 # ' # Grr. syntax highlighters that don't grok pod.
903 my ($module, $compat_version, $autoloader) = @_;
904 $compat_version ||= $];
905 croak "Can't maintain compatibility back as far as version $compat_version"
906 if $compat_version < 5;
907 my $func = "sub AUTOLOAD {\n"
908 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
910 $func .= " If a constant is not found then control is passed\n"
911 . " # to the AUTOLOAD in AutoLoader." if $autoloader;
915 . " my \$constname;\n";
917 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
920 (\$constname = \$AUTOLOAD) =~ s/.*:://;
921 croak "&${module}::constant not defined" if \$constname eq 'constant';
922 my (\$error, \$val) = constant(\$constname);
928 if ($error =~ /is not a valid/) {
929 $AutoLoader::AUTOLOAD = $AUTOLOAD;
930 goto &AutoLoader::AUTOLOAD;
938 " if (\$error) { croak \$error; }\n";
944 # Fixed between 5.005_53 and 5.005_61
945 #XXX if ($] >= 5.00561) {
946 #XXX *$AUTOLOAD = sub () { $val };
949 *$AUTOLOAD = sub { $val };
966 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and