1package ExtUtils::Constant; 2use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS); 3$VERSION = '0.14'; 4 5=head1 NAME 6 7ExtUtils::Constant - generate XS code to import C header constants 8 9=head1 SYNOPSIS 10 11 use ExtUtils::Constant qw (WriteConstants); 12 WriteConstants( 13 NAME => 'Foo', 14 NAMES => [qw(FOO BAR BAZ)], 15 ); 16 # Generates wrapper code to make the values of the constants FOO BAR BAZ 17 # available to perl 18 19=head1 DESCRIPTION 20 21ExtUtils::Constant facilitates generating C and XS wrapper code to allow 22perl modules to AUTOLOAD constants defined in C library header files. 23It is principally used by the C<h2xs> utility, on which this code is based. 24It doesn't contain the routines to scan header files to extract these 25constants. 26 27=head1 USAGE 28 29Generally one only needs to call the C<WriteConstants> function, and then 30 31 #include "const-c.inc" 32 33in the C section of C<Foo.xs> 34 35 INCLUDE const-xs.inc 36 37in the XS section of C<Foo.xs>. 38 39For greater flexibility use C<constant_types()>, C<C_constant> and 40C<XS_constant>, with which C<WriteConstants> is implemented. 41 42Currently this module understands the following types. h2xs may only know 43a subset. The sizes of the numeric types are chosen by the C<Configure> 44script at compile time. 45 46=over 4 47 48=item IV 49 50signed integer, at least 32 bits. 51 52=item UV 53 54unsigned integer, the same size as I<IV> 55 56=item NV 57 58floating point type, probably C<double>, possibly C<long double> 59 60=item PV 61 62NUL terminated string, length will be determined with C<strlen> 63 64=item PVN 65 66A fixed length thing, given as a [pointer, length] pair. If you know the 67length of a string at compile time you may use this instead of I<PV> 68 69=item SV 70 71A B<mortal> SV. 72 73=item YES 74 75Truth. (C<PL_sv_yes>) The value is not needed (and ignored). 76 77=item NO 78 79Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). 80 81=item UNDEF 82 83C<undef>. The value of the macro is not needed. 84 85=back 86 87=head1 FUNCTIONS 88 89=over 4 90 91=cut 92 93if ($] >= 5.006) { 94 eval "use warnings; 1" or die $@; 95} 96use strict; 97use vars '$is_perl56'; 98use Carp; 99 100$is_perl56 = ($] < 5.007 && $] > 5.005_50); 101 102use Exporter; 103use Text::Wrap; 104$Text::Wrap::huge = 'overflow'; 105$Text::Wrap::columns = 80; 106 107@ISA = 'Exporter'; 108 109%EXPORT_TAGS = ( 'all' => [ qw( 110 XS_constant constant_types return_clause memEQ_clause C_stringify 111 C_constant autoload WriteConstants WriteMakefileSnippet 112) ] ); 113 114@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 115 116# '' is used as a flag to indicate non-ascii macro names, and hence the need 117# to pass in the utf8 on/off flag. 118%XS_Constant = ( 119 '' => '', 120 IV => 'PUSHi(iv)', 121 UV => 'PUSHu((UV)iv)', 122 NV => 'PUSHn(nv)', 123 PV => 'PUSHp(pv, strlen(pv))', 124 PVN => 'PUSHp(pv, iv)', 125 SV => 'PUSHs(sv)', 126 YES => 'PUSHs(&PL_sv_yes)', 127 NO => 'PUSHs(&PL_sv_no)', 128 UNDEF => '', # implicit undef 129); 130 131%XS_TypeSet = ( 132 IV => '*iv_return =', 133 UV => '*iv_return = (IV)', 134 NV => '*nv_return =', 135 PV => '*pv_return =', 136 PVN => ['*pv_return =', '*iv_return = (IV)'], 137 SV => '*sv_return = ', 138 YES => undef, 139 NO => undef, 140 UNDEF => undef, 141); 142 143 144=item C_stringify NAME 145 146A function which returns a 7 bit ASCII correctly \ escaped version of the 147string passed suitable for C's "" or ''. It will die if passed Unicode 148characters. 149 150=cut 151 152# Hopefully make a happy C identifier. 153sub C_stringify { 154 local $_ = shift; 155 return unless defined $_; 156 # grr 5.6.1 157 confess "Wide character in '$_' intended as a C identifier" 158 if tr/\0-\377// != length; 159 # grr 5.6.1 moreso because its regexps will break on data that happens to 160 # be utf8, which includes my 8 bit test cases. 161 $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56; 162 s/\\/\\\\/g; 163 s/([\"\'])/\\$1/g; # Grr. fix perl mode. 164 s/\n/\\n/g; # Ensure newlines don't end up in octal 165 s/\r/\\r/g; 166 s/\t/\\t/g; 167 s/\f/\\f/g; 168 s/\a/\\a/g; 169 s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; 170 unless ($] < 5.006) { 171 # This will elicit a warning on 5.005_03 about [: :] being reserved unless 172 # I cheat 173 my $cheat = '([[:^print:]])'; 174 s/$cheat/sprintf "\\%03o", ord $1/ge; 175 } else { 176 require POSIX; 177 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; 178 } 179 $_; 180} 181 182=item perl_stringify NAME 183 184A function which returns a 7 bit ASCII correctly \ escaped version of the 185string passed suitable for a perl "" string. 186 187=cut 188 189# Hopefully make a happy perl identifier. 190sub perl_stringify { 191 local $_ = shift; 192 return unless defined $_; 193 s/\\/\\\\/g; 194 s/([\"\'])/\\$1/g; # Grr. fix perl mode. 195 s/\n/\\n/g; # Ensure newlines don't end up in octal 196 s/\r/\\r/g; 197 s/\t/\\t/g; 198 s/\f/\\f/g; 199 s/\a/\\a/g; 200 unless ($] < 5.006) { 201 if ($] > 5.007) { 202 s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; 203 } else { 204 # Grr 5.6.1. And I don't think I can use utf8; to force the regexp 205 # because 5.005_03 will fail. 206 # This is grim, but I also can't split on // 207 my $copy; 208 foreach my $index (0 .. length ($_) - 1) { 209 my $char = substr ($_, $index, 1); 210 $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; 211 } 212 $_ = $copy; 213 } 214 # This will elicit a warning on 5.005_03 about [: :] being reserved unless 215 # I cheat 216 my $cheat = '([[:^print:]])'; 217 s/$cheat/sprintf "\\%03o", ord $1/ge; 218 } else { 219 # Turns out "\x{}" notation only arrived with 5.6 220 s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; 221 require POSIX; 222 s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; 223 } 224 $_; 225} 226 227=item constant_types 228 229A function returning a single scalar with C<#define> definitions for the 230constants used internally between the generated C and XS functions. 231 232=cut 233 234sub constant_types () { 235 my $start = 1; 236 my @lines; 237 push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; 238 push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; 239 foreach (sort keys %XS_Constant) { 240 next if $_ eq ''; 241 push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; 242 } 243 push @lines, << 'EOT'; 244 245#ifndef NVTYPE 246typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ 247#endif 248#ifndef aTHX_ 249#define aTHX_ /* 5.6 or later define this for threading support. */ 250#endif 251#ifndef pTHX_ 252#define pTHX_ /* 5.6 or later define this for threading support. */ 253#endif 254EOT 255 256 return join '', @lines; 257} 258 259=item memEQ_clause NAME, CHECKED_AT, INDENT 260 261A function to return a suitable C C<if> statement to check whether I<NAME> 262is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it 263is used to avoid C<memEQ> for short names, or to generate a comment to 264highlight the position of the character in the C<switch> statement. 265 266If I<CHECKED_AT> is a reference to a scalar, then instead it gives 267the characters pre-checked at the beginning, (and the number of chars by 268which the C variable name has been advanced. These need to be chopped from 269the front of I<NAME>). 270 271=cut 272 273sub memEQ_clause { 274# if (memEQ(name, "thingy", 6)) { 275 # Which could actually be a character comparison or even "" 276 my ($name, $checked_at, $indent) = @_; 277 $indent = ' ' x ($indent || 4); 278 my $front_chop; 279 if (ref $checked_at) { 280 # regexp won't work on 5.6.1 without use utf8; in turn that won't work 281 # on 5.005_03. 282 substr ($name, 0, length $$checked_at,) = ''; 283 $front_chop = C_stringify ($$checked_at); 284 undef $checked_at; 285 } 286 my $len = length $name; 287 288 if ($len < 2) { 289 return $indent . "{\n" if (defined $checked_at and $checked_at == 0); 290 # We didn't switch, drop through to the code for the 2 character string 291 $checked_at = 1; 292 } 293 if ($len < 3 and defined $checked_at) { 294 my $check; 295 if ($checked_at == 1) { 296 $check = 0; 297 } elsif ($checked_at == 0) { 298 $check = 1; 299 } 300 if (defined $check) { 301 my $char = C_stringify (substr $name, $check, 1); 302 return $indent . "if (name[$check] == '$char') {\n"; 303 } 304 } 305 if (($len == 2 and !defined $checked_at) 306 or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { 307 my $char1 = C_stringify (substr $name, 0, 1); 308 my $char2 = C_stringify (substr $name, 1, 1); 309 return $indent . "if (name[0] == '$char1' && name[1] == '$char2') {\n"; 310 } 311 if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { 312 my $char1 = C_stringify (substr $name, 0, 1); 313 my $char2 = C_stringify (substr $name, 2, 1); 314 return $indent . "if (name[0] == '$char1' && name[2] == '$char2') {\n"; 315 } 316 317 my $pointer = '^'; 318 my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; 319 if ($have_checked_last) { 320 # Checked at the last character, so no need to memEQ it. 321 $pointer = C_stringify (chop $name); 322 $len--; 323 } 324 325 $name = C_stringify ($name); 326 my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n"; 327 # Put a little ^ under the letter we checked at 328 # Screws up for non printable and non-7 bit stuff, but that's too hard to 329 # get right. 330 if (defined $checked_at) { 331 $body .= $indent . "/* ". (' ' x $checked_at) . $pointer 332 . (' ' x ($len - $checked_at + length $len)) . " */\n"; 333 } elsif (defined $front_chop) { 334 $body .= $indent . "/* $front_chop" 335 . (' ' x ($len + 1 + length $len)) . " */\n"; 336 } 337 return $body; 338} 339 340=item assign INDENT, TYPE, PRE, POST, VALUE... 341 342A function to return a suitable assignment clause. If I<TYPE> is aggregate 343(eg I<PVN> expects both pointer and length) then there should be multiple 344I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets 345of C code to proceed and follow the assignment. I<PRE> will be at the start 346of a block, so variables may be defined in it. 347 348=cut 349 350# Hmm. value undef to to NOTDEF? value () to do NOTFOUND? 351 352sub assign { 353 my $indent = shift; 354 my $type = shift; 355 my $pre = shift; 356 my $post = shift || ''; 357 my $clause; 358 my $close; 359 if ($pre) { 360 chomp $pre; 361 $clause = $indent . "{\n$pre"; 362 $clause .= ";" unless $pre =~ /;$/; 363 $clause .= "\n"; 364 $close = "$indent}\n"; 365 $indent .= " "; 366 } 367 confess "undef \$type" unless defined $type; 368 confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type}; 369 my $typeset = $XS_TypeSet{$type}; 370 if (ref $typeset) { 371 die "Type $type is aggregate, but only single value given" 372 if @_ == 1; 373 foreach (0 .. $#$typeset) { 374 $clause .= $indent . "$typeset->[$_] $_[$_];\n"; 375 } 376 } elsif (defined $typeset) { 377 die "Aggregate value given for type $type" 378 if @_ > 1; 379 $clause .= $indent . "$typeset $_[0];\n"; 380 } 381 chomp $post; 382 if (length $post) { 383 $clause .= "$post"; 384 $clause .= ";" unless $post =~ /;$/; 385 $clause .= "\n"; 386 } 387 $clause .= "${indent}return PERL_constant_IS$type;\n"; 388 $clause .= $close if $close; 389 return $clause; 390} 391 392=item return_clause 393 394return_clause ITEM, INDENT 395 396A function to return a suitable C<#ifdef> clause. I<ITEM> is a hashref 397(as passed to C<C_constant> and C<match_clause>. I<INDENT> is the number 398of spaces to indent, defaulting to 6. 399 400=cut 401 402sub return_clause ($$) { 403##ifdef thingy 404# *iv_return = thingy; 405# return PERL_constant_ISIV; 406##else 407# return PERL_constant_NOTDEF; 408##endif 409 my ($item, $indent) = @_; 410 411 my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post, $type) 412 = @$item{qw (name value macro default pre post def_pre def_post type)}; 413 $value = $name unless defined $value; 414 $macro = $name unless defined $macro; 415 416 $macro = $value unless defined $macro; 417 $indent = ' ' x ($indent || 6); 418 unless ($type) { 419 # use Data::Dumper; print STDERR Dumper ($item); 420 confess "undef \$type"; 421 } 422 423 my $clause; 424 425 ##ifdef thingy 426 if (ref $macro) { 427 $clause = $macro->[0]; 428 } elsif ($macro ne "1") { 429 $clause = "#ifdef $macro\n"; 430 } 431 432 # *iv_return = thingy; 433 # return PERL_constant_ISIV; 434 $clause .= assign ($indent, $type, $pre, $post, 435 ref $value ? @$value : $value); 436 437 if (ref $macro or $macro ne "1") { 438 ##else 439 $clause .= "#else\n"; 440 441 # return PERL_constant_NOTDEF; 442 if (!defined $default) { 443 $clause .= "${indent}return PERL_constant_NOTDEF;\n"; 444 } else { 445 my @default = ref $default ? @$default : $default; 446 $type = shift @default; 447 $clause .= assign ($indent, $type, $def_pre, $def_post, @default); 448 } 449 450 ##endif 451 if (ref $macro) { 452 $clause .= $macro->[1]; 453 } else { 454 $clause .= "#endif\n"; 455 } 456 } 457 return $clause; 458} 459 460=pod 461 462XXX document me 463 464=cut 465 466sub match_clause { 467 # $offset defined if we have checked an offset. 468 my ($item, $offset, $indent) = @_; 469 $indent = ' ' x ($indent || 4); 470 my $body = ''; 471 my ($no, $yes, $either, $name, $inner_indent); 472 if (ref $item eq 'ARRAY') { 473 ($yes, $no) = @$item; 474 $either = $yes || $no; 475 confess "$item is $either expecting hashref in [0] || [1]" 476 unless ref $either eq 'HASH'; 477 $name = $either->{name}; 478 } else { 479 confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" 480 if $item->{utf8}; 481 $name = $item->{name}; 482 $inner_indent = $indent; 483 } 484 485 $body .= memEQ_clause ($name, $offset, length $indent); 486 if ($yes) { 487 $body .= $indent . " if (utf8) {\n"; 488 } elsif ($no) { 489 $body .= $indent . " if (!utf8) {\n"; 490 } 491 if ($either) { 492 $body .= return_clause ($either, 4 + length $indent); 493 if ($yes and $no) { 494 $body .= $indent . " } else {\n"; 495 $body .= return_clause ($no, 4 + length $indent); 496 } 497 $body .= $indent . " }\n"; 498 } else { 499 $body .= return_clause ($item, 2 + length $indent); 500 } 501 $body .= $indent . "}\n"; 502} 503 504=item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM... 505 506An internal function to generate a suitable C<switch> clause, called by 507C<C_constant> I<ITEM>s are in the hash ref format as given in the description 508of C<C_constant>, and must all have the names of the same length, given by 509I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash, 510keyed by name, values being the hashrefs in the I<ITEM> list. 511(No parameters are modified, and there can be keys in the I<ITEMHASH> that 512are not in the list of I<ITEM>s without causing problems). 513 514=cut 515 516sub switch_clause { 517 my ($indent, $comment, $namelen, $items, @items) = @_; 518 $indent = ' ' x ($indent || 2); 519 520 my @names = sort map {$_->{name}} @items; 521 my $leader = $indent . '/* '; 522 my $follower = ' ' x length $leader; 523 my $body = $indent . "/* Names all of length $namelen. */\n"; 524 if ($comment) { 525 $body = wrap ($leader, $follower, $comment) . "\n"; 526 $leader = $follower; 527 } 528 my @safe_names = @names; 529 foreach (@safe_names) { 530 confess sprintf "Name '$_' is length %d, not $namelen", length 531 unless length == $namelen; 532 # Argh. 5.6.1 533 # next unless tr/A-Za-z0-9_//c; 534 next if tr/A-Za-z0-9_// == length; 535 $_ = '"' . perl_stringify ($_) . '"'; 536 # Ensure that the enclosing C comment doesn't end 537 # by turning */ into *" . "/ 538 s!\*\/!\*"."/!gs; 539 # gcc -Wall doesn't like finding /* inside a comment 540 s!\/\*!/"."\*!gs; 541 } 542 $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; 543 # Figure out what to switch on. 544 # (RMS, Spread of jump table, Position, Hashref) 545 my @best = (1e38, ~0); 546 # Prefer the last character over the others. (As it lets us shortern the 547 # memEQ clause at no cost). 548 foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { 549 my ($min, $max) = (~0, 0); 550 my %spread; 551 if ($is_perl56) { 552 # Need proper Unicode preserving hash keys for bytes in range 128-255 553 # here too, for some reason. grr 5.6.1 yet again. 554 tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; 555 } 556 foreach (@names) { 557 my $char = substr $_, $i, 1; 558 my $ord = ord $char; 559 confess "char $ord is out of range" if $ord > 255; 560 $max = $ord if $ord > $max; 561 $min = $ord if $ord < $min; 562 push @{$spread{$char}}, $_; 563 # warn "$_ $char"; 564 } 565 # I'm going to pick the character to split on that minimises the root 566 # mean square of the number of names in each case. Normally this should 567 # be the one with the most keys, but it may pick a 7 where the 8 has 568 # one long linear search. I'm not sure if RMS or just sum of squares is 569 # actually better. 570 # $max and $min are for the tie-breaker if the root mean squares match. 571 # Assuming that the compiler may be building a jump table for the 572 # switch() then try to minimise the size of that jump table. 573 # Finally use < not <= so that if it still ties the earliest part of 574 # the string wins. Because if that passes but the memEQ fails, it may 575 # only need the start of the string to bin the choice. 576 # I think. But I'm micro-optimising. :-) 577 # OK. Trump that. Now favour the last character of the string, before the 578 # rest. 579 my $ss; 580 $ss += @$_ * @$_ foreach values %spread; 581 my $rms = sqrt ($ss / keys %spread); 582 if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { 583 @best = ($rms, $max - $min, $i, \%spread); 584 } 585 } 586 confess "Internal error. Failed to pick a switch point for @names" 587 unless defined $best[2]; 588 # use Data::Dumper; print Dumper (@best); 589 my ($offset, $best) = @best[2,3]; 590 $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; 591 592 my $do_front_chop = $offset == 0 && $namelen > 2; 593 if ($do_front_chop) { 594 $body .= $indent . "switch (*name++) {\n"; 595 } else { 596 $body .= $indent . "switch (name[$offset]) {\n"; 597 } 598 foreach my $char (sort keys %$best) { 599 confess sprintf "'$char' is %d bytes long, not 1", length $char 600 if length ($char) != 1; 601 confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; 602 $body .= $indent . "case '" . C_stringify ($char) . "':\n"; 603 foreach my $name (sort @{$best->{$char}}) { 604 my $thisone = $items->{$name}; 605 # warn "You are here"; 606 if ($do_front_chop) { 607 $body .= match_clause ($thisone, \$char, 2 + length $indent); 608 } else { 609 $body .= match_clause ($thisone, $offset, 2 + length $indent); 610 } 611 } 612 $body .= $indent . " break;\n"; 613 } 614 $body .= $indent . "}\n"; 615 return $body; 616} 617 618=item params WHAT 619 620An internal function. I<WHAT> should be a hashref of types the constant 621function will return. I<params> returns a hashref keyed IV NV PV SV to show 622which combination of pointers will be needed in the C argument list. 623 624=cut 625 626sub params { 627 my $what = shift; 628 foreach (sort keys %$what) { 629 warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; 630 } 631 my $params = {}; 632 $params->{''} = 1 if $what->{''}; 633 $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; 634 $params->{NV} = 1 if $what->{NV}; 635 $params->{PV} = 1 if $what->{PV} || $what->{PVN}; 636 $params->{SV} = 1 if $what->{SV}; 637 return $params; 638} 639 640=item dump_names 641 642dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM... 643 644An internal function to generate the embedded perl code that will regenerate 645the constant subroutines. I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the 646same as for C_constant. I<INDENT> is treated as number of spaces to indent 647by. I<OPTIONS> is a hashref of options. Currently only C<declare_types> is 648recognised. If the value is true a C<$types> is always declared in the perl 649code generated, if defined and false never declared, and if undefined C<$types> 650is only declared if the values in I<TYPES> as passed in cannot be inferred from 651I<DEFAULT_TYPES> and the I<ITEM>s. 652 653=cut 654 655sub dump_names { 656 my ($default_type, $what, $indent, $options, @items) = @_; 657 my $declare_types = $options->{declare_types}; 658 $indent = ' ' x ($indent || 0); 659 660 my $result; 661 my (@simple, @complex, %used_types); 662 foreach (@items) { 663 my $type; 664 if (ref $_) { 665 $type = $_->{type} || $default_type; 666 if ($_->{utf8}) { 667 # For simplicity always skip the bytes case, and reconstitute this entry 668 # from its utf8 twin. 669 next if $_->{utf8} eq 'no'; 670 # Copy the hashref, as we don't want to mess with the caller's hashref. 671 $_ = {%$_}; 672 unless ($is_perl56) { 673 utf8::decode ($_->{name}); 674 } else { 675 $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; 676 } 677 delete $_->{utf8}; 678 } 679 } else { 680 $_ = {name=>$_}; 681 $type = $default_type; 682 } 683 $used_types{$type}++; 684 if ($type eq $default_type 685 # grr 5.6.1 686 and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) 687 and !defined ($_->{macro}) and !defined ($_->{value}) 688 and !defined ($_->{default}) and !defined ($_->{pre}) 689 and !defined ($_->{post}) and !defined ($_->{def_pre}) 690 and !defined ($_->{def_post})) { 691 # It's the default type, and the name consists only of A-Za-z0-9_ 692 push @simple, $_->{name}; 693 } else { 694 push @complex, $_; 695 } 696 } 697 698 if (!defined $declare_types) { 699 # Do they pass in any types we weren't already using? 700 foreach (keys %$what) { 701 next if $used_types{$_}; 702 $declare_types++; # Found one in $what that wasn't used. 703 last; # And one is enough to terminate this loop 704 } 705 } 706 if ($declare_types) { 707 $result = $indent . 'my $types = {map {($_, 1)} qw(' 708 . join (" ", sort keys %$what) . ")};\n"; 709 } 710 $result .= wrap ($indent . "my \@names = (qw(", 711 $indent . " ", join (" ", sort @simple) . ")"); 712 if (@complex) { 713 foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { 714 my $name = perl_stringify $item->{name}; 715 my $line = ",\n$indent {name=>\"$name\""; 716 $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; 717 foreach my $thing (qw (macro value default pre post def_pre def_post)) { 718 my $value = $item->{$thing}; 719 if (defined $value) { 720 if (ref $value) { 721 $line .= ", $thing=>[\"" 722 . join ('", "', map {perl_stringify $_} @$value) . '"]'; 723 } else { 724 $line .= ", $thing=>\"" . perl_stringify($value) . "\""; 725 } 726 } 727 } 728 $line .= "}"; 729 # Ensure that the enclosing C comment doesn't end 730 # by turning */ into *" . "/ 731 $line =~ s!\*\/!\*" . "/!gs; 732 # gcc -Wall doesn't like finding /* inside a comment 733 $line =~ s!\/\*!/" . "\*!gs; 734 $result .= $line; 735 } 736 } 737 $result .= ");\n"; 738 739 $result; 740} 741 742 743=item dogfood 744 745dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... 746 747An internal function to generate the embedded perl code that will regenerate 748the constant subroutines. Parameters are the same as for C_constant. 749 750=cut 751 752sub dogfood { 753 my ($package, $subname, $default_type, $what, $indent, $breakout, @items) 754 = @_; 755 my $result = <<"EOT"; 756 /* When generated this function returned values for the list of names given 757 in this section of perl code. Rather than manually editing these functions 758 to add or remove constants, which would result in this comment and section 759 of code becoming inaccurate, we recommend that you edit this section of 760 code, and use it to regenerate a new set of constant functions which you 761 then use to replace the originals. 762 763 Regenerate these constant functions by feeding this entire source file to 764 perl -x 765 766#!$^X -w 767use ExtUtils::Constant qw (constant_types C_constant XS_constant); 768 769EOT 770 $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items); 771 $result .= <<'EOT'; 772 773print constant_types(); # macro defs 774EOT 775 $package = perl_stringify($package); 776 $result .= 777 "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; 778 # The form of the indent parameter isn't defined. (Yet) 779 if (defined $indent) { 780 require Data::Dumper; 781 $Data::Dumper::Terse=1; 782 $Data::Dumper::Terse=1; # Not used once. :-) 783 chomp ($indent = Data::Dumper::Dumper ($indent)); 784 $result .= $indent; 785 } else { 786 $result .= 'undef'; 787 } 788 $result .= ", $breakout" . ', @names) ) { 789 print $_, "\n"; # C constant subs 790} 791print "#### XS Section:\n"; 792print XS_constant ("' . $package . '", $types); 793__END__ 794 */ 795 796'; 797 798 $result; 799} 800 801=item C_constant 802 803C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM... 804 805A function that returns a B<list> of C subroutine definitions that return 806the value and type of constants when passed the name by the XS wrapper. 807I<ITEM...> gives a list of constant names. Each can either be a string, 808which is taken as a C macro name, or a reference to a hash with the following 809keys 810 811=over 8 812 813=item name 814 815The name of the constant, as seen by the perl code. 816 817=item type 818 819The type of the constant (I<IV>, I<NV> etc) 820 821=item value 822 823A C expression for the value of the constant, or a list of C expressions if 824the type is aggregate. This defaults to the I<name> if not given. 825 826=item macro 827 828The C pre-processor macro to use in the C<#ifdef>. This defaults to the 829I<name>, and is mainly used if I<value> is an C<enum>. If a reference an 830array is passed then the first element is used in place of the C<#ifdef> 831line, and the second element in place of the C<#endif>. This allows 832pre-processor constructions such as 833 834 #if defined (foo) 835 #if !defined (bar) 836 ... 837 #endif 838 #endif 839 840to be used to determine if a constant is to be defined. 841 842A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> 843test is omitted. 844 845=item default 846 847Default value to use (instead of C<croak>ing with "your vendor has not 848defined...") to return if the macro isn't defined. Specify a reference to 849an array with type followed by value(s). 850 851=item pre 852 853C code to use before the assignment of the value of the constant. This allows 854you to use temporary variables to extract a value from part of a C<struct> 855and return this as I<value>. This C code is places at the start of a block, 856so you can declare variables in it. 857 858=item post 859 860C code to place between the assignment of value (to a temporary) and the 861return from the function. This allows you to clear up anything in I<pre>. 862Rarely needed. 863 864=item def_pre 865=item def_post 866 867Equivalents of I<pre> and I<post> for the default value. 868 869=item utf8 870 871Generated internally. Is zero or undefined if name is 7 bit ASCII, 872"no" if the name is 8 bit (and so should only match if SvUTF8() is false), 873"yes" if the name is utf8 encoded. 874 875The internals automatically clone any name with characters 128-255 but none 876256+ (ie one that could be either in bytes or utf8) into a second entry 877which is utf8 encoded. 878 879=back 880 881I<PACKAGE> is the name of the package, and is only used in comments inside the 882generated C code. 883 884The next 5 arguments can safely be given as C<undef>, and are mainly used 885for recursion. I<SUBNAME> defaults to C<constant> if undefined. 886 887I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their 888type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma 889separated list of types that the C subroutine C<constant> will generate or as 890a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not 891present, as will any types given in the list of I<ITEM>s. The resultant list 892should be the same list of types that C<XS_constant> is given. [Otherwise 893C<XS_constant> and C<C_constant> may differ in the number of parameters to the 894constant function. I<INDENT> is currently unused and ignored. In future it may 895be used to pass in information used to change the C indentation style used.] 896The best way to maintain consistency is to pass in a hash reference and let 897this function update it. 898 899I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there 900are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code 901to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for 902example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is 9033. A single C<ITEM> is always inlined. 904 905=cut 906 907# The parameter now BREAKOUT was previously documented as: 908# 909# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of 910# this length, and that the constant name passed in by perl is checked and 911# also of this length. It is used during recursion, and should be C<undef> 912# unless the caller has checked all the lengths during code generation, and 913# the generated subroutine is only to be called with a name of this length. 914# 915# As you can see it now performs this function during recursion by being a 916# scalar reference. 917 918sub C_constant { 919 my ($package, $subname, $default_type, $what, $indent, $breakout, @items) 920 = @_; 921 $package ||= 'Foo'; 922 $subname ||= 'constant'; 923 # I'm not using this. But a hashref could be used for full formatting without 924 # breaking this API 925 # $indent ||= 0; 926 927 my ($namelen, $items); 928 if (ref $breakout) { 929 # We are called recursively. We trust @items to be normalised, $what to 930 # be a hashref, and pinch %$items from our parent to save recalculation. 931 ($namelen, $items) = @$breakout; 932 } else { 933 if ($is_perl56) { 934 # Need proper Unicode preserving hash keys. 935 $items = {}; 936 tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; 937 } 938 $breakout ||= 3; 939 $default_type ||= 'IV'; 940 if (!ref $what) { 941 # Convert line of the form IV,UV,NV to hash 942 $what = {map {$_ => 1} split /,\s*/, ($what || '')}; 943 # Figure out what types we're dealing with, and assign all unknowns to the 944 # default type 945 } 946 my @new_items; 947 foreach my $orig (@items) { 948 my ($name, $item); 949 if (ref $orig) { 950 # Make a copy which is a normalised version of the ref passed in. 951 $name = $orig->{name}; 952 my ($type, $macro, $value) = @$orig{qw (type macro value)}; 953 $type ||= $default_type; 954 $what->{$type} = 1; 955 $item = {name=>$name, type=>$type}; 956 957 undef $macro if defined $macro and $macro eq $name; 958 $item->{macro} = $macro if defined $macro; 959 undef $value if defined $value and $value eq $name; 960 $item->{value} = $value if defined $value; 961 foreach my $key (qw(default pre post def_pre def_post)) { 962 my $value = $orig->{$key}; 963 $item->{$key} = $value if defined $value; 964 # warn "$key $value"; 965 } 966 } else { 967 $name = $orig; 968 $item = {name=>$name, type=>$default_type}; 969 $what->{$default_type} = 1; 970 } 971 warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}}; 972 # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c 973 # doesn't work. Upgrade to 5.8 974 # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { 975 if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50) { 976 # No characters outside 7 bit ASCII. 977 if (exists $items->{$name}) { 978 die "Multiple definitions for macro $name"; 979 } 980 $items->{$name} = $item; 981 } else { 982 # No characters outside 8 bit. This is hardest. 983 if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { 984 confess "Unexpected ASCII definition for macro $name"; 985 } 986 # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; 987 # if ($name !~ tr/\0-\377//c) { 988 if ($name =~ tr/\0-\377// == length $name) { 989# if ($] < 5.007) { 990# $name = pack "C*", unpack "U*", $name; 991# } 992 $item->{utf8} = 'no'; 993 $items->{$name}[1] = $item; 994 push @new_items, $item; 995 # Copy item, to create the utf8 variant. 996 $item = {%$item}; 997 } 998 # Encode the name as utf8 bytes. 999 unless ($is_perl56) { 1000 utf8::encode($name); 1001 } else { 1002# warn "Was >$name< " . length ${name}; 1003 $name = pack 'C*', unpack 'C*', $name . pack 'U*'; 1004# warn "Now '${name}' " . length ${name}; 1005 } 1006 if ($items->{$name}[0]) { 1007 die "Multiple definitions for macro $name"; 1008 } 1009 $item->{utf8} = 'yes'; 1010 $item->{name} = $name; 1011 $items->{$name}[0] = $item; 1012 # We have need for the utf8 flag. 1013 $what->{''} = 1; 1014 } 1015 push @new_items, $item; 1016 } 1017 @items = @new_items; 1018 # use Data::Dumper; print Dumper @items; 1019 } 1020 my $params = params ($what); 1021 1022 my ($body, @subs) = "static int\n$subname (pTHX_ const char *name"; 1023 $body .= ", STRLEN len" unless defined $namelen; 1024 $body .= ", int utf8" if $params->{''}; 1025 $body .= ", IV *iv_return" if $params->{IV}; 1026 $body .= ", NV *nv_return" if $params->{NV}; 1027 $body .= ", const char **pv_return" if $params->{PV}; 1028 $body .= ", SV **sv_return" if $params->{SV}; 1029 $body .= ") {\n"; 1030 1031 if (defined $namelen) { 1032 # We are a child subroutine. Print the simple description 1033 my $comment = 'When generated this function returned values for the list' 1034 . ' of names given here. However, subsequent manual editing may have' 1035 . ' added or removed some.'; 1036 $body .= switch_clause (2, $comment, $namelen, $items, @items); 1037 } else { 1038 # We are the top level. 1039 $body .= " /* Initially switch on the length of the name. */\n"; 1040 $body .= dogfood ($package, $subname, $default_type, $what, $indent, 1041 $breakout, @items); 1042 $body .= " switch (len) {\n"; 1043 # Need to group names of the same length 1044 my @by_length; 1045 foreach (@items) { 1046 push @{$by_length[length $_->{name}]}, $_; 1047 } 1048 foreach my $i (0 .. $#by_length) { 1049 next unless $by_length[$i]; # None of this length 1050 $body .= " case $i:\n"; 1051 if (@{$by_length[$i]} == 1) { 1052 my $only_thing = $by_length[$i]->[0]; 1053 if ($only_thing->{utf8}) { 1054 if ($only_thing->{utf8} eq 'yes') { 1055 # With utf8 on flag item is passed in element 0 1056 $body .= match_clause ([$only_thing]); 1057 } else { 1058 # With utf8 off flag item is passed in element 1 1059 $body .= match_clause ([undef, $only_thing]); 1060 } 1061 } else { 1062 $body .= match_clause ($only_thing); 1063 } 1064 } elsif (@{$by_length[$i]} < $breakout) { 1065 $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]}); 1066 } else { 1067 # Only use the minimal set of parameters actually needed by the types 1068 # of the names of this length. 1069 my $what = {}; 1070 foreach (@{$by_length[$i]}) { 1071 $what->{$_->{type}} = 1; 1072 $what->{''} = 1 if $_->{utf8}; 1073 } 1074 $params = params ($what); 1075 push @subs, C_constant ($package, "${subname}_$i", $default_type, $what, 1076 $indent, [$i, $items], @{$by_length[$i]}); 1077 $body .= " return ${subname}_$i (aTHX_ name"; 1078 $body .= ", utf8" if $params->{''}; 1079 $body .= ", iv_return" if $params->{IV}; 1080 $body .= ", nv_return" if $params->{NV}; 1081 $body .= ", pv_return" if $params->{PV}; 1082 $body .= ", sv_return" if $params->{SV}; 1083 $body .= ");\n"; 1084 } 1085 $body .= " break;\n"; 1086 } 1087 $body .= " }\n"; 1088 } 1089 $body .= " return PERL_constant_NOTFOUND;\n}\n"; 1090 return (@subs, $body); 1091} 1092 1093=item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME 1094 1095A function to generate the XS code to implement the perl subroutine 1096I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. 1097This XS code is a wrapper around a C subroutine usually generated by 1098C<C_constant>, and usually named C<constant>. 1099 1100I<TYPES> should be given either as a comma separated list of types that the 1101C subroutine C<constant> will generate or as a reference to a hash. It should 1102be the same list of types as C<C_constant> was given. 1103[Otherwise C<XS_constant> and C<C_constant> may have different ideas about 1104the number of parameters passed to the C function C<constant>] 1105 1106You can call the perl visible subroutine something other than C<constant> if 1107you give the parameter I<SUBNAME>. The C subroutine it calls defaults to 1108the name of the perl visible subroutine, unless you give the parameter 1109I<C_SUBNAME>. 1110 1111=cut 1112 1113sub XS_constant { 1114 my $package = shift; 1115 my $what = shift; 1116 my $subname = shift; 1117 my $C_subname = shift; 1118 $subname ||= 'constant'; 1119 $C_subname ||= $subname; 1120 1121 if (!ref $what) { 1122 # Convert line of the form IV,UV,NV to hash 1123 $what = {map {$_ => 1} split /,\s*/, ($what)}; 1124 } 1125 my $params = params ($what); 1126 my $type; 1127 1128 my $xs = <<"EOT"; 1129void 1130$subname(sv) 1131 PREINIT: 1132#ifdef dXSTARG 1133 dXSTARG; /* Faster if we have it. */ 1134#else 1135 dTARGET; 1136#endif 1137 STRLEN len; 1138 int type; 1139EOT 1140 1141 if ($params->{IV}) { 1142 $xs .= " IV iv;\n"; 1143 } else { 1144 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; 1145 } 1146 if ($params->{NV}) { 1147 $xs .= " NV nv;\n"; 1148 } else { 1149 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; 1150 } 1151 if ($params->{PV}) { 1152 $xs .= " const char *pv;\n"; 1153 } else { 1154 $xs .= 1155 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; 1156 } 1157 1158 $xs .= << 'EOT'; 1159 INPUT: 1160 SV * sv; 1161 const char * s = SvPV(sv, len); 1162EOT 1163 if ($params->{''}) { 1164 $xs .= << 'EOT'; 1165 INPUT: 1166 int utf8 = SvUTF8(sv); 1167EOT 1168 } 1169 $xs .= << 'EOT'; 1170 PPCODE: 1171EOT 1172 1173 if ($params->{IV} xor $params->{NV}) { 1174 $xs .= << "EOT"; 1175 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); 1176 if you need to return both NVs and IVs */ 1177EOT 1178 } 1179 $xs .= " type = $C_subname(aTHX_ s, len"; 1180 $xs .= ', utf8' if $params->{''}; 1181 $xs .= ', &iv' if $params->{IV}; 1182 $xs .= ', &nv' if $params->{NV}; 1183 $xs .= ', &pv' if $params->{PV}; 1184 $xs .= ', &sv' if $params->{SV}; 1185 $xs .= ");\n"; 1186 1187 $xs .= << "EOT"; 1188 /* Return 1 or 2 items. First is error message, or undef if no error. 1189 Second, if present, is found value */ 1190 switch (type) { 1191 case PERL_constant_NOTFOUND: 1192 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); 1193 PUSHs(sv); 1194 break; 1195 case PERL_constant_NOTDEF: 1196 sv = sv_2mortal(newSVpvf( 1197 "Your vendor has not defined $package macro %s, used", s)); 1198 PUSHs(sv); 1199 break; 1200EOT 1201 1202 foreach $type (sort keys %XS_Constant) { 1203 # '' marks utf8 flag needed. 1204 next if $type eq ''; 1205 $xs .= "\t/* Uncomment this if you need to return ${type}s\n" 1206 unless $what->{$type}; 1207 $xs .= " case PERL_constant_IS$type:\n"; 1208 if (length $XS_Constant{$type}) { 1209 $xs .= << "EOT"; 1210 EXTEND(SP, 1); 1211 PUSHs(&PL_sv_undef); 1212 $XS_Constant{$type}; 1213EOT 1214 } else { 1215 # Do nothing. return (), which will be correctly interpreted as 1216 # (undef, undef) 1217 } 1218 $xs .= " break;\n"; 1219 unless ($what->{$type}) { 1220 chop $xs; # Yes, another need for chop not chomp. 1221 $xs .= " */\n"; 1222 } 1223 } 1224 $xs .= << "EOT"; 1225 default: 1226 sv = sv_2mortal(newSVpvf( 1227 "Unexpected return type %d while processing $package macro %s, used", 1228 type, s)); 1229 PUSHs(sv); 1230 } 1231EOT 1232 1233 return $xs; 1234} 1235 1236 1237=item autoload PACKAGE, VERSION, AUTOLOADER 1238 1239A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> 1240I<VERSION> is the perl version the code should be backwards compatible with. 1241It defaults to the version of perl running the subroutine. If I<AUTOLOADER> 1242is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all 1243names that the constant() routine doesn't recognise. 1244 1245=cut 1246 1247# ' # Grr. syntax highlighters that don't grok pod. 1248 1249sub autoload { 1250 my ($module, $compat_version, $autoloader) = @_; 1251 $compat_version ||= $]; 1252 croak "Can't maintain compatibility back as far as version $compat_version" 1253 if $compat_version < 5; 1254 my $func = "sub AUTOLOAD {\n" 1255 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" 1256 . " # XS function."; 1257 $func .= " If a constant is not found then control is passed\n" 1258 . " # to the AUTOLOAD in AutoLoader." if $autoloader; 1259 1260 1261 $func .= "\n\n" 1262 . " my \$constname;\n"; 1263 $func .= 1264 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); 1265 1266 $func .= <<"EOT"; 1267 (\$constname = \$AUTOLOAD) =~ s/.*:://; 1268 croak "&${module}::constant not defined" if \$constname eq 'constant'; 1269 my (\$error, \$val) = constant(\$constname); 1270EOT 1271 1272 if ($autoloader) { 1273 $func .= <<'EOT'; 1274 if ($error) { 1275 if ($error =~ /is not a valid/) { 1276 $AutoLoader::AUTOLOAD = $AUTOLOAD; 1277 goto &AutoLoader::AUTOLOAD; 1278 } else { 1279 croak $error; 1280 } 1281 } 1282EOT 1283 } else { 1284 $func .= 1285 " if (\$error) { croak \$error; }\n"; 1286 } 1287 1288 $func .= <<'END'; 1289 { 1290 no strict 'refs'; 1291 # Fixed between 5.005_53 and 5.005_61 1292#XXX if ($] >= 5.00561) { 1293#XXX *$AUTOLOAD = sub () { $val }; 1294#XXX } 1295#XXX else { 1296 *$AUTOLOAD = sub { $val }; 1297#XXX } 1298 } 1299 goto &$AUTOLOAD; 1300} 1301 1302END 1303 1304 return $func; 1305} 1306 1307 1308=item WriteMakefileSnippet 1309 1310WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 1311 1312A function to generate perl code for Makefile.PL that will regenerate 1313the constant subroutines. Parameters are named as passed to C<WriteConstants>, 1314with the addition of C<INDENT> to specify the number of leading spaces 1315(default 2). 1316 1317Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and 1318C<XS_FILE> are recognised. 1319 1320=cut 1321 1322sub WriteMakefileSnippet { 1323 my %args = @_; 1324 my $indent = $args{INDENT} || 2; 1325 1326 my $result = <<"EOT"; 1327ExtUtils::Constant::WriteConstants( 1328 NAME => '$args{NAME}', 1329 NAMES => \\\@names, 1330 DEFAULT_TYPE => '$args{DEFAULT_TYPE}', 1331EOT 1332 foreach (qw (C_FILE XS_FILE)) { 1333 next unless exists $args{$_}; 1334 $result .= sprintf " %-12s => '%s',\n", 1335 $_, $args{$_}; 1336 } 1337 $result .= <<'EOT'; 1338 ); 1339EOT 1340 1341 $result =~ s/^/' 'x$indent/gem; 1342 return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef, 1343 @{$args{NAMES}}) 1344 . $result; 1345} 1346 1347=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] 1348 1349Writes a file of C code and a file of XS code which you should C<#include> 1350and C<INCLUDE> in the C and XS sections respectively of your module's XS 1351code. You probably want to do this in your C<Makefile.PL>, so that you can 1352easily edit the list of constants without touching the rest of your module. 1353The attributes supported are 1354 1355=over 4 1356 1357=item NAME 1358 1359Name of the module. This must be specified 1360 1361=item DEFAULT_TYPE 1362 1363The default type for the constants. If not specified C<IV> is assumed. 1364 1365=item BREAKOUT_AT 1366 1367The names of the constants are grouped by length. Generate child subroutines 1368for each group with this number or more names in. 1369 1370=item NAMES 1371 1372An array of constants' names, either scalars containing names, or hashrefs 1373as detailed in L<"C_constant">. 1374 1375=item C_FILE 1376 1377The name of the file to write containing the C code. The default is 1378C<const-c.inc>. The C<-> in the name ensures that the file can't be 1379mistaken for anything related to a legitimate perl package name, and 1380not naming the file C<.c> avoids having to override Makefile.PL's 1381C<.xs> to C<.c> rules. 1382 1383=item XS_FILE 1384 1385The name of the file to write containing the XS code. The default is 1386C<const-xs.inc>. 1387 1388=item SUBNAME 1389 1390The perl visible name of the XS subroutine generated which will return the 1391constants. The default is C<constant>. 1392 1393=item C_SUBNAME 1394 1395The name of the C subroutine generated which will return the constants. 1396The default is I<SUBNAME>. Child subroutines have C<_> and the name 1397length appended, so constants with 10 character names would be in 1398C<constant_10> with the default I<XS_SUBNAME>. 1399 1400=back 1401 1402=cut 1403 1404sub WriteConstants { 1405 my %ARGS = 1406 ( # defaults 1407 C_FILE => 'const-c.inc', 1408 XS_FILE => 'const-xs.inc', 1409 SUBNAME => 'constant', 1410 DEFAULT_TYPE => 'IV', 1411 @_); 1412 1413 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0' 1414 1415 croak "Module name not specified" unless length $ARGS{NAME}; 1416 1417 open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; 1418 open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; 1419 1420 # As this subroutine is intended to make code that isn't edited, there's no 1421 # need for the user to specify any types that aren't found in the list of 1422 # names. 1423 my $types = {}; 1424 1425 print $c_fh constant_types(); # macro defs 1426 print $c_fh "\n"; 1427 1428 # indent is still undef. Until anyone implements indent style rules with it. 1429 foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE}, 1430 $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) { 1431 print $c_fh $_, "\n"; # C constant subs 1432 } 1433 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, 1434 $ARGS{C_SUBNAME}); 1435 1436 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!"; 1437 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!"; 1438} 1439 1440package ExtUtils::Constant::Aaargh56Hash; 1441# A support module (hack) to provide sane Unicode hash keys on 5.6.x perl 1442use strict; 1443require Tie::Hash if $ExtUtils::Constant::is_perl56; 1444use vars '@ISA'; 1445@ISA = 'Tie::StdHash'; 1446 1447#my $a; 1448# Storing the values as concatenated BER encoded numbers is actually going to 1449# be terser than using UTF8 :-) 1450# And the tests are slightly faster. Ops are bad, m'kay 1451sub to_key {pack "w*", unpack "U*", ($_[0] . pack "U*")}; 1452sub from_key {defined $_[0] ? pack "U*", unpack 'w*', $_[0] : undef}; 1453 1454sub STORE { $_[0]->{to_key($_[1])} = $_[2] } 1455sub FETCH { $_[0]->{to_key($_[1])} } 1456sub FIRSTKEY { my $a = scalar keys %{$_[0]}; from_key (each %{$_[0]}) } 1457sub NEXTKEY { from_key (each %{$_[0]}) } 1458sub EXISTS { exists $_[0]->{to_key($_[1])} } 1459sub DELETE { delete $_[0]->{to_key($_[1])} } 1460 1461#END {warn "$a accesses";} 14621; 1463__END__ 1464 1465=back 1466 1467=head1 AUTHOR 1468 1469Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and 1470others 1471 1472=cut 1473