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