1package ExtUtils::Constant; 2use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); 3$VERSION = 0.17; 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, 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<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 $subname = shift; 176 my $C_subname = shift; 177 $subname ||= 'constant'; 178 $C_subname ||= $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$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;\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;\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;\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 $xs .= << "EOT"; 247 /* Return 1 or 2 items. First is error message, or undef if no error. 248 Second, if present, is found value */ 249 switch (type) { 250 case PERL_constant_NOTFOUND: 251 sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); 252 PUSHs(sv); 253 break; 254 case PERL_constant_NOTDEF: 255 sv = sv_2mortal(newSVpvf( 256 "Your vendor has not defined $package macro %s, used", s)); 257 PUSHs(sv); 258 break; 259EOT 260 261 foreach $type (sort keys %XS_Constant) { 262 # '' marks utf8 flag needed. 263 next if $type eq ''; 264 $xs .= "\t/* Uncomment this if you need to return ${type}s\n" 265 unless $what->{$type}; 266 $xs .= " case PERL_constant_IS$type:\n"; 267 if (length $XS_Constant{$type}) { 268 $xs .= << "EOT"; 269 EXTEND(SP, 1); 270 PUSHs(&PL_sv_undef); 271 $XS_Constant{$type}; 272EOT 273 } else { 274 # Do nothing. return (), which will be correctly interpreted as 275 # (undef, undef) 276 } 277 $xs .= " break;\n"; 278 unless ($what->{$type}) { 279 chop $xs; # Yes, another need for chop not chomp. 280 $xs .= " */\n"; 281 } 282 } 283 $xs .= << "EOT"; 284 default: 285 sv = sv_2mortal(newSVpvf( 286 "Unexpected return type %d while processing $package macro %s, used", 287 type, s)); 288 PUSHs(sv); 289 } 290EOT 291 292 return $xs; 293} 294 295 296=item autoload PACKAGE, VERSION, AUTOLOADER 297 298A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> 299I<VERSION> is the perl version the code should be backwards compatible with. 300It defaults to the version of perl running the subroutine. If I<AUTOLOADER> 301is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all 302names that the constant() routine doesn't recognise. 303 304=cut 305 306# ' # Grr. syntax highlighters that don't grok pod. 307 308sub autoload { 309 my ($module, $compat_version, $autoloader) = @_; 310 $compat_version ||= $]; 311 croak "Can't maintain compatibility back as far as version $compat_version" 312 if $compat_version < 5; 313 my $func = "sub AUTOLOAD {\n" 314 . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" 315 . " # XS function."; 316 $func .= " If a constant is not found then control is passed\n" 317 . " # to the AUTOLOAD in AutoLoader." if $autoloader; 318 319 320 $func .= "\n\n" 321 . " my \$constname;\n"; 322 $func .= 323 " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); 324 325 $func .= <<"EOT"; 326 (\$constname = \$AUTOLOAD) =~ s/.*:://; 327 croak "&${module}::constant not defined" if \$constname eq 'constant'; 328 my (\$error, \$val) = constant(\$constname); 329EOT 330 331 if ($autoloader) { 332 $func .= <<'EOT'; 333 if ($error) { 334 if ($error =~ /is not a valid/) { 335 $AutoLoader::AUTOLOAD = $AUTOLOAD; 336 goto &AutoLoader::AUTOLOAD; 337 } else { 338 croak $error; 339 } 340 } 341EOT 342 } else { 343 $func .= 344 " if (\$error) { croak \$error; }\n"; 345 } 346 347 $func .= <<'END'; 348 { 349 no strict 'refs'; 350 # Fixed between 5.005_53 and 5.005_61 351#XXX if ($] >= 5.00561) { 352#XXX *$AUTOLOAD = sub () { $val }; 353#XXX } 354#XXX else { 355 *$AUTOLOAD = sub { $val }; 356#XXX } 357 } 358 goto &$AUTOLOAD; 359} 360 361END 362 363 return $func; 364} 365 366 367=item WriteMakefileSnippet 368 369WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 370 371A function to generate perl code for Makefile.PL that will regenerate 372the constant subroutines. Parameters are named as passed to C<WriteConstants>, 373with the addition of C<INDENT> to specify the number of leading spaces 374(default 2). 375 376Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and 377C<XS_FILE> are recognised. 378 379=cut 380 381sub WriteMakefileSnippet { 382 my %args = @_; 383 my $indent = $args{INDENT} || 2; 384 385 my $result = <<"EOT"; 386ExtUtils::Constant::WriteConstants( 387 NAME => '$args{NAME}', 388 NAMES => \\\@names, 389 DEFAULT_TYPE => '$args{DEFAULT_TYPE}', 390EOT 391 foreach (qw (C_FILE XS_FILE)) { 392 next unless exists $args{$_}; 393 $result .= sprintf " %-12s => '%s',\n", 394 $_, $args{$_}; 395 } 396 $result .= <<'EOT'; 397 ); 398EOT 399 400 $result =~ s/^/' 'x$indent/gem; 401 return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, 402 indent=>$indent,}, 403 @{$args{NAMES}}) 404 . $result; 405} 406 407=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] 408 409Writes a file of C code and a file of XS code which you should C<#include> 410and C<INCLUDE> in the C and XS sections respectively of your module's XS 411code. You probably want to do this in your C<Makefile.PL>, so that you can 412easily edit the list of constants without touching the rest of your module. 413The attributes supported are 414 415=over 4 416 417=item NAME 418 419Name of the module. This must be specified 420 421=item DEFAULT_TYPE 422 423The default type for the constants. If not specified C<IV> is assumed. 424 425=item BREAKOUT_AT 426 427The names of the constants are grouped by length. Generate child subroutines 428for each group with this number or more names in. 429 430=item NAMES 431 432An array of constants' names, either scalars containing names, or hashrefs 433as detailed in L<"C_constant">. 434 435=item C_FILE 436 437The name of the file to write containing the C code. The default is 438C<const-c.inc>. The C<-> in the name ensures that the file can't be 439mistaken for anything related to a legitimate perl package name, and 440not naming the file C<.c> avoids having to override Makefile.PL's 441C<.xs> to C<.c> rules. 442 443=item XS_FILE 444 445The name of the file to write containing the XS code. The default is 446C<const-xs.inc>. 447 448=item SUBNAME 449 450The perl visible name of the XS subroutine generated which will return the 451constants. The default is C<constant>. 452 453=item C_SUBNAME 454 455The name of the C subroutine generated which will return the constants. 456The default is I<SUBNAME>. Child subroutines have C<_> and the name 457length appended, so constants with 10 character names would be in 458C<constant_10> with the default I<XS_SUBNAME>. 459 460=back 461 462=cut 463 464sub WriteConstants { 465 my %ARGS = 466 ( # defaults 467 C_FILE => 'const-c.inc', 468 XS_FILE => 'const-xs.inc', 469 SUBNAME => 'constant', 470 DEFAULT_TYPE => 'IV', 471 @_); 472 473 $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0' 474 475 croak "Module name not specified" unless length $ARGS{NAME}; 476 477 my ($c_fh, $xs_fh); 478 if ($] <= 5.008) { 479 # We need these little games, rather than doing things unconditionally, 480 # because we're used in core Makefile.PLs before IO is available (needed 481 # by filehandle), but also we want to work on older perls where undefined 482 # scalars do not automatically turn into anonymous file handles. 483 require FileHandle; 484 $c_fh = FileHandle->new(); 485 $xs_fh = FileHandle->new(); 486 } 487 open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; 488 open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; 489 490 # As this subroutine is intended to make code that isn't edited, there's no 491 # need for the user to specify any types that aren't found in the list of 492 # names. 493 my $types = {}; 494 495 print $c_fh constant_types(); # macro defs 496 print $c_fh "\n"; 497 498 # indent is still undef. Until anyone implements indent style rules with it. 499 foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, 500 subname => $ARGS{C_SUBNAME}, 501 default_type => 502 $ARGS{DEFAULT_TYPE}, 503 types => $types, 504 breakout => $ARGS{BREAKOUT_AT}}, 505 @{$ARGS{NAMES}})) { 506 print $c_fh $_, "\n"; # C constant subs 507 } 508 print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, 509 $ARGS{C_SUBNAME}); 510 511 close $c_fh or warn "Error closing $ARGS{C_FILE}: $!"; 512 close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!"; 513} 514 5151; 516__END__ 517 518=back 519 520=head1 AUTHOR 521 522Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and 523others 524 525=cut 526