This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add method macro_from_item to encapsulate the entire logic for getting
[perl5.git] / lib / ExtUtils / Constant / Base.pm
1 package ExtUtils::Constant::Base;
2
3 use strict;
4 use vars qw($VERSION $is_perl56);
5 use Carp;
6 use Text::Wrap;
7 use ExtUtils::Constant::Utils qw(C_stringify perl_stringify);
8 $VERSION = '0.02';
9
10 $is_perl56 = ($] < 5.007 && $] > 5.005_50);
11
12
13 =head1 NAME
14
15 ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
16
17 =head1 SYNOPSIS
18
19     require ExtUtils::Constant::Base;
20     @ISA = 'ExtUtils::Constant::Base';
21
22 =head1 DESCRIPTION
23
24 ExtUtils::Constant::Base provides a base implementation of methods to
25 generate C code to give fast constant value lookup by named string. Currently
26 it's mostly used ExtUtils::Constant::XS, which generates the lookup code
27 for the constant() subroutine found in many XS modules.
28
29 =head1 USAGE
30
31 ExtUtils::Constant::Base exports no subroutines. The following methods are
32 available
33
34 =over 4
35
36 =cut
37
38 sub valid_type {
39   # Default to assuming that you don't need different types of return data.
40   1;
41 }
42 sub default_type {
43   '';
44 }
45
46 =item header
47
48 A method returning a scalar containing definitions needed, typically for a
49 C header file.
50
51 =cut
52
53 sub header {
54   ''
55 }
56
57 # This might actually be a return statement. Note that you are responsible
58 # for any space you might need before your value, as it lets to perform
59 # "tricks" such as "return KEY_" and have strings appended.
60 sub assignment_clause_for_type;
61 # In which case this might be an empty string
62 sub return_statement_for_type {undef};
63 sub return_statement_for_notdef;
64 sub return_statement_for_notfound;
65
66 # "#if 1" is true to a C pre-processor
67 sub macro_from_name {
68   1;
69 }
70
71 sub macro_from_item {
72   1;
73 }
74
75 sub macro_to_ifdef {
76     my ($self, $macro) = @_;
77     if (ref $macro) {
78         return $macro->[0];
79     }
80     if (defined $macro && $macro ne "" && $macro ne "1") {
81         return "#ifdef $macro\n";
82     }
83     return "";
84 }
85
86 sub macro_to_endif {
87     my ($self, $macro) = @_;
88
89     if (ref $macro) {
90         return $macro->[1];
91     }
92     if (defined $macro && $macro ne "" && $macro ne "1") {
93         return "#endif\n";
94     }
95     return "";
96 }
97
98 sub name_param {
99   'name';
100 }
101
102 # This is possibly buggy, in that it's not mandatory (below, in the main
103 # C_constant parameters, but is expected to exist here, if it's needed)
104 # Buggy because if you're definitely pure 8 bit only, and will never be
105 # presented with your constants in utf8, the default form of C_constant can't
106 # be told not to do the utf8 version.
107
108 sub is_utf8_param {
109   'utf8';
110 }
111
112 sub memEQ {
113   "!memcmp";
114 }
115
116 =item memEQ_clause args_hashref
117
118 A method to return a suitable C C<if> statement to check whether I<name>
119 is equal to the C variable C<name>. If I<checked_at> is defined, then it
120 is used to avoid C<memEQ> for short names, or to generate a comment to
121 highlight the position of the character in the C<switch> statement.
122
123 If i<checked_at> is a reference to a scalar, then instead it gives
124 the characters pre-checked at the beginning, (and the number of chars by
125 which the C variable name has been advanced. These need to be chopped from
126 the front of I<name>).
127
128 =cut
129
130 sub memEQ_clause {
131 #    if (memEQ(name, "thingy", 6)) {
132   # Which could actually be a character comparison or even ""
133   my ($self, $args) = @_;
134   my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)};
135   $indent = ' ' x ($indent || 4);
136   my $front_chop;
137   if (ref $checked_at) {
138     # regexp won't work on 5.6.1 without use utf8; in turn that won't work
139     # on 5.005_03.
140     substr ($name, 0, length $$checked_at,) = '';
141     $front_chop = C_stringify ($$checked_at);
142     undef $checked_at;
143   }
144   my $len = length $name;
145
146   if ($len < 2) {
147     return $indent . "{\n"
148         if (defined $checked_at and $checked_at == 0) or $len == 0;
149     # We didn't switch, drop through to the code for the 2 character string
150     $checked_at = 1;
151   }
152
153   my $name_param = $self->name_param;
154
155   if ($len < 3 and defined $checked_at) {
156     my $check;
157     if ($checked_at == 1) {
158       $check = 0;
159     } elsif ($checked_at == 0) {
160       $check = 1;
161     }
162     if (defined $check) {
163       my $char = C_stringify (substr $name, $check, 1);
164       # Placate 5.005 with a break in the string. I can't see a good way of
165       # getting it to not take [ as introducing an array lookup, even with
166       # ${name_param}[$check]
167       return $indent . "if ($name_param" . "[$check] == '$char') {\n";
168     }
169   }
170   if (($len == 2 and !defined $checked_at)
171      or ($len == 3 and defined ($checked_at) and $checked_at == 2)) {
172     my $char1 = C_stringify (substr $name, 0, 1);
173     my $char2 = C_stringify (substr $name, 1, 1);
174     return $indent .
175       "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n";
176   }
177   if (($len == 3 and defined ($checked_at) and $checked_at == 1)) {
178     my $char1 = C_stringify (substr $name, 0, 1);
179     my $char2 = C_stringify (substr $name, 2, 1);
180     return $indent .
181       "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n";
182   }
183
184   my $pointer = '^';
185   my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1;
186   if ($have_checked_last) {
187     # Checked at the last character, so no need to memEQ it.
188     $pointer = C_stringify (chop $name);
189     $len--;
190   }
191
192   $name = C_stringify ($name);
193   my $memEQ = $self->memEQ();
194   my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n";
195   # Put a little ^ under the letter we checked at
196   # Screws up for non printable and non-7 bit stuff, but that's too hard to
197   # get right.
198   if (defined $checked_at) {
199     $body .= $indent . "/*      " . (' ' x length $memEQ)
200       . (' ' x length $name_param)
201       . (' ' x $checked_at) . $pointer
202       . (' ' x ($len - $checked_at + length $len)) . "    */\n";
203   } elsif (defined $front_chop) {
204     $body .= $indent . "/*                $front_chop"
205       . (' ' x ($len + 1 + length $len)) . "    */\n";
206   }
207   return $body;
208 }
209
210 =item dump_names arg_hashref, ITEM...
211
212 An internal function to generate the embedded perl code that will regenerate
213 the constant subroutines.  I<default_type>, I<types> and I<ITEM>s are the
214 same as for C_constant.  I<indent> is treated as number of spaces to indent
215 by.  If C<declare_types> is true a C<$types> is always declared in the perl
216 code generated, if defined and false never declared, and if undefined C<$types>
217 is only declared if the values in I<types> as passed in cannot be inferred from
218 I<default_types> and the I<ITEM>s.
219
220 =cut
221
222 sub dump_names {
223   my ($self, $args, @items) = @_;
224   my ($default_type, $what, $indent, $declare_types)
225     = @{$args}{qw(default_type what indent declare_types)};
226   $indent = ' ' x ($indent || 0);
227
228   my $result;
229   my (@simple, @complex, %used_types);
230   foreach (@items) {
231     my $type;
232     if (ref $_) {
233       $type = $_->{type} || $default_type;
234       if ($_->{utf8}) {
235         # For simplicity always skip the bytes case, and reconstitute this entry
236         # from its utf8 twin.
237         next if $_->{utf8} eq 'no';
238         # Copy the hashref, as we don't want to mess with the caller's hashref.
239         $_ = {%$_};
240         unless ($is_perl56) {
241           utf8::decode ($_->{name});
242         } else {
243           $_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
244         }
245         delete $_->{utf8};
246       }
247     } else {
248       $_ = {name=>$_};
249       $type = $default_type;
250     }
251     $used_types{$type}++;
252     if ($type eq $default_type
253         # grr 5.6.1
254         and length $_->{name}
255         and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
256         and !defined ($_->{macro}) and !defined ($_->{value})
257         and !defined ($_->{default}) and !defined ($_->{pre})
258         and !defined ($_->{post}) and !defined ($_->{def_pre})
259         and !defined ($_->{def_post}) and !defined ($_->{weight})) {
260       # It's the default type, and the name consists only of A-Za-z0-9_
261       push @simple, $_->{name};
262     } else {
263       push @complex, $_;
264     }
265   }
266
267   if (!defined $declare_types) {
268     # Do they pass in any types we weren't already using?
269     foreach (keys %$what) {
270       next if $used_types{$_};
271       $declare_types++; # Found one in $what that wasn't used.
272       last; # And one is enough to terminate this loop
273     }
274   }
275   if ($declare_types) {
276     $result = $indent . 'my $types = {map {($_, 1)} qw('
277       . join (" ", sort keys %$what) . ")};\n";
278   }
279   local $Text::Wrap::huge = 'overflow';
280   local $Text::Wrap::columns = 80;
281   $result .= wrap ($indent . "my \@names = (qw(",
282                    $indent . "               ", join (" ", sort @simple) . ")");
283   if (@complex) {
284     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
285       my $name = perl_stringify $item->{name};
286       my $line = ",\n$indent            {name=>\"$name\"";
287       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
288       foreach my $thing (qw (macro value default pre post def_pre def_post)) {
289         my $value = $item->{$thing};
290         if (defined $value) {
291           if (ref $value) {
292             $line .= ", $thing=>[\""
293               . join ('", "', map {perl_stringify $_} @$value) . '"]';
294           } else {
295             $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
296           }
297         }
298       }
299       $line .= "}";
300       # Ensure that the enclosing C comment doesn't end
301       # by turning */  into *" . "/
302       $line =~ s!\*\/!\*" . "/!gs;
303       # gcc -Wall doesn't like finding /* inside a comment
304       $line =~ s!\/\*!/" . "\*!gs;
305       $result .= $line;
306     }
307   }
308   $result .= ");\n";
309
310   $result;
311 }
312
313 =item assign arg_hashref, VALUE...
314
315 A method to return a suitable assignment clause. If I<type> is aggregate
316 (eg I<PVN> expects both pointer and length) then there should be multiple
317 I<VALUE>s for the components. I<pre> and I<post> if defined give snippets
318 of C code to proceed and follow the assignment. I<pre> will be at the start
319 of a block, so variables may be defined in it.
320
321 =cut
322 # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
323
324 sub assign {
325   my $self = shift;
326   my $args = shift;
327   my ($indent, $type, $pre, $post, $item)
328       = @{$args}{qw(indent type pre post item)};
329   $post ||= '';
330   my $clause;
331   my $close;
332   if ($pre) {
333     chomp $pre;
334     $close = "$indent}\n";
335     $clause = $indent . "{\n";
336     $indent .= "  ";
337     $clause .= "$indent$pre";
338     $clause .= ";" unless $pre =~ /;$/;
339     $clause .= "\n";
340   }
341   confess "undef \$type" unless defined $type;
342   confess "Can't generate code for type $type"
343     unless $self->valid_type($type);
344
345   $clause .= join '', map {"$indent$_\n"}
346     $self->assignment_clause_for_type({type=>$type,item=>$item}, @_);
347   chomp $post;
348   if (length $post) {
349     $clause .= "$post";
350     $clause .= ";" unless $post =~ /;$/;
351     $clause .= "\n";
352   }
353   my $return = $self->return_statement_for_type($type);
354   $clause .= "$indent$return\n" if defined $return;
355   $clause .= $close if $close;
356   return $clause;
357 }
358
359 =item return_clause arg_hashref, ITEM
360
361 A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
362 (as passed to C<C_constant> and C<match_clause>. I<indent> is the number
363 of spaces to indent, defaulting to 6.
364
365 =cut
366
367 sub return_clause {
368
369 ##ifdef thingy
370 #      *iv_return = thingy;
371 #      return PERL_constant_ISIV;
372 ##else
373 #      return PERL_constant_NOTDEF;
374 ##endif
375   my ($self, $args, $item) = @_;
376   my $indent = $args->{indent};
377
378   my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type)
379     = @$item{qw (name value default pre post def_pre def_post type)};
380   $value = $name unless defined $value;
381   my $macro = $self->macro_from_item($item);
382   $indent = ' ' x ($indent || 6);
383   unless (defined $type) {
384     # use Data::Dumper; print STDERR Dumper ($item);
385     confess "undef \$type";
386   }
387
388   ##ifdef thingy
389   my $clause = $self->macro_to_ifdef($macro);
390
391   #      *iv_return = thingy;
392   #      return PERL_constant_ISIV;
393   $clause
394     .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post,
395                        item=>$item}, ref $value ? @$value : $value);
396
397   if (defined $macro && $macro ne "" && $macro ne "1") {
398     ##else
399     $clause .= "#else\n";
400
401     #      return PERL_constant_NOTDEF;
402     if (!defined $default) {
403       my $notdef = $self->return_statement_for_notdef();
404       $clause .= "$indent$notdef\n" if defined $notdef;
405     } else {
406       my @default = ref $default ? @$default : $default;
407       $type = shift @default;
408       $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre,
409                                  post=>$post, item=>$item}, @default);
410     }
411   }
412   ##endif
413   $clause .= $self->macro_to_endif($macro);
414
415   return $clause;
416 }
417
418 sub match_clause {
419   # $offset defined if we have checked an offset.
420   my ($self, $args, $item) = @_;
421   my ($offset, $indent) = @{$args}{qw(checked_at indent)};
422   $indent = ' ' x ($indent || 4);
423   my $body = '';
424   my ($no, $yes, $either, $name, $inner_indent);
425   if (ref $item eq 'ARRAY') {
426     ($yes, $no) = @$item;
427     $either = $yes || $no;
428     confess "$item is $either expecting hashref in [0] || [1]"
429       unless ref $either eq 'HASH';
430     $name = $either->{name};
431   } else {
432     confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
433       if $item->{utf8};
434     $name = $item->{name};
435     $inner_indent = $indent;
436   }
437
438   $body .= $self->memEQ_clause ({name => $name, checked_at => $offset,
439                                  indent => length $indent});
440   # If we've been presented with an arrayref for $item, then the user string
441   # contains in the range 128-255, and we need to check whether it was utf8
442   # (or not).
443   # In the worst case we have two named constants, where one's name happens
444   # encoded in UTF8 happens to be the same byte sequence as the second's
445   # encoded in (say) ISO-8859-1.
446   # In this case, $yes and $no both have item hashrefs.
447   if ($yes) {
448     $body .= $indent . "  if (" . $self->is_utf8_param . ") {\n";
449   } elsif ($no) {
450     $body .= $indent . "  if (!" . $self->is_utf8_param . ") {\n";
451   }
452   if ($either) {
453     $body .= $self->return_clause ({indent=>4 + length $indent}, $either);
454     if ($yes and $no) {
455       $body .= $indent . "  } else {\n";
456       $body .= $self->return_clause ({indent=>4 + length $indent}, $no);
457     }
458     $body .= $indent . "  }\n";
459   } else {
460     $body .= $self->return_clause ({indent=>2 + length $indent}, $item);
461   }
462   $body .= $indent . "}\n";
463 }
464
465
466 =item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM...
467
468 An internal method to generate a suitable C<switch> clause, called by
469 C<C_constant> I<ITEM>s are in the hash ref format as given in the description
470 of C<C_constant>, and must all have the names of the same length, given by
471 I<NAMELEN>.  I<ITEMHASH> is a reference to a hash, keyed by name, values being
472 the hashrefs in the I<ITEM> list.  (No parameters are modified, and there can
473 be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without
474 causing problems - the hash is passed in to save generating it afresh for
475 each call).
476
477 =cut
478
479 sub switch_clause {
480   my ($self, $args, $namelen, $items, @items) = @_;
481   my ($indent, $comment) = @{$args}{qw(indent comment)};
482   $indent = ' ' x ($indent || 2);
483
484   local $Text::Wrap::huge = 'overflow';
485   local $Text::Wrap::columns = 80;
486
487   my @names = sort map {$_->{name}} @items;
488   my $leader = $indent . '/* ';
489   my $follower = ' ' x length $leader;
490   my $body = $indent . "/* Names all of length $namelen.  */\n";
491   if (defined $comment) {
492     $body = wrap ($leader, $follower, $comment) . "\n";
493     $leader = $follower;
494   }
495   my @safe_names = @names;
496   foreach (@safe_names) {
497     confess sprintf "Name '$_' is length %d, not $namelen", length
498       unless length == $namelen;
499     # Argh. 5.6.1
500     # next unless tr/A-Za-z0-9_//c;
501     next if tr/A-Za-z0-9_// == length;
502     $_ = '"' . perl_stringify ($_) . '"';
503     # Ensure that the enclosing C comment doesn't end
504     # by turning */  into *" . "/
505     s!\*\/!\*"."/!gs;
506     # gcc -Wall doesn't like finding /* inside a comment
507     s!\/\*!/"."\*!gs;
508   }
509   $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
510   # Figure out what to switch on.
511   # (RMS, Spread of jump table, Position, Hashref)
512   my @best = (1e38, ~0);
513   # Prefer the last character over the others. (As it lets us shorten the
514   # memEQ clause at no cost).
515   foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
516     my ($min, $max) = (~0, 0);
517     my %spread;
518     if ($is_perl56) {
519       # Need proper Unicode preserving hash keys for bytes in range 128-255
520       # here too, for some reason. grr 5.6.1 yet again.
521       tie %spread, 'ExtUtils::Constant::Aaargh56Hash';
522     }
523     foreach (@names) {
524       my $char = substr $_, $i, 1;
525       my $ord = ord $char;
526       confess "char $ord is out of range" if $ord > 255;
527       $max = $ord if $ord > $max;
528       $min = $ord if $ord < $min;
529       push @{$spread{$char}}, $_;
530       # warn "$_ $char";
531     }
532     # I'm going to pick the character to split on that minimises the root
533     # mean square of the number of names in each case. Normally this should
534     # be the one with the most keys, but it may pick a 7 where the 8 has
535     # one long linear search. I'm not sure if RMS or just sum of squares is
536     # actually better.
537     # $max and $min are for the tie-breaker if the root mean squares match.
538     # Assuming that the compiler may be building a jump table for the
539     # switch() then try to minimise the size of that jump table.
540     # Finally use < not <= so that if it still ties the earliest part of
541     # the string wins. Because if that passes but the memEQ fails, it may
542     # only need the start of the string to bin the choice.
543     # I think. But I'm micro-optimising. :-)
544     # OK. Trump that. Now favour the last character of the string, before the
545     # rest.
546     my $ss;
547     $ss += @$_ * @$_ foreach values %spread;
548     my $rms = sqrt ($ss / keys %spread);
549     if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
550       @best = ($rms, $max - $min, $i, \%spread);
551     }
552   }
553   confess "Internal error. Failed to pick a switch point for @names"
554     unless defined $best[2];
555   # use Data::Dumper; print Dumper (@best);
556   my ($offset, $best) = @best[2,3];
557   $body .= $indent . "/* Offset $offset gives the best switch position.  */\n";
558
559   my $do_front_chop = $offset == 0 && $namelen > 2;
560   if ($do_front_chop) {
561     $body .= $indent . "switch (*" . $self->name_param() . "++) {\n";
562   } else {
563     $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n";
564   }
565   foreach my $char (sort keys %$best) {
566     confess sprintf "'$char' is %d bytes long, not 1", length $char
567       if length ($char) != 1;
568     confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255;
569     $body .= $indent . "case '" . C_stringify ($char) . "':\n";
570     foreach my $thisone (sort {
571         # Deal with the case of an item actually being an array ref to 1 or 2
572         # hashrefs. Don't assign to $a or $b, as they're aliases to the orignal
573         my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a;
574         my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b;
575         # Sort by weight first
576         ($r->{weight} || 0) <=> ($l->{weight} || 0)
577             # Sort equal weights by name
578             or $l->{name} cmp $r->{name}}
579                          # If this looks evil, maybe it is.  $items is a
580                          # hashref, and we're doing a hash slice on it
581                          @{$items}{@{$best->{$char}}}) {
582       # warn "You are here";
583       if ($do_front_chop) {
584         $body .= $self->match_clause ({indent => 2 + length $indent,
585                                        checked_at => \$char}, $thisone);
586       } else {
587         $body .= $self->match_clause ({indent => 2 + length $indent,
588                                        checked_at => $offset}, $thisone);
589       }
590     }
591     $body .= $indent . "  break;\n";
592   }
593   $body .= $indent . "}\n";
594   return $body;
595 }
596
597 sub C_constant_return_type {
598   "static int";
599 }
600
601 sub C_constant_prefix_param {
602   '';
603 }
604
605 sub C_constant_prefix_param_defintion {
606   '';
607 }
608
609 sub name_param_definition {
610   "const char *" . $_[0]->name_param;
611 }
612
613 sub namelen_param {
614   'len';
615 }
616
617 sub namelen_param_definition {
618   'size_t ' . $_[0]->namelen_param;
619 }
620
621 sub C_constant_other_params {
622   '';
623 }
624
625 sub C_constant_other_params_defintion {
626   '';
627 }
628
629 =item params WHAT
630
631 An "internal" method, subject to change, currently called to allow an
632 overriding class to cache information that will then be passed into all
633 the C<*param*> calls. (Yes, having to read the source to make sense of this is
634 considered a known bug). I<WHAT> is be a hashref of types the constant
635 function will return. In ExtUtils::Constant::XS this method is used to
636 returns a hashref keyed IV NV PV SV to show which combination of pointers will
637 be needed in the C argument list generated by
638 C_constant_other_params_definition and C_constant_other_params
639
640 =cut
641
642 sub params {
643   '';
644 }
645
646
647 =item dogfood arg_hashref, ITEM...
648
649 An internal function to generate the embedded perl code that will regenerate
650 the constant subroutines.  Parameters are the same as for C_constant.
651
652 Currently the base class does nothing and returns an empty string.
653
654 =cut
655
656 sub dogfood {
657   ''
658 }
659
660 =item normalise_items args, default_type, seen_types, seen_items, ITEM...
661
662 Convert the items to a normalised form. For 8 bit and Unicode values converts
663 the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded.
664
665 =cut
666
667 sub normalise_items
668 {
669     my $self = shift;
670     my $args = shift;
671     my $default_type = shift;
672     my $what = shift;
673     my $items = shift;
674     my @new_items;
675     foreach my $orig (@_) {
676         my ($name, $item);
677       if (ref $orig) {
678         # Make a copy which is a normalised version of the ref passed in.
679         $name = $orig->{name};
680         my ($type, $macro, $value) = @$orig{qw (type macro value)};
681         $type ||= $default_type;
682         $what->{$type} = 1;
683         $item = {name=>$name, type=>$type};
684
685         undef $macro if defined $macro and $macro eq $name;
686         $item->{macro} = $macro if defined $macro;
687         undef $value if defined $value and $value eq $name;
688         $item->{value} = $value if defined $value;
689         foreach my $key (qw(default pre post def_pre def_post weight
690                             not_constant)) {
691           my $value = $orig->{$key};
692           $item->{$key} = $value if defined $value;
693           # warn "$key $value";
694         }
695       } else {
696         $name = $orig;
697         $item = {name=>$name, type=>$default_type};
698         $what->{$default_type} = 1;
699       }
700       warn +(ref ($self) || $self)
701         . "doesn't know how to handle values of type $_ used in macro $name"
702           unless $self->valid_type ($item->{type});
703       # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c
704       # doesn't work. Upgrade to 5.8
705       # if ($name !~ tr/\0-\177//c || $] < 5.005_50) {
706       if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50
707          || $args->{disable_utf8_duplication}) {
708         # No characters outside 7 bit ASCII.
709         if (exists $items->{$name}) {
710           die "Multiple definitions for macro $name";
711         }
712         $items->{$name} = $item;
713       } else {
714         # No characters outside 8 bit. This is hardest.
715         if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
716           confess "Unexpected ASCII definition for macro $name";
717         }
718         # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/;
719         # if ($name !~ tr/\0-\377//c) {
720         if ($name =~ tr/\0-\377// == length $name) {
721 #          if ($] < 5.007) {
722 #            $name = pack "C*", unpack "U*", $name;
723 #          }
724           $item->{utf8} = 'no';
725           $items->{$name}[1] = $item;
726           push @new_items, $item;
727           # Copy item, to create the utf8 variant.
728           $item = {%$item};
729         }
730         # Encode the name as utf8 bytes.
731         unless ($is_perl56) {
732           utf8::encode($name);
733         } else {
734 #          warn "Was >$name< " . length ${name};
735           $name = pack 'C*', unpack 'C*', $name . pack 'U*';
736 #          warn "Now '${name}' " . length ${name};
737         }
738         if ($items->{$name}[0]) {
739           die "Multiple definitions for macro $name";
740         }
741         $item->{utf8} = 'yes';
742         $item->{name} = $name;
743         $items->{$name}[0] = $item;
744         # We have need for the utf8 flag.
745         $what->{''} = 1;
746       }
747       push @new_items, $item;
748     }
749     @new_items;
750 }
751
752 =item C_constant arg_hashref, ITEM...
753
754 A function that returns a B<list> of C subroutine definitions that return
755 the value and type of constants when passed the name by the XS wrapper.
756 I<ITEM...> gives a list of constant names. Each can either be a string,
757 which is taken as a C macro name, or a reference to a hash with the following
758 keys
759
760 =over 8
761
762 =item name
763
764 The name of the constant, as seen by the perl code.
765
766 =item type
767
768 The type of the constant (I<IV>, I<NV> etc)
769
770 =item value
771
772 A C expression for the value of the constant, or a list of C expressions if
773 the type is aggregate. This defaults to the I<name> if not given.
774
775 =item macro
776
777 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
778 I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
779 array is passed then the first element is used in place of the C<#ifdef>
780 line, and the second element in place of the C<#endif>. This allows
781 pre-processor constructions such as
782
783     #if defined (foo)
784     #if !defined (bar)
785     ...
786     #endif
787     #endif
788
789 to be used to determine if a constant is to be defined.
790
791 A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
792 test is omitted.
793
794 =item default
795
796 Default value to use (instead of C<croak>ing with "your vendor has not
797 defined...") to return if the macro isn't defined. Specify a reference to
798 an array with type followed by value(s).
799
800 =item pre
801
802 C code to use before the assignment of the value of the constant. This allows
803 you to use temporary variables to extract a value from part of a C<struct>
804 and return this as I<value>. This C code is places at the start of a block,
805 so you can declare variables in it.
806
807 =item post
808
809 C code to place between the assignment of value (to a temporary) and the
810 return from the function. This allows you to clear up anything in I<pre>.
811 Rarely needed.
812
813 =item def_pre
814
815 =item def_post
816
817 Equivalents of I<pre> and I<post> for the default value.
818
819 =item utf8
820
821 Generated internally. Is zero or undefined if name is 7 bit ASCII,
822 "no" if the name is 8 bit (and so should only match if SvUTF8() is false),
823 "yes" if the name is utf8 encoded.
824
825 The internals automatically clone any name with characters 128-255 but none
826 256+ (ie one that could be either in bytes or utf8) into a second entry
827 which is utf8 encoded.
828
829 =item weight
830
831 Optional sorting weight for names, to determine the order of
832 linear testing when multiple names fall in the same case of a switch clause.
833 Higher comes earlier, undefined defaults to zero.
834
835 =back
836
837 In the argument hashref, I<package> is the name of the package, and is only
838 used in comments inside the generated C code. I<subname> defaults to
839 C<constant> if undefined.
840
841 I<default_type> is the type returned by C<ITEM>s that don't specify their
842 type. It defaults to the value of C<default_type()>. I<types> should be given
843 either as a comma separated list of types that the C subroutine I<subname>
844 will generate or as a reference to a hash. I<default_type> will be added to
845 the list if not present, as will any types given in the list of I<ITEM>s. The
846 resultant list should be the same list of types that C<XS_constant> is
847 given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of
848 parameters to the constant function. I<indent> is currently unused and
849 ignored. In future it may be used to pass in information used to change the C
850 indentation style used.]  The best way to maintain consistency is to pass in a
851 hash reference and let this function update it.
852
853 I<breakout> governs when child functions of I<subname> are generated.  If there
854 are I<breakout> or more I<ITEM>s with the same length of name, then the code
855 to switch between them is placed into a function named I<subname>_I<len>, for
856 example C<constant_5> for names 5 characters long.  The default I<breakout> is
857 3.  A single C<ITEM> is always inlined.
858
859 =cut
860
861 # The parameter now BREAKOUT was previously documented as:
862 #
863 # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
864 # this length, and that the constant name passed in by perl is checked and
865 # also of this length. It is used during recursion, and should be C<undef>
866 # unless the caller has checked all the lengths during code generation, and
867 # the generated subroutine is only to be called with a name of this length.
868 #
869 # As you can see it now performs this function during recursion by being a
870 # scalar reference.
871
872 sub C_constant {
873   my ($self, $args, @items) = @_;
874   my ($package, $subname, $default_type, $what, $indent, $breakout) =
875     @{$args}{qw(package subname default_type types indent breakout)};
876   $package ||= 'Foo';
877   $subname ||= 'constant';
878   # I'm not using this. But a hashref could be used for full formatting without
879   # breaking this API
880   # $indent ||= 0;
881
882   my ($namelen, $items);
883   if (ref $breakout) {
884     # We are called recursively. We trust @items to be normalised, $what to
885     # be a hashref, and pinch %$items from our parent to save recalculation.
886     ($namelen, $items) = @$breakout;
887   } else {
888     $items = {};
889     if ($is_perl56) {
890       # Need proper Unicode preserving hash keys.
891       require ExtUtils::Constant::Aaargh56Hash;
892       tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
893     }
894     $breakout ||= 3;
895     $default_type ||= $self->default_type();
896     if (!ref $what) {
897       # Convert line of the form IV,UV,NV to hash
898       $what = {map {$_ => 1} split /,\s*/, ($what || '')};
899       # Figure out what types we're dealing with, and assign all unknowns to the
900       # default type
901     }
902     @items = $self->normalise_items ({}, $default_type, $what, $items, @items);
903     # use Data::Dumper; print Dumper @items;
904   }
905   my $params = $self->params ($what);
906
907   # Probably "static int"
908   my ($body, @subs);
909   $body = $self->C_constant_return_type($params) . "\n$subname ("
910     # Eg "pTHX_ "
911     . $self->C_constant_prefix_param_defintion($params)
912       # Probably "const char *name"
913       . $self->name_param_definition($params);
914   # Something like ", STRLEN len"
915   $body .= ", " . $self->namelen_param_definition($params)
916     unless defined $namelen;
917   $body .= $self->C_constant_other_params_defintion($params);
918   $body .= ") {\n";
919
920   if (defined $namelen) {
921     # We are a child subroutine. Print the simple description
922     my $comment = 'When generated this function returned values for the list'
923       . ' of names given here.  However, subsequent manual editing may have'
924         . ' added or removed some.';
925     $body .= $self->switch_clause ({indent=>2, comment=>$comment},
926                                    $namelen, $items, @items);
927   } else {
928     # We are the top level.
929     $body .= "  /* Initially switch on the length of the name.  */\n";
930     $body .= $self->dogfood ({package => $package, subname => $subname,
931                               default_type => $default_type, what => $what,
932                               indent => $indent, breakout => $breakout},
933                              @items);
934     $body .= '  switch ('.$self->namelen_param().") {\n";
935     # Need to group names of the same length
936     my @by_length;
937     foreach (@items) {
938       push @{$by_length[length $_->{name}]}, $_;
939     }
940     foreach my $i (0 .. $#by_length) {
941       next unless $by_length[$i];       # None of this length
942       $body .= "  case $i:\n";
943       if (@{$by_length[$i]} == 1) {
944         my $only_thing = $by_length[$i]->[0];
945         if ($only_thing->{utf8}) {
946           if ($only_thing->{utf8} eq 'yes') {
947             # With utf8 on flag item is passed in element 0
948             $body .= $self->match_clause (undef, [$only_thing]);
949           } else {
950             # With utf8 off flag item is passed in element 1
951             $body .= $self->match_clause (undef, [undef, $only_thing]);
952           }
953         } else {
954           $body .= $self->match_clause (undef, $only_thing);
955         }
956       } elsif (@{$by_length[$i]} < $breakout) {
957         $body .= $self->switch_clause ({indent=>4},
958                                        $i, $items, @{$by_length[$i]});
959       } else {
960         # Only use the minimal set of parameters actually needed by the types
961         # of the names of this length.
962         my $what = {};
963         foreach (@{$by_length[$i]}) {
964           $what->{$_->{type}} = 1;
965           $what->{''} = 1 if $_->{utf8};
966         }
967         $params = $self->params ($what);
968         push @subs, $self->C_constant ({package=>$package,
969                                         subname=>"${subname}_$i",
970                                         default_type => $default_type,
971                                         types => $what, indent => $indent,
972                                         breakout => [$i, $items]},
973                                        @{$by_length[$i]});
974         $body .= "    return ${subname}_$i ("
975           # Eg "aTHX_ "
976           . $self->C_constant_prefix_param($params)
977             # Probably "name"
978             . $self->name_param($params);
979         $body .= $self->C_constant_other_params($params);
980         $body .= ");\n";
981       }
982       $body .= "    break;\n";
983     }
984     $body .= "  }\n";
985   }
986   my $notfound = $self->return_statement_for_notfound();
987   $body .= "  $notfound\n" if $notfound;
988   $body .= "}\n";
989   return (@subs, $body);
990 }
991
992 1;
993 __END__
994
995 =back
996
997 =head1 BUGS
998
999 Not everything is documented yet.
1000
1001 Probably others.
1002
1003 =head1 AUTHOR
1004
1005 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
1006 others