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