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
 298
 299 dump_names  PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
 300
 301 An internal function to generate the embedded perl code that will regenerate
 302 the constant subroutines.  Parameters are the same as for C_constant, except
 303 that there is no NAMELEN.
 304
 305 =cut
 306
 307 sub dump_names {
 308   my ($package, $subname, $default_type, $what, $indent, @items) = @_;
 309   my (@simple, @complex);
 310   foreach (@items) {
 311     my $type = $_->{type} || $default_type;
 312     if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
 313         and !defined ($_->{macro}) and !defined ($_->{value})
 314         and !defined ($_->{default})) {
 315       # It's the default type, and the name consists only of A-Za-z0-9_
 316       push @simple, $_->{name};
 317     } else {
 318       push @complex, $_;
 319     }
 320   }
 321   my $result = <<"EOT";
 322   /* When generated this function returned values for the list of names given
 323      in this section of perl code.  Rather than manually editing these functions
 324      to add or remove constants, which would result in this comment and section
 325      of code becoming inaccurate, we recommend that you edit this section of
 326      code, and use it to regenerate a new set of constant functions which you
 327      then use to replace the originals.
 328
 329      Regenerate these constant functions by feeding this entire source file to
 330      perl -x
 331
 332 #!$^X -w
 333 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 334
 335 EOT
 336   $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
 337  . "};\n";
 338   $result .= wrap ("my \@names = (qw(",
 339                    "               ", join (" ", sort @simple) . ")");
 340   if (@complex) {
 341     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
 342       my $name = C_stringify $item->{name};
 343       my ($macro, $value, $default) = @$item{qw (macro value default)};
 344       my $line = ",\n            {name=>\"$name\"";
 345       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
 346       if (defined $macro) {
 347         if (ref $macro) {
 348           $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
 349             . '"]';
 350         } else {
 351           $line .= ", macro=>\"" . C_stringify($macro) . "\"";
 352         }
 353       }
 354       if (defined $value) {
 355         if (ref $value) {
 356           $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
 357             . '"]';
 358         } else {
 359           $line .= ", value=>\"" . C_stringify($value) . "\"";
 360         }
 361       }
 362       if (defined $default) {
 363         if (ref $default) {
 364           $line .= ', default=>["'. join ('", "', map {C_stringify $_}
 365                                           @$default)
 366             . '"]';
 367         } else {
 368           $line .= ", default=>\"" . C_stringify($default) . "\"";
 369         }
 370       }
 371       $line .= "}";
 372       # Ensure that the enclosing C comment doesn't end
 373       # by turning */  into *" . "/
 374       $line =~ s!\*\/!\*" . "/!gs;
 375       $result .= $line;
 376     }
 377   }
 378   $result .= ");\n";
 379
 380   $result .= <<'EOT';
 381
 382 print constant_types(); # macro defs
 383 EOT
 384   $package = C_stringify($package);
 385   $result .=
 386     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 387   # The form of the indent parameter isn't defined. (Yet)
 388   if (defined $indent) {
 389     require Data::Dumper;
 390     $Data::Dumper::Terse=1;
 391     chomp ($indent = Data::Dumper::Dumper ($indent));
 392     $result .= $indent;
 393   } else {
 394     $result .= 'undef';
 395   }
 396   $result .= ', undef, @names) ) {
 397     print $_, "\n"; # C constant subs
 398 }
 399 print "#### XS Section:\n";
 400 print XS_constant ("' . $package . '", $types);
 401 __END__
 402    */
 403
 404 ';
 405
 406   $result;
 407 }
 408
 409 =item C_constant
 410
 411 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
 412
 413 A function that returns a B<list> of C subroutine definitions that return
 414 the value and type of constants when passed the name by the XS wrapper.
 415 I<ITEM...> gives a list of constant names. Each can either be a string,
 416 which is taken as a C macro name, or a reference to a hash with the following
 417 keys
 418
 419 =over 8
 420
 421 =item name
 422
 423 The name of the constant, as seen by the perl code.
 424
 425 =item type
 426
 427 The type of the constant (I<IV>, I<NV> etc)
 428
 429 =item value
 430
 431 A C expression for the value of the constant, or a list of C expressions if
 432 the type is aggregate. This defaults to the I<name> if not given.
 433
 434 =item macro
 435
 436 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
 437 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
 438 array is passed then the first element is used in place of the C<#ifdef>
 439 line, and the second element in place of the C<#endif>. This allows
 440 pre-processor constructions such as
 441
 442     #if defined (foo)
 443     #if !defined (bar)
 444     ...
 445     #endif
 446     #endif
 447
 448 to be used to determine if a constant is to be defined.
 449
 450 =item default
 451
 452 Default value to use (instead of C<croak>ing with "your vendor has not
 453 defined...") to return if the macro isn't defined. Specify a reference to
 454 an array with type followed by value(s).
 455
 456 =back
 457
 458 I<PACKAGE> is the name of the package, and is only used in comments inside the
 459 generated C code.
 460
 461 The next 5 arguments can safely be given as C<undef>, and are mainly used
 462 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
 463
 464 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
 465 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
 466 separated list of types that the C subroutine C<constant> will generate or as
 467 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
 468 present, as will any types given in the list of I<ITEM>s. The resultant list
 469 should be the same list of types that C<XS_constant> is given. [Otherwise
 470 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
 471 constant function. I<INDENT> is currently unused and ignored. In future it may
 472 be used to pass in information used to change the C indentation style used.]
 473 The best way to maintain consistency is to pass in a hash reference and let
 474 this function update it.
 475
 476 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
 477 this length, and that the constant name passed in by perl is checked and
 478 also of this length. It is used during recursion, and should be C<undef>
 479 unless the caller has checked all the lengths during code generation, and
 480 the generated subroutine is only to be called with a name of this length.
 481
 482 =cut
 483
 484 sub C_constant {
 485   my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
 486   $package ||= 'Foo';
 487   $subname ||= 'constant';
 488   # I'm not using this. But a hashref could be used for full formatting without
 489   # breaking this API
 490   # $indent ||= 0;
 491    $default_type ||= 'IV';
 492   if (!ref $what) {
 493     # Convert line of the form IV,UV,NV to hash
 494     $what = {map {$_ => 1} split /,\s*/, ($what || '')};
 495     # Figure out what types we're dealing with, and assign all unknowns to the
 496     # default type
 497   }
 498   my %items;
 499   foreach (@items) {
 500     my $name;
 501     if (ref $_) {
 502       # Make a copy which is a normalised version of the ref passed in.
 503       $name = $_->{name};
 504       my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
 505       $type ||= $default_type;
 506       $what->{$type} = 1;
 507       $_ = {name=>$name, type=>$type};
 508
 509       undef $macro if defined $macro and $macro eq $name;
 510       $_->{macro} = $macro if defined $macro;
 511       undef $value if defined $value and $value eq $name;
 512       $_->{value} = $value if defined $value;
 513       $_->{default} = $default if defined $default;
 514     } else {
 515       $name = $_;
 516       $_ = {name=>$_, type=>$default_type};
 517       $what->{$default_type} = 1;
 518     }
 519     warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
 520     if (exists $items{$name}) {
 521       die "Multiple definitions for macro $name";
 522     }
 523     $items{$name} = $_;
 524   }
 525   my ($use_iv, $use_nv, $use_pv) = params ($what);
 526
 527   my ($body, @subs) = "static int\n$subname (const char *name";
 528   $body .= ", STRLEN len" unless defined $namelen;
 529   $body .= ", IV *iv_return" if $use_iv;
 530   $body .= ", NV *nv_return" if $use_nv;
 531   $body .= ", const char **pv_return" if $use_pv;
 532   $body .= ") {\n";
 533
 534   if (defined $namelen) {
 535     # We are a child subroutine. Print the simple description
 536     my @names = sort map {$_->{name}} @items;
 537     my $names = << 'EOT'
 538   /* When generated this function returned values for the list of names given
 539      here.  However, subsequent manual editing may have added or removed some.
 540 EOT
 541      . wrap ("     ", "     ", join (" ", @names) . " */") . "\n";
 542     # Figure out what to switch on.
 543     # (RMS, Spread of jump table, Position, Hashref)
 544     my @best = (1e38, ~0);
 545     foreach my $i (0 .. ($namelen - 1)) {
 546       my ($min, $max) = (~0, 0);
 547       my %spread;
 548       foreach (@names) {
 549         my $char = substr $_, $i, 1;
 550         my $ord = ord $char;
 551         $max = $ord if $ord > $max;
 552         $min = $ord if $ord < $min;
 553         push @{$spread{$char}}, $_;
 554         # warn "$_ $char";
 555       }
 556       # I'm going to pick the character to split on that minimises the root
 557       # mean square of the number of names in each case. Normally this should
 558       # be the one with the most keys, but it may pick a 7 where the 8 has
 559       # one long linear search. I'm not sure if RMS or just sum of squares is
 560       # actually better.
 561       # $max and $min are for the tie-breaker if the root mean squares match.
 562       # Assuming that the compiler may be building a jump table for the
 563       # switch() then try to minimise the size of that jump table.
 564       # Finally use < not <= so that if it still ties the earliest part of
 565       # the string wins. Because if that passes but the memEQ fails, it may
 566       # only need the start of the string to bin the choice.
 567       # I think. But I'm micro-optimising. :-)
 568       my $ss;
 569       $ss += @$_ * @$_ foreach values %spread;
 570       my $rms = sqrt ($ss / keys %spread);
 571       if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
 572         @best = ($rms, $max - $min, $i, \%spread);
 573       }
 574     }
 575     die "Internal error. Failed to pick a switch point for @names"
 576       unless defined $best[2];
 577     # use Data::Dumper; print Dumper (@best);
 578     my ($offset, $best) = @best[2,3];
 579     $body .= "  /* Names all of length $namelen.  */\n";
 580     $body .= $names;
 581     $body .= "  /* Offset $offset gives the best switch position.  */\n";
 582     $body .= "  switch (name[$offset]) {\n";
 583     foreach my $char (sort keys %$best) {
 584       $body .= "  case '" . C_stringify ($char) . "':\n";
 585       foreach my $name (sort @{$best->{$char}}) {
 586         my $thisone = $items{$name};
 587         my ($value, $macro, $default) = @$thisone{qw (value macro default)};
 588         $value = $name unless defined $value;
 589         $macro = $name unless defined $macro;
 590
 591         $body .= memEQ_clause ($name, $offset); # We have checked this offset.
 592         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 593                                 $default);
 594         $body .= "    }\n";
 595       }
 596       $body .= "    break;\n";
 597     }
 598     $body .= "  }\n";
 599   } else {
 600     # We are the top level.
 601     $body .= "  /* Initially switch on the length of the name.  */\n";
 602     $body .= dump_names ($package, $subname, $default_type, $what, $indent,
 603                          @items);
 604     $body .= "  switch (len) {\n";
 605     # Need to group names of the same length
 606     my @by_length;
 607     foreach (@items) {
 608       push @{$by_length[length $_->{name}]}, $_;
 609     }
 610     foreach my $i (0 .. $#by_length) {
 611       next unless $by_length[$i];       # None of this length
 612       $body .= "  case $i:\n";
 613       if (@{$by_length[$i]} == 1) {
 614         my $thisone = $by_length[$i]->[0];
 615         my ($name, $value, $macro, $default)
 616           = @$thisone{qw (name value macro default)};
 617         $value = $name unless defined $value;
 618         $macro = $name unless defined $macro;
 619
 620         $body .= memEQ_clause ($name);
 621         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 622                                 $default);
 623         $body .= "    }\n";
 624       } else {
 625         push @subs, C_constant ($package, "${subname}_$i", $default_type,
 626                                 $what, $indent, $i, @{$by_length[$i]});
 627         $body .= "    return ${subname}_$i (name";
 628         $body .= ", iv_return" if $use_iv;
 629         $body .= ", nv_return" if $use_nv;
 630         $body .= ", pv_return" if $use_pv;
 631         $body .= ");\n";
 632       }
 633       $body .= "    break;\n";
 634     }
 635     $body .= "  }\n";
 636   }
 637   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
 638   return (@subs, $body);
 639 }
 640
 641 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
 642
 643 A function to generate the XS code to implement the perl subroutine
 644 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
 645 This XS code is a wrapper around a C subroutine usually generated by
 646 C<C_constant>, and usually named C<constant>.
 647
 648 I<TYPES> should be given either as a comma separated list of types that the
 649 C subroutine C<constant> will generate or as a reference to a hash. It should
 650 be the same list of types as C<C_constant> was given.
 651 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
 652 the number of parameters passed to the C function C<constant>]
 653
 654 You can call the perl visible subroutine something other than C<constant> if
 655 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
 656 the name of the perl visible subroutine, unless you give the parameter
 657 I<C_SUBNAME>.
 658
 659 =cut
 660
 661 sub XS_constant {
 662   my $package = shift;
 663   my $what = shift;
 664   my $subname = shift;
 665   my $C_subname = shift;
 666   $subname ||= 'constant';
 667   $C_subname ||= $subname;
 668
 669   if (!ref $what) {
 670     # Convert line of the form IV,UV,NV to hash
 671     $what = {map {$_ => 1} split /,\s*/, ($what)};
 672   }
 673   my ($use_iv, $use_nv, $use_pv) = params ($what);
 674   my $type;
 675
 676   my $xs = <<"EOT";
 677 void
 678 $subname(sv)
 679     PREINIT:
 680 #ifdef dXSTARG
 681         dXSTARG; /* Faster if we have it.  */
 682 #else
 683         dTARGET;
 684 #endif
 685         STRLEN          len;
 686         int             type;
 687 EOT
 688
 689   if ($use_iv) {
 690     $xs .= "    IV              iv;\n";
 691   } else {
 692     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
 693   }
 694   if ($use_nv) {
 695     $xs .= "    NV              nv;\n";
 696   } else {
 697     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
 698   }
 699   if ($use_pv) {
 700     $xs .= "    const char      *pv;\n";
 701   } else {
 702     $xs .=
 703       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
 704   }
 705
 706   $xs .= << 'EOT';
 707     INPUT:
 708         SV *            sv;
 709         const char *    s = SvPV(sv, len);
 710     PPCODE:
 711 EOT
 712
 713   if ($use_iv xor $use_nv) {
 714     $xs .= << "EOT";
 715         /* Change this to $C_subname(s, len, &iv, &nv);
 716            if you need to return both NVs and IVs */
 717 EOT
 718   }
 719   $xs .= "      type = $C_subname(s, len";
 720   $xs .= ', &iv' if $use_iv;
 721   $xs .= ', &nv' if $use_nv;
 722   $xs .= ', &pv' if $use_pv;
 723   $xs .= ");\n";
 724
 725   $xs .= << "EOT";
 726       /* Return 1 or 2 items. First is error message, or undef if no error.
 727            Second, if present, is found value */
 728         switch (type) {
 729         case PERL_constant_NOTFOUND:
 730           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
 731           PUSHs(sv);
 732           break;
 733         case PERL_constant_NOTDEF:
 734           sv = sv_2mortal(newSVpvf(
 735             "Your vendor has not defined $package macro %s used", s));
 736           PUSHs(sv);
 737           break;
 738 EOT
 739
 740   foreach $type (sort keys %XS_Constant) {
 741     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
 742       unless $what->{$type};
 743     $xs .= << "EOT";
 744         case PERL_constant_IS$type:
 745           EXTEND(SP, 1);
 746           PUSHs(&PL_sv_undef);
 747           $XS_Constant{$type};
 748           break;
 749 EOT
 750     unless ($what->{$type}) {
 751       chop $xs; # Yes, another need for chop not chomp.
 752       $xs .= " */\n";
 753     }
 754   }
 755   $xs .= << "EOT";
 756         default:
 757           sv = sv_2mortal(newSVpvf(
 758             "Unexpected return type %d while processing $package macro %s used",
 759                type, s));
 760           PUSHs(sv);
 761         }
 762 EOT
 763
 764   return $xs;
 765 }
 766
 767
 768 =item autoload PACKAGE, VERSION, AUTOLOADER
 769
 770 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 771 I<VERSION> is the perl version the code should be backwards compatible with.
 772 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
 773 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
 774 names that the constant() routine doesn't recognise.
 775
 776 =cut
 777
 778 # ' # Grr. syntax highlighters that don't grok pod.
 779
 780 sub autoload {
 781   my ($module, $compat_version, $autoloader) = @_;
 782   $compat_version ||= $];
 783   croak "Can't maintain compatibility back as far as version $compat_version"
 784     if $compat_version < 5;
 785   my $func = "sub AUTOLOAD {\n"
 786   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
 787   . "    # XS function.";
 788   $func .= "  If a constant is not found then control is passed\n"
 789   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
 790
 791
 792   $func .= "\n\n"
 793   . "    my \$constname;\n";
 794   $func .=
 795     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
 796
 797   $func .= <<"EOT";
 798     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 799     croak "&${module}::constant not defined" if \$constname eq 'constant';
 800     my (\$error, \$val) = constant(\$constname);
 801 EOT
 802
 803   if ($autoloader) {
 804     $func .= <<'EOT';
 805     if ($error) {
 806         if ($error =~  /is not a valid/) {
 807             $AutoLoader::AUTOLOAD = $AUTOLOAD;
 808             goto &AutoLoader::AUTOLOAD;
 809         } else {
 810             croak $error;
 811         }
 812     }
 813 EOT
 814   } else {
 815     $func .=
 816       "    if (\$error) { croak \$error; }\n";
 817   }
 818
 819   $func .= <<'END';
 820     {
 821         no strict 'refs';
 822         # Fixed between 5.005_53 and 5.005_61
 823 #XXX    if ($] >= 5.00561) {
 824 #XXX        *$AUTOLOAD = sub () { $val };
 825 #XXX    }
 826 #XXX    else {
 827             *$AUTOLOAD = sub { $val };
 828 #XXX    }
 829     }
 830     goto &$AUTOLOAD;
 831 }
 832
 833 END
 834
 835   return $func;
 836 }
 837 1;
 838 __END__
 839
 840 =back
 841
 842 =head1 AUTHOR
 843
 844 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 845 others
 846
 847 =cut