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.11';
   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 Carp;
  98
  99 use Exporter;
 100 use Text::Wrap;
 101 $Text::Wrap::huge = 'overflow';
 102 $Text::Wrap::columns = 80;
 103
 104 @ISA = 'Exporter';
 105
 106 %EXPORT_TAGS = ( 'all' => [ qw(
 107         XS_constant constant_types return_clause memEQ_clause C_stringify
 108         C_constant autoload WriteConstants WriteMakefileSnippet
 109 ) ] );
 110
 111 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 112
 113 %XS_Constant = (
 114                 IV    => 'PUSHi(iv)',
 115                 UV    => 'PUSHu((UV)iv)',
 116                 NV    => 'PUSHn(nv)',
 117                 PV    => 'PUSHp(pv, strlen(pv))',
 118                 PVN   => 'PUSHp(pv, iv)',
 119                 SV    => 'PUSHs(sv)',
 120                 YES   => 'PUSHs(&PL_sv_yes)',
 121                 NO    => 'PUSHs(&PL_sv_no)',
 122                 UNDEF => '',    # implicit undef
 123 );
 124
 125 %XS_TypeSet = (
 126                 IV    => '*iv_return =',
 127                 UV    => '*iv_return = (IV)',
 128                 NV    => '*nv_return =',
 129                 PV    => '*pv_return =',
 130                 PVN   => ['*pv_return =', '*iv_return = (IV)'],
 131                 SV    => '*sv_return = ',
 132                 YES   => undef,
 133                 NO    => undef,
 134                 UNDEF => undef,
 135 );
 136
 137
 138 =item C_stringify NAME
 139
 140 A function which returns a correctly \ escaped version of the string passed
 141 suitable for C's "" or ''.  It will also be valid as a perl "" string.
 142
 143 =cut
 144
 145 # Hopefully make a happy C identifier.
 146 sub C_stringify {
 147   local $_ = shift;
 148   return unless defined $_;
 149   s/\\/\\\\/g;
 150   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 151   s/\n/\\n/g;           # Ensure newlines don't end up in octal
 152   s/\r/\\r/g;
 153   s/\t/\\t/g;
 154   s/\f/\\f/g;
 155   s/\a/\\a/g;
 156   unless ($] < 5.006) {
 157     # This will elict a warning on 5.005_03 about [: :] being reserved unless
 158     # I cheat
 159     my $cheat = '([[:^print:]])';
 160     s/$cheat/sprintf "\\%03o", ord $1/ge;
 161   } else {
 162     require POSIX;
 163     s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
 164   }
 165   $_;
 166 }
 167
 168 =item constant_types
 169
 170 A function returning a single scalar with C<#define> definitions for the
 171 constants used internally between the generated C and XS functions.
 172
 173 =cut
 174
 175 sub constant_types () {
 176   my $start = 1;
 177   my @lines;
 178   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
 179   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
 180   foreach (sort keys %XS_Constant) {
 181     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
 182   }
 183   push @lines, << 'EOT';
 184
 185 #ifndef NVTYPE
 186 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 187 #endif
 188 #ifndef aTHX_
 189 #define aTHX_ /* 5.6 or later define this for threading support.  */
 190 #endif
 191 #ifndef pTHX_
 192 #define pTHX_ /* 5.6 or later define this for threading support.  */
 193 #endif
 194 EOT
 195
 196   return join '', @lines;
 197 }
 198
 199 =item memEQ_clause NAME, CHECKED_AT, INDENT
 200
 201 A function to return a suitable C C<if> statement to check whether I<NAME>
 202 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
 203 is used to avoid C<memEQ> for short names, or to generate a comment to
 204 highlight the position of the character in the C<switch> statement.
 205
 206 =cut
 207
 208 sub memEQ_clause {
 209 #    if (memEQ(name, "thingy", 6)) {
 210   # Which could actually be a character comparison or even ""
 211   my ($name, $checked_at, $indent) = @_;
 212   $indent = ' ' x ($indent || 4);
 213   my $len = length $name;
 214
 215   if ($len < 2) {
 216     return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
 217     # We didn't switch, drop through to the code for the 2 character string
 218     $checked_at = 1;
 219   }
 220   if ($len < 3 and defined $checked_at) {
 221     my $check;
 222     if ($checked_at == 1) {
 223       $check = 0;
 224     } elsif ($checked_at == 0) {
 225       $check = 1;
 226     }
 227     if (defined $check) {
 228       my $char = C_stringify (substr $name, $check, 1);
 229       return $indent . "if (name[$check] == '$char') {\n";
 230     }
 231   }
 232   # Could optimise a memEQ on 3 to 2 single character checks here
 233   $name = C_stringify ($name);
 234   my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
 235     $body .= $indent . "/*               ". (' ' x $checked_at) . '^'
 236       . (' ' x ($len - $checked_at + length $len)) . "    */\n"
 237         if defined $checked_at;
 238   return $body;
 239 }
 240
 241 =item assign INDENT, TYPE, PRE, POST, VALUE...
 242
 243 A function to return a suitable assignment clause. If I<TYPE> is aggregate
 244 (eg I<PVN> expects both pointer and length) then there should be multiple
 245 I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
 246 of C code to preceed and follow the assignment. I<PRE> will be at the start
 247 of a block, so variables may be defined in it.
 248
 249 =cut
 250
 251 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
 252
 253 sub assign {
 254   my $indent = shift;
 255   my $type = shift;
 256   my $pre = shift;
 257   my $post = shift || '';
 258   my $clause;
 259   my $close;
 260   if ($pre) {
 261     chomp $pre;
 262     $clause = $indent . "{\n$pre";
 263     $clause .= ";" unless $pre =~ /;$/;
 264     $clause .= "\n";
 265     $close = "$indent}\n";
 266     $indent .= "  ";
 267   }
 268   die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
 269   my $typeset = $XS_TypeSet{$type};
 270   if (ref $typeset) {
 271     die "Type $type is aggregate, but only single value given"
 272       if @_ == 1;
 273     foreach (0 .. $#$typeset) {
 274       $clause .= $indent . "$typeset->[$_] $_[$_];\n";
 275     }
 276   } elsif (defined $typeset) {
 277     die "Aggregate value given for type $type"
 278       if @_ > 1;
 279     $clause .= $indent . "$typeset $_[0];\n";
 280   }
 281   chomp $post;
 282   if (length $post) {
 283     $clause .= "$post";
 284     $clause .= ";" unless $post =~ /;$/;
 285     $clause .= "\n";
 286   }
 287   $clause .= "${indent}return PERL_constant_IS$type;\n";
 288   $clause .= $close if $close;
 289   return $clause;
 290 }
 291
 292 =item return_clause
 293
 294 return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
 295
 296 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
 297 I<VALUE> when not defined.  If I<TYPE> is aggregate (eg I<PVN> expects both
 298 pointer and length) then I<VALUE> should be a reference to an array of
 299 values in the order expected by the type.  C<C_constant> will always call
 300 this function with I<MACRO> defined, defaulting to the constant's name.
 301 I<DEFAULT> if defined is an array reference giving default type and
 302 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
 303 The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
 304 and follow the value, and the default value.
 305
 306 =cut
 307
 308 sub return_clause ($$$$$$$$$) {
 309 ##ifdef thingy
 310 #      *iv_return = thingy;
 311 #      return PERL_constant_ISIV;
 312 ##else
 313 #      return PERL_constant_NOTDEF;
 314 ##endif
 315   my ($value, $type, $indent, $macro, $default, $pre, $post,
 316       $def_pre, $def_post) = @_;
 317   $macro = $value unless defined $macro;
 318   $indent = ' ' x ($indent || 6);
 319
 320   my $clause;
 321
 322   ##ifdef thingy
 323   if (ref $macro) {
 324     $clause = $macro->[0];
 325   } elsif ($macro ne "1") {
 326     $clause = "#ifdef $macro\n";
 327   }
 328
 329   #      *iv_return = thingy;
 330   #      return PERL_constant_ISIV;
 331   $clause .= assign ($indent, $type, $pre, $post,
 332                      ref $value ? @$value : $value);
 333
 334   if (ref $macro or $macro ne "1") {
 335     ##else
 336     $clause .= "#else\n";
 337
 338     #      return PERL_constant_NOTDEF;
 339     if (!defined $default) {
 340       $clause .= "${indent}return PERL_constant_NOTDEF;\n";
 341     } else {
 342       my @default = ref $default ? @$default : $default;
 343       $type = shift @default;
 344       $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
 345     }
 346
 347     ##endif
 348     if (ref $macro) {
 349       $clause .= $macro->[1];
 350     } else {
 351       $clause .= "#endif\n";
 352     }
 353   }
 354   return $clause
 355 }
 356
 357 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
 358
 359 An internal function to generate a suitable C<switch> clause, called by
 360 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
 361 of C<C_constant>, and must all have the names of the same length, given by
 362 I<NAMELEN> (This is not checked).  I<ITEMHASH> is a reference to a hash,
 363 keyed by name, values being the hashrefs in the I<ITEM> list.
 364 (No parameters are modified, and there can be keys in the I<ITEMHASH> that
 365 are not in the list of I<ITEM>s without causing problems).
 366
 367 =cut
 368
 369 sub switch_clause {
 370   my ($indent, $comment, $namelen, $items, @items) = @_;
 371   $indent = ' ' x ($indent || 2);
 372
 373   my @names = sort map {$_->{name}} @items;
 374   my $leader = $indent . '/* ';
 375   my $follower = ' ' x length $leader;
 376   my $body = $indent . "/* Names all of length $namelen.  */\n";
 377   if ($comment) {
 378     $body = wrap ($leader, $follower, $comment) . "\n";
 379     $leader = $follower;
 380   }
 381   $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
 382   # Figure out what to switch on.
 383   # (RMS, Spread of jump table, Position, Hashref)
 384   my @best = (1e38, ~0);
 385   foreach my $i (0 .. ($namelen - 1)) {
 386     my ($min, $max) = (~0, 0);
 387     my %spread;
 388     foreach (@names) {
 389       my $char = substr $_, $i, 1;
 390       my $ord = ord $char;
 391       $max = $ord if $ord > $max;
 392       $min = $ord if $ord < $min;
 393       push @{$spread{$char}}, $_;
 394       # warn "$_ $char";
 395     }
 396     # I'm going to pick the character to split on that minimises the root
 397     # mean square of the number of names in each case. Normally this should
 398     # be the one with the most keys, but it may pick a 7 where the 8 has
 399     # one long linear search. I'm not sure if RMS or just sum of squares is
 400     # actually better.
 401     # $max and $min are for the tie-breaker if the root mean squares match.
 402     # Assuming that the compiler may be building a jump table for the
 403     # switch() then try to minimise the size of that jump table.
 404     # Finally use < not <= so that if it still ties the earliest part of
 405     # the string wins. Because if that passes but the memEQ fails, it may
 406     # only need the start of the string to bin the choice.
 407     # I think. But I'm micro-optimising. :-)
 408     my $ss;
 409     $ss += @$_ * @$_ foreach values %spread;
 410     my $rms = sqrt ($ss / keys %spread);
 411     if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
 412       @best = ($rms, $max - $min, $i, \%spread);
 413     }
 414   }
 415   die "Internal error. Failed to pick a switch point for @names"
 416     unless defined $best[2];
 417   # use Data::Dumper; print Dumper (@best);
 418   my ($offset, $best) = @best[2,3];
 419   $body .= $indent . "/* Offset $offset gives the best switch position.  */\n";
 420   $body .= $indent . "switch (name[$offset]) {\n";
 421   foreach my $char (sort keys %$best) {
 422     $body .= $indent . "case '" . C_stringify ($char) . "':\n";
 423     foreach my $name (sort @{$best->{$char}}) {
 424       my $thisone = $items->{$name};
 425       my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
 426         = @$thisone{qw (value macro default pre post def_pre def_post)};
 427       $value = $name unless defined $value;
 428       $macro = $name unless defined $macro;
 429
 430       # We have checked this offset.
 431       $body .= memEQ_clause ($name, $offset, 2 + length $indent);
 432       $body .= return_clause ($value, $thisone->{type},  4 + length $indent,
 433                               $macro, $default, $pre, $post,
 434                               $def_pre, $def_post);
 435       $body .= $indent . "  }\n";
 436     }
 437     $body .= $indent . "  break;\n";
 438   }
 439   $body .= $indent . "}\n";
 440   return $body;
 441 }
 442
 443 =item params WHAT
 444
 445 An internal function. I<WHAT> should be a hashref of types the constant
 446 function will return. I<params> returns a hashref keyed IV NV PV SV to show
 447 which combination of pointers will be needed in the C argument list.
 448
 449 =cut
 450
 451 sub params {
 452   my $what = shift;
 453   foreach (sort keys %$what) {
 454     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 455   }
 456   my $params = {};
 457   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
 458   $params->{NV} = 1 if $what->{NV};
 459   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
 460   $params->{SV} = 1 if $what->{SV};
 461   return $params;
 462 }
 463
 464 =item dump_names
 465
 466 dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
 467
 468 An internal function to generate the embedded perl code that will regenerate
 469 the constant subroutines.  I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the
 470 same as for C_constant.  I<INDENT> is treated as number of spaces to indent
 471 by.  I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
 472 recognised.  If the value is true a C<$types> is always declared in the perl
 473 code generated, if defined and false never declared, and if undefined C<$types>
 474 is only declared if the values in I<TYPES> as passed in cannot be inferred from
 475 I<DEFAULT_TYPES> and the I<ITEM>s.
 476
 477 =cut
 478
 479 sub dump_names {
 480   my ($default_type, $what, $indent, $options, @items) = @_;
 481   my $declare_types = $options->{declare_types};
 482   $indent = ' ' x ($indent || 0);
 483
 484   my $result;
 485   my (@simple, @complex, %used_types);
 486   foreach (@items) {
 487     my $type;
 488     if (ref $_) {
 489       $type = $_->{type} || $default_type;
 490     } else {
 491       $_ = {name=>$_};
 492       $type = $default_type;
 493     }
 494     $used_types{$type}++;
 495     if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
 496         and !defined ($_->{macro}) and !defined ($_->{value})
 497         and !defined ($_->{default}) and !defined ($_->{pre})
 498         and !defined ($_->{post}) and !defined ($_->{def_pre})
 499         and !defined ($_->{def_post})) {
 500       # It's the default type, and the name consists only of A-Za-z0-9_
 501       push @simple, $_->{name};
 502     } else {
 503       push @complex, $_;
 504     }
 505   }
 506
 507   if (!defined $declare_types) {
 508     # Do they pass in any types we weren't already using?
 509     foreach (keys %$what) {
 510       next if $used_types{$_};
 511       $declare_types++; # Found one in $what that wasn't used.
 512       last; # And one is enough to terminate this loop
 513     }
 514   }
 515   if ($declare_types) {
 516     $result = $indent . 'my $types = {map {($_, 1)} qw('
 517       . join (" ", sort keys %$what) . ")};\n";
 518   }
 519   $result .= wrap ($indent . "my \@names = (qw(",
 520                    $indent . "               ", join (" ", sort @simple) . ")");
 521   if (@complex) {
 522     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
 523       my $name = C_stringify $item->{name};
 524       my $line = ",\n$indent            {name=>\"$name\"";
 525       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
 526       foreach my $thing (qw (macro value default pre post def_pre def_post)) {
 527         my $value = $item->{$thing};
 528         if (defined $value) {
 529           if (ref $value) {
 530             $line .= ", $thing=>[\""
 531               . join ('", "', map {C_stringify $_} @$value) . '"]';
 532           } else {
 533             $line .= ", $thing=>\"" . C_stringify($value) . "\"";
 534           }
 535         }
 536       }
 537       $line .= "}";
 538       # Ensure that the enclosing C comment doesn't end
 539       # by turning */  into *" . "/
 540       $line =~ s!\*\/!\*" . "/!gs;
 541       # gcc -Wall doesn't like finding /* inside a comment
 542       $line =~ s!\/\*!/" . "\*!gs;
 543       $result .= $line;
 544     }
 545   }
 546   $result .= ");\n";
 547
 548   $result;
 549 }
 550
 551
 552 =item dogfood
 553
 554 dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 555
 556 An internal function to generate the embedded perl code that will regenerate
 557 the constant subroutines.  Parameters are the same as for C_constant.
 558
 559 =cut
 560
 561 sub dogfood {
 562   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 563     = @_;
 564   my $result = <<"EOT";
 565   /* When generated this function returned values for the list of names given
 566      in this section of perl code.  Rather than manually editing these functions
 567      to add or remove constants, which would result in this comment and section
 568      of code becoming inaccurate, we recommend that you edit this section of
 569      code, and use it to regenerate a new set of constant functions which you
 570      then use to replace the originals.
 571
 572      Regenerate these constant functions by feeding this entire source file to
 573      perl -x
 574
 575 #!$^X -w
 576 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 577
 578 EOT
 579   $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
 580   $result .= <<'EOT';
 581
 582 print constant_types(); # macro defs
 583 EOT
 584   $package = C_stringify($package);
 585   $result .=
 586     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 587   # The form of the indent parameter isn't defined. (Yet)
 588   if (defined $indent) {
 589     require Data::Dumper;
 590     $Data::Dumper::Terse=1;
 591     $Data::Dumper::Terse=1; # Not used once. :-)
 592     chomp ($indent = Data::Dumper::Dumper ($indent));
 593     $result .= $indent;
 594   } else {
 595     $result .= 'undef';
 596   }
 597   $result .= ", $breakout" . ', @names) ) {
 598     print $_, "\n"; # C constant subs
 599 }
 600 print "#### XS Section:\n";
 601 print XS_constant ("' . $package . '", $types);
 602 __END__
 603    */
 604
 605 ';
 606
 607   $result;
 608 }
 609
 610 =item C_constant
 611
 612 C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 613
 614 A function that returns a B<list> of C subroutine definitions that return
 615 the value and type of constants when passed the name by the XS wrapper.
 616 I<ITEM...> gives a list of constant names. Each can either be a string,
 617 which is taken as a C macro name, or a reference to a hash with the following
 618 keys
 619
 620 =over 8
 621
 622 =item name
 623
 624 The name of the constant, as seen by the perl code.
 625
 626 =item type
 627
 628 The type of the constant (I<IV>, I<NV> etc)
 629
 630 =item value
 631
 632 A C expression for the value of the constant, or a list of C expressions if
 633 the type is aggregate. This defaults to the I<name> if not given.
 634
 635 =item macro
 636
 637 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
 638 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
 639 array is passed then the first element is used in place of the C<#ifdef>
 640 line, and the second element in place of the C<#endif>. This allows
 641 pre-processor constructions such as
 642
 643     #if defined (foo)
 644     #if !defined (bar)
 645     ...
 646     #endif
 647     #endif
 648
 649 to be used to determine if a constant is to be defined.
 650
 651 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
 652 test is omitted.
 653
 654 =item default
 655
 656 Default value to use (instead of C<croak>ing with "your vendor has not
 657 defined...") to return if the macro isn't defined. Specify a reference to
 658 an array with type followed by value(s).
 659
 660 =item pre
 661
 662 C code to use before the assignment of the value of the constant. This allows
 663 you to use temporary variables to extract a value from part of a C<struct>
 664 and return this as I<value>. This C code is places at the start of a block,
 665 so you can declare variables in it.
 666
 667 =item post
 668
 669 C code to place between the assignment of value (to a temporary) and the
 670 return from the function. This allows you to clear up anything in I<pre>.
 671 Rarely needed.
 672
 673 =item def_pre
 674 =item def_post
 675
 676 Equivalents of I<pre> and I<post> for the default value.
 677
 678 =back
 679
 680 I<PACKAGE> is the name of the package, and is only used in comments inside the
 681 generated C code.
 682
 683 The next 5 arguments can safely be given as C<undef>, and are mainly used
 684 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
 685
 686 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
 687 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
 688 separated list of types that the C subroutine C<constant> will generate or as
 689 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
 690 present, as will any types given in the list of I<ITEM>s. The resultant list
 691 should be the same list of types that C<XS_constant> is given. [Otherwise
 692 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
 693 constant function. I<INDENT> is currently unused and ignored. In future it may
 694 be used to pass in information used to change the C indentation style used.]
 695 The best way to maintain consistency is to pass in a hash reference and let
 696 this function update it.
 697
 698 I<BREAKOUT> governs when child functions of I<SUBNAME> are generated.  If there
 699 are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
 700 to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
 701 example C<constant_5> for names 5 characters long.  The default I<BREAKOUT> is
 702 3.  A single C<ITEM> is always inlined.
 703
 704 =cut
 705
 706 # The parameter now BREAKOUT was previously documented as:
 707 #
 708 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
 709 # this length, and that the constant name passed in by perl is checked and
 710 # also of this length. It is used during recursion, and should be C<undef>
 711 # unless the caller has checked all the lengths during code generation, and
 712 # the generated subroutine is only to be called with a name of this length.
 713 #
 714 # As you can see it now performs this function during recursion by being a
 715 # scalar reference.
 716
 717 sub C_constant {
 718   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
 719     = @_;
 720   $package ||= 'Foo';
 721   $subname ||= 'constant';
 722   # I'm not using this. But a hashref could be used for full formatting without
 723   # breaking this API
 724   # $indent ||= 0;
 725
 726   my ($namelen, $items);
 727   if (ref $breakout) {
 728     # We are called recursively. We trust @items to be normalised, $what to
 729     # be a hashref, and pinch %$items from our parent to save recalculation.
 730     ($namelen, $items) = @$breakout;
 731   } else {
 732     $breakout ||= 3;
 733     $default_type ||= 'IV';
 734     if (!ref $what) {
 735       # Convert line of the form IV,UV,NV to hash
 736       $what = {map {$_ => 1} split /,\s*/, ($what || '')};
 737       # Figure out what types we're dealing with, and assign all unknowns to the
 738       # default type
 739     }
 740     foreach (@items) {
 741       my $name;
 742       if (ref $_) {
 743         my $orig = $_;
 744         # Make a copy which is a normalised version of the ref passed in.
 745         $name = $_->{name};
 746         my ($type, $macro, $value) = @$_{qw (type macro value)};
 747         $type ||= $default_type;
 748         $what->{$type} = 1;
 749         $_ = {name=>$name, type=>$type};
 750
 751         undef $macro if defined $macro and $macro eq $name;
 752         $_->{macro} = $macro if defined $macro;
 753         undef $value if defined $value and $value eq $name;
 754         $_->{value} = $value if defined $value;
 755         foreach my $key (qw(default pre post def_pre def_post)) {
 756           my $value = $orig->{$key};
 757           $_->{$key} = $value if defined $value;
 758           # warn "$key $value";
 759         }
 760       } else {
 761         $name = $_;
 762         $_ = {name=>$_, type=>$default_type};
 763         $what->{$default_type} = 1;
 764       }
 765       warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
 766       if (exists $items->{$name}) {
 767         die "Multiple definitions for macro $name";
 768       }
 769       $items->{$name} = $_;
 770     }
 771   }
 772   my $params = params ($what);
 773
 774   my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
 775   $body .= ", STRLEN len" unless defined $namelen;
 776   $body .= ", IV *iv_return" if $params->{IV};
 777   $body .= ", NV *nv_return" if $params->{NV};
 778   $body .= ", const char **pv_return" if $params->{PV};
 779   $body .= ", SV **sv_return" if $params->{SV};
 780   $body .= ") {\n";
 781
 782   if (defined $namelen) {
 783     # We are a child subroutine. Print the simple description
 784     my $comment = 'When generated this function returned values for the list'
 785       . ' of names given here.  However, subsequent manual editing may have'
 786         . ' added or removed some.';
 787     $body .= switch_clause (2, $comment, $namelen, $items, @items);
 788   } else {
 789     # We are the top level.
 790     $body .= "  /* Initially switch on the length of the name.  */\n";
 791     $body .= dogfood ($package, $subname, $default_type, $what, $indent,
 792                       $breakout, @items);
 793     $body .= "  switch (len) {\n";
 794     # Need to group names of the same length
 795     my @by_length;
 796     foreach (@items) {
 797       push @{$by_length[length $_->{name}]}, $_;
 798     }
 799     foreach my $i (0 .. $#by_length) {
 800       next unless $by_length[$i];       # None of this length
 801       $body .= "  case $i:\n";
 802       if (@{$by_length[$i]} == 1) {
 803         my $thisone = $by_length[$i]->[0];
 804         my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
 805           = @$thisone{qw (name value macro default pre post def_pre def_post)};
 806         $value = $name unless defined $value;
 807         $macro = $name unless defined $macro;
 808
 809         $body .= memEQ_clause ($name);
 810         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
 811                                 $default, $pre, $post, $def_pre, $def_post);
 812         $body .= "    }\n";
 813       } elsif (@{$by_length[$i]} < $breakout) {
 814         $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
 815       } else {
 816         # Only use the minimal set of parameters actually needed by the types
 817         # of the names of this length.
 818         my $what = {};
 819         foreach (@{$by_length[$i]}) {
 820           $what->{$_->{type}} = 1;
 821         }
 822         $params = params ($what);
 823         push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
 824                                 $indent, [$i, $items], @{$by_length[$i]});
 825         $body .= "    return ${subname}_$i (aTHX_ name";
 826         $body .= ", iv_return" if $params->{IV};
 827         $body .= ", nv_return" if $params->{NV};
 828         $body .= ", pv_return" if $params->{PV};
 829         $body .= ", sv_return" if $params->{SV};
 830         $body .= ");\n";
 831       }
 832       $body .= "    break;\n";
 833     }
 834     $body .= "  }\n";
 835   }
 836   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
 837   return (@subs, $body);
 838 }
 839
 840 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
 841
 842 A function to generate the XS code to implement the perl subroutine
 843 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
 844 This XS code is a wrapper around a C subroutine usually generated by
 845 C<C_constant>, and usually named C<constant>.
 846
 847 I<TYPES> should be given either as a comma separated list of types that the
 848 C subroutine C<constant> will generate or as a reference to a hash. It should
 849 be the same list of types as C<C_constant> was given.
 850 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
 851 the number of parameters passed to the C function C<constant>]
 852
 853 You can call the perl visible subroutine something other than C<constant> if
 854 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
 855 the name of the perl visible subroutine, unless you give the parameter
 856 I<C_SUBNAME>.
 857
 858 =cut
 859
 860 sub XS_constant {
 861   my $package = shift;
 862   my $what = shift;
 863   my $subname = shift;
 864   my $C_subname = shift;
 865   $subname ||= 'constant';
 866   $C_subname ||= $subname;
 867
 868   if (!ref $what) {
 869     # Convert line of the form IV,UV,NV to hash
 870     $what = {map {$_ => 1} split /,\s*/, ($what)};
 871   }
 872   my $params = params ($what);
 873   my $type;
 874
 875   my $xs = <<"EOT";
 876 void
 877 $subname(sv)
 878     PREINIT:
 879 #ifdef dXSTARG
 880         dXSTARG; /* Faster if we have it.  */
 881 #else
 882         dTARGET;
 883 #endif
 884         STRLEN          len;
 885         int             type;
 886 EOT
 887
 888   if ($params->{IV}) {
 889     $xs .= "    IV              iv;\n";
 890   } else {
 891     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
 892   }
 893   if ($params->{NV}) {
 894     $xs .= "    NV              nv;\n";
 895   } else {
 896     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
 897   }
 898   if ($params->{PV}) {
 899     $xs .= "    const char      *pv;\n";
 900   } else {
 901     $xs .=
 902       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
 903   }
 904
 905   $xs .= << 'EOT';
 906     INPUT:
 907         SV *            sv;
 908         const char *    s = SvPV(sv, len);
 909     PPCODE:
 910 EOT
 911
 912   if ($params->{IV} xor $params->{NV}) {
 913     $xs .= << "EOT";
 914         /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
 915            if you need to return both NVs and IVs */
 916 EOT
 917   }
 918   $xs .= "      type = $C_subname(aTHX_ s, len";
 919   $xs .= ', &iv' if $params->{IV};
 920   $xs .= ', &nv' if $params->{NV};
 921   $xs .= ', &pv' if $params->{PV};
 922   $xs .= ', &sv' if $params->{SV};
 923   $xs .= ");\n";
 924
 925   $xs .= << "EOT";
 926       /* Return 1 or 2 items. First is error message, or undef if no error.
 927            Second, if present, is found value */
 928         switch (type) {
 929         case PERL_constant_NOTFOUND:
 930           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
 931           PUSHs(sv);
 932           break;
 933         case PERL_constant_NOTDEF:
 934           sv = sv_2mortal(newSVpvf(
 935             "Your vendor has not defined $package macro %s, used", s));
 936           PUSHs(sv);
 937           break;
 938 EOT
 939
 940   foreach $type (sort keys %XS_Constant) {
 941     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
 942       unless $what->{$type};
 943     $xs .= "        case PERL_constant_IS$type:\n";
 944     if (length $XS_Constant{$type}) {
 945       $xs .= << "EOT";
 946           EXTEND(SP, 1);
 947           PUSHs(&PL_sv_undef);
 948           $XS_Constant{$type};
 949 EOT
 950     } else {
 951       # Do nothing. return (), which will be correctly interpreted as
 952       # (undef, undef)
 953     }
 954     $xs .= "          break;\n";
 955     unless ($what->{$type}) {
 956       chop $xs; # Yes, another need for chop not chomp.
 957       $xs .= " */\n";
 958     }
 959   }
 960   $xs .= << "EOT";
 961         default:
 962           sv = sv_2mortal(newSVpvf(
 963             "Unexpected return type %d while processing $package macro %s, used",
 964                type, s));
 965           PUSHs(sv);
 966         }
 967 EOT
 968
 969   return $xs;
 970 }
 971
 972
 973 =item autoload PACKAGE, VERSION, AUTOLOADER
 974
 975 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 976 I<VERSION> is the perl version the code should be backwards compatible with.
 977 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
 978 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
 979 names that the constant() routine doesn't recognise.
 980
 981 =cut
 982
 983 # ' # Grr. syntax highlighters that don't grok pod.
 984
 985 sub autoload {
 986   my ($module, $compat_version, $autoloader) = @_;
 987   $compat_version ||= $];
 988   croak "Can't maintain compatibility back as far as version $compat_version"
 989     if $compat_version < 5;
 990   my $func = "sub AUTOLOAD {\n"
 991   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
 992   . "    # XS function.";
 993   $func .= "  If a constant is not found then control is passed\n"
 994   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
 995
 996
 997   $func .= "\n\n"
 998   . "    my \$constname;\n";
 999   $func .=
