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