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