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