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