lib/ExtUtils/Constant.pm

   1 package ExtUtils::Constant;
   2 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
   3 $VERSION = '0.06';
   4
   5 =head1 NAME
   6
   7 ExtUtils::Constant - generate XS code to import C header constants
   8
   9 =head1 SYNOPSIS
  10
  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,
  14                          @names) ) {
  15         print $_, "\n"; # C constant subs
  16     }
  17     print "MODULE = Foo         PACKAGE = Foo\n";
  18     print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
  19
  20 =head1 DESCRIPTION
  21
  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
  26 constants.
  27
  28 =head1 USAGE
  29
  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>.
  32
  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.
  36
  37 =over 4
  38
  39 =item IV
  40
  41 signed integer, at least 32 bits.
  42
  43 =item UV
  44
  45 unsigned integer, the same size as I<IV>
  46
  47 =item NV
  48
  49 floating point type, probably C<double>, possibly C<long double>
  50
  51 =item PV
  52
  53 NUL terminated string, length will be determined with C<strlen>
  54
  55 =item PVN
  56
  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>
  59
  60 =item PVN
  61
  62 A B<mortal> SV.
  63
  64 =item YES
  65
  66 Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
  67
  68 =item NO
  69
  70 Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
  71
  72 =item UNDEF
  73
  74 C<undef>.  The value of the macro is not needed.
  75
  76 =back
  77
  78 =head1 FUNCTIONS
  79
  80 =over 4
  81
  82 =cut
  83
  84 require 5.006; # I think, for [:cntrl:] in REGEXP
  85 use warnings;
  86 use strict;
  87 use Carp;
  88
  89 use Exporter;
  90 use Text::Wrap;
  91 $Text::Wrap::huge = 'overflow';
  92 $Text::Wrap::columns = 80;
  93
  94 @ISA = 'Exporter';
  95
  96 %EXPORT_TAGS = ( 'all' => [ qw(
  97         XS_constant constant_types return_clause memEQ_clause C_stringify
  98         C_constant autoload
  99 ) ] );
 100
 101 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 102
 103 %XS_Constant = (
 104                 IV    => 'PUSHi(iv)',
 105                 UV    => 'PUSHu((UV)iv)',
 106                 NV    => 'PUSHn(nv)',
 107                 PV    => 'PUSHp(pv, strlen(pv))',
 108                 PVN   => 'PUSHp(pv, iv)',
 109                 SV    => 'PUSHs(sv)',
 110                 YES   => 'PUSHs(&PL_sv_yes)',
 111                 NO    => 'PUSHs(&PL_sv_no)',
 112                 UNDEF => '',    # implicit undef
 113 );
 114
 115 %XS_TypeSet = (
 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 = ',
 122                 YES   => undef,
 123                 NO    => undef,
 124                 UNDEF => undef,
 125 );
 126
 127
 128 =item C_stringify NAME
 129
 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.
 132
 133 =cut
 134
 135 # Hopefully make a happy C identifier.
 136 sub C_stringify {
 137   local $_ = shift;
 138   return unless defined $_;
 139   s/\\/\\\\/g;
 140   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 141   s/\n/\\n/g;           # Ensure newlines don't end up in octal
 142   s/\r/\\r/g;
 143   s/\t/\\t/g;
 144   s/\f/\\f/g;
 145   s/\a/\\a/g;
 146   s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
 147   s/\177/\\177/g;       # DEL doesn't seem to be a [:cntrl:]
 148   $_;
 149 }
 150
 151 =item constant_types
 152
 153 A function returning a single scalar with C<#define> definitions for the
 154 constants used internally between the generated C and XS functions.
 155
 156 =cut
 157
 158 sub constant_types () {
 159   my $start = 1;
 160   my @lines;
 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++;
 165   }
 166   push @lines, << 'EOT';
 167
 168 #ifndef NVTYPE
 169 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 170 #endif
 171 EOT
 172
 173   return join '', @lines;
 174 }
 175
 176 =item memEQ_clause NAME, CHECKED_AT, INDENT
 177
 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.
 182
 183 =cut
 184
 185 sub memEQ_clause {
 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;
 191
 192   if ($len < 2) {
 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
 195     $checked_at = 1;
 196   }
 197   if ($len < 3 and defined $checked_at) {
 198     my $check;
 199     if ($checked_at == 1) {
 200       $check = 0;
 201     } elsif ($checked_at == 0) {
 202       $check = 1;
 203     }
 204     if (defined $check) {
 205       my $char = C_stringify (substr $name, $check, 1);
 206       return $indent . "if (name[$check] == '$char') {\n";
 207     }
 208   }
 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;
 215   return $body;
 216 }
 217
 218 =item assign INDENT, TYPE, PRE, POST, VALUE...
 219
 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.
 225
 226 =cut
 227
 228 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
 229
 230 sub assign {
 231   my $indent = shift;
 232   my $type = shift;
 233   my $pre = shift;
 234   my $post = shift || '';
 235   my $clause;
 236   my $close;
 237   if ($pre) {
 238     chomp $pre;
 239     $clause = $indent . "{\n$pre";
 240     $clause .= ";" unless $pre =~ /;$/;
 241     $clause .= "\n";
 242     $close = "$indent}\n";
 243     $indent .= "  ";
 244   }
 245   die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
 246   my $typeset = $XS_TypeSet{$type};
 247   if (ref $typeset) {
 248     die "Type $type is aggregate, but only single value given"
 249       if @_ == 1;
 250     foreach (0 .. $#$typeset) {
 251       $clause .= $indent . "$typeset->[$_] $_[$_];\n";
 252     }
 253   } elsif (defined $typeset) {
 254     die "Aggregate value given for type $type"
 255       if @_ > 1;
 256     $clause .= $indent . "$typeset $_[0];\n";
 257   }
 258   chomp $post;
 259   if (length $post) {
 260     $clause .= "$post";
 261     $clause .= ";" unless $post =~ /;$/;
 262     $clause .= "\n";
 263   }
 264   $clause .= "${indent}return PERL_constant_IS$type;\n";
 265   $clause .= $close if $close;
 266   return $clause;
 267 }
 268
 269 =item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
 270
 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.
 280
 281 =cut
 282
 283 sub return_clause ($$$$$$$$$) {
 284 ##ifdef thingy
 285 #      *iv_return = thingy;
 286 #      return PERL_constant_ISIV;
 287 ##else
 288 #      return PERL_constant_NOTDEF;
 289 ##endif
 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);
 294
 295   my $clause;
 296
 297   ##ifdef thingy
 298   if (ref $macro) {
 299     $clause = $macro->[0];
 300   } else {
 301     $clause = "#ifdef $macro\n";
 302   }
 303
 304   #      *iv_return = thingy;
 305   #      return PERL_constant_ISIV;
 306   $clause .= assign ($indent, $type, $pre, $post,
 307                      ref $value ? @$value : $value);
 308
 309   ##else
 310   $clause .= "#else\n";
 311
 312   #      return PERL_constant_NOTDEF;
 313   if (!defined $default) {
 314     $clause .= "${indent}return PERL_constant_NOTDEF;\n";
 315   } else {
 316     my @default = ref $default ? @$default : $default;
 317     $type = shift @default;
 318     $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
 319   }
 320
 321   ##endif
 322   if (ref $macro) {
 323     $clause .= $macro->[1];
 324   } else {
 325     $clause .= "#endif\n";
 326   }
 327   return $clause
 328 }
 329
 330 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
 331
 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).
 339
 340 =cut
 341
 342 sub switch_clause {
 343   my ($indent, $comment, $namelen, $items, @items) = @_;
 344   $indent = ' ' x ($indent || 2);
 345
 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";
 350   if ($comment) {
 351     $body = wrap ($leader, $follower, $comment) . "\n";
 352     $leader = $follower;
 353   }
 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);
 360     my %spread;
 361     foreach (@names) {
 362       my $char = substr $_, $i, 1;
 363       my $ord = ord $char;
 364       $max = $ord if $ord > $max;
 365       $min = $ord if $ord < $min;
 366       push @{$spread{$char}}, $_;
 367       # warn "$_ $char";
 368     }
 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
 373     # actually better.
 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. :-)
 381     my $ss;
 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);
 386     }
 387   }
 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;
 402
 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";
 409     }
 410     $body .= $indent . "  break;\n";
 411   }
 412   $body .= $indent . "}\n";
 413   return $body;
 414 }
 415
 416 =item params WHAT
 417
 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
 421 argument list.
 422
 423 =cut
 424
 425 sub params {
 426   my $what = shift;
 427   foreach (sort keys %$what) {
 428     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 429   }
 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);
 435 }
 436
 437 =item dump_names
 438
 439 dump_names  PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 440
 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.
 443
 444 =cut
 445
 446 sub dump_names {
 447   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 448     = @_;
 449   my (@simple, @complex);
 450   foreach (@items) {
 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};
 459     } else {
 460       push @complex, $_;
 461     }
 462   }
 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.
 470
 471      Regenerate these constant functions by feeding this entire source file to
 472      perl -x
 473
 474 #!$^X -w
 475 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 476
 477 EOT
 478   $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what)
 479     . ")};\n";
 480   $result .= wrap ("my \@names = (qw(",
 481                    "               ", join (" ", sort @simple) . ")");
 482   if (@complex) {
 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) {
 490           if (ref $value) {
 491             $line .= ", $thing=>[\""
 492               . join ('", "', map {C_stringify $_} @$value) . '"]';
 493           } else {
 494             $line .= ", $thing=>\"" . C_stringify($value) . "\"";
 495           }
 496         }
 497       }
 498       $line .= "}";
 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;
 504       $result .= $line;
 505     }
 506   }
 507   $result .= ");\n";
 508
 509   $result .= <<'EOT';
 510
 511 print constant_types(); # macro defs
 512 EOT
 513   $package = C_stringify($package);
 514   $result .=
 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));
 522     $result .= $indent;
 523   } else {
 524     $result .= 'undef';
 525   }
 526   $result .= ", $breakout" . ', @names) ) {
 527     print $_, "\n"; # C constant subs
 528 }
 529 print "#### XS Section:\n";
 530 print XS_constant ("' . $package . '", $types);
 531 __END__
 532    */
 533
 534 ';
 535
 536   $result;
 537 }
 538
 539 =item C_constant
 540
 541 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 542
 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
 547 keys
 548
 549 =over 8
 550
 551 =item name
 552
 553 The name of the constant, as seen by the perl code.
 554
 555 =item type
 556
 557 The type of the constant (I<IV>, I<NV> etc)
 558
 559 =item value
 560
 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.
 563
 564 =item macro
 565
 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
 571
 572     #if defined (foo)
 573     #if !defined (bar)
 574     ...
 575     #endif
 576     #endif
 577
 578 to be used to determine if a constant is to be defined.
 579
 580 =item default
 581
 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).
 585
 586 =item pre
 587
 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.
 592
 593 =item post
 594
 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>.
 597 Rarely needed.
 598
 599 =item def_pre
 600 =item def_post
 601
 602 Equivalents of I<pre> and I<post> for the default value.
 603
 604 =back
 605
 606 I<PACKAGE> is the name of the package, and is only used in comments inside the
 607 generated C code.
 608
 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.
 611
 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.
 623
 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.
 629
 630 =cut
 631
 632 # The parameter now BREAKOUT was previously documented as:
 633 #
 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.
 639 #
 640 # As you can see it now performs this function during recursion by being a
 641 # scalar reference.
 642
 643 sub C_constant {
 644   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 645     = @_;
 646   my $namelen;
 647   if (ref $breakout) {
 648     $namelen = $$breakout;
 649   } else {
 650     $breakout ||= 3;
 651   }
 652   $package ||= 'Foo';
 653   $subname ||= 'constant';
 654   # I'm not using this. But a hashref could be used for full formatting without
 655   # breaking this API
 656   # $indent ||= 0;
 657    $default_type ||= 'IV';
 658   if (!ref $what) {
 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
 662     # default type
 663   }
 664   my %items;
 665   foreach (@items) {
 666     my $name;
 667     if (ref $_) {
 668       my $orig = $_;
 669       # Make a copy which is a normalised version of the ref passed in.
 670       $name = $_->{name};
 671       my ($type, $macro, $value) = @$_{qw (type macro value)};
 672       $type ||= $default_type;
 673       $what->{$type} = 1;
 674       $_ = {name=>$name, type=>$type};
 675
 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";
 684       }
 685     } else {
 686       $name = $_;
 687       $_ = {name=>$_, type=>$default_type};
 688       $what->{$default_type} = 1;
 689     }
 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";
 693     }
 694     $items{$name} = $_;
 695   }
 696   my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
 697
 698   my ($body, @subs) = "static int\n$subname (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;
 704   $body .= ") {\n";
 705
 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);
 712   } else {
 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,
 716                          $breakout, @items);
 717     $body .= "  switch (len) {\n";
 718     # Need to group names of the same length
 719     my @by_length;
 720     foreach (@items) {
 721       push @{$by_length[length $_->{name}]}, $_;
 722     }
 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;
 732
 733         $body .= memEQ_clause ($name);
 734         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 735                                 $default, $pre, $post, $def_pre, $def_post);
 736         $body .= "    }\n";
 737       } elsif (@{$by_length[$i]} < $breakout) {
 738         $body .= switch_clause (4, '', $i, \%items, @{$by_length[$i]});
 739       } else {
 740         push @subs, C_constant ($package, "${subname}_$i", $default_type,
 741                                 $what, $indent, \$i, @{$by_length[$i]});
 742         $body .= "    return ${subname}_$i (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;
 747         $body .= ");\n";
 748       }
 749       $body .= "    break;\n";
 750     }
 751     $body .= "  }\n";
 752   }
 753   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
 754   return (@subs, $body);
 755 }
 756
 757 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
 758
 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>.
 763
 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>]
 769
 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
 773 I<C_SUBNAME>.
 774
 775 =cut
 776
 777 sub XS_constant {
 778   my $package = shift;
 779   my $what = shift;
 780   my $subname = shift;
 781   my $C_subname = shift;
 782   $subname ||= 'constant';
 783   $C_subname ||= $subname;
 784
 785   if (!ref $what) {
 786     # Convert line of the form IV,UV,NV to hash
 787     $what = {map {$_ => 1} split /,\s*/, ($what)};
 788   }
 789   my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
 790   my $type;
 791
 792   my $xs = <<"EOT";
 793 void
 794 $subname(sv)
 795     PREINIT:
 796 #ifdef dXSTARG
 797         dXSTARG; /* Faster if we have it.  */
 798 #else
 799         dTARGET;
 800 #endif
 801         STRLEN          len;
 802         int             type;
 803 EOT
 804
 805   if ($use_iv) {
 806     $xs .= "    IV              iv;\n";
 807   } else {
 808     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
 809   }
 810   if ($use_nv) {
 811     $xs .= "    NV              nv;\n";
 812   } else {
 813     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
 814   }
 815   if ($use_pv) {
 816     $xs .= "    const char      *pv;\n";
 817   } else {
 818     $xs .=
 819       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
 820   }
 821
 822   $xs .= << 'EOT';
 823     INPUT:
 824         SV *            sv;
 825         const char *    s = SvPV(sv, len);
 826     PPCODE:
 827 EOT
 828
 829   if ($use_iv xor $use_nv) {
 830     $xs .= << "EOT";
 831         /* Change this to $C_subname(s, len, &iv, &nv);
 832            if you need to return both NVs and IVs */
 833 EOT
 834   }
 835   $xs .= "      type = $C_subname(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;
 840   $xs .= ");\n";
 841
 842   $xs .= << "EOT";
 843       /* Return 1 or 2 items. First is error message, or undef if no error.
 844            Second, if present, is found value */
 845         switch (type) {
 846         case PERL_constant_NOTFOUND:
 847           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
 848           PUSHs(sv);
 849           break;
 850         case PERL_constant_NOTDEF:
 851           sv = sv_2mortal(newSVpvf(
 852             "Your vendor has not defined $package macro %s, used", s));
 853           PUSHs(sv);
 854           break;
 855 EOT
 856
 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}) {
 862       $xs .= << "EOT";
 863           EXTEND(SP, 1);
 864           PUSHs(&PL_sv_undef);
 865           $XS_Constant{$type};
 866 EOT
 867     } else {
 868       # Do nothing. return (), which will be correctly interpreted as
 869       # (undef, undef)
 870     }
 871     $xs .= "          break;\n";
 872     unless ($what->{$type}) {
 873       chop $xs; # Yes, another need for chop not chomp.
 874       $xs .= " */\n";
 875     }
 876   }
 877   $xs .= << "EOT";
 878         default:
 879           sv = sv_2mortal(newSVpvf(
 880             "Unexpected return type %d while processing $package macro %s, used",
 881                type, s));
 882           PUSHs(sv);
 883         }
 884 EOT
 885
 886   return $xs;
 887 }
 888
 889
 890 =item autoload PACKAGE, VERSION, AUTOLOADER
 891
 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.
 897
 898 =cut
 899
 900 # ' # Grr. syntax highlighters that don't grok pod.
 901
 902 sub autoload {
 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"
 909   . "    # XS function.";
 910   $func .= "  If a constant is not found then control is passed\n"
 911   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
 912
 913
 914   $func .= "\n\n"
 915   . "    my \$constname;\n";
 916   $func .=
 917     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
 918
 919   $func .= <<"EOT";
 920     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 921     croak "&${module}::constant not defined" if \$constname eq 'constant';
 922     my (\$error, \$val) = constant(\$constname);
 923 EOT
 924
 925   if ($autoloader) {
 926     $func .= <<'EOT';
 927     if ($error) {
 928         if ($error =~  /is not a valid/) {
 929             $AutoLoader::AUTOLOAD = $AUTOLOAD;
 930             goto &AutoLoader::AUTOLOAD;
 931         } else {
 932             croak $error;
 933         }
 934     }
 935 EOT
 936   } else {
 937     $func .=
 938       "    if (\$error) { croak \$error; }\n";
 939   }
 940
 941   $func .= <<'END';
 942     {
 943         no strict 'refs';
 944         # Fixed between 5.005_53 and 5.005_61
 945 #XXX    if ($] >= 5.00561) {
 946 #XXX        *$AUTOLOAD = sub () { $val };
 947 #XXX    }
 948 #XXX    else {
 949             *$AUTOLOAD = sub { $val };
 950 #XXX    }
 951     }
 952     goto &$AUTOLOAD;
 953 }
 954
 955 END
 956
 957   return $func;
 958 }
 959 1;
 960 __END__
 961
 962 =back
 963
 964 =head1 AUTHOR
 965
 966 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 967 others
 968
 969 =cut