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