| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package ExtUtils::Constant::Base; 2 3 use strict; 4 use vars qw($VERSION); 5 use Carp; 6 use Text::Wrap; 7 use ExtUtils::Constant::Utils qw(C_stringify perl_stringify); 8 $VERSION = '0.04'; 9 10 use constant 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 $macro ? "#ifdef $macro\n" : "#if 0\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
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |