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