lib/ExtUtils/Constant.pm

   1 package ExtUtils::Constant;
   2
   3 =head1 NAME
   4
   5 ExtUtils::Constant - generate XS code to import C header constants
   6
   7 =head1 SYNOPSIS
   8
   9     use ExtUtils::Constant qw (constant_types C_constant XS_constant);
  10     print constant_types(); # macro defs
  11     foreach (C_constant (undef, "IV", undef, undef, undef, @names) ) {
  12         print $_, "\n"; # C constant subs
  13     }
  14     print "MODULE = Foo         PACKAGE = Foo\n";
  15     print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
  16
  17 =head1 DESCRIPTION
  18
  19 ExtUtils::Constant facilitates generating C and XS wrapper code to allow
  20 perl modules to AUTOLOAD constants defined in C library header files.
  21 It is principally used by the C<h2xs> utility, on which this code is based.
  22 It doesn't contain the routines to scan header files to extract these
  23 constants.
  24
  25 =head1 USAGE
  26
  27 Generally one only needs to call the 3 functions shown in the synopsis,
  28 C<constant_types()>, C<C_constant> and C<XS_constant>.
  29
  30 Currently this module understands the following types. h2xs may only know
  31 a subset. The sizes of the numeric types are chosen by the C<Configure>
  32 script at compile time.
  33
  34 =over 4
  35
  36 =item IV
  37
  38 signed integer, at least 32 bits.
  39
  40 =item UV
  41
  42 unsigned integer, the same size as I<IV>
  43
  44 =item NV
  45
  46 floating point type, probably C<double>, possibly C<long double>
  47
  48 =item PV
  49
  50 NUL terminated string, length will be determined with C<strlen>
  51
  52 =item PVN
  53
  54 A fixed length thing, given as a [pointer, length] pair. If you know the
  55 length of a string at compile time you may use this instead of I<PV>
  56
  57 =back
  58
  59 =head1 FUNCTIONS
  60
  61 =over 4
  62
  63 =cut
  64
  65 require 5.006; # I think, for [:cntrl:] in REGEXP
  66 use warnings;
  67 use strict;
  68 use Carp;
  69
  70 use Exporter;
  71 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
  72 use Text::Wrap;
  73 $Text::Wrap::huge = 'overflow';
  74 $Text::Wrap::columns = 80;
  75
  76 @ISA = 'Exporter';
  77 $VERSION = '0.01';
  78
  79 %EXPORT_TAGS = ( 'all' => [ qw(
  80         XS_constant constant_types return_clause memEQ_clause C_stringify
  81         C_constant autoload
  82 ) ] );
  83
  84 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  85
  86 %XS_Constant = (
  87                 IV => 'PUSHi(iv)',
  88                 UV => 'PUSHu((UV)iv)',
  89                 NV => 'PUSHn(nv)',
  90                 PV => 'PUSHp(pv, strlen(pv))',
  91                 PVN => 'PUSHp(pv, iv)'
  92 );
  93
  94 %XS_TypeSet = (
  95                 IV => '*iv_return =',
  96                 UV => '*iv_return = (IV)',
  97                 NV => '*nv_return =',
  98                 PV => '*pv_return =',
  99                 PVN => ['*pv_return =', '*iv_return = (IV)']
 100 );
 101
 102
 103 =item C_stringify NAME
 104
 105 A function which returns a correctly \ escaped version of the string passed
 106 suitable for C's "" or ''
 107
 108 =cut
 109
 110 # Hopefully make a happy C identifier.
 111 sub C_stringify {
 112   local $_ = shift;
 113   s/\\/\\\\/g;
 114   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
 115   s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
 116   s/\177/\\177/g;       # DEL doesn't seem to be a [:cntrl:]
 117   $_;
 118 }
 119
 120 =item constant_types
 121
 122 A function returning a single scalar with C<#define> definitions for the
 123 constants used internally between the generated C and XS functions.
 124
 125 =cut
 126
 127 sub constant_types () {
 128   my $start = 1;
 129   my @lines;
 130   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
 131   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
 132   foreach (sort keys %XS_Constant) {
 133     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
 134   }
 135   push @lines, << 'EOT';
 136
 137 #ifndef NVTYPE
 138 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 139 #endif
 140 EOT
 141
 142   return join '', @lines;
 143 }
 144
 145 =item memEQ_clause NAME, CHECKED_AT, INDENT
 146
 147 A function to return a suitable C C<if> statement to check whether I<NAME>
 148 is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
 149 is used to avoid C<memEQ> for short names, or to generate a comment to
 150 highlight the position of the character in the C<switch> statement.
 151
 152 =cut
 153
 154 sub memEQ_clause {
 155 #    if (memEQ(name, "thingy", 6)) {
 156   # Which could actually be a character comparison or even ""
 157   my ($name, $checked_at, $indent) = @_;
 158   $indent = ' ' x ($indent || 4);
 159   my $len = length $name;
 160
 161   if ($len < 2) {
 162     return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
 163     # We didn't switch, drop through to the code for the 2 character string
 164     $checked_at = 1;
 165   }
 166   if ($len < 3 and defined $checked_at) {
 167     my $check;
 168     if ($checked_at == 1) {
 169       $check = 0;
 170     } elsif ($checked_at == 0) {
 171       $check = 1;
 172     }
 173     if (defined $check) {
 174       my $char = C_stringify (substr $name, $check, 1);
 175       return $indent . "if (name[$check] == '$char') {\n";
 176     }
 177   }
 178   # Could optimise a memEQ on 3 to 2 single character checks here
 179   $name = C_stringify ($name);
 180   my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
 181     $body .= $indent . "/*               ". (' ' x $checked_at) . '^'
 182       . (' ' x ($len - $checked_at + length $len)) . "    */\n"
 183         if defined $checked_at;
 184   return $body;
 185 }
 186
 187 =item return_clause VALUE, TYPE, INDENT, MACRO
 188
 189 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
 190 I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
 191 pointer and length) then I<VALUE> should be a reference to an array of
 192 values in the order expected by the type.
 193
 194 =cut
 195
 196 sub return_clause {
 197 ##ifdef thingy
 198 #      *iv_return = thingy;
 199 #      return PERL_constant_ISIV;
 200 ##else
 201 #      return PERL_constant_NOTDEF;
 202 ##endif
 203   my ($value, $type, $indent, $macro) = @_;
 204   $macro = $value unless defined $macro;
 205   $indent = ' ' x ($indent || 6);
 206
 207   die "Macro must not be a reference" if ref $macro;
 208   my $clause = "#ifdef $macro\n";
 209
 210   my $typeset = $XS_TypeSet{$type};
 211   die "Can't generate code for type $type" unless defined $typeset;
 212   if (ref $typeset) {
 213     die "Type $type is aggregate, but only single value given"
 214       unless ref $value;
 215     foreach (0 .. $#$typeset) {
 216       $clause .= $indent . "$typeset->[$_] $value->[$_];\n";
 217     }
 218   } else {
 219     die "Aggregate value given for type $type"
 220       if ref $value;
 221     $clause .= $indent . "$typeset $value;\n";
 222   }
 223   return $clause . <<"EOT";
 224 ${indent}return PERL_constant_IS$type;
 225 #else
 226 ${indent}return PERL_constant_NOTDEF;
 227 #endif
 228 EOT
 229 }
 230
 231 =item params WHAT
 232
 233 An internal function. I<WHAT> should be a hashref of types the constant
 234 function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
 235 $use_pv> to show which combination of pointers will be needed in the C
 236 argument list.
 237
 238 =cut
 239
 240 sub params {
 241   my $what = shift;
 242   foreach (sort keys %$what) {
 243     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 244   }
 245   my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
 246   my $use_nv = $what->{NV};
 247   my $use_pv = $what->{PV} || $what->{PVN};
 248   return ($use_iv, $use_nv, $use_pv);
 249 }
 250
 251 =item C_constant SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
 252
 253 A function that returns a B<list> of C subroutine definitions that return
 254 the value and type of constants when passed the name by the XS wrapper.
 255 I<ITEM...> gives a list of constant names. Each can either be a string,
 256 which is taken as a C macro name, or a reference to a hash with the following
 257 keys
 258
 259 =over 8
 260
 261 =item name
 262
 263 The name of the constant, as seen by the perl code.
 264
 265 =item type
 266
 267 The type of the constant (I<IV>, I<NV> etc)
 268
 269 =item value
 270
 271 A C expression for the value of the constant, or a list of C expressions if
 272 the type is aggregate. This defaults to the I<name> if not given.
 273
 274 =item macro
 275
 276 The C pre-processor macro to use in the C<#ifdef>. This defaults to the
 277 I<name>, and is mainly used if I<value> is an C<enum>.
 278
 279 =back
 280
 281 The first 5 argument can safely be given as C<undef>, and are mainly used
 282 for recursion. I<SUBNAME> defaults to C<constant> if undefined.
 283
 284 I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
 285 type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
 286 separated list of types that the C subroutine C<constant> will generate or as
 287 a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
 288 present, as will any types given in the list of I<ITEM>s. The resultant list
 289 should be the same list of types that C<XS_constant> is given. [Otherwise
 290 C<XS_constant> and C<C_constant> may differ in the number of parameters to the
 291 constant function. I<INDENT> is currently unused and ignored. In future it may
 292 be used to pass in information used to change the C indentation style used.]
 293 The best way to maintain consistency is to pass in a hash reference and let
 294 this function update it.
 295
 296 I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
 297 this length, and that the constant name passed in by perl is checked and
 298 also of this length. It is used during recursion, and should be C<undef>
 299 unless the caller has checked all the lengths during code generation, and
 300 the generated subroutine is only to be called with a name of this length.
 301
 302 =cut
 303
 304 sub C_constant {
 305   my ($subname, $default_type, $what, $indent, $namelen, @items) = @_;
 306   $subname ||= 'constant';
 307   # I'm not using this. But a hashref could be used for full formatting without
 308   # breaking this API
 309   $indent ||= 0;
 310    $default_type ||= 'IV';
 311   if (!ref $what) {
 312     # Convert line of the form IV,UV,NV to hash
 313     $what = {map {$_ => 1} split /,\s*/, ($what || '')};
 314     # Figure out what types we're dealing with, and assign all unknowns to the
 315     # default type
 316   }
 317   my %items;
 318   foreach (@items) {
 319     my $name;
 320     if (ref $_) {
 321       $name = $_->{name};
 322       $what->{$_->{type} ||= $default_type} = 1;
 323     } else {
 324       $name = $_;
 325       $_ = {name=>$_, type=>$default_type};
 326       $what->{$default_type} = 1;
 327     }
 328     warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
 329     if (exists $items{$name}) {
 330       die "Multiple definitions for macro $name";
 331     }
 332     $items{$name} = $_;
 333   }
 334   my ($use_iv, $use_nv, $use_pv) = params ($what);
 335
 336   my ($body, @subs) = "static int\n$subname (const char *name";
 337   $body .= ", STRLEN len" unless defined $namelen;
 338   $body .= ", IV *iv_return" if $use_iv;
 339   $body .= ", NV *nv_return" if $use_nv;
 340   $body .= ", const char **pv_return" if $use_pv;
 341   $body .= ") {\n";
 342
 343   my @names = sort map {$_->{name}} @items;
 344   my $names = << 'EOT'
 345   /* When generated this function returned values for the list of names given
 346      here.  However, subsequent manual editing may have added or removed some.
 347 EOT
 348   . wrap ("     ", "     ", join (" ", @names) . " */") . "\n";
 349
 350   if (defined $namelen) {
 351     # We are a child subroutine.
 352     # Figure out what to switch on.
 353     # (RMS, Spread of jump table, Position, Hashref)
 354     my @best = (1e38, ~0);
 355     foreach my $i (0 .. ($namelen - 1)) {
 356       my ($min, $max) = (~0, 0);
 357       my %spread;
 358       foreach (@names) {
 359         my $char = substr $_, $i, 1;
 360         my $ord = ord $char;
 361         $max = $ord if $ord > $max;
 362         $min = $ord if $ord < $min;
 363         push @{$spread{$char}}, $_;
 364         # warn "$_ $char";
 365       }
 366       # I'm going to pick the character to split on that minimises the root
 367       # mean square of the number of names in each case. Normally this should
 368       # be the one with the most keys, but it may pick a 7 where the 8 has
 369       # one long linear search. I'm not sure if RMS or just sum of squares is
 370       # actually better.
 371       # $max and $min are for the tie-breaker if the root mean squares match.
 372       # Assuming that the compiler may be building a jump table for the
 373       # switch() then try to minimise the size of that jump table.
 374       # Finally use < not <= so that if it still ties the earliest part of
 375       # the string wins. Because if that passes but the memEQ fails, it may
 376       # only need the start of the string to bin the choice.
 377       # I think. But I'm micro-optimising. :-)
 378       my $ss;
 379       $ss += @$_ * @$_ foreach values %spread;
 380       my $rms = sqrt ($ss / keys %spread);
 381       if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
 382         @best = ($rms, $max - $min, $i, \%spread);
 383       }
 384     }
 385     die "Internal error. Failed to pick a switch point for @names"
 386       unless defined $best[2];
 387     # use Data::Dumper; print Dumper (@best);
 388     my ($offset, $best) = @best[2,3];
 389     $body .= "  /* Names all of length $namelen.  */\n";
 390     $body .= $names;
 391     $body .= "  /* Offset $offset gives the best switch position.  */\n";
 392     $body .= "  switch (name[$offset]) {\n";
 393     foreach my $char (sort keys %$best) {
 394       $body .= "  case '" . C_stringify ($char) . "':\n";
 395       foreach my $name (sort @{$best->{$char}}) {
 396         my $thisone = $items{$name};
 397         my ($value, $macro) = (@$thisone{qw (value macro)});
 398         $value = $name unless defined $value;
 399         $macro = $name unless defined $macro;
 400
 401         $body .= memEQ_clause ($name, $offset); # We have checked this offset.
 402         $body .= return_clause ($value, $thisone->{type}, undef, $macro);
 403         $body .= "    }\n";
 404       }
 405       $body .= "    break;\n";
 406     }
 407     $body .= "  }\n";
 408   } else {
 409     # We are the top level.
 410     $body .= "  /* Initially switch on the length of the name.  */\n";
 411     $body .= $names;
 412     $body .= "  switch (len) {\n";
 413     # Need to group names of the same length
 414     my @by_length;
 415     foreach (@items) {
 416       push @{$by_length[length $_->{name}]}, $_;
 417     }
 418     foreach my $i (0 .. $#by_length) {
 419       next unless $by_length[$i];       # None of this length
 420       $body .= "  case $i:\n";
 421       if (@{$by_length[$i]} == 1) {
 422         my $thisone = $by_length[$i]->[0];
 423         my ($name, $value, $macro) = (@$thisone{qw (name value macro)});
 424         $value = $name unless defined $value;
 425         $macro = $name unless defined $macro;
 426
 427         $body .= memEQ_clause ($name);
 428         $body .= return_clause ($value, $thisone->{type}, undef, $macro);
 429         $body .= "    }\n";
 430       } else {
 431         push @subs, C_constant ("${subname}_$i", $default_type, $what, $indent,
 432                                 $i, @{$by_length[$i]});
 433         $body .= "    return ${subname}_$i (name";
 434         $body .= ", iv_return" if $use_iv;
 435         $body .= ", nv_return" if $use_nv;
 436         $body .= ", pv_return" if $use_pv;
 437         $body .= ");\n";
 438       }
 439       $body .= "    break;\n";
 440     }
 441     $body .= "  }\n";
 442   }
 443   $body .= "  return PERL_constant_NOTFOUND;\n}\n";
 444   return (@subs, $body);
 445 }
 446
 447 =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
 448
 449 A function to generate the XS code to implement the perl subroutine
 450 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
 451 This XS code is a wrapper around a C subroutine usually generated by
 452 C<C_constant>, and usually named C<constant>.
 453
 454 I<TYPES> should be given either as a comma separated list of types that the
 455 C subroutine C<constant> will generate or as a reference to a hash. It should
 456 be the same list of types as C<C_constant> was given.
 457 [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
 458 the number of parameters passed to the C function C<constant>]
 459
 460 You can call the perl visible subroutine something other than C<constant> if
 461 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
 462 the name of the perl visible subroutine, unless you give the parameter
 463 I<C_SUBNAME>.
 464
 465 =cut
 466
 467 sub XS_constant {
 468   my $package = shift;
 469   my $what = shift;
 470   my $subname = shift;
 471   my $C_subname = shift;
 472   $subname ||= 'constant';
 473   $C_subname ||= $subname;
 474
 475   if (!ref $what) {
 476     # Convert line of the form IV,UV,NV to hash
 477     $what = {map {$_ => 1} split /,\s*/, ($what)};
 478   }
 479   my ($use_iv, $use_nv, $use_pv) = params ($what);
 480   my $type;
 481
 482   my $xs = <<"EOT";
 483 void
 484 $subname(sv)
 485     PREINIT:
 486 #ifdef dXSTARG
 487         dXSTARG; /* Faster if we have it.  */
 488 #else
 489         dTARGET;
 490 #endif
 491         STRLEN          len;
 492         int             type;
 493 EOT
 494
 495   if ($use_iv) {
 496     $xs .= "    IV              iv;\n";
 497   } else {
 498     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
 499   }
 500   if ($use_nv) {
 501     $xs .= "    NV              nv;\n";
 502   } else {
 503     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
 504   }
 505   if ($use_pv) {
 506     $xs .= "    const char      *pv;\n";
 507   } else {
 508     $xs .=
 509       " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
 510   }
 511
 512   $xs .= << 'EOT';
 513     INPUT:
 514         SV *            sv;
 515         const char *    s = SvPV(sv, len);
 516     PPCODE:
 517 EOT
 518
 519   if ($use_iv xor $use_nv) {
 520     $xs .= << "EOT";
 521         /* Change this to $C_subname(s, len, &iv, &nv);
 522            if you need to return both NVs and IVs */
 523 EOT
 524   }
 525   $xs .= "      type = $C_subname(s, len";
 526   $xs .= ', &iv' if $use_iv;
 527   $xs .= ', &nv' if $use_nv;
 528   $xs .= ', &pv' if $use_pv;
 529   $xs .= ");\n";
 530
 531   $xs .= << "EOT";
 532       /* Return 1 or 2 items. First is error message, or undef if no error.
 533            Second, if present, is found value */
 534         switch (type) {
 535         case PERL_constant_NOTFOUND:
 536           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
 537           break;
 538         case PERL_constant_NOTDEF:
 539           sv = sv_2mortal(newSVpvf(
 540             "Your vendor has not defined $package macro %s used", s));
 541           break;
 542 EOT
 543
 544   foreach $type (sort keys %XS_Constant) {
 545     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
 546       unless $what->{$type};
 547     $xs .= << "EOT";
 548         case PERL_constant_IS$type:
 549           EXTEND(SP, 1);
 550           PUSHs(&PL_sv_undef);
 551           $XS_Constant{$type};
 552           break;
 553 EOT
 554     unless ($what->{$type}) {
 555       chop $xs; # Yes, another need for chop not chomp.
 556       $xs .= " */\n";
 557     }
 558   }
 559   $xs .= << "EOT";
 560         default:
 561           sv = sv_2mortal(newSVpvf(
 562             "Unexpected return type %d while processing $package macro %s used",
 563                type, s));
 564         }
 565 EOT
 566
 567   return $xs;
 568 }
 569
 570
 571 =item autoload PACKAGE, VERSION
 572
 573 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 574 I<VERSION> is the perl version the code should be backwards compatible with.
 575 It defaults to the version of perl running the subroutine.
 576
 577 =cut
 578
 579 sub autoload {
 580   my ($module, $compat_version) = @_;
 581   $compat_version ||= $];
 582   croak "Can't maintain compatibility back as far as version $compat_version"
 583     if $compat_version < 5;
 584   my $tmp = ( $compat_version < 5.006 ?  "" : "our \$AUTOLOAD;" );
 585   return <<"END";
 586 sub AUTOLOAD {
 587     # This AUTOLOAD is used to 'autoload' constants from the constant()
 588     # XS function.  If a constant is not found then control is passed
 589     # to the AUTOLOAD in AutoLoader.
 590
 591     my \$constname;
 592     $tmp
 593     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 594     croak "&${module}::constant not defined" if \$constname eq 'constant';
 595     my (\$error, \$val) = constant(\$constname);
 596     if (\$error) {
 597         if (\$error =~  /is not a valid/) {
 598             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 599             goto &AutoLoader::AUTOLOAD;
 600         } else {
 601             croak \$error;
 602         }
 603     }
 604     {
 605         no strict 'refs';
 606         # Fixed between 5.005_53 and 5.005_61
 607 #XXX    if (\$] >= 5.00561) {
 608 #XXX        *\$AUTOLOAD = sub () { \$val };
 609 #XXX    }
 610 #XXX    else {
 611             *\$AUTOLOAD = sub { \$val };
 612 #XXX    }
 613     }
 614     goto &\$AUTOLOAD;
 615 }
 616
 617 END
 618
 619 }
 620 1;
 621 __END__
 622
 623 =back
 624
 625 =head1 AUTHOR
 626
 627 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 628 others
 629
 630 =cut