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