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.14';
   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 (WriteConstants);
  12     WriteConstants(
  13         NAME => 'Foo',
  14         NAMES => [qw(FOO BAR BAZ)],
  15     );
  16     # Generates wrapper code to make the values of the constants FOO BAR BAZ
  17     #  available to perl
  18
  19 =head1 DESCRIPTION
  20
  21 ExtUtils::Constant facilitates generating C and XS wrapper code to allow
  22 perl modules to AUTOLOAD constants defined in C library header files.
  23 It is principally used by the C<h2xs> utility, on which this code is based.
  24 It doesn't contain the routines to scan header files to extract these
  25 constants.
  26
  27 =head1 USAGE
  28
  29 Generally one only needs to call the C<WriteConstants> function, and then
  30
  31     #include "const-c.inc"
  32
  33 in the C section of C<Foo.xs>
  34
  35     INCLUDE: const-xs.inc
  36
  37 in the XS section of C<Foo.xs>.
  38
  39 For greater flexibility use C<constant_types()>, C<C_constant> and
  40 C<XS_constant>, with which C<WriteConstants> is implemented.
  41
  42 Currently this module understands the following types. h2xs may only know
  43 a subset. The sizes of the numeric types are chosen by the C<Configure>
  44 script at compile time.
  45
  46 =over 4
  47
  48 =item IV
  49
  50 signed integer, at least 32 bits.
  51
  52 =item UV
  53
  54 unsigned integer, the same size as I<IV>
  55
  56 =item NV
  57
  58 floating point type, probably C<double>, possibly C<long double>
  59
  60 =item PV
  61
  62 NUL terminated string, length will be determined with C<strlen>
  63
  64 =item PVN
  65
  66 A fixed length thing, given as a [pointer, length] pair. If you know the
  67 length of a string at compile time you may use this instead of I<PV>
  68
  69 =item SV
  70
  71 A B<mortal> SV.
  72
  73 =item YES
  74
  75 Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
  76
  77 =item NO
  78
  79 Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
  80
  81 =item UNDEF
  82
  83 C<undef>.  The value of the macro is not needed.
  84
  85 =back
  86
  87 =head1 FUNCTIONS
  88
  89 =over 4
  90
  91 =cut
  92
  93 if ($] >= 5.006) {
  94   eval "use warnings; 1" or die $@;
  95 }
  96 use strict;
  97 use vars '$is_perl56';
  98 use Carp;
  99
 100 $is_perl56 = ($] < 5.007 && $] > 5.005_50);
 101
 102 use Exporter;
 103 use Text::Wrap;
 104 $Text::Wrap::huge = 'overflow';
 105 $Text::Wrap::columns = 80;
 106
 107 @ISA = 'Exporter';
 108
 109 %EXPORT_TAGS = ( 'all' => [ qw(
 110         XS_constant constant_types return_clause memEQ_clause C_stringify
 111         C_constant autoload WriteConstants WriteMakefileSnippet
 112 ) ] );
 113
 114 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 115
 116 # '' is used as a flag to indicate non-ascii macro names, and hence the need
 117 # to pass in the utf8 on/off flag.
 118 %XS_Constant = (
 119                 ''    => '',
 120                 IV    => 'PUSHi(iv)',
 121                 UV    => 'PUSHu((UV)iv)',
 122                 NV    => 'PUSHn(nv)',
 123                 PV    => 'PUSHp(pv, strlen(pv))',
 124                 PVN   => 'PUSHp(pv, iv)',
 125                 SV    => 'PUSHs(sv)',
 126                 YES   => 'PUSHs(&PL_sv_yes)',
 127                 NO    => 'PUSHs(&PL_sv_no)',
 128                 UNDEF => '',    # implicit undef
 129 );
 130
 131 %XS_TypeSet = (
 132                 IV    => '*iv_return =',
 133                 UV    => '*iv_return = (IV)',
 134                 NV    => '*nv_return =',
 135                 PV    => '*pv_return =',
 136                 PVN   => ['*pv_return =', '*iv_return = (IV)'],
 137                 SV    => '*sv_return = ',
 138                 YES   => undef,
 139                 NO    => undef,
 140                 UNDEF => undef,
 141 );
 142
 143
 144 =item C_stringify NAME
 145
 146 A function which returns a 7 bit ASCII correctly \ escaped version of the
 147 string passed suitable for C's "" or ''. It will die if passed Unicode
 148 characters.
 149
 150 =cut
 151
 152 # Hopefully make a happy C identifier.
 153 sub C_stringify {
 154   local $_ = shift;
 155   return unless defined $_;
 156   # grr 5.6.1
 157   confess "Wide character in '$_' intended as a C identifier"
 158     if tr/\0-\377// != length;
 159   # grr 5.6.1 moreso because its regexps will break on data that happens to
 160   # be utf8, which includes my 8 bit test cases.
 161   $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56;
 162   s/\\/\\\\/g;
 163   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 164   s/\n/\\n/g;           # Ensure newlines don't end up in octal
 165   s/\r/\\r/g;
 166   s/\t/\\t/g;
 167   s/\f/\\f/g;
 168   s/\a/\\a/g;
 169   s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
 170   unless ($] < 5.006) {
 171     # This will elicit a warning on 5.005_03 about [: :] being reserved unless
 172     # I cheat
 173     my $cheat = '([[:^print:]])';
 174     s/$cheat/sprintf "\\%03o", ord $1/ge;
 175   } else {
 176     require POSIX;
 177     s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
 178   }
 179   $_;
 180 }
 181
 182 =item perl_stringify NAME
 183
 184 A function which returns a 7 bit ASCII correctly \ escaped version of the
 185 string passed suitable for a perl "" string.
 186
 187 =cut
 188
 189 # Hopefully make a happy perl identifier.
 190 sub perl_stringify {
 191   local $_ = shift;
 192   return unless defined $_;
 193   s/\\/\\\\/g;
 194   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 195   s/\n/\\n/g;           # Ensure newlines don't end up in octal
 196   s/\r/\\r/g;
 197   s/\t/\\t/g;
 198   s/\f/\\f/g;
 199   s/\a/\\a/g;
 200   unless ($] < 5.006) {
 201     if ($] > 5.007) {
 202       s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
 203     } else {
 204       # Grr 5.6.1. And I don't think I can use utf8; to force the regexp
 205       # because 5.005_03 will fail.
 206       # This is grim, but I also can't split on //
 207       my $copy;
 208       foreach my $index (0 .. length ($_) - 1) {
 209         my $char = substr ($_, $index, 1);
 210         $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
 211       }
 212       $_ = $copy;
 213     }
 214     # This will elicit a warning on 5.005_03 about [: :] being reserved unless
 215     # I cheat
 216     my $cheat = '([[:^print:]])';
 217     s/$cheat/sprintf "\\%03o", ord $1/ge;
 218   } else {
 219     # Turns out "\x{}" notation only arrived with 5.6
 220     s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
 221     require POSIX;
 222     s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
 223   }
 224   $_;
 225 }
 226
 227 =item constant_types
 228
 229 A function returning a single scalar with C<#define> definitions for the
 230 constants used internally between the generated C and XS functions.
 231
 232 =cut
 233
 234 sub constant_types () {
 235   my $start = 1;
 236   my @lines;
 237   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
 238   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
 239   foreach (sort keys %XS_Constant) {
 240     next if $_ eq '';
 241     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
 242   }
 243   push @lines, << 'EOT';
 244
 245 #ifndef NVTYPE
 246 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 247 #endif
 248 #ifndef aTHX_
 249 #define aTHX_ /* 5.6 or later define this for threading support.  */
 250 #endif
 251 #ifndef pTHX_
 252 #define pTHX_ /* 5.6 or later define this for threading support.  */
 253 #endif
 254 EOT
 255
 256   return join '', @lines;
 257 }
 258
 259 =item memEQ_clause NAME, CHECKED_AT, INDENT
 260
 261 A function to return a suitable C C<if> statement to check whether I<NAME>
 262 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
 263 is used to avoid C<memEQ> for short names, or to generate a comment to
 264 highlight the position of the character in the C<switch> statement.
 265
 266 If I<CHECKED_AT> is a reference to a scalar, then instead it gives
 267 the characters pre-checked at the beginning, (and the number of chars by
 268 which the C variable name has been advanced. These need to be chopped from
 269 the front of I<NAME>).
 270
 271 =cut
 272
 273 sub memEQ_clause {
 274 #    if (memEQ(name, "thingy", 6)) {
 275   # Which could actually be a character comparison or even ""
 276   my ($name, $checked_at, $indent) = @_;
 277   $indent = ' ' x ($indent || 4);
 278   my $front_chop;
 279   if (ref $checked_at) {
 280     # regexp won't work on 5.6.1 without use utf8; in turn that won't work
 281     # on 5.005_03.
 282     substr ($name, 0, length $$checked_at,) = '';
 283     $front_chop = C_stringify ($$checked_at);
 284     undef $checked_at;
 285   }
 286   my $len = length $name;
 287
 288   if ($len < 2) {
 289     return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
 290     # We didn't switch, drop through to the code for the 2 character string
 291     $checked_at = 1;
 292   }
 293   if ($len < 3 and defined $checked_at) {
 294     my $check;
 295     if ($checked_at == 1) {
 296       $check = 0;
 297     } elsif ($checked_at == 0) {
 298       $check = 1;
 299     }
 300     if (defined $check) {
 301       my $char = C_stringify (substr $name, $check, 1);
 302       return $indent . "if (name[$check] == '$char') {\n";
 303     }
 304   }
 305   if (($len == 2 and !defined $checked_at)
 306      or ($len == 3 and defined ($checked_at) and $checked_at == 2)) {
 307     my $char1 = C_stringify (substr $name, 0, 1);
 308     my $char2 = C_stringify (substr $name, 1, 1);
 309     return $indent . "if (name[0] == '$char1' && name[1] == '$char2') {\n";
 310   }
 311   if (($len == 3 and defined ($checked_at) and $checked_at == 1)) {
 312     my $char1 = C_stringify (substr $name, 0, 1);
 313     my $char2 = C_stringify (substr $name, 2, 1);
 314     return $indent . "if (name[0] == '$char1' && name[2] == '$char2') {\n";
 315   }
 316
 317   my $pointer = '^';
 318   my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1;
 319   if ($have_checked_last) {
 320     # Checked at the last character, so no need to memEQ it.
 321     $pointer = C_stringify (chop $name);
 322     $len--;
 323   }
 324
 325   $name = C_stringify ($name);
 326   my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
 327   # Put a little ^ under the letter we checked at
 328   # Screws up for non printable and non-7 bit stuff, but that's too hard to
 329   # get right.
 330   if (defined $checked_at) {
 331     $body .= $indent . "/*               ". (' ' x $checked_at) . $pointer
 332       . (' ' x ($len - $checked_at + length $len)) . "    */\n";
 333   } elsif (defined $front_chop) {
 334     $body .= $indent . "/*              $front_chop"
 335       . (' ' x ($len + 1 + length $len)) . "    */\n";
 336   }
 337   return $body;
 338 }
 339
 340 =item assign INDENT, TYPE, PRE, POST, VALUE...
 341
 342 A function to return a suitable assignment clause. If I<TYPE> is aggregate
 343 (eg I<PVN> expects both pointer and length) then there should be multiple
 344 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
 345 of C code to proceed and follow the assignment. I<PRE> will be at the start
 346 of a block, so variables may be defined in it.
 347
 348 =cut
 349
 350 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
 351
 352 sub assign {
 353   my $indent = shift;
 354   my $type = shift;
 355   my $pre = shift;
 356   my $post = shift || '';
 357   my $clause;
 358   my $close;
 359   if ($pre) {
 360     chomp $pre;
 361     $clause = $indent . "{\n$pre";
 362     $clause .= ";" unless $pre =~ /;$/;
 363     $clause .= "\n";
 364     $close = "$indent}\n";
 365     $indent .= "  ";
 366   }
 367   confess "undef \$type" unless defined $type;
 368   confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
 369   my $typeset = $XS_TypeSet{$type};
 370   if (ref $typeset) {
 371     die "Type $type is aggregate, but only single value given"
 372       if @_ == 1;
 373     foreach (0 .. $#$typeset) {
 374       $clause .= $indent . "$typeset->[$_] $_[$_];\n";
 375     }
 376   } elsif (defined $typeset) {
 377     die "Aggregate value given for type $type"
 378       if @_ > 1;
 379     $clause .= $indent . "$typeset $_[0];\n";
 380   }
 381   chomp $post;
 382   if (length $post) {
 383     $clause .= "$post";
 384     $clause .= ";" unless $post =~ /;$/;
 385     $clause .= "\n";
 386   }
 387   $clause .= "${indent}return PERL_constant_IS$type;\n";
 388   $clause .= $close if $close;
 389   return $clause;
 390 }
 391
 392 =item return_clause
 393
 394 return_clause ITEM, INDENT
 395
 396 A function to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
 397 (as passed to C<C_constant> and C<match_clause>. I<INDENT> is the number
 398 of spaces to indent, defaulting to 6.
 399
 400 =cut
 401
 402 sub return_clause ($$) {
 403 ##ifdef thingy
 404 #      *iv_return = thingy;
 405 #      return PERL_constant_ISIV;
 406 ##else
 407 #      return PERL_constant_NOTDEF;
 408 ##endif
 409   my ($item, $indent) = @_;
 410
 411   my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post, $type)
 412     = @$item{qw (name value macro default pre post def_pre def_post type)};
 413   $value = $name unless defined $value;
 414   $macro = $name unless defined $macro;
 415
 416   $macro = $value unless defined $macro;
 417   $indent = ' ' x ($indent || 6);
 418   unless ($type) {
 419     # use Data::Dumper; print STDERR Dumper ($item);
 420     confess "undef \$type";
 421   }
 422
 423   my $clause;
 424
 425   ##ifdef thingy
 426   if (ref $macro) {
 427     $clause = $macro->[0];
 428   } elsif ($macro ne "1") {
 429     $clause = "#ifdef $macro\n";
 430   }
 431
 432   #      *iv_return = thingy;
 433   #      return PERL_constant_ISIV;
 434   $clause .= assign ($indent, $type, $pre, $post,
 435                      ref $value ? @$value : $value);
 436
 437   if (ref $macro or $macro ne "1") {
 438     ##else
 439     $clause .= "#else\n";
 440
 441     #      return PERL_constant_NOTDEF;
 442     if (!defined $default) {
 443       $clause .= "${indent}return PERL_constant_NOTDEF;\n";
 444     } else {
 445       my @default = ref $default ? @$default : $default;
 446       $type = shift @default;
 447       $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
 448     }
 449
 450     ##endif
 451     if (ref $macro) {
 452       $clause .= $macro->[1];
 453     } else {
 454       $clause .= "#endif\n";
 455     }
 456   }
 457   return $clause;
 458 }
 459
 460 =pod
 461
 462 XXX document me
 463
 464 =cut
 465
 466 sub match_clause {
 467   # $offset defined if we have checked an offset.
 468   my ($item, $offset, $indent) = @_;
 469   $indent = ' ' x ($indent || 4);
 470   my $body = '';
 471   my ($no, $yes, $either, $name, $inner_indent);
 472   if (ref $item eq 'ARRAY') {
 473     ($yes, $no) = @$item;
 474     $either = $yes || $no;
 475     confess "$item is $either expecting hashref in [0] || [1]"
 476       unless ref $either eq 'HASH';
 477     $name = $either->{name};
 478   } else {
 479     confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
 480       if $item->{utf8};
 481     $name = $item->{name};
 482     $inner_indent = $indent;
 483   }
 484
 485   $body .= memEQ_clause ($name, $offset, length $indent);
 486   if ($yes) {
 487     $body .= $indent . "  if (utf8) {\n";
 488   } elsif ($no) {
 489     $body .= $indent . "  if (!utf8) {\n";
 490   }
 491   if ($either) {
 492     $body .= return_clause ($either, 4 + length $indent);
 493     if ($yes and $no) {
 494       $body .= $indent . "  } else {\n";
 495       $body .= return_clause ($no, 4 + length $indent);
 496     }
 497     $body .= $indent . "  }\n";
 498   } else {
 499     $body .= return_clause ($item, 2 + length $indent);
 500   }
 501   $body .= $indent . "}\n";
 502 }
 503
 504 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
 505
 506 An internal function to generate a suitable C<switch> clause, called by
 507 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
 508 of C<C_constant>, and must all have the names of the same length, given by
 509 I<NAMELEN> (This is not checked).  I<ITEMHASH> is a reference to a hash,
 510 keyed by name, values being the hashrefs in the I<ITEM> list.
 511 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
 512 are not in the list of I<ITEM>s without causing problems).
 513
 514 =cut
 515
 516 sub switch_clause {
 517   my ($indent, $comment, $namelen, $items, @items) = @_;
 518   $indent = ' ' x ($indent || 2);
 519
 520   my @names = sort map {$_->{name}} @items;
 521   my $leader = $indent . '/* ';
 522   my $follower = ' ' x length $leader;
 523   my $body = $indent . "/* Names all of length $namelen.  */\n";
 524   if ($comment) {
 525     $body = wrap ($leader, $follower, $comment) . "\n";
 526     $leader = $follower;
 527   }
 528   my @safe_names = @names;
 529   foreach (@safe_names) {
 530     confess sprintf "Name '$_' is length %d, not $namelen", length
 531       unless length == $namelen;
 532     # Argh. 5.6.1
 533     # next unless tr/A-Za-z0-9_//c;
 534     next if tr/A-Za-z0-9_// == length;
 535     $_ = '"' . perl_stringify ($_) . '"';
 536     # Ensure that the enclosing C comment doesn't end
 537     # by turning */  into *" . "/
 538     s!\*\/!\*"."/!gs;
 539     # gcc -Wall doesn't like finding /* inside a comment
 540     s!\/\*!/"."\*!gs;
 541   }
 542   $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
 543   # Figure out what to switch on.
 544   # (RMS, Spread of jump table, Position, Hashref)
 545   my @best = (1e38, ~0);
 546   # Prefer the last character over the others. (As it lets us shortern the
 547   # memEQ clause at no cost).
 548   foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
 549     my ($min, $max) = (~0, 0);
 550     my %spread;
 551     if ($is_perl56) {
 552       # Need proper Unicode preserving hash keys for bytes in range 128-255
 553       # here too, for some reason. grr 5.6.1 yet again.
 554       tie %spread, 'ExtUtils::Constant::Aaargh56Hash';
 555     }
 556     foreach (@names) {
 557       my $char = substr $_, $i, 1;
 558       my $ord = ord $char;
 559       confess "char $ord is out of range" if $ord > 255;
 560       $max = $ord if $ord > $max;
 561       $min = $ord if $ord < $min;
 562       push @{$spread{$char}}, $_;
 563       # warn "$_ $char";
 564     }
 565     # I'm going to pick the character to split on that minimises the root
 566     # mean square of the number of names in each case. Normally this should
 567     # be the one with the most keys, but it may pick a 7 where the 8 has
 568     # one long linear search. I'm not sure if RMS or just sum of squares is
 569     # actually better.
 570     # $max and $min are for the tie-breaker if the root mean squares match.
 571     # Assuming that the compiler may be building a jump table for the
 572     # switch() then try to minimise the size of that jump table.
 573     # Finally use < not <= so that if it still ties the earliest part of
 574     # the string wins. Because if that passes but the memEQ fails, it may
 575     # only need the start of the string to bin the choice.
 576     # I think. But I'm micro-optimising. :-)
 577     # OK. Trump that. Now favour the last character of the string, before the
 578     # rest.
 579     my $ss;
 580     $ss += @$_ * @$_ foreach values %spread;
 581     my $rms = sqrt ($ss / keys %spread);
 582     if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
 583       @best = ($rms, $max - $min, $i, \%spread);
 584     }
 585   }
 586   confess "Internal error. Failed to pick a switch point for @names"
 587     unless defined $best[2];
 588   # use Data::Dumper; print Dumper (@best);
 589   my ($offset, $best) = @best[2,3];
 590   $body .= $indent . "/* Offset $offset gives the best switch position.  */\n";
 591
 592   my $do_front_chop = $offset == 0 && $namelen > 2;
 593   if ($do_front_chop) {
 594     $body .= $indent . "switch (*name++) {\n";
 595   } else {
 596     $body .= $indent . "switch (name[$offset]) {\n";
 597   }
 598   foreach my $char (sort keys %$best) {
 599     confess sprintf "'$char' is %d bytes long, not 1", length $char
 600       if length ($char) != 1;
 601     confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255;
 602     $body .= $indent . "case '" . C_stringify ($char) . "':\n";
 603     foreach my $name (sort @{$best->{$char}}) {
 604       my $thisone = $items->{$name};
 605       # warn "You are here";
 606       if ($do_front_chop) {
 607         $body .= match_clause ($thisone, \$char, 2 + length $indent);
 608       } else {
 609         $body .= match_clause ($thisone, $offset, 2 + length $indent);
 610       }
 611     }
 612     $body .= $indent . "  break;\n";
 613   }
 614   $body .= $indent . "}\n";
 615   return $body;
 616 }
 617
 618 =item params WHAT
 619
 620 An internal function. I<WHAT> should be a hashref of types the constant
 621 function will return. I<params> returns a hashref keyed IV NV PV SV to show
 622 which combination of pointers will be needed in the C argument list.
 623
 624 =cut
 625
 626 sub params {
 627   my $what = shift;
 628   foreach (sort keys %$what) {
 629     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 630   }
 631   my $params = {};
 632   $params->{''} = 1 if $what->{''};
 633   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
 634   $params->{NV} = 1 if $what->{NV};
 635   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
 636   $params->{SV} = 1 if $what->{SV};
 637   return $params;
 638 }
 639
 640 =item dump_names
 641
 642 dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
 643
 644 An internal function to generate the embedded perl code that will regenerate
 645 the constant subroutines.  I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the
 646 same as for C_constant.  I<INDENT> is treated as number of spaces to indent
 647 by.  I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
 648 recognised.  If the value is true a C<$types> is always declared in the perl
 649 code generated, if defined and false never declared, and if undefined C<$types>
 650 is only declared if the values in I<TYPES> as passed in cannot be inferred from
 651 I<DEFAULT_TYPES> and the I<ITEM>s.
 652
 653 =cut
 654
 655 sub dump_names {
 656   my ($default_type, $what, $indent, $options, @items) = @_;
 657   my $declare_types = $options->{declare_types};
 658   $indent = ' ' x ($indent || 0);
 659
 660   my $result;
 661   my (@simple, @complex, %used_types);
 662   foreach (@items) {
 663     my $type;
 664     if (ref $_) {
 665       $type = $_->{type} || $default_type;
 666       if ($_->{utf8}) {
 667         # For simplicity always skip the bytes case, and reconstitute this entry
 668         # from its utf8 twin.
 669         next if $_->{utf8} eq 'no';
 670         # Copy the hashref, as we don't want to mess with the caller's hashref.
 671         $_ = {%$_};
 672         unless ($is_perl56) {
 673           utf8::decode ($_->{name});
 674         } else {
 675           $_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
 676         }
 677         delete $_->{utf8};
 678       }
 679     } else {
 680       $_ = {name=>$_};
 681       $type = $default_type;
 682     }
 683     $used_types{$type}++;
 684     if ($type eq $default_type
 685         # grr 5.6.1
 686         and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
 687         and !defined ($_->{macro}) and !defined ($_->{value})
 688         and !defined ($_->{default}) and !defined ($_->{pre})
 689         and !defined ($_->{post}) and !defined ($_->{def_pre})
 690         and !defined ($_->{def_post})) {
 691       # It's the default type, and the name consists only of A-Za-z0-9_
 692       push @simple, $_->{name};
 693     } else {
 694       push @complex, $_;
 695     }
 696   }
 697
 698   if (!defined $declare_types) {
 699     # Do they pass in any types we weren't already using?
 700     foreach (keys %$what) {
 701       next if $used_types{$_};
 702       $declare_types++; # Found one in $what that wasn't used.
 703       last; # And one is enough to terminate this loop
 704     }
 705   }
 706   if ($declare_types) {
 707     $result = $indent . 'my $types = {map {($_, 1)} qw('
 708       . join (" ", sort keys %$what) . ")};\n";
 709   }
 710   $result .= wrap ($indent . "my \@names = (qw(",
 711                    $indent . "               ", join (" ", sort @simple) . ")");
 712   if (@complex) {
 713     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
 714       my $name = perl_stringify $item->{name};
 715       my $line = ",\n$indent            {name=>\"$name\"";
 716       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
 717       foreach my $thing (qw (macro value default pre post def_pre def_post)) {
 718         my $value = $item->{$thing};
 719         if (defined $value) {
 720           if (ref $value) {
 721             $line .= ", $thing=>[\""
 722               . join ('", "', map {perl_stringify $_} @$value) . '"]';
 723           } else {
 724             $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
 725           }
 726         }
 727       }
 728       $line .= "}";
 729       # Ensure that the enclosing C comment doesn't end
 730       # by turning */  into *" . "/
 731       $line =~ s!\*\/!\*" . "/!gs;
 732       # gcc -Wall doesn't like finding /* inside a comment
 733       $line =~ s!\/\*!/" . "\*!gs;
 734       $result .= $line;
 735     }
 736   }
 737   $result .= ");\n";
 738
 739   $result;
 740 }
 741
 742
 743 =item dogfood
 744
 745 dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 746
 747 An internal function to generate the embedded perl code that will regenerate
 748 the constant subroutines.  Parameters are the same as for C_constant.
 749
 750 =cut
 751
 752 sub dogfood {
 753   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 754     = @_;
 755   my $result = <<"EOT";
 756   /* When generated this function returned values for the list of names given
 757      in this section of perl code.  Rather than manually editing these functions
 758      to add or remove constants, which would result in this comment and section
 759      of code becoming inaccurate, we recommend that you edit this section of
 760      code, and use it to regenerate a new set of constant functions which you
 761      then use to replace the originals.
 762
 763      Regenerate these constant functions by feeding this entire source file to
 764      perl -x
 765
 766 #!$^X -w
 767 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 768
 769 EOT
 770   $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
 771   $result .= <<'EOT';
 772
 773 print constant_types(); # macro defs
 774 EOT
 775   $package = perl_stringify($package);
 776   $result .=
 777     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 778   # The form of the indent parameter isn't defined. (Yet)
 779   if (defined $indent) {
 780     require Data::Dumper;
 781     $Data::Dumper::Terse=1;
 782     $Data::Dumper::Terse=1; # Not used once. :-)
 783     chomp ($indent = Data::Dumper::Dumper ($indent));
 784     $result .= $indent;
 785   } else {
 786     $result .= 'undef';
 787   }
 788   $result .= ", $breakout" . ', @names) ) {
 789     print $_, "\n"; # C constant subs
 790 }
 791 print "#### XS Section:\n";
 792 print XS_constant ("' . $package . '", $types);
 793 __END__
 794    */
 795
 796 ';
 797
 798   $result;
 799 }
 800
 801 =item C_constant
 802
 803 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 804
 805 A function that returns a B<list> of C subroutine definitions that return
 806 the value and type of constants when passed the name by the XS wrapper.
 807 I<ITEM...> gives a list of constant names. Each can either be a string,
 808 which is taken as a C macro name, or a reference to a hash with the following
 809 keys
 810
 811 =over 8
 812
 813 =item name
 814
 815 The name of the constant, as seen by the perl code.
 816
 817 =item type
 818
 819 The type of the constant (I<IV>, I<NV> etc)
 820
 821 =item value
 822
 823 A C expression for the value of the constant, or a list of C expressions if
 824 the type is aggregate. This defaults to the I<name> if not given.
 825
 826 =item macro
 827
 828 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
 829 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
 830 array is passed then the first element is used in place of the C<#ifdef>
 831 line, and the second element in place of the C<#endif>. This allows
 832 pre-processor constructions such as
 833
 834     #if defined (foo)
 835     #if !defined (bar)
 836     ...
 837     #endif
 838     #endif
 839
 840 to be used to determine if a constant is to be defined.
 841
 842 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
 843 test is omitted.
 844
 845 =item default
 846
 847 Default value to use (instead of C<croak>ing with "your vendor has not
 848 defined...") to return if the macro isn't defined. Specify a reference to
 849 an array with type followed by value(s).
 850
 851 =item pre
 852
 853 C code to use before the assignment of the value of the constant. This allows
 854 you to use temporary variables to extract a value from part of a C<struct>
 855 and return this as I<value>. This C code is places at the start of a block,
 856 so you can declare variables in it.
 857
 858 =item post
 859
 860 C code to place between the assignment of value (to a temporary) and the
 861 return from the function. This allows you to clear up anything in I<pre>.
 862 Rarely needed.
 863
 864 =item def_pre
 865 =item def_post
 866
 867 Equivalents of I<pre> and I<post> for the default value.
 868
 869 =item utf8
 870
 871 Generated internally. Is zero or undefined if name is 7 bit ASCII,
 872 "no" if the name is 8 bit (and so should only match if SvUTF8() is false),
 873 "yes" if the name is utf8 encoded.
 874
 875 The internals automatically clone any name with characters 128-255 but none
 876 256+ (ie one that could be either in bytes or utf8) into a second entry
 877 which is utf8 encoded.
 878
 879 =back
 880
 881 I<PACKAGE> is the name of the package, and is only used in comments inside the
 882 generated C code.
 883
 884 The next 5 arguments can safely be given as C<undef>, and are mainly used
 885 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
 886
 887 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
 888 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
 889 separated list of types that the C subroutine C<constant> will generate or as
 890 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
 891 present, as will any types given in the list of I<ITEM>s. The resultant list
 892 should be the same list of types that C<XS_constant> is given. [Otherwise
 893 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
 894 constant function. I<INDENT> is currently unused and ignored. In future it may
 895 be used to pass in information used to change the C indentation style used.]
 896 The best way to maintain consistency is to pass in a hash reference and let
 897 this function update it.
 898
 899 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated.  If there
 900 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
 901 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
 902 example C<constant_5> for names 5 characters long.  The default I<BREAKOUT> is
 903 3.  A single C<ITEM> is always inlined.
 904
 905 =cut
 906
 907 # The parameter now BREAKOUT was previously documented as:
 908 #
 909 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
 910 # this length, and that the constant name passed in by perl is checked and
 911 # also of this length. It is used during recursion, and should be C<undef>
 912 # unless the caller has checked all the lengths during code generation, and
 913 # the generated subroutine is only to be called with a name of this length.
 914 #
 915 # As you can see it now performs this function during recursion by being a
 916 # scalar reference.
 917
 918 sub C_constant {
 919   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 920     = @_;
 921   $package ||= 'Foo';
 922   $subname ||= 'constant';
 923   # I'm not using this. But a hashref could be used for full formatting without
 924   # breaking this API
 925   # $indent ||= 0;
 926
 927   my ($namelen, $items);
 928   if (ref $breakout) {
 929     # We are called recursively. We trust @items to be normalised, $what to
 930     # be a hashref, and pinch %$items from our parent to save recalculation.
 931     ($namelen, $items) = @$breakout;
 932   } else {
 933     if ($is_perl56) {
 934       # Need proper Unicode preserving hash keys.
 935       $items = {};
 936       tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
 937     }
 938     $breakout ||= 3;
 939     $default_type ||= 'IV';
 940     if (!ref $what) {
 941       # Convert line of the form IV,UV,NV to hash
 942       $what = {map {$_ => 1} split /,\s*/, ($what || '')};
 943       # Figure out what types we're dealing with, and assign all unknowns to the
 944       # default type
 945     }
 946     my @new_items;
 947     foreach my $orig (@items) {
 948       my ($name, $item);
 949       if (ref $orig) {
 950         # Make a copy which is a normalised version of the ref passed in.
 951         $name = $orig->{name};
 952         my ($type, $macro, $value) = @$orig{qw (type macro value)};
 953         $type ||= $default_type;
 954         $what->{$type} = 1;
 955         $item = {name=>$name, type=>$type};
 956
 957         undef $macro if defined $macro and $macro eq $name;
 958         $item->{macro} = $macro if defined $macro;
 959         undef $value if defined $value and $value eq $name;
 960         $item->{value} = $value if defined $value;
 961         foreach my $key (qw(default pre post def_pre def_post)) {
 962           my $value = $orig->{$key};
 963           $item->{$key} = $value if defined $value;
 964           # warn "$key $value";
 965         }
 966       } else {
 967         $name = $orig;
 968         $item = {name=>$name, type=>$default_type};
 969         $what->{$default_type} = 1;
 970       }
 971       warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}};
 972       # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c
 973       # doesn't work. Upgrade to 5.8
 974       # if ($name !~ tr/\0-\177//c || $] < 5.005_50) {
 975       if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50) {
 976         # No characters outside 7 bit ASCII.
 977         if (exists $items->{$name}) {
 978           die "Multiple definitions for macro $name";
 979         }
 980         $items->{$name} = $item;
 981       } else {
 982         # No characters outside 8 bit. This is hardest.
 983         if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
 984           confess "Unexpected ASCII definition for macro $name";
 985         }
 986         # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/;
 987         # if ($name !~ tr/\0-\377//c) {
 988         if ($name =~ tr/\0-\377// == length $name) {
 989 #          if ($] < 5.007) {
 990 #            $name = pack "C*", unpack "U*", $name;
 991 #          }
 992           $item->{utf8} = 'no';
 993           $items->{$name}[1] = $item;
 994           push @new_items, $item;
 995           # Copy item, to create the utf8 variant.
 996           $item = {%$item};
 997         }
 998         # Encode the name as utf8 bytes.
 999         unless ($is_perl56) {
1000           utf8::encode($name);
1001         } else {
1002 #          warn "Was >$name< " . length ${name};
1003           $name = pack 'C*', unpack 'C*', $name . pack 'U*';
1004 #          warn "Now '${name}' " . length ${name};
1005         }
1006         if ($items->{$name}[0]) {
1007           die "Multiple definitions for macro $name";
1008         }
1009         $item->{utf8} = 'yes';
1010         $item->{name} = $name;
1011         $items->{$name}[0] = $item;
1012         # We have need for the utf8 flag.
1013         $what->{''} = 1;
1014       }
1015       push @new_items, $item;
1016     }
1017     @items = @new_items;
1018     # use Data::Dumper; print Dumper @items;
1019   }
1020   my $params = params ($what);
1021
1022   my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
1023   $body .= ", STRLEN len" unless defined $namelen;
1024   $body .= ", int utf8" if $params->{''};
1025   $body .= ", IV *iv_return" if $params->{IV};
1026   $body .= ", NV *nv_return" if $params->{NV};
1027   $body .= ", const char **pv_return" if $params->{PV};
1028   $body .= ", SV **sv_return" if $params->{SV};
1029   $body .= ") {\n";
1030
1031   if (defined $namelen) {
1032     # We are a child subroutine. Print the simple description
1033     my $comment = 'When generated this function returned values for the list'
1034       . ' of names given here.  However, subsequent manual editing may have'
1035         . ' added or removed some.';
1036     $body .= switch_clause (2, $comment, $namelen, $items, @items);
1037   } else {
1038     # We are the top level.
1039     $body .= "  /* Initially switch on the length of the name.  */\n";
1040     $body .= dogfood ($package, $subname, $default_type, $what, $indent,
1041                       $breakout, @items);
1042     $body .= "  switch (len) {\n";
1043     # Need to group names of the same length
1044     my @by_length;
1045     foreach (@items) {
1046       push @{$by_length[length $_->{name}]}, $_;
1047     }
1048     foreach my $i (0 .. $#by_length) {
1049       next unless $by_length[$i];       # None of this length
1050       $body .= "  case $i:\n";
1051       if (@{$by_length[$i]} == 1) {
1052         my $only_thing = $by_length[$i]->[0];
1053         if ($only_thing->{utf8}) {
1054           if ($only_thing->{utf8} eq 'yes') {
1055             # With utf8 on flag item is passed in element 0
1056             $body .= match_clause ([$only_thing]);
1057           } else {
1058             # With utf8 off flag item is passed in element 1
1059             $body .= match_clause ([undef, $only_thing]);
1060           }
1061         } else {
1062           $body .= match_clause ($only_thing);
1063         }
1064       } elsif (@{$by_length[$i]} < $breakout) {
1065         $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
1066       } else {
1067         # Only use the minimal set of parameters actually needed by the types
1068         # of the names of this length.
1069         my $what = {};
1070         foreach (@{$by_length[$i]}) {
1071           $what->{$_->{type}} = 1;
1072           $what->{''} = 1 if $_->{utf8};
1073         }
1074         $params = params ($what);
1075         push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
1076                                 $indent, [$i, $items], @{$by_length[$i]});
1077         $body .= "    return ${subname}_$i (aTHX_ name";
1078         $body .= ", utf8" if $params->{''};
1079         $body .= ", iv_return" if $params->{IV};
1080         $body .= ", nv_return" if $params->{NV};
1081         $body .= ", pv_return" if $params->{PV};
1082         $body .= ", sv_return" if $params->{SV};
1083         $body .= ");\n";
1084       }
1085       $body .= "    break;\n";
1086     }
1087     $body .= "  }\n";
1088   }
1089   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
1090   return (@subs, $body);
1091 }
1092
1093 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
1094
1095 A function to generate the XS code to implement the perl subroutine
1096 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
1097 This XS code is a wrapper around a C subroutine usually generated by
1098 C<C_constant>, and usually named C<constant>.
1099
1100 I<TYPES> should be given either as a comma separated list of types that the
1101 C subroutine C<constant> will generate or as a reference to a hash. It should
1102 be the same list of types as C<C_constant> was given.
1103 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
1104 the number of parameters passed to the C function C<constant>]
1105
1106 You can call the perl visible subroutine something other than C<constant> if
1107 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
1108 the name of the perl visible subroutine, unless you give the parameter
1109 I<C_SUBNAME>.
1110
1111 =cut
1112
1113 sub XS_constant {
1114   my $package = shift;
1115   my $what = shift;
1116   my $subname = shift;
1117   my $C_subname = shift;
1118   $subname ||= 'constant';
1119   $C_subname ||= $subname;
1120
1121   if (!ref $what) {
1122     # Convert line of the form IV,UV,NV to hash
1123     $what = {map {$_ => 1} split /,\s*/, ($what)};
1124   }
1125   my $params = params ($what);
1126   my $type;
1127
1128   my $xs = <<"EOT";
1129 void
1130 $subname(sv)
1131     PREINIT:
1132 #ifdef dXSTARG
1133         dXSTARG; /* Faster if we have it.  */
1134 #else
1135         dTARGET;
1136 #endif
1137         STRLEN          len;
1138         int             type;
1139 EOT
1140
1141   if ($params->{IV}) {
1142     $xs .= "    IV              iv;\n";
1143   } else {
1144     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
1145   }
1146   if ($params->{NV}) {
1147     $xs .= "    NV              nv;\n";
1148   } else {
1149     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
1150   }
1151   if ($params->{PV}) {
1152     $xs .= "    const char      *pv;\n";
1153   } else {
1154     $xs .=
1155       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
1156   }
1157
1158   $xs .= << 'EOT';
1159     INPUT:
1160         SV *            sv;
1161         const char *    s = SvPV(sv, len);
1162 EOT
1163   if ($params->{''}) {
1164   $xs .= << 'EOT';
1165     INPUT:
1166         int             utf8 = SvUTF8(sv);
1167 EOT
1168   }
1169   $xs .= << 'EOT';
1170     PPCODE:
1171 EOT
1172
1173   if ($params->{IV} xor $params->{NV}) {
1174     $xs .= << "EOT";
1175         /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
1176            if you need to return both NVs and IVs */
1177 EOT
1178   }
1179   $xs .= "      type = $C_subname(aTHX_ s, len";
1180   $xs .= ', utf8' if $params->{''};
1181   $xs .= ', &iv' if $params->{IV};
1182   $xs .= ', &nv' if $params->{NV};
1183   $xs .= ', &pv' if $params->{PV};
1184   $xs .= ', &sv' if $params->{SV};
1185   $xs .= ");\n";
1186
1187   $xs .= << "EOT";
1188       /* Return 1 or 2 items. First is error message, or undef if no error.
1189            Second, if present, is found value */
1190         switch (type) {
1191         case PERL_constant_NOTFOUND:
1192           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
1193           PUSHs(sv);
1194           break;
1195         case PERL_constant_NOTDEF:
1196           sv = sv_2mortal(newSVpvf(
1197             "Your vendor has not defined $package macro %s, used", s));
1198           PUSHs(sv);
1199           break;
1200 EOT
1201
1202   foreach $type (sort keys %XS_Constant) {
1203     # '' marks utf8 flag needed.
1204     next if $type eq '';
1205     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
1206       unless $what->{$type};
1207     $xs .= "        case PERL_constant_IS$type:\n";
1208     if (length $XS_Constant{$type}) {
1209       $xs .= << "EOT";
1210           EXTEND(SP, 1);
1211           PUSHs(&PL_sv_undef);
1212           $XS_Constant{$type};
1213 EOT
1214     } else {
1215       # Do nothing. return (), which will be correctly interpreted as
1216       # (undef, undef)
1217     }
1218     $xs .= "          break;\n";
1219     unless ($what->{$type}) {
1220       chop $xs; # Yes, another need for chop not chomp.
1221       $xs .= " */\n";
1222     }
1223   }
1224   $xs .= << "EOT";
1225         default:
1226           sv = sv_2mortal(newSVpvf(
1227             "Unexpected return type %d while processing $package macro %s, used",
1228                type, s));
1229           PUSHs(sv);
1230         }
1231 EOT
1232
1233   return $xs;
1234 }
1235
1236
1237 =item autoload PACKAGE, VERSION, AUTOLOADER
1238
1239 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
1240 I<VERSION> is the perl version the code should be backwards compatible with.
1241 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
1242 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
1243 names that the constant() routine doesn't recognise.
1244
1245 =cut
1246
1247 # ' # Grr. syntax highlighters that don't grok pod.
1248
1249 sub autoload {
1250   my ($module, $compat_version, $autoloader) = @_;
1251   $compat_version ||= $];
1252   croak "Can't maintain compatibility back as far as version $compat_version"
1253     if $compat_version < 5;
1254   my $func = "sub AUTOLOAD {\n"
1255   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
1256   . "    # XS function.";
1257   $func .= "  If a constant is not found then control is passed\n"
1258   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
1259
1260
1261   $func .= "\n\n"
1262   . "    my \$constname;\n";
1263   $func .=
1264     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
1265
1266   $func .= <<"EOT";
1267     (\$constname = \$AUTOLOAD) =~ s/.*:://;
1268     croak "&${module}::constant not defined" if \$constname eq 'constant';
1269     my (\$error, \$val) = constant(\$constname);
1270 EOT
1271
1272   if ($autoloader) {
1273     $func .= <<'EOT';
1274     if ($error) {
1275         if ($error =~  /is not a valid/) {
1276             $AutoLoader::AUTOLOAD = $AUTOLOAD;
1277             goto &AutoLoader::AUTOLOAD;
1278         } else {
1279             croak $error;
1280         }
1281     }
1282 EOT
1283   } else {
1284     $func .=
1285       "    if (\$error) { croak \$error; }\n";
1286   }
1287
1288   $func .= <<'END';
1289     {
1290         no strict 'refs';
1291         # Fixed between 5.005_53 and 5.005_61
1292 #XXX    if ($] >= 5.00561) {
1293 #XXX        *$AUTOLOAD = sub () { $val };
1294 #XXX    }
1295 #XXX    else {
1296             *$AUTOLOAD = sub { $val };
1297 #XXX    }
1298     }
1299     goto &$AUTOLOAD;
1300 }
1301
1302 END
1303
1304   return $func;
1305 }
1306
1307
1308 =item WriteMakefileSnippet
1309
1310 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
1311
1312 A function to generate perl code for Makefile.PL that will regenerate
1313 the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
1314 with the addition of C<INDENT> to specify the number of leading spaces
1315 (default 2).
1316
1317 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
1318 C<XS_FILE> are recognised.
1319
1320 =cut
1321
1322 sub WriteMakefileSnippet {
1323   my %args = @_;
1324   my $indent = $args{INDENT} || 2;
1325
1326   my $result = <<"EOT";
1327 ExtUtils::Constant::WriteConstants(
1328                                    NAME         => '$args{NAME}',
1329                                    NAMES        => \\\@names,
1330                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
1331 EOT
1332   foreach (qw (C_FILE XS_FILE)) {
1333     next unless exists $args{$_};
1334     $result .= sprintf "                                   %-12s => '%s',\n",
1335       $_, $args{$_};
1336   }
1337   $result .= <<'EOT';
1338                                 );
1339 EOT
1340
1341   $result =~ s/^/' 'x$indent/gem;
1342   return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
1343                            @{$args{NAMES}})
1344           . $result;
1345 }
1346
1347 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
1348
1349 Writes a file of C code and a file of XS code which you should C<#include>
1350 and C<INCLUDE> in the C and XS sections respectively of your module's XS
1351 code.  You probably want to do this in your C<Makefile.PL>, so that you can
1352 easily edit the list of constants without touching the rest of your module.
1353 The attributes supported are
1354
1355 =over 4
1356
1357 =item NAME
1358
1359 Name of the module.  This must be specified
1360
1361 =item DEFAULT_TYPE
1362
1363 The default type for the constants.  If not specified C<IV> is assumed.
1364
1365 =item BREAKOUT_AT
1366
1367 The names of the constants are grouped by length.  Generate child subroutines
1368 for each group with this number or more names in.
1369
1370 =item NAMES
1371
1372 An array of constants' names, either scalars containing names, or hashrefs
1373 as detailed in L<"C_constant">.
1374
1375 =item C_FILE
1376
1377 The name of the file to write containing the C code.  The default is
1378 C<const-c.inc>.  The C<-> in the name ensures that the file can't be
1379 mistaken for anything related to a legitimate perl package name, and
1380 not naming the file C<.c> avoids having to override Makefile.PL's
1381 C<.xs> to C<.c> rules.
1382
1383 =item XS_FILE
1384
1385 The name of the file to write containing the XS code.  The default is
1386 C<const-xs.inc>.
1387
1388 =item SUBNAME
1389
1390 The perl visible name of the XS subroutine generated which will return the
1391 constants. The default is C<constant>.
1392
1393 =item C_SUBNAME
1394
1395 The name of the C subroutine generated which will return the constants.
1396 The default is I<SUBNAME>.  Child subroutines have C<_> and the name
1397 length appended, so constants with 10 character names would be in
1398 C<constant_10> with the default I<XS_SUBNAME>.
1399
1400 =back
1401
1402 =cut
1403
1404 sub WriteConstants {
1405   my %ARGS =
1406     ( # defaults
1407      C_FILE =>       'const-c.inc',
1408      XS_FILE =>      'const-xs.inc',
1409      SUBNAME =>      'constant',
1410      DEFAULT_TYPE => 'IV',
1411      @_);
1412
1413   $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1414
1415   croak "Module name not specified" unless length $ARGS{NAME};
1416
1417   open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1418   open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1419
1420   # As this subroutine is intended to make code that isn't edited, there's no
1421   # need for the user to specify any types that aren't found in the list of
1422   # names.
1423   my $types = {};
1424
1425   print $c_fh constant_types(); # macro defs
1426   print $c_fh "\n";
1427
1428   # indent is still undef. Until anyone implements indent style rules with it.
1429   foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1430                        $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1431     print $c_fh $_, "\n"; # C constant subs
1432   }
1433   print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1434                             $ARGS{C_SUBNAME});
1435
1436   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1437   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1438 }
1439
1440 package ExtUtils::Constant::Aaargh56Hash;
1441 # A support module (hack) to provide sane Unicode hash keys on 5.6.x perl
1442 use strict;
1443 require Tie::Hash if $ExtUtils::Constant::is_perl56;
1444 use vars '@ISA';
1445 @ISA = 'Tie::StdHash';
1446
1447 #my $a;
1448 # Storing the values as concatenated BER encoded numbers is actually going to
1449 # be terser than using UTF8 :-)
1450 # And the tests are slightly faster. Ops are bad, m'kay
1451 sub to_key {pack "w*", unpack "U*", ($_[0] . pack "U*")};
1452 sub from_key {defined $_[0] ? pack "U*", unpack 'w*', $_[0] : undef};
1453
1454 sub STORE    { $_[0]->{to_key($_[1])} = $_[2] }
1455 sub FETCH    { $_[0]->{to_key($_[1])} }
1456 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; from_key (each %{$_[0]}) }
1457 sub NEXTKEY  { from_key (each %{$_[0]}) }
1458 sub EXISTS   { exists $_[0]->{to_key($_[1])} }
1459 sub DELETE   { delete $_[0]->{to_key($_[1])} }
1460
1461 #END {warn "$a accesses";}
1462 1;
1463 __END__
1464
1465 =back
1466
1467 =head1 AUTHOR
1468
1469 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
1470 others
1471
1472 =cut