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