1000     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
1001
1002   $func .= <<"EOT";
1003     (\$constname = \$AUTOLOAD) =~ s/.*:://;
1004     croak "&${module}::constant not defined" if \$constname eq 'constant';
1005     my (\$error, \$val) = constant(\$constname);
1006 EOT
1007
1008   if ($autoloader) {
1009     $func .= <<'EOT';
1010     if ($error) {
1011         if ($error =~  /is not a valid/) {
1012             $AutoLoader::AUTOLOAD = $AUTOLOAD;
1013             goto &AutoLoader::AUTOLOAD;
1014         } else {
1015             croak $error;
1016         }
1017     }
1018 EOT
1019   } else {
1020     $func .=
1021       "    if (\$error) { croak \$error; }\n";
1022   }
1023
1024   $func .= <<'END';
1025     {
1026         no strict 'refs';
1027         # Fixed between 5.005_53 and 5.005_61
1028 #XXX    if ($] >= 5.00561) {
1029 #XXX        *$AUTOLOAD = sub () { $val };
1030 #XXX    }
1031 #XXX    else {
1032             *$AUTOLOAD = sub { $val };
1033 #XXX    }
1034     }
1035     goto &$AUTOLOAD;
1036 }
1037
1038 END
1039
1040   return $func;
1041 }
1042
1043
1044 =item WriteMakefileSnippet
1045
1046 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
1047
1048 A function to generate perl code for Makefile.PL that will regenerate
1049 the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
1050 with the addition of C<INDENT> to specify the number of leading spaces
1051 (default 2).
1052
1053 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
1054 C<XS_FILE> are recognised.
1055
1056 =cut
1057
1058 sub WriteMakefileSnippet {
1059   my %args = @_;
1060   my $indent = $args{INDENT} || 2;
1061
1062   my $result = <<"EOT";
1063 ExtUtils::Constant::WriteConstants(
1064                                    NAME         => '$args{NAME}',
1065                                    NAMES        => \\\@names,
1066                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
1067 EOT
1068   foreach (qw (C_FILE XS_FILE)) {
1069     next unless exists $args{$_};
1070     $result .= sprintf "                                   %-12s => '%s',\n",
1071       $_, $args{$_};
1072   }
1073   $result .= <<'EOT';
1074                                 );
1075 EOT
1076
1077   $result =~ s/^/' 'x$indent/gem;
1078   return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
1079                            @{$args{NAMES}})
1080           . $result;
1081 }
1082
1083 =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
1084
1085 Writes a file of C code and a file of XS code which you should C<#include>
1086 and C<INCLUDE> in the C and XS sections respectively of your module's XS
1087 code.  You probaby want to do this in your C<Makefile.PL>, so that you can
1088 easily edit the list of constants without touching the rest of your module.
1089 The attributes supported are
1090
1091 =over 4
1092
1093 =item NAME
1094
1095 Name of the module.  This must be specified
1096
1097 =item DEFAULT_TYPE
1098
1099 The default type for the constants.  If not specified C<IV> is assumed.
1100
1101 =item BREAKOUT_AT
1102
1103 The names of the constants are grouped by length.  Generate child subroutines
1104 for each group with this number or more names in.
1105
1106 =item NAMES
1107
1108 An array of constants' names, either scalars containing names, or hashrefs
1109 as detailed in L<"C_constant">.
1110
1111 =item C_FILE
1112
1113 The name of the file to write containing the C code.  The default is
1114 C<const-c.inc>.  The C<-> in the name ensures that the file can't be
1115 mistaken for anything related to a legitimate perl package name, and
1116 not naming the file C<.c> avoids having to override Makefile.PL's
1117 C<.xs> to C<.c> rules.
1118
1119 =item XS_FILE
1120
1121 The name of the file to write containing the XS code.  The default is
1122 C<const-xs.inc>.
1123
1124 =item SUBNAME
1125
1126 The perl visible name of the XS subroutine generated which will return the
1127 constants. The default is C<constant>.
1128
1129 =item C_SUBNAME
1130
1131 The name of the C subroutine generated which will return the constants.
1132 The default is I<SUBNAME>.  Child subroutines have C<_> and the name
1133 length appended, so constants with 10 character names would be in
1134 C<constant_10> with the default I<XS_SUBNAME>.
1135
1136 =back
1137
1138 =cut
1139
1140 sub WriteConstants {
1141   my %ARGS =
1142     ( # defaults
1143      C_FILE =>       'const-c.inc',
1144      XS_FILE =>      'const-xs.inc',
1145      SUBNAME =>      'constant',
1146      DEFAULT_TYPE => 'IV',
1147      @_);
1148
1149   $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
1150
1151   croak "Module name not specified" unless length $ARGS{NAME};
1152
1153   open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
1154   open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
1155
1156   # As this subroutine is intended to make code that isn't edited, there's no
1157   # need for the user to specify any types that aren't found in the list of
1158   # names.
1159   my $types = {};
1160
1161   print $c_fh constant_types(); # macro defs
1162   print $c_fh "\n";
1163
1164   # indent is still undef. Until anyone implents indent style rules with it.
1165   foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
1166                        $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
1167     print $c_fh $_, "\n"; # C constant subs
1168   }
1169   print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
1170                             $ARGS{C_SUBNAME});
1171
1172   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
1173   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
1174 }
1175
1176 1;
1177 __END__
1178
1179 =back
1180
1181 =head1 AUTHOR
1182
1183 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
1184 others
1185
1186 =cut