lib/ExtUtils/Constant.pm

   1 package ExtUtils::Constant;
   2
   3 =head1 NAME
   4
   5 ExtUtils::Constant - generate XS code to import C header constants
   6
   7 =head1 SYNOPSIS
   8
   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,
  12                          @names) ) {
  13         print $_, "\n"; # C constant subs
  14     }
  15     print "MODULE = Foo         PACKAGE = Foo\n";
  16     print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
  17
  18 =head1 DESCRIPTION
  19
  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
  24 constants.
  25
  26 =head1 USAGE
  27
  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>.
  30
  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.
  34
  35 =over 4
  36
  37 =item IV
  38
  39 signed integer, at least 32 bits.
  40
  41 =item UV
  42
  43 unsigned integer, the same size as I<IV>
  44
  45 =item NV
  46
  47 floating point type, probably C<double>, possibly C<long double>
  48
  49 =item PV
  50
  51 NUL terminated string, length will be determined with C<strlen>
  52
  53 =item PVN
  54
  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>
  57
  58 =item YES
  59
  60 Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
  61
  62 =item NO
  63
  64 Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
  65
  66 =item UNDEF
  67
  68 C<undef>.  The value of the macro is not needed.
  69
  70 =back
  71
  72 =head1 FUNCTIONS
  73
  74 =over 4
  75
  76 =cut
  77
  78 require 5.006; # I think, for [:cntrl:] in REGEXP
  79 use warnings;
  80 use strict;
  81 use Carp;
  82
  83 use Exporter;
  84 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
  85 use Text::Wrap;
  86 $Text::Wrap::huge = 'overflow';
  87 $Text::Wrap::columns = 80;
  88
  89 @ISA = 'Exporter';
  90 $VERSION = '0.04';
  91
  92 %EXPORT_TAGS = ( 'all' => [ qw(
  93         XS_constant constant_types return_clause memEQ_clause C_stringify
  94         C_constant autoload
  95 ) ] );
  96
  97 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  98
  99 %XS_Constant = (
 100                 IV => 'PUSHi(iv)',
 101                 UV => 'PUSHu((UV)iv)',
 102                 NV => 'PUSHn(nv)',
 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
 108 );
 109
 110 %XS_TypeSet = (
 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,
 117                 NO    => undef,
 118                 UNDEF => undef,
 119 );
 120
 121
 122 =item C_stringify NAME
 123
 124 A function which returns a correctly \ escaped version of the string passed
 125 suitable for C's "" or ''.  It will also be valid as a perl "" string.
 126
 127 =cut
 128
 129 # Hopefully make a happy C identifier.
 130 sub C_stringify {
 131   local $_ = shift;
 132   return unless defined $_;
 133   s/\\/\\\\/g;
 134   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 135   s/\n/\\n/g;           # Ensure newlines don't end up in octal
 136   s/\r/\\r/g;
 137   s/\t/\\t/g;
 138   s/\f/\\f/g;
 139   s/\a/\\a/g;
 140   s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
 141   s/\177/\\177/g;       # DEL doesn't seem to be a [:cntrl:]
 142   $_;
 143 }
 144
 145 =item constant_types
 146
 147 A function returning a single scalar with C<#define> definitions for the
 148 constants used internally between the generated C and XS functions.
 149
 150 =cut
 151
 152 sub constant_types () {
 153   my $start = 1;
 154   my @lines;
 155   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
 156   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
 157   foreach (sort keys %XS_Constant) {
 158     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
 159   }
 160   push @lines, << 'EOT';
 161
 162 #ifndef NVTYPE
 163 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 164 #endif
 165 EOT
 166
 167   return join '', @lines;
 168 }
 169
 170 =item memEQ_clause NAME, CHECKED_AT, INDENT
 171
 172 A function to return a suitable C C<if> statement to check whether I<NAME>
 173 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
 174 is used to avoid C<memEQ> for short names, or to generate a comment to
 175 highlight the position of the character in the C<switch> statement.
 176
 177 =cut
 178
 179 sub memEQ_clause {
 180 #    if (memEQ(name, "thingy", 6)) {
 181   # Which could actually be a character comparison or even ""
 182   my ($name, $checked_at, $indent) = @_;
 183   $indent = ' ' x ($indent || 4);
 184   my $len = length $name;
 185
 186   if ($len < 2) {
 187     return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
 188     # We didn't switch, drop through to the code for the 2 character string
 189     $checked_at = 1;
 190   }
 191   if ($len < 3 and defined $checked_at) {
 192     my $check;
 193     if ($checked_at == 1) {
 194       $check = 0;
 195     } elsif ($checked_at == 0) {
 196       $check = 1;
 197     }
 198     if (defined $check) {
 199       my $char = C_stringify (substr $name, $check, 1);
 200       return $indent . "if (name[$check] == '$char') {\n";
 201     }
 202   }
 203   # Could optimise a memEQ on 3 to 2 single character checks here
 204   $name = C_stringify ($name);
 205   my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
 206     $body .= $indent . "/*               ". (' ' x $checked_at) . '^'
 207       . (' ' x ($len - $checked_at + length $len)) . "    */\n"
 208         if defined $checked_at;
 209   return $body;
 210 }
 211
 212 =item assign INDENT, TYPE, VALUE...
 213
 214 A function to return a suitable assignment clause. If I<TYPE> is aggregate
 215 (eg I<PVN> expects both pointer and length) then there should be multiple
 216 I<VALUE>s for the components.
 217
 218 =cut
 219
 220 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
 221
 222 sub assign {
 223   my $indent = shift;
 224   my $type = shift;
 225   my $clause;
 226   die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
 227   my $typeset = $XS_TypeSet{$type};
 228   if (ref $typeset) {
 229     die "Type $type is aggregate, but only single value given"
 230       if @_ == 1;
 231     foreach (0 .. $#$typeset) {
 232       $clause .= $indent . "$typeset->[$_] $_[$_];\n";
 233     }
 234   } elsif (defined $typeset) {
 235     die "Aggregate value given for type $type"
 236       if @_ > 1;
 237     $clause .= $indent . "$typeset $_[0];\n";
 238   }
 239   $clause .= "${indent}return PERL_constant_IS$type;\n";
 240   return $clause;
 241 }
 242
 243 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
 244
 245 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
 246 I<VALUE> when not defined.  If I<TYPE> is aggregate (eg I<PVN> expects both
 247 pointer and length) then I<VALUE> should be a reference to an array of
 248 values in the order expected by the type.  C<C_constant> will always call
 249 this function with I<MACRO> defined, defaulting to the constant's name.
 250 I<DEFAULT> if defined is an array reference giving default type and and
 251 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
 252
 253 =cut
 254
 255 sub return_clause ($$$$$) {
 256 ##ifdef thingy
 257 #      *iv_return = thingy;
 258 #      return PERL_constant_ISIV;
 259 ##else
 260 #      return PERL_constant_NOTDEF;
 261 ##endif
 262   my ($value, $type, $indent, $macro, $default) = @_;
 263   $macro = $value unless defined $macro;
 264   $indent = ' ' x ($indent || 6);
 265
 266   my $clause;
 267
 268   ##ifdef thingy
 269   if (ref $macro) {
 270     $clause = $macro->[0];
 271   } else {
 272     $clause = "#ifdef $macro\n";
 273   }
 274
 275   #      *iv_return = thingy;
 276   #      return PERL_constant_ISIV;
 277   $clause .= assign ($indent, $type, ref $value ? @$value : $value);
 278
 279   ##else
 280   $clause .= "#else\n";
 281
 282   #      return PERL_constant_NOTDEF;
 283   if (!defined $default) {
 284     $clause .= "${indent}return PERL_constant_NOTDEF;\n";
 285   } else {
 286     $clause .= assign ($indent, ref $default ? @$default : $default);
 287   }
 288
 289   ##endif
 290   if (ref $macro) {
 291     $clause .= $macro->[1];
 292   } else {
 293     $clause .= "#endif\n";
 294   }
 295   return $clause
 296 }
 297
 298 =item params WHAT
 299
 300 An internal function. I<WHAT> should be a hashref of types the constant
 301 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
 302 $use_pv> to show which combination of pointers will be needed in the C
 303 argument list.
 304
 305 =cut
 306
 307 sub params {
 308   my $what = shift;
 309   foreach (sort keys %$what) {
 310     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 311   }
 312   my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
 313   my $use_nv = $what->{NV};
 314   my $use_pv = $what->{PV} || $what->{PVN};
 315   return ($use_iv, $use_nv, $use_pv);
 316 }
 317
 318 =item dump_names
 319
 320 dump_names  PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
 321
 322 An internal function to generate the embedded perl code that will regenerate
 323 the constant subroutines.  Parameters are the same as for C_constant, except
 324 that there is no NAMELEN.
 325
 326 =cut
 327
 328 sub dump_names {
 329   my ($package, $subname, $default_type, $what, $indent, @items) = @_;
 330   my (@simple, @complex);
 331   foreach (@items) {
 332     my $type = $_->{type} || $default_type;
 333     if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
 334         and !defined ($_->{macro}) and !defined ($_->{value})
 335         and !defined ($_->{default})) {
 336       # It's the default type, and the name consists only of A-Za-z0-9_
 337       push @simple, $_->{name};
 338     } else {
 339       push @complex, $_;
 340     }
 341   }
 342   my $result = <<"EOT";
 343   /* When generated this function returned values for the list of names given
 344      in this section of perl code.  Rather than manually editing these functions
 345      to add or remove constants, which would result in this comment and section
 346      of code becoming inaccurate, we recommend that you edit this section of
 347      code, and use it to regenerate a new set of constant functions which you
 348      then use to replace the originals.
 349
 350      Regenerate these constant functions by feeding this entire source file to
 351      perl -x
 352
 353 #!$^X -w
 354 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 355
 356 EOT
 357   $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
 358  . "};\n";
 359   $result .= wrap ("my \@names = (qw(",
 360                    "               ", join (" ", sort @simple) . ")");
 361   if (@complex) {
 362     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
 363       my $name = C_stringify $item->{name};
 364       my ($macro, $value, $default) = @$item{qw (macro value default)};
 365       my $line = ",\n            {name=>\"$name\"";
 366       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
 367       if (defined $macro) {
 368         if (ref $macro) {
 369           $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
 370             . '"]';
 371         } else {
 372           $line .= ", macro=>\"" . C_stringify($macro) . "\"";
 373         }
 374       }
 375       if (defined $value) {
 376         if (ref $value) {
 377           $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
 378             . '"]';
 379         } else {
 380           $line .= ", value=>\"" . C_stringify($value) . "\"";
 381         }
 382       }
 383       if (defined $default) {
 384         if (ref $default) {
 385           $line .= ', default=>["'. join ('", "', map {C_stringify $_}
 386                                           @$default)
 387             . '"]';
 388         } else {
 389           $line .= ", default=>\"" . C_stringify($default) . "\"";
 390         }
 391       }
 392       $line .= "}";
 393       # Ensure that the enclosing C comment doesn't end
 394       # by turning */  into *" . "/
 395       $line =~ s!\*\/!\*" . "/!gs;
 396       # gcc -Wall doesn't like finding /* inside a comment
 397       $line =~ s!\/\*!/" . "\*!gs;
 398       $result .= $line;
 399     }
 400   }
 401   $result .= ");\n";
 402
 403   $result .= <<'EOT';
 404
 405 print constant_types(); # macro defs
 406 EOT
 407   $package = C_stringify($package);
 408   $result .=
 409     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 410   # The form of the indent parameter isn't defined. (Yet)
 411   if (defined $indent) {
 412     require Data::Dumper;
 413     $Data::Dumper::Terse=1;
 414     chomp ($indent = Data::Dumper::Dumper ($indent));
 415     $result .= $indent;
 416   } else {
 417     $result .= 'undef';
 418   }
 419   $result .= ', undef, @names) ) {
 420     print $_, "\n"; # C constant subs
 421 }
 422 print "#### XS Section:\n";
 423 print XS_constant ("' . $package . '", $types);
 424 __END__
 425    */
 426
 427 ';
 428
 429   $result;
 430 }
 431
 432 =item C_constant
 433
 434 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
 435
 436 A function that returns a B<list> of C subroutine definitions that return
 437 the value and type of constants when passed the name by the XS wrapper.
 438 I<ITEM...> gives a list of constant names. Each can either be a string,
 439 which is taken as a C macro name, or a reference to a hash with the following
 440 keys
 441
 442 =over 8
 443
 444 =item name
 445
 446 The name of the constant, as seen by the perl code.
 447
 448 =item type
 449
 450 The type of the constant (I<IV>, I<NV> etc)
 451
 452 =item value
 453
 454 A C expression for the value of the constant, or a list of C expressions if
 455 the type is aggregate. This defaults to the I<name> if not given.
 456
 457 =item macro
 458
 459 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
 460 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
 461 array is passed then the first element is used in place of the C<#ifdef>
 462 line, and the second element in place of the C<#endif>. This allows
 463 pre-processor constructions such as
 464
 465     #if defined (foo)
 466     #if !defined (bar)
 467     ...
 468     #endif
 469     #endif
 470
 471 to be used to determine if a constant is to be defined.
 472
 473 =item default
 474
 475 Default value to use (instead of C<croak>ing with "your vendor has not
 476 defined...") to return if the macro isn't defined. Specify a reference to
 477 an array with type followed by value(s).
 478
 479 =back
 480
 481 I<PACKAGE> is the name of the package, and is only used in comments inside the
 482 generated C code.
 483
 484 The next 5 arguments can safely be given as C<undef>, and are mainly used
 485 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
 486
 487 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
 488 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
 489 separated list of types that the C subroutine C<constant> will generate or as
 490 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
 491 present, as will any types given in the list of I<ITEM>s. The resultant list
 492 should be the same list of types that C<XS_constant> is given. [Otherwise
 493 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
 494 constant function. I<INDENT> is currently unused and ignored. In future it may
 495 be used to pass in information used to change the C indentation style used.]
 496 The best way to maintain consistency is to pass in a hash reference and let
 497 this function update it.
 498
 499 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
 500 this length, and that the constant name passed in by perl is checked and
 501 also of this length. It is used during recursion, and should be C<undef>
 502 unless the caller has checked all the lengths during code generation, and
 503 the generated subroutine is only to be called with a name of this length.
 504
 505 =cut
 506
 507 sub C_constant {
 508   my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
 509   $package ||= 'Foo';
 510   $subname ||= 'constant';
 511   # I'm not using this. But a hashref could be used for full formatting without
 512   # breaking this API
 513   # $indent ||= 0;
 514    $default_type ||= 'IV';
 515   if (!ref $what) {
 516     # Convert line of the form IV,UV,NV to hash
 517     $what = {map {$_ => 1} split /,\s*/, ($what || '')};
 518     # Figure out what types we're dealing with, and assign all unknowns to the
 519     # default type
 520   }
 521   my %items;
 522   foreach (@items) {
 523     my $name;
 524     if (ref $_) {
 525       # Make a copy which is a normalised version of the ref passed in.
 526       $name = $_->{name};
 527       my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
 528       $type ||= $default_type;
 529       $what->{$type} = 1;
 530       $_ = {name=>$name, type=>$type};
 531
 532       undef $macro if defined $macro and $macro eq $name;
 533       $_->{macro} = $macro if defined $macro;
 534       undef $value if defined $value and $value eq $name;
 535       $_->{value} = $value if defined $value;
 536       $_->{default} = $default if defined $default;
 537     } else {
 538       $name = $_;
 539       $_ = {name=>$_, type=>$default_type};
 540       $what->{$default_type} = 1;
 541     }
 542     warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
 543     if (exists $items{$name}) {
 544       die "Multiple definitions for macro $name";
 545     }
 546     $items{$name} = $_;
 547   }
 548   my ($use_iv, $use_nv, $use_pv) = params ($what);
 549
 550   my ($body, @subs) = "static int\n$subname (const char *name";
 551   $body .= ", STRLEN len" unless defined $namelen;
 552   $body .= ", IV *iv_return" if $use_iv;
 553   $body .= ", NV *nv_return" if $use_nv;
 554   $body .= ", const char **pv_return" if $use_pv;
 555   $body .= ") {\n";
 556
 557   if (defined $namelen) {
 558     # We are a child subroutine. Print the simple description
 559     my @names = sort map {$_->{name}} @items;
 560     my $names = << 'EOT'
 561   /* When generated this function returned values for the list of names given
 562      here.  However, subsequent manual editing may have added or removed some.
 563 EOT
 564      . wrap ("     ", "     ", join (" ", @names) . " */") . "\n";
 565     # Figure out what to switch on.
 566     # (RMS, Spread of jump table, Position, Hashref)
 567     my @best = (1e38, ~0);
 568     foreach my $i (0 .. ($namelen - 1)) {
 569       my ($min, $max) = (~0, 0);
 570       my %spread;
 571       foreach (@names) {
 572         my $char = substr $_, $i, 1;
 573         my $ord = ord $char;
 574         $max = $ord if $ord > $max;
 575         $min = $ord if $ord < $min;
 576         push @{$spread{$char}}, $_;
 577         # warn "$_ $char";
 578       }
 579       # I'm going to pick the character to split on that minimises the root
 580       # mean square of the number of names in each case. Normally this should
 581       # be the one with the most keys, but it may pick a 7 where the 8 has
 582       # one long linear search. I'm not sure if RMS or just sum of squares is
 583       # actually better.
 584       # $max and $min are for the tie-breaker if the root mean squares match.
 585       # Assuming that the compiler may be building a jump table for the
 586       # switch() then try to minimise the size of that jump table.
 587       # Finally use < not <= so that if it still ties the earliest part of
 588       # the string wins. Because if that passes but the memEQ fails, it may
 589       # only need the start of the string to bin the choice.
 590       # I think. But I'm micro-optimising. :-)
 591       my $ss;
 592       $ss += @$_ * @$_ foreach values %spread;
 593       my $rms = sqrt ($ss / keys %spread);
 594       if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
 595         @best = ($rms, $max - $min, $i, \%spread);
 596       }
 597     }
 598     die "Internal error. Failed to pick a switch point for @names"
 599       unless defined $best[2];
 600     # use Data::Dumper; print Dumper (@best);
 601     my ($offset, $best) = @best[2,3];
 602     $body .= "  /* Names all of length $namelen.  */\n";
 603     $body .= $names;
 604     $body .= "  /* Offset $offset gives the best switch position.  */\n";
 605     $body .= "  switch (name[$offset]) {\n";
 606     foreach my $char (sort keys %$best) {
 607       $body .= "  case '" . C_stringify ($char) . "':\n";
 608       foreach my $name (sort @{$best->{$char}}) {
 609         my $thisone = $items{$name};
 610         my ($value, $macro, $default) = @$thisone{qw (value macro default)};
 611         $value = $name unless defined $value;
 612         $macro = $name unless defined $macro;
 613
 614         $body .= memEQ_clause ($name, $offset); # We have checked this offset.
 615         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 616                                 $default);
 617         $body .= "    }\n";
 618       }
 619       $body .= "    break;\n";
 620     }
 621     $body .= "  }\n";
 622   } else {
 623     # We are the top level.
 624     $body .= "  /* Initially switch on the length of the name.  */\n";
 625     $body .= dump_names ($package, $subname, $default_type, $what, $indent,
 626                          @items);
 627     $body .= "  switch (len) {\n";
 628     # Need to group names of the same length
 629     my @by_length;
 630     foreach (@items) {
 631       push @{$by_length[length $_->{name}]}, $_;
 632     }
 633     foreach my $i (0 .. $#by_length) {
 634       next unless $by_length[$i];       # None of this length
 635       $body .= "  case $i:\n";
 636       if (@{$by_length[$i]} == 1) {
 637         my $thisone = $by_length[$i]->[0];
 638         my ($name, $value, $macro, $default)
 639           = @$thisone{qw (name value macro default)};
 640         $value = $name unless defined $value;
 641         $macro = $name unless defined $macro;
 642
 643         $body .= memEQ_clause ($name);
 644         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 645                                 $default);
 646         $body .= "    }\n";
 647       } else {
 648         push @subs, C_constant ($package, "${subname}_$i", $default_type,
 649                                 $what, $indent, $i, @{$by_length[$i]});
 650         $body .= "    return ${subname}_$i (name";
 651         $body .= ", iv_return" if $use_iv;
 652         $body .= ", nv_return" if $use_nv;
 653         $body .= ", pv_return" if $use_pv;
 654         $body .= ");\n";
 655       }
 656       $body .= "    break;\n";
 657     }
 658     $body .= "  }\n";
 659   }
 660   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
 661   return (@subs, $body);
 662 }
 663
 664 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
 665
 666 A function to generate the XS code to implement the perl subroutine
 667 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
 668 This XS code is a wrapper around a C subroutine usually generated by
 669 C<C_constant>, and usually named C<constant>.
 670
 671 I<TYPES> should be given either as a comma separated list of types that the
 672 C subroutine C<constant> will generate or as a reference to a hash. It should
 673 be the same list of types as C<C_constant> was given.
 674 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
 675 the number of parameters passed to the C function C<constant>]
 676
 677 You can call the perl visible subroutine something other than C<constant> if
 678 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
 679 the name of the perl visible subroutine, unless you give the parameter
 680 I<C_SUBNAME>.
 681
 682 =cut
 683
 684 sub XS_constant {
 685   my $package = shift;
 686   my $what = shift;
 687   my $subname = shift;
 688   my $C_subname = shift;
 689   $subname ||= 'constant';
 690   $C_subname ||= $subname;
 691
 692   if (!ref $what) {
 693     # Convert line of the form IV,UV,NV to hash
 694     $what = {map {$_ => 1} split /,\s*/, ($what)};
 695   }
 696   my ($use_iv, $use_nv, $use_pv) = params ($what);
 697   my $type;
 698
 699   my $xs = <<"EOT";
 700 void
 701 $subname(sv)
 702     PREINIT:
 703 #ifdef dXSTARG
 704         dXSTARG; /* Faster if we have it.  */
 705 #else
 706         dTARGET;
 707 #endif
 708         STRLEN          len;
 709         int             type;
 710 EOT
 711
 712   if ($use_iv) {
 713     $xs .= "    IV              iv;\n";
 714   } else {
 715     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
 716   }
 717   if ($use_nv) {
 718     $xs .= "    NV              nv;\n";
 719   } else {
 720     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
 721   }
 722   if ($use_pv) {
 723     $xs .= "    const char      *pv;\n";
 724   } else {
 725     $xs .=
 726       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
 727   }
 728
 729   $xs .= << 'EOT';
 730     INPUT:
 731         SV *            sv;
 732         const char *    s = SvPV(sv, len);
 733     PPCODE:
 734 EOT
 735
 736   if ($use_iv xor $use_nv) {
 737     $xs .= << "EOT";
 738         /* Change this to $C_subname(s, len, &iv, &nv);
 739            if you need to return both NVs and IVs */
 740 EOT
 741   }
 742   $xs .= "      type = $C_subname(s, len";
 743   $xs .= ', &iv' if $use_iv;
 744   $xs .= ', &nv' if $use_nv;
 745   $xs .= ', &pv' if $use_pv;
 746   $xs .= ");\n";
 747
 748   $xs .= << "EOT";
 749       /* Return 1 or 2 items. First is error message, or undef if no error.
 750            Second, if present, is found value */
 751         switch (type) {
 752         case PERL_constant_NOTFOUND:
 753           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
 754           PUSHs(sv);
 755           break;
 756         case PERL_constant_NOTDEF:
 757           sv = sv_2mortal(newSVpvf(
 758             "Your vendor has not defined $package macro %s used", s));
 759           PUSHs(sv);
 760           break;
 761 EOT
 762
 763   foreach $type (sort keys %XS_Constant) {
 764     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
 765       unless $what->{$type};
 766     $xs .= << "EOT";
 767         case PERL_constant_IS$type:
 768           EXTEND(SP, 1);
 769           PUSHs(&PL_sv_undef);
 770           $XS_Constant{$type};
 771           break;
 772 EOT
 773     unless ($what->{$type}) {
 774       chop $xs; # Yes, another need for chop not chomp.
 775       $xs .= " */\n";
 776     }
 777   }
 778   $xs .= << "EOT";
 779         default:
 780           sv = sv_2mortal(newSVpvf(
 781             "Unexpected return type %d while processing $package macro %s used",
 782                type, s));
 783           PUSHs(sv);
 784         }
 785 EOT
 786
 787   return $xs;
 788 }
 789
 790
 791 =item autoload PACKAGE, VERSION, AUTOLOADER
 792
 793 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 794 I<VERSION> is the perl version the code should be backwards compatible with.
 795 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
 796 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
 797 names that the constant() routine doesn't recognise.
 798
 799 =cut
 800
 801 # ' # Grr. syntax highlighters that don't grok pod.
 802
 803 sub autoload {
 804   my ($module, $compat_version, $autoloader) = @_;
 805   $compat_version ||= $];
 806   croak "Can't maintain compatibility back as far as version $compat_version"
 807     if $compat_version < 5;
 808   my $func = "sub AUTOLOAD {\n"
 809   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
 810   . "    # XS function.";
 811   $func .= "  If a constant is not found then control is passed\n"
 812   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
 813
 814
 815   $func .= "\n\n"
 816   . "    my \$constname;\n";
 817   $func .=
 818     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
 819
 820   $func .= <<"EOT";
 821     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 822     croak "&${module}::constant not defined" if \$constname eq 'constant';
 823     my (\$error, \$val) = constant(\$constname);
 824 EOT
 825
 826   if ($autoloader) {
 827     $func .= <<'EOT';
 828     if ($error) {
 829         if ($error =~  /is not a valid/) {
 830             $AutoLoader::AUTOLOAD = $AUTOLOAD;
 831             goto &AutoLoader::AUTOLOAD;
 832         } else {
 833             croak $error;
 834         }
 835     }
 836 EOT
 837   } else {
 838     $func .=
 839       "    if (\$error) { croak \$error; }\n";
 840   }
 841
 842   $func .= <<'END';
 843     {
 844         no strict 'refs';
 845         # Fixed between 5.005_53 and 5.005_61
 846 #XXX    if ($] >= 5.00561) {
 847 #XXX        *$AUTOLOAD = sub () { $val };
 848 #XXX    }
 849 #XXX    else {
 850             *$AUTOLOAD = sub { $val };
 851 #XXX    }
 852     }
 853     goto &$AUTOLOAD;
 854 }
 855
 856 END
 857
 858   return $func;
 859 }
 860 1;
 861 __END__
 862
 863 =back
 864
 865 =head1 AUTHOR
 866
 867 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 868 others
 869
 870 =cut