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