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