lib/ExtUtils/Constant.pm

   1 package ExtUtils::Constant;
   2 use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
   3 $VERSION = 0.16;
   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 qw(croak cluck);
  98
  99 use Exporter;
 100 use ExtUtils::Constant::Utils qw(C_stringify);
 101 use 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
 114 A function returning a single scalar with C<#define> definitions for the
 115 constants used internally between the generated C and XS functions.
 116
 117 =cut
 118
 119 sub constant_types {
 120   ExtUtils::Constant::XS->header();
 121 }
 122
 123 sub 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
 129 sub return_clause ($$) {
 130   cluck "ExtUtils::Constant::return_clause is deprecated";
 131   my $indent = shift;
 132   ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
 133 }
 134
 135 sub 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
 143 sub 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
 154 A function to generate the XS code to implement the perl subroutine
 155 I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
 156 This XS code is a wrapper around a C subroutine usually generated by
 157 C<C_constant>, and usually named C<constant>.
 158
 159 I<TYPES> should be given either as a comma separated list of types that the
 160 C subroutine C<constant> will generate or as a reference to a hash. It should
 161 be 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
 163 the number of parameters passed to the C function C<constant>]
 164
 165 You can call the perl visible subroutine something other than C<constant> if
 166 you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
 167 the name of the perl visible subroutine, unless you give the parameter
 168 I<C_SUBNAME>.
 169
 170 =cut
 171
 172 sub 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";
 188 void
 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;
 198 EOT
 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);
 221 EOT
 222   if ($params->{''}) {
 223   $xs .= << 'EOT';
 224     INPUT:
 225         int             utf8 = SvUTF8(sv);
 226 EOT
 227   }
 228   $xs .= << 'EOT';
 229     PPCODE:
 230 EOT
 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 */
 236 EOT
 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;
 259 EOT
 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};
 272 EOT
 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         }
 290 EOT
 291
 292   return $xs;
 293 }
 294
 295
 296 =item autoload PACKAGE, VERSION, AUTOLOADER
 297
 298 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 299 I<VERSION> is the perl version the code should be backwards compatible with.
 300 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
 301 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
 302 names that the constant() routine doesn't recognise.
 303
 304 =cut
 305
 306 # ' # Grr. syntax highlighters that don't grok pod.
 307
 308 sub 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);
 329 EOT
 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     }
 341 EOT
 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
 361 END
 362
 363   return $func;
 364 }
 365
 366
 367 =item WriteMakefileSnippet
 368
 369 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
 370
 371 A function to generate perl code for Makefile.PL that will regenerate
 372 the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
 373 with the addition of C<INDENT> to specify the number of leading spaces
 374 (default 2).
 375
 376 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
 377 C<XS_FILE> are recognised.
 378
 379 =cut
 380
 381 sub WriteMakefileSnippet {
 382   my %args = @_;
 383   my $indent = $args{INDENT} || 2;
 384
 385   my $result = <<"EOT";
 386 ExtUtils::Constant::WriteConstants(
 387                                    NAME         => '$args{NAME}',
 388                                    NAMES        => \\\@names,
 389                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
 390 EOT
 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                                 );
 398 EOT
 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
 409 Writes a file of C code and a file of XS code which you should C<#include>
 410 and C<INCLUDE> in the C and XS sections respectively of your module's XS
 411 code.  You probably want to do this in your C<Makefile.PL>, so that you can
 412 easily edit the list of constants without touching the rest of your module.
 413 The attributes supported are
 414
 415 =over 4
 416
 417 =item NAME
 418
 419 Name of the module.  This must be specified
 420
 421 =item DEFAULT_TYPE
 422
 423 The default type for the constants.  If not specified C<IV> is assumed.
 424
 425 =item BREAKOUT_AT
 426
 427 The names of the constants are grouped by length.  Generate child subroutines
 428 for each group with this number or more names in.
 429
 430 =item NAMES
 431
 432 An array of constants' names, either scalars containing names, or hashrefs
 433 as detailed in L<"C_constant">.
 434
 435 =item C_FILE
 436
 437 The name of the file to write containing the C code.  The default is
 438 C<const-c.inc>.  The C<-> in the name ensures that the file can't be
 439 mistaken for anything related to a legitimate perl package name, and
 440 not naming the file C<.c> avoids having to override Makefile.PL's
 441 C<.xs> to C<.c> rules.
 442
 443 =item XS_FILE
 444
 445 The name of the file to write containing the XS code.  The default is
 446 C<const-xs.inc>.
 447
 448 =item SUBNAME
 449
 450 The perl visible name of the XS subroutine generated which will return the
 451 constants. The default is C<constant>.
 452
 453 =item C_SUBNAME
 454
 455 The name of the C subroutine generated which will return the constants.
 456 The default is I<SUBNAME>.  Child subroutines have C<_> and the name
 457 length appended, so constants with 10 character names would be in
 458 C<constant_10> with the default I<XS_SUBNAME>.
 459
 460 =back
 461
 462 =cut
 463
 464 sub 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   open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
 478   open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
 479
 480   # As this subroutine is intended to make code that isn't edited, there's no
 481   # need for the user to specify any types that aren't found in the list of
 482   # names.
 483   my $types = {};
 484
 485   print $c_fh constant_types(); # macro defs
 486   print $c_fh "\n";
 487
 488   # indent is still undef. Until anyone implements indent style rules with it.
 489   foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
 490                                                subname => $ARGS{C_SUBNAME},
 491                                                default_type =>
 492                                                $ARGS{DEFAULT_TYPE},
 493                                                types => $types,
 494                                                breakout => $ARGS{BREAKOUT_AT}},
 495                                                @{$ARGS{NAMES}})) {
 496     print $c_fh $_, "\n"; # C constant subs
 497   }
 498   print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
 499                             $ARGS{C_SUBNAME});
 500
 501   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
 502   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
 503 }
 504
 505 1;
 506 __END__
 507
 508 =back
 509
 510 =head1 AUTHOR
 511
 512 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 513 others
 514
 515 =cut