lib/ExtUtils/Constant.pm

   1 package ExtUtils::Constant;
   2 use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
   3 $VERSION = 0.22;
   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, XS_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<XS_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 $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";
 188 void
 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;
 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   # 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;
 265 EOT
 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, 1);
 276           PUSHs(&PL_sv_undef);
 277           $XS_Constant{$type};
 278 EOT
 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         }
 296 EOT
 297
 298   return $xs;
 299 }
 300
 301
 302 =item autoload PACKAGE, VERSION, AUTOLOADER
 303
 304 A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
 305 I<VERSION> is the perl version the code should be backwards compatible with.
 306 It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
 307 is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
 308 names that the constant() routine doesn't recognise.
 309
 310 =cut
 311
 312 # ' # Grr. syntax highlighters that don't grok pod.
 313
 314 sub 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);
 335 EOT
 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     }
 347 EOT
 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
 367 END
 368
 369   return $func;
 370 }
 371
 372
 373 =item WriteMakefileSnippet
 374
 375 WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
 376
 377 A function to generate perl code for Makefile.PL that will regenerate
 378 the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
 379 with the addition of C<INDENT> to specify the number of leading spaces
 380 (default 2).
 381
 382 Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
 383 C<XS_FILE> are recognised.
 384
 385 =cut
 386
 387 sub WriteMakefileSnippet {
 388   my %args = @_;
 389   my $indent = $args{INDENT} || 2;
 390
 391   my $result = <<"EOT";
 392 ExtUtils::Constant::WriteConstants(
 393                                    NAME         => '$args{NAME}',
 394                                    NAMES        => \\\@names,
 395                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
 396 EOT
 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                                 );
 404 EOT
 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
 415 Writes a file of C code and a file of XS code which you should C<#include>
 416 and C<INCLUDE> in the C and XS sections respectively of your module's XS
 417 code.  You probably want to do this in your C<Makefile.PL>, so that you can
 418 easily edit the list of constants without touching the rest of your module.
 419 The attributes supported are
 420
 421 =over 4
 422
 423 =item NAME
 424
 425 Name of the module.  This must be specified
 426
 427 =item DEFAULT_TYPE
 428
 429 The default type for the constants.  If not specified C<IV> is assumed.
 430
 431 =item BREAKOUT_AT
 432
 433 The names of the constants are grouped by length.  Generate child subroutines
 434 for each group with this number or more names in.
 435
 436 =item NAMES
 437
 438 An array of constants' names, either scalars containing names, or hashrefs
 439 as detailed in L<"C_constant">.
 440
 441 =item PROXYSUBS
 442
 443 If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>.
 444
 445 =item C_FH
 446
 447 A filehandle to write the C code to.  If not given, then I<C_FILE> is opened
 448 for writing.
 449
 450 =item C_FILE
 451
 452 The name of the file to write containing the C code.  The default is
 453 C<const-c.inc>.  The C<-> in the name ensures that the file can't be
 454 mistaken for anything related to a legitimate perl package name, and
 455 not naming the file C<.c> avoids having to override Makefile.PL's
 456 C<.xs> to C<.c> rules.
 457
 458 =item XS_FH
 459
 460 A filehandle to write the XS code to.  If not given, then I<XS_FILE> is opened
 461 for writing.
 462
 463 =item XS_FILE
 464
 465 The name of the file to write containing the XS code.  The default is
 466 C<const-xs.inc>.
 467
 468 =item XS_SUBNAME
 469
 470 The perl visible name of the XS subroutine generated which will return the
 471 constants. The default is C<constant>.
 472
 473 =item C_SUBNAME
 474
 475 The name of the C subroutine generated which will return the constants.
 476 The default is I<XS_SUBNAME>.  Child subroutines have C<_> and the name
 477 length appended, so constants with 10 character names would be in
 478 C<constant_10> with the default I<XS_SUBNAME>.
 479
 480 =back
 481
 482 =cut
 483
 484 sub 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   my $c_fh = $ARGS{C_FH};
 498   if (!$c_fh) {
 499       if ($] <= 5.008) {
 500           # We need these little games, rather than doing things
 501           # unconditionally, because we're used in core Makefile.PLs before
 502           # IO is available (needed by filehandle), but also we want to work on
 503           # older perls where undefined scalars do not automatically turn into
 504           # anonymous file handles.
 505           require FileHandle;
 506           $c_fh = FileHandle->new();
 507       }
 508       open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
 509   }
 510
 511   my $xs_fh = $ARGS{XS_FH};
 512   if (!$xs_fh) {
 513       if ($] <= 5.008) {
 514           require FileHandle;
 515           $xs_fh = FileHandle->new();
 516       }
 517       open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
 518   }
 519
 520   # As this subroutine is intended to make code that isn't edited, there's no
 521   # need for the user to specify any types that aren't found in the list of
 522   # names.
 523
 524   if ($ARGS{PROXYSUBS}) {
 525       require ExtUtils::Constant::ProxySubs;
 526       $ARGS{C_FH} = $c_fh;
 527       $ARGS{XS_FH} = $xs_fh;
 528       ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
 529   } else {
 530       my $types = {};
 531
 532       print $c_fh constant_types(); # macro defs
 533       print $c_fh "\n";
 534
 535       # indent is still undef. Until anyone implements indent style rules with
 536       # it.
 537       foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
 538                                                    subname => $ARGS{C_SUBNAME},
 539                                                    default_type =>
 540                                                        $ARGS{DEFAULT_TYPE},
 541                                                        types => $types,
 542                                                        breakout =>
 543                                                        $ARGS{BREAKOUT_AT}},
 544                                                   @{$ARGS{NAMES}})) {
 545           print $c_fh $_, "\n"; # C constant subs
 546       }
 547       print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
 548                                 $ARGS{C_SUBNAME});
 549   }
 550
 551   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
 552   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
 553 }
 554
 555 1;
 556 __END__
 557
 558 =back
 559
 560 =head1 AUTHOR
 561
 562 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
 563 others
 564
 565 =cut