1package ExtUtils::Constant; 2use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); 3$VERSION = '0.25'; 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 Carp qw(croak cluck); 98 99use Exporter; 100use ExtUtils::Constant::Utils qw(C_stringify); 101use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet); 102 103@ISA = 'Exporter'; 104 105%EXPORT_TAGS = ( 'all' => [ qw( 106 XS_constant constant_types return_clause memEQ_clause C_stringify 107 C_constant autoload WriteConstants WriteMakefileSnippet 108) ] ); 109 110@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 111 112=item constant_types 113 114A function returning a single scalar with C<#define> definitions for the 115constants used internally between the generated C and XS functions. 116 117=cut 118 119sub constant_types { 120 ExtUtils::Constant::XS->header(); 121} 122 123sub memEQ_clause { 124 cluck "ExtUtils::Constant::memEQ_clause is deprecated"; 125 ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1], 126 indent=>$_[2]}); 127} 128 129sub return_clause ($$) { 130 cluck "ExtUtils::Constant::return_clause is deprecated"; 131 my $indent = shift; 132 ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_); 133} 134 135sub switch_clause { 136 cluck "ExtUtils::Constant::switch_clause is deprecated"; 137 my $indent = shift; 138 my $comment = shift; 139 ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment}, 140 @_); 141} 142 143sub C_constant { 144 my ($package, $subname, $default_type, $what, $indent, $breakout, @items) 145 = @_; 146 ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname, 147 default_type => $default_type, 148 types => $what, indent => $indent, 149 breakout => $breakout}, @items); 150} 151 152=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME 153 154A function to generate the XS code to implement the perl subroutine 155I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. 156This XS code is a wrapper around a C subroutine usually generated by 157C<C_constant>, and usually named C<constant>. 158 159I<TYPES> should be given either as a comma separated list of types that the 160C subroutine C<constant> will generate or as a reference to a hash. It should 161be the same list of types as C<C_constant> was given. 162[Otherwise C<XS_constant> and C<C_constant> may have different ideas about 163the number of parameters passed to the C function C<constant>] 164 165You can call the perl visible subroutine something other than C<constant> if 166you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to 167the name of the perl visible subroutine, unless you give the parameter 168I<C_SUBNAME>. 169 170=cut 171 172sub XS_constant { 173 my $package = shift; 174 my $what = shift; 175 my $XS_subname = shift; 176 my $C_subname = shift; 177 $XS_subname ||= 'constant'; 178 $C_subname ||= $XS_subname; 179 180 if (!ref $what) { 181 # Convert line of the form IV,UV,NV to hash 182 $what = {map {$_ => 1} split /,\s*/, ($what)}; 183 } 184 my $params = ExtUtils::Constant::XS->params ($what); 185 my $type; 186 187 my $xs = <<"EOT"; 188void 189$XS_subname(sv) 190 PREINIT: 191#ifdef dXSTARG 192 dXSTARG; /* Faster if we have it. */ 193#else 194 dTARGET; 195#endif 196 STRLEN len; 197 int type; 198EOT 199 200 if ($params->{IV}) { 201 $xs .= " IV iv = 0; /* avoid uninit var warning */\n"; 202 } else { 203 $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; 204 } 205 if ($params->{NV}) { 206 $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n"; 207 } else { 208 $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; 209 } 210 if ($params->{PV}) { 211 $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n"; 212 } else { 213 $xs .= 214 " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; 215 } 216 217 $xs .= << 'EOT'; 218 INPUT: 219 SV * sv; 220 const char * s = SvPV(sv, len); 221EOT 222 if ($params->{''}) { 223 $xs .= << 'EOT'; 224 INPUT: 225 int utf8 = SvUTF8(sv); 226EOT 227 } 228 $xs .= << 'EOT'; 229 PPCODE: 230EOT 231 232 if ($params->{IV} xor $params->{NV}) { 233 $xs .= << "EOT"; 234 /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); 235 if you need to return both NVs and IVs */ 236EOT 237 } 238 $xs .= " type = $C_subname(aTHX_ s, len"; 239 $xs .= ', utf8' if $params->{''}; 240 $xs .= ', &iv' if $params->{IV}; 241 $xs .= ', &nv' if $params->{NV}; 242 $xs .= ', &pv' if $params->{PV}; 243 $xs .= ', &sv' if $params->{SV}; 244 $xs .= ");\n"; 245 246 # If anyone is insane enough to suggest a package name containing % 247 my $package_sprintf_safe = $package; 248 $package_sprintf_safe =~ s/%/%%/g; 249 250 $xs .= << "EOT"; 251 /* Return 1 or 2 items. First is error message, or undef if no error. 252 Second, if present, is found value */ 253 switch (type) { 254 case PERL_constant_NOTFOUND: 255 sv = 256 sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s)); 257 PUSHs(sv); 258 break; 259 case PERL_constant_NOTDEF: 260 sv = sv_2mortal(newSVpvf( 261 "Your vendor has not defined $package_sprintf_safe macro %s, used", 262 s)); 263 PUSHs(sv); 264 break; 265EOT 266 267 foreach $type (sort keys %XS_Constant) { 268 # '' marks utf8 flag needed. 269 next if $type eq ''; 270 $xs .= "\t/* Uncomment this if you need to return ${type}s\n" 271 unless $what->{$type}; 272 $xs .= " case PERL_constant_IS$type:\n"; 273 if (length $XS_Constant{$type}) { 274 $xs .= << "EOT"; 275 EXTEND(SP, 2); 276 PUSHs(&PL_sv_undef); 277 $XS_Constant{$type}; 278EOT 279 } else { 280 # Do nothing. return (), which will be correctly interpreted as 281 # (undef, undef) 282 } 283 $xs .= " break;\n"; 284 unless ($what->{$type}) { 285 chop $xs; # Yes, another need for chop not chomp. 286 $xs .= " */\n"; 287 } 288 } 289 $xs .= << "EOT"; 290 default: 291 sv = sv_2mortal(newSVpvf( 292 "Unexpected return type %d while processing $package_sprintf_safe macro %s, used", 293 type, s)); 294 PUSHs(sv); 295 } 296EOT 297 298 return $xs; 299} 300 301 302=item autoload PACKAGE, VERSION, AUTOLOADER 303 304A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> 305I<VERSION> is the perl version the code should be backwards compatible with. 306It defaults to the version of perl running the subroutine. If I<AUTOLOADER> 307is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all 308names that the constant() routine doesn't recognise. 309 310=cut 311 312# ' # Grr. syntax highlighters that don't grok pod. 313 314sub autoload { 315 my ($module, $compat_version, $autoloader) = @_; 316 $compat_version ||= $]; 317 croak "Can't maintain compatibility back as far as version $compat_version" 318 if $compat_version < 5; 319 my $func = "sub AUTOLOAD {\n" 320 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" 321 . " # XS function."; 322 $func .= " If a constant is not found then control is passed\n" 323 . " # to the AUTOLOAD in AutoLoader." if $autoloader; 324 325 326 $func .= "\n\n" 327 . " my \$constname;\n"; 328 $func .= 329 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); 330 331 $func .= <<"EOT"; 332 (\$constname = \$AUTOLOAD) =~ s/.*:://; 333 croak "&${module}::constant not defined" if \$constname eq 'constant'; 334 my (\$error, \$val) = constant(\$constname); 335EOT 336 337 if ($autoloader) { 338 $func .= <<'EOT'; 339 if ($error) { 340 if ($error =~ /is not a valid/) { 341 $AutoLoader::AUTOLOAD = $AUTOLOAD; 342 goto &AutoLoader::AUTOLOAD; 343 } else { 344 croak $error; 345 } 346 } 347EOT 348 } else { 349 $func .= 350 " if (\$error) { croak \$error; }\n"; 351 } 352 353 $func .= <<'END'; 354 { 355 no strict 'refs'; 356 # Fixed between 5.005_53 and 5.005_61 357#XXX if ($] >= 5.00561) { 358#XXX *$AUTOLOAD = sub () { $val }; 359#XXX } 360#XXX else { 361 *$AUTOLOAD = sub { $val }; 362#XXX } 363 } 364 goto &$AUTOLOAD; 365} 366 367END 368 369 return $func; 370} 371 372 373=item WriteMakefileSnippet 374 375WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 376 377A function to generate perl code for Makefile.PL that will regenerate 378the constant subroutines. Parameters are named as passed to C<WriteConstants>, 379with the addition of C<INDENT> to specify the number of leading spaces 380(default 2). 381 382Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and 383C<XS_FILE> are recognised. 384 385=cut 386 387sub WriteMakefileSnippet { 388 my %args = @_; 389 my $indent = $args{INDENT} || 2; 390 391 my $result = <<"EOT"; 392ExtUtils::Constant::WriteConstants( 393 NAME => '$args{NAME}', 394 NAMES => \\\@names, 395 DEFAULT_TYPE => '$args{DEFAULT_TYPE}', 396EOT 397 foreach (qw (C_FILE XS_FILE)) { 398 next unless exists $args{$_}; 399 $result .= sprintf " %-12s => '%s',\n", 400 $_, $args{$_}; 401 } 402 $result .= <<'EOT'; 403 ); 404EOT 405 406 $result =~ s/^/' 'x$indent/gem; 407 return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, 408 indent=>$indent,}, 409 @{$args{NAMES}}) 410 . $result; 411} 412 413=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] 414 415Writes a file of C code and a file of XS code which you should C<#include> 416and C<INCLUDE> in the C and XS sections respectively of your module's XS 417code. You probably want to do this in your C<Makefile.PL>, so that you can 418easily edit the list of constants without touching the rest of your module. 419The attributes supported are 420 421=over 4 422 423=item NAME 424 425Name of the module. This must be specified 426 427=item DEFAULT_TYPE 428 429The default type for the constants. If not specified C<IV> is assumed. 430 431=item BREAKOUT_AT 432 433The names of the constants are grouped by length. Generate child subroutines 434for each group with this number or more names in. 435 436=item NAMES 437 438An array of constants' names, either scalars containing names, or hashrefs 439as detailed in L<"C_constant">. 440 441=item PROXYSUBS 442 443If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>. 444 445=item C_FH 446 447A filehandle to write the C code to. If not given, then I<C_FILE> is opened 448for writing. 449 450=item C_FILE 451 452The name of the file to write containing the C code. The default is 453C<const-c.inc>. The C<-> in the name ensures that the file can't be 454mistaken for anything related to a legitimate perl package name, and 455not naming the file C<.c> avoids having to override Makefile.PL's 456C<.xs> to C<.c> rules. 457 458=item XS_FH 459 460A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened 461for writing. 462 463=item XS_FILE 464 465The name of the file to write containing the XS code. The default is 466C<const-xs.inc>. 467 468=item XS_SUBNAME 469 470The perl visible name of the XS subroutine generated which will return the 471constants. The default is C<constant>. 472 473=item C_SUBNAME 474 475The name of the C subroutine generated which will return the constants. 476The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name 477length appended, so constants with 10 character names would be in 478C<constant_10> with the default I<XS_SUBNAME>. 479 480=back 481 482=cut 483 484sub WriteConstants { 485 my %ARGS = 486 ( # defaults 487 C_FILE => 'const-c.inc', 488 XS_FILE => 'const-xs.inc', 489 XS_SUBNAME => 'constant', 490 DEFAULT_TYPE => 'IV', 491 @_); 492 493 $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0' 494 495 croak "Module name not specified" unless length $ARGS{NAME}; 496 497 # Do this before creating (empty) files, in case it fails: 498 require ExtUtils::Constant::ProxySubs if $ARGS{PROXYSUBS}; 499 500 my $c_fh = $ARGS{C_FH}; 501 if (!$c_fh) { 502 if ($] <= 5.008) { 503 # We need these little games, rather than doing things 504 # unconditionally, because we're used in core Makefile.PLs before 505 # IO is available (needed by filehandle), but also we want to work on 506 # older perls where undefined scalars do not automatically turn into 507 # anonymous file handles. 508 require FileHandle; 509 $c_fh = FileHandle->new(); 510 } 511 open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; 512 } 513 514 my $xs_fh = $ARGS{XS_FH}; 515 if (!$xs_fh) { 516 if ($] <= 5.008) { 517 require FileHandle; 518 $xs_fh = FileHandle->new(); 519 } 520 open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; 521 } 522 523 # As this subroutine is intended to make code that isn't edited, there's no 524 # need for the user to specify any types that aren't found in the list of 525 # names. 526 527 if ($ARGS{PROXYSUBS}) { 528 $ARGS{C_FH} = $c_fh; 529 $ARGS{XS_FH} = $xs_fh; 530 ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS); 531 } else { 532 my $types = {}; 533 534 print $c_fh constant_types(); # macro defs 535 print $c_fh "\n"; 536 537 # indent is still undef. Until anyone implements indent style rules with 538 # it. 539 foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, 540 subname => $ARGS{C_SUBNAME}, 541 default_type => 542 $ARGS{DEFAULT_TYPE}, 543 types => $types, 544 breakout => 545 $ARGS{BREAKOUT_AT}}, 546 @{$ARGS{NAMES}})) { 547 print $c_fh $_, "\n"; # C constant subs 548 } 549 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, 550 $ARGS{C_SUBNAME}); 551 } 552 553 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH}; 554 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH}; 555} 556 5571; 558__END__ 559 560=back 561 562=head1 AUTHOR 563 564Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and 565others 566 567=cut 568