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