home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / ExtUtils / Constant.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-19  |  40.5 KB  |  1,327 lines

  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
  1327.