| package ExtUtils::Constant; |
| use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); |
| $VERSION = 0.23; |
| |
| =head1 NAME |
| |
| ExtUtils::Constant - generate XS code to import C header constants |
| |
| =head1 SYNOPSIS |
| |
| use ExtUtils::Constant qw (WriteConstants); |
| WriteConstants( |
| NAME => 'Foo', |
| NAMES => [qw(FOO BAR BAZ)], |
| ); |
| # Generates wrapper code to make the values of the constants FOO BAR BAZ |
| # available to perl |
| |
| =head1 DESCRIPTION |
| |
| ExtUtils::Constant facilitates generating C and XS wrapper code to allow |
| perl modules to AUTOLOAD constants defined in C library header files. |
| It is principally used by the C<h2xs> utility, on which this code is based. |
| It doesn't contain the routines to scan header files to extract these |
| constants. |
| |
| =head1 USAGE |
| |
| Generally one only needs to call the C<WriteConstants> function, and then |
| |
| #include "const-c.inc" |
| |
| in the C section of C<Foo.xs> |
| |
| INCLUDE: const-xs.inc |
| |
| in the XS section of C<Foo.xs>. |
| |
| For greater flexibility use C<constant_types()>, C<C_constant> and |
| C<XS_constant>, with which C<WriteConstants> is implemented. |
| |
| Currently this module understands the following types. h2xs may only know |
| a subset. The sizes of the numeric types are chosen by the C<Configure> |
| script at compile time. |
| |
| =over 4 |
| |
| =item IV |
| |
| signed integer, at least 32 bits. |
| |
| =item UV |
| |
| unsigned integer, the same size as I<IV> |
| |
| =item NV |
| |
| floating point type, probably C<double>, possibly C<long double> |
| |
| =item PV |
| |
| NUL terminated string, length will be determined with C<strlen> |
| |
| =item PVN |
| |
| A fixed length thing, given as a [pointer, length] pair. If you know the |
| length of a string at compile time you may use this instead of I<PV> |
| |
| =item SV |
| |
| A B<mortal> SV. |
| |
| =item YES |
| |
| Truth. (C<PL_sv_yes>) The value is not needed (and ignored). |
| |
| =item NO |
| |
| Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). |
| |
| =item UNDEF |
| |
| C<undef>. The value of the macro is not needed. |
| |
| =back |
| |
| =head1 FUNCTIONS |
| |
| =over 4 |
| |
| =cut |
| |
| if ($] >= 5.006) { |
| eval "use warnings; 1" or die $@; |
| } |
| use strict; |
| use Carp qw(croak cluck); |
| |
| use Exporter; |
| use ExtUtils::Constant::Utils qw(C_stringify); |
| use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet); |
| |
| @ISA = 'Exporter'; |
| |
| %EXPORT_TAGS = ( 'all' => [ qw( |
| XS_constant constant_types return_clause memEQ_clause C_stringify |
| C_constant autoload WriteConstants WriteMakefileSnippet |
| ) ] ); |
| |
| @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
| |
| =item constant_types |
| |
| A function returning a single scalar with C<#define> definitions for the |
| constants used internally between the generated C and XS functions. |
| |
| =cut |
| |
| sub constant_types { |
| ExtUtils::Constant::XS->header(); |
| } |
| |
| sub memEQ_clause { |
| cluck "ExtUtils::Constant::memEQ_clause is deprecated"; |
| ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1], |
| indent=>$_[2]}); |
| } |
| |
| sub return_clause ($$) { |
| cluck "ExtUtils::Constant::return_clause is deprecated"; |
| my $indent = shift; |
| ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_); |
| } |
| |
| sub switch_clause { |
| cluck "ExtUtils::Constant::switch_clause is deprecated"; |
| my $indent = shift; |
| my $comment = shift; |
| ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment}, |
| @_); |
| } |
| |
| sub C_constant { |
| my ($package, $subname, $default_type, $what, $indent, $breakout, @items) |
| = @_; |
| ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname, |
| default_type => $default_type, |
| types => $what, indent => $indent, |
| breakout => $breakout}, @items); |
| } |
| |
| =item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME |
| |
| A function to generate the XS code to implement the perl subroutine |
| I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. |
| This XS code is a wrapper around a C subroutine usually generated by |
| C<C_constant>, and usually named C<constant>. |
| |
| I<TYPES> should be given either as a comma separated list of types that the |
| C subroutine C<constant> will generate or as a reference to a hash. It should |
| be the same list of types as C<C_constant> was given. |
| [Otherwise C<XS_constant> and C<C_constant> may have different ideas about |
| the number of parameters passed to the C function C<constant>] |
| |
| You can call the perl visible subroutine something other than C<constant> if |
| you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to |
| the name of the perl visible subroutine, unless you give the parameter |
| I<C_SUBNAME>. |
| |
| =cut |
| |
| sub XS_constant { |
| my $package = shift; |
| my $what = shift; |
| my $XS_subname = shift; |
| my $C_subname = shift; |
| $XS_subname ||= 'constant'; |
| $C_subname ||= $XS_subname; |
| |
| if (!ref $what) { |
| # Convert line of the form IV,UV,NV to hash |
| $what = {map {$_ => 1} split /,\s*/, ($what)}; |
| } |
| my $params = ExtUtils::Constant::XS->params ($what); |
| my $type; |
| |
| my $xs = <<"EOT"; |
| void |
| $XS_subname(sv) |
| PREINIT: |
| #ifdef dXSTARG |
| dXSTARG; /* Faster if we have it. */ |
| #else |
| dTARGET; |
| #endif |
| STRLEN len; |
| int type; |
| EOT |
| |
| if ($params->{IV}) { |
| $xs .= " IV iv;\n"; |
| } else { |
| $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; |
| } |
| if ($params->{NV}) { |
| $xs .= " NV nv;\n"; |
| } else { |
| $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; |
| } |
| if ($params->{PV}) { |
| $xs .= " const char *pv;\n"; |
| } else { |
| $xs .= |
| " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; |
| } |
| |
| $xs .= << 'EOT'; |
| INPUT: |
| SV * sv; |
| const char * s = SvPV(sv, len); |
| EOT |
| if ($params->{''}) { |
| $xs .= << 'EOT'; |
| INPUT: |
| int utf8 = SvUTF8(sv); |
| EOT |
| } |
| $xs .= << 'EOT'; |
| PPCODE: |
| EOT |
| |
| if ($params->{IV} xor $params->{NV}) { |
| $xs .= << "EOT"; |
| /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); |
| if you need to return both NVs and IVs */ |
| EOT |
| } |
| $xs .= " type = $C_subname(aTHX_ s, len"; |
| $xs .= ', utf8' if $params->{''}; |
| $xs .= ', &iv' if $params->{IV}; |
| $xs .= ', &nv' if $params->{NV}; |
| $xs .= ', &pv' if $params->{PV}; |
| $xs .= ', &sv' if $params->{SV}; |
| $xs .= ");\n"; |
| |
| # If anyone is insane enough to suggest a package name containing % |
| my $package_sprintf_safe = $package; |
| $package_sprintf_safe =~ s/%/%%/g; |
| |
| $xs .= << "EOT"; |
| /* Return 1 or 2 items. First is error message, or undef if no error. |
| Second, if present, is found value */ |
| switch (type) { |
| case PERL_constant_NOTFOUND: |
| sv = |
| sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s)); |
| PUSHs(sv); |
| break; |
| case PERL_constant_NOTDEF: |
| sv = sv_2mortal(newSVpvf( |
| "Your vendor has not defined $package_sprintf_safe macro %s, used", |
| s)); |
| PUSHs(sv); |
| break; |
| EOT |
| |
| foreach $type (sort keys %XS_Constant) { |
| # '' marks utf8 flag needed. |
| next if $type eq ''; |
| $xs .= "\t/* Uncomment this if you need to return ${type}s\n" |
| unless $what->{$type}; |
| $xs .= " case PERL_constant_IS$type:\n"; |
| if (length $XS_Constant{$type}) { |
| $xs .= << "EOT"; |
| EXTEND(SP, 1); |
| PUSHs(&PL_sv_undef); |
| $XS_Constant{$type}; |
| EOT |
| } else { |
| # Do nothing. return (), which will be correctly interpreted as |
| # (undef, undef) |
| } |
| $xs .= " break;\n"; |
| unless ($what->{$type}) { |
| chop $xs; # Yes, another need for chop not chomp. |
| $xs .= " */\n"; |
| } |
| } |
| $xs .= << "EOT"; |
| default: |
| sv = sv_2mortal(newSVpvf( |
| "Unexpected return type %d while processing $package_sprintf_safe macro %s, used", |
| type, s)); |
| PUSHs(sv); |
| } |
| EOT |
| |
| return $xs; |
| } |
| |
| |
| =item autoload PACKAGE, VERSION, AUTOLOADER |
| |
| A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> |
| I<VERSION> is the perl version the code should be backwards compatible with. |
| It defaults to the version of perl running the subroutine. If I<AUTOLOADER> |
| is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all |
| names that the constant() routine doesn't recognise. |
| |
| =cut |
| |
| # ' # Grr. syntax highlighters that don't grok pod. |
| |
| sub autoload { |
| my ($module, $compat_version, $autoloader) = @_; |
| $compat_version ||= $]; |
| croak "Can't maintain compatibility back as far as version $compat_version" |
| if $compat_version < 5; |
| my $func = "sub AUTOLOAD {\n" |
| . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" |
| . " # XS function."; |
| $func .= " If a constant is not found then control is passed\n" |
| . " # to the AUTOLOAD in AutoLoader." if $autoloader; |
| |
| |
| $func .= "\n\n" |
| . " my \$constname;\n"; |
| $func .= |
| " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); |
| |
| $func .= <<"EOT"; |
| (\$constname = \$AUTOLOAD) =~ s/.*:://; |
| croak "&${module}::constant not defined" if \$constname eq 'constant'; |
| my (\$error, \$val) = constant(\$constname); |
| EOT |
| |
| if ($autoloader) { |
| $func .= <<'EOT'; |
| if ($error) { |
| if ($error =~ /is not a valid/) { |
| $AutoLoader::AUTOLOAD = $AUTOLOAD; |
| goto &AutoLoader::AUTOLOAD; |
| } else { |
| croak $error; |
| } |
| } |
| EOT |
| } else { |
| $func .= |
| " if (\$error) { croak \$error; }\n"; |
| } |
| |
| $func .= <<'END'; |
| { |
| no strict 'refs'; |
| # Fixed between 5.005_53 and 5.005_61 |
| #XXX if ($] >= 5.00561) { |
| #XXX *$AUTOLOAD = sub () { $val }; |
| #XXX } |
| #XXX else { |
| *$AUTOLOAD = sub { $val }; |
| #XXX } |
| } |
| goto &$AUTOLOAD; |
| } |
| |
| END |
| |
| return $func; |
| } |
| |
| |
| =item WriteMakefileSnippet |
| |
| WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] |
| |
| A function to generate perl code for Makefile.PL that will regenerate |
| the constant subroutines. Parameters are named as passed to C<WriteConstants>, |
| with the addition of C<INDENT> to specify the number of leading spaces |
| (default 2). |
| |
| Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and |
| C<XS_FILE> are recognised. |
| |
| =cut |
| |
| sub WriteMakefileSnippet { |
| my %args = @_; |
| my $indent = $args{INDENT} || 2; |
| |
| my $result = <<"EOT"; |
| ExtUtils::Constant::WriteConstants( |
| NAME => '$args{NAME}', |
| NAMES => \\\@names, |
| DEFAULT_TYPE => '$args{DEFAULT_TYPE}', |
| EOT |
| foreach (qw (C_FILE XS_FILE)) { |
| next unless exists $args{$_}; |
| $result .= sprintf " %-12s => '%s',\n", |
| $_, $args{$_}; |
| } |
| $result .= <<'EOT'; |
| ); |
| EOT |
| |
| $result =~ s/^/' 'x$indent/gem; |
| return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, |
| indent=>$indent,}, |
| @{$args{NAMES}}) |
| . $result; |
| } |
| |
| =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] |
| |
| Writes a file of C code and a file of XS code which you should C<#include> |
| and C<INCLUDE> in the C and XS sections respectively of your module's XS |
| code. You probably want to do this in your C<Makefile.PL>, so that you can |
| easily edit the list of constants without touching the rest of your module. |
| The attributes supported are |
| |
| =over 4 |
| |
| =item NAME |
| |
| Name of the module. This must be specified |
| |
| =item DEFAULT_TYPE |
| |
| The default type for the constants. If not specified C<IV> is assumed. |
| |
| =item BREAKOUT_AT |
| |
| The names of the constants are grouped by length. Generate child subroutines |
| for each group with this number or more names in. |
| |
| =item NAMES |
| |
| An array of constants' names, either scalars containing names, or hashrefs |
| as detailed in L<"C_constant">. |
| |
| =item PROXYSUBS |
| |
| If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>. |
| |
| =item C_FH |
| |
| A filehandle to write the C code to. If not given, then I<C_FILE> is opened |
| for writing. |
| |
| =item C_FILE |
| |
| The name of the file to write containing the C code. The default is |
| C<const-c.inc>. The C<-> in the name ensures that the file can't be |
| mistaken for anything related to a legitimate perl package name, and |
| not naming the file C<.c> avoids having to override Makefile.PL's |
| C<.xs> to C<.c> rules. |
| |
| =item XS_FH |
| |
| A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened |
| for writing. |
| |
| =item XS_FILE |
| |
| The name of the file to write containing the XS code. The default is |
| C<const-xs.inc>. |
| |
| =item XS_SUBNAME |
| |
| The perl visible name of the XS subroutine generated which will return the |
| constants. The default is C<constant>. |
| |
| =item C_SUBNAME |
| |
| The name of the C subroutine generated which will return the constants. |
| The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name |
| length appended, so constants with 10 character names would be in |
| C<constant_10> with the default I<XS_SUBNAME>. |
| |
| =back |
| |
| =cut |
| |
| sub WriteConstants { |
| my %ARGS = |
| ( # defaults |
| C_FILE => 'const-c.inc', |
| XS_FILE => 'const-xs.inc', |
| XS_SUBNAME => 'constant', |
| DEFAULT_TYPE => 'IV', |
| @_); |
| |
| $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0' |
| |
| croak "Module name not specified" unless length $ARGS{NAME}; |
| |
| # Do this before creating (empty) files, in case it fails: |
| require ExtUtils::Constant::ProxySubs if $ARGS{PROXYSUBS}; |
| |
| my $c_fh = $ARGS{C_FH}; |
| if (!$c_fh) { |
| if ($] <= 5.008) { |
| # We need these little games, rather than doing things |
| # unconditionally, because we're used in core Makefile.PLs before |
| # IO is available (needed by filehandle), but also we want to work on |
| # older perls where undefined scalars do not automatically turn into |
| # anonymous file handles. |
| require FileHandle; |
| $c_fh = FileHandle->new(); |
| } |
| open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; |
| } |
| |
| my $xs_fh = $ARGS{XS_FH}; |
| if (!$xs_fh) { |
| if ($] <= 5.008) { |
| require FileHandle; |
| $xs_fh = FileHandle->new(); |
| } |
| open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; |
| } |
| |
| # As this subroutine is intended to make code that isn't edited, there's no |
| # need for the user to specify any types that aren't found in the list of |
| # names. |
| |
| if ($ARGS{PROXYSUBS}) { |
| $ARGS{C_FH} = $c_fh; |
| $ARGS{XS_FH} = $xs_fh; |
| ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS); |
| } else { |
| my $types = {}; |
| |
| print $c_fh constant_types(); # macro defs |
| print $c_fh "\n"; |
| |
| # indent is still undef. Until anyone implements indent style rules with |
| # it. |
| foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, |
| subname => $ARGS{C_SUBNAME}, |
| default_type => |
| $ARGS{DEFAULT_TYPE}, |
| types => $types, |
| breakout => |
| $ARGS{BREAKOUT_AT}}, |
| @{$ARGS{NAMES}})) { |
| print $c_fh $_, "\n"; # C constant subs |
| } |
| print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, |
| $ARGS{C_SUBNAME}); |
| } |
| |
| close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH}; |
| close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH}; |
| } |
| |
| 1; |
| __END__ |
| |
| =back |
| |
| =head1 AUTHOR |
| |
| Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and |
| others |
| |
| =cut |