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