| Current File : /home/mmdealscpanel/yummmdeals.com/ExtUtils.zip |
PK ()�Z�� *'+ '+ typemapnu �[��� # basic C types
int T_IV
unsigned T_UV
unsigned int T_UV
long T_IV
unsigned long T_UV
short T_IV
unsigned short T_UV
char T_CHAR
unsigned char T_U_CHAR
char * T_PV
unsigned char * T_PV
const char * T_PV
caddr_t T_PV
wchar_t * T_PV
wchar_t T_IV
# bool_t is defined in <rpc/rpc.h>
bool_t T_IV
size_t T_UV
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
char ** T_PACKEDARRAY
void * T_PTR
Time_t * T_PV
SV * T_SV
# These are the backwards-compatibility AV*/HV* typemaps that
# do not decrement refcounts. Locally override with
# "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED",
# "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED",
# to get the fixed versions.
SVREF T_SVREF
CV * T_CVREF
AV * T_AVREF
HV * T_HVREF
IV T_IV
UV T_UV
NV T_NV
I32 T_IV
I16 T_IV
I8 T_IV
STRLEN T_UV
U32 T_U_LONG
U16 T_U_SHORT
U8 T_UV
Result T_U_CHAR
Boolean T_BOOL
float T_FLOAT
double T_DOUBLE
SysRet T_SYSRET
SysRetLong T_SYSRET
FILE * T_STDIO
PerlIO * T_INOUT
FileHandle T_PTROBJ
InputStream T_IN
InOutStream T_INOUT
OutputStream T_OUT
bool T_BOOL
#############################################################################
INPUT
T_SV
$var = $arg
T_SVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv)){
$var = SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_SVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv)){
$var = SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_AVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
$var = (AV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_AVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
$var = (AV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_HVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
$var = (HV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not a HASH reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_HVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
$var = (HV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak_nocontext(\"%s: %s is not a HASH reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_CVREF
STMT_START {
HV *st;
GV *gvp;
SV * const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
$var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
if (!$var) {
Perl_croak_nocontext(\"%s: %s is not a CODE reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_CVREF_REFCOUNT_FIXED
STMT_START {
HV *st;
GV *gvp;
SV * const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
$var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
if (!$var) {
Perl_croak_nocontext(\"%s: %s is not a CODE reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_SYSRET
$var NOT IMPLEMENTED
T_UV
$var = ($type)SvUV($arg)
T_IV
$var = ($type)SvIV($arg)
T_INT
$var = (int)SvIV($arg)
T_ENUM
$var = ($type)SvIV($arg)
T_BOOL
$var = (bool)SvTRUE($arg)
T_U_INT
$var = (unsigned int)SvUV($arg)
T_SHORT
$var = (short)SvIV($arg)
T_U_SHORT
$var = (unsigned short)SvUV($arg)
T_LONG
$var = (long)SvIV($arg)
T_U_LONG
$var = (unsigned long)SvUV($arg)
T_CHAR
$var = (char)*SvPV_nolen($arg)
T_U_CHAR
$var = (unsigned char)SvUV($arg)
T_FLOAT
$var = (float)SvNV($arg)
T_NV
$var = ($type)SvNV($arg)
T_DOUBLE
$var = (double)SvNV($arg)
T_PV
$var = ($type)SvPV_nolen($arg)
T_PTR
$var = INT2PTR($type,SvIV($arg))
T_PTRREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\")
T_REF_IV_REF
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type *, tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_REF_IV_PTR
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type, tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_PTROBJ
if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_PTRDESC
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
${type}_desc = (\U${type}_DESC\E*) tmp;
$var = ${type}_desc->ptr;
}
else
Perl_croak_nocontext(\"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_REFREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\")
T_REFOBJ
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak_nocontext(\"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_OPAQUE
$var = *($type *)SvPV_nolen($arg)
T_OPAQUEPTR
$var = ($type)SvPV_nolen($arg)
T_PACKED
$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
$var = XS_unpack_$ntype($arg)
T_ARRAY
U32 ix_$var = $argoff;
$var = $ntype(items -= $argoff);
while (items--) {
DO_ARRAY_ELEM;
ix_$var++;
}
/* this is the number of elements in the array */
ix_$var -= $argoff
T_STDIO
$var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
$var = IoIFP(sv_2io($arg))
T_INOUT
$var = IoIFP(sv_2io($arg))
T_OUT
$var = IoOFP(sv_2io($arg))
#############################################################################
OUTPUT
T_SV
$arg = $var;
T_SVREF
$arg = newRV((SV*)$var);
T_SVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_AVREF
$arg = newRV((SV*)$var);
T_AVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_HVREF
$arg = newRV((SV*)$var);
T_HVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_CVREF
$arg = newRV((SV*)$var);
T_CVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_IV
sv_setiv($arg, (IV)$var);
T_UV
sv_setuv($arg, (UV)$var);
T_INT
sv_setiv($arg, (IV)$var);
T_SYSRET
if ($var != -1) {
if ($var == 0)
sv_setpvn($arg, "0 but true", 10);
else
sv_setiv($arg, (IV)$var);
}
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"}
T_U_INT
sv_setuv($arg, (UV)$var);
T_SHORT
sv_setiv($arg, (IV)$var);
T_U_SHORT
sv_setuv($arg, (UV)$var);
T_LONG
sv_setiv($arg, (IV)$var);
T_U_LONG
sv_setuv($arg, (UV)$var);
T_CHAR
sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
sv_setuv($arg, (UV)$var);
T_FLOAT
sv_setnv($arg, (double)$var);
T_NV
sv_setnv($arg, (NV)$var);
T_DOUBLE
sv_setnv($arg, (double)$var);
T_PV
sv_setpv((SV*)$arg, $var);
T_PTR
sv_setiv($arg, PTR2IV($var));
T_PTRREF
sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
T_REF_IV_PTR
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTROBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTRDESC
sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
T_REFREF
NOT_IMPLEMENTED
T_REFOBJ
NOT IMPLEMENTED
T_OPAQUE
sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
sv_setpvn($arg, (char *)$var, sizeof(*$var));
T_PACKED
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
T_ARRAY
{
U32 ix_$var;
SSize_t extend_size =
/* The weird way this is written is because g++ is dumb
* enough to warn "comparison is always false" on something
* like:
*
* sizeof(a) > sizeof(b) && a > B_t_MAX
*
* (where the LH condition is false)
*/
(size_$var > (sizeof(size_$var) > sizeof(SSize_t)
? SSize_t_MAX : size_$var))
? -1 : (SSize_t)size_$var;
EXTEND(SP, extend_size);
for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
ST(ix_$var) = sv_newmortal();
DO_ARRAY_ELEM
}
}
T_STDIO
{
GV *gv = newGVgen("$Package");
PerlIO *fp = PerlIO_importFILE($var,0);
if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) {
SV *rv = newRV_inc((SV*)gv);
rv = sv_bless(rv, GvSTASH(gv));
${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
: \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
}${"$var" ne "RETVAL" ? \"
else
sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_IN
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) {
SV *rv = newRV_inc((SV*)gv);
rv = sv_bless(rv, GvSTASH(gv));
${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
: \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
}${"$var" ne "RETVAL" ? \"
else
sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_INOUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) {
SV *rv = newRV_inc((SV*)gv);
rv = sv_bless(rv, GvSTASH(gv));
${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
: \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
}${"$var" ne "RETVAL" ? \"
else
sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_OUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) {
SV *rv = newRV_inc((SV*)gv);
rv = sv_bless(rv, GvSTASH(gv));
${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
: \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
}${"$var" ne "RETVAL" ? \"
else
sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
PK ()�Z
DA�� � Miniperl.pmnu �[��� #!./perl -w
package ExtUtils::Miniperl;
use strict;
require Exporter;
use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body);
use vars qw($VERSION @ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(writemain);
$VERSION = '1.06';
# blead will run this with miniperl, hence we can't use autodie or File::Temp
my $temp;
END {
return if !defined $temp || !-e $temp;
unlink $temp or warn "Can't unlink '$temp': $!";
}
sub writemain{
my ($fh, $real);
if (ref $_[0] eq 'SCALAR') {
$real = ${+shift};
$temp = $real;
$temp =~ s/(?:.c)?\z/.new/;
open $fh, '>', $temp
or die "Can't open '$temp' for writing: $!";
} elsif (ref $_[0]) {
$fh = shift;
} else {
$fh = \*STDOUT;
}
my(@exts) = @_;
printf $fh <<'EOF!HEAD', xsi_header();
/* miniperlmain.c or perlmain.c - a generated file
*
* Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
* 2004, 2005, 2006, 2007, 2016 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* The Road goes ever on and on
* Down from the door where it began.
*
* [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
* [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
*/
/* This file contains the main() function for the perl interpreter.
* Note that miniperlmain.c contains main() for the 'miniperl' binary,
* while perlmain.c contains main() for the 'perl' binary. The typical
* difference being that the latter includes Dynaloader.
*
* Miniperl is like perl except that it does not support dynamic loading,
* and in fact is used to build the dynamic modules needed for the 'real'
* perl executable.
*
* The content of the body of this generated file is mostly contained
* in Miniperl.pm - edit that file if you want to change anything.
* miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while
* perlmain.c is built automatically by Makefile (so the former is
* included in the tarball while the latter isn't).
*/
#ifdef OEMVS
#ifdef MYMALLOC
/* sbrk is limited to first heap segment so make it big */
#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#else
#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#endif
#endif
#define PERL_IN_MINIPERLMAIN_C
%s
static void xs_init (pTHX);
static PerlInterpreter *my_perl;
#if defined(PERL_GLOBAL_STRUCT_PRIVATE)
/* The static struct perl_vars* may seem counterproductive since the
* whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note
* that this static is not in the shared perl library, the globals PL_Vars
* and PL_VarsPtr will stay away. */
static struct perl_vars* my_plvarsp;
struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
#endif
#ifdef NO_ENV_ARRAY_IN_MAIN
extern char **environ;
int
main(int argc, char **argv)
#else
int
main(int argc, char **argv, char **env)
#endif
{
int exitstatus, i;
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *my_vars = init_global_struct();
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
int veto;
my_plvarsp = my_vars;
# endif
#endif /* PERL_GLOBAL_STRUCT */
#ifndef NO_ENV_ARRAY_IN_MAIN
PERL_UNUSED_ARG(env);
#endif
#ifndef PERL_USE_SAFE_PUTENV
PL_use_safe_putenv = FALSE;
#endif /* PERL_USE_SAFE_PUTENV */
/* if user wants control of gprof profiling off by default */
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
#ifdef NO_ENV_ARRAY_IN_MAIN
PERL_SYS_INIT3(&argc,&argv,&environ);
#else
PERL_SYS_INIT3(&argc,&argv,&env);
#endif
#if defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
* perl_construct() to keep libperl.a transparently fork()-safe.
* It is currently done here only because Apache/mod_perl have
* problems due to lack of a call to cancel pthread_atfork()
* handlers when shared objects that contain the handlers may
* be dlclose()d. This forces applications that embed perl to
* call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
* been called at least once before in the current process.
* --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
#endif
PERL_SYS_FPU_INIT;
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
#ifndef PERL_MICRO
/* Unregister our signal handler before destroying my_perl */
for (i = 1; PL_sig_name[i]; i++) {
if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) {
rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL);
}
}
#endif
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
/*
* The old environment may have been freed by perl_free()
* when PERL_TRACK_MEMPOOL is defined, but without having
* been restored by perl_destruct() before (this is only
* done if destruct_level > 0).
*
* It is important to have a valid environment for atexit()
* routines that are eventually called.
*/
environ = env;
#endif
PERL_SYS_TERM();
#ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
veto = my_plvarsp->Gveto_cleanup;
# endif
free_global_struct(my_vars);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
if (!veto)
my_plvarsp = NULL;
/* Remember, functions registered with atexit() can run after this point,
and may access "global" variables, and hence end up calling
Perl_GetVarsPrivate() */
#endif
#endif /* PERL_GLOBAL_STRUCT */
exit(exitstatus);
}
/* Register any extra external extensions */
EOF!HEAD
print $fh xsi_protos(@exts), <<'EOT', xsi_body(@exts), "}\n";
static void
xs_init(pTHX)
{
EOT
if ($real) {
close $fh or die "Can't close '$temp': $!";
rename $temp, $real or die "Can't rename '$temp' to '$real': $!";
}
}
1;
__END__
=head1 NAME
ExtUtils::Miniperl - write the C code for miniperlmain.c and perlmain.c
=head1 SYNOPSIS
use ExtUtils::Miniperl;
writemain(@directories);
# or
writemain($fh, @directories);
# or
writemain(\$filename, @directories);
=head1 DESCRIPTION
C<writemain()> takes an argument list of zero or more directories
containing archive
libraries that relate to perl modules and should be linked into a new
perl binary. It writes a corresponding F<miniperlmain.c> or F<perlmain.c>
file that
is a plain C file containing all the bootstrap code to make the
modules associated with the libraries available from within perl.
If the first argument to C<writemain()> is a reference to a scalar it is
used as the filename to open for output. Any other reference is used as
the filehandle to write to. Otherwise output defaults to C<STDOUT>.
The typical usage is from within perl's own Makefile (to build
F<perlmain.c>) or from F<regen/miniperlmain.pl> (to build miniperlmain.c).
So under normal circumstances you won't have to deal with this module
directly.
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
# ex: set ts=8 sts=4 sw=4 et:
PK ()�Z��3 � � Constant/Base.pmnu �[��� package ExtUtils::Constant::Base;
use strict;
use vars qw($VERSION);
use Carp;
use Text::Wrap;
use ExtUtils::Constant::Utils qw(C_stringify perl_stringify);
$VERSION = '0.05';
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
=head1 NAME
ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
=head1 SYNOPSIS
require ExtUtils::Constant::Base;
@ISA = 'ExtUtils::Constant::Base';
=head1 DESCRIPTION
ExtUtils::Constant::Base provides a base implementation of methods to
generate C code to give fast constant value lookup by named string. Currently
it's mostly used ExtUtils::Constant::XS, which generates the lookup code
for the constant() subroutine found in many XS modules.
=head1 USAGE
ExtUtils::Constant::Base exports no subroutines. The following methods are
available
=over 4
=cut
sub valid_type {
# Default to assuming that you don't need different types of return data.
1;
}
sub default_type {
'';
}
=item header
A method returning a scalar containing definitions needed, typically for a
C header file.
=cut
sub header {
''
}
# This might actually be a return statement. Note that you are responsible
# for any space you might need before your value, as it lets to perform
# "tricks" such as "return KEY_" and have strings appended.
sub assignment_clause_for_type;
# In which case this might be an empty string
sub return_statement_for_type {undef};
sub return_statement_for_notdef;
sub return_statement_for_notfound;
# "#if 1" is true to a C pre-processor
sub macro_from_name {
1;
}
sub macro_from_item {
1;
}
sub macro_to_ifdef {
my ($self, $macro) = @_;
if (ref $macro) {
return $macro->[0];
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return $macro ? "#ifdef $macro\n" : "#if 0\n";
}
return "";
}
sub macro_to_ifndef {
my ($self, $macro) = @_;
if (ref $macro) {
# Can't invert these stylishly, so "bodge it"
return "$macro->[0]#else\n";
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return $macro ? "#ifndef $macro\n" : "#if 1\n";
}
croak "Can't generate an ifndef for unconditional code";
}
sub macro_to_endif {
my ($self, $macro) = @_;
if (ref $macro) {
return $macro->[1];
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return "#endif\n";
}
return "";
}
sub name_param {
'name';
}
# This is possibly buggy, in that it's not mandatory (below, in the main
# C_constant parameters, but is expected to exist here, if it's needed)
# Buggy because if you're definitely pure 8 bit only, and will never be
# presented with your constants in utf8, the default form of C_constant can't
# be told not to do the utf8 version.
sub is_utf8_param {
'utf8';
}
sub memEQ {
"!memcmp";
}
=item memEQ_clause args_hashref
A method to return a suitable C C<if> statement to check whether I<name>
is equal to the C variable C<name>. If I<checked_at> is defined, then it
is used to avoid C<memEQ> for short names, or to generate a comment to
highlight the position of the character in the C<switch> statement.
If i<checked_at> is a reference to a scalar, then instead it gives
the characters pre-checked at the beginning, (and the number of chars by
which the C variable name has been advanced. These need to be chopped from
the front of I<name>).
=cut
sub memEQ_clause {
# if (memEQ(name, "thingy", 6)) {
# Which could actually be a character comparison or even ""
my ($self, $args) = @_;
my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)};
$indent = ' ' x ($indent || 4);
my $front_chop;
if (ref $checked_at) {
# regexp won't work on 5.6.1 without use utf8; in turn that won't work
# on 5.005_03.
substr ($name, 0, length $$checked_at,) = '';
$front_chop = C_stringify ($$checked_at);
undef $checked_at;
}
my $len = length $name;
if ($len < 2) {
return $indent . "{\n"
if (defined $checked_at and $checked_at == 0) or $len == 0;
# We didn't switch, drop through to the code for the 2 character string
$checked_at = 1;
}
my $name_param = $self->name_param;
if ($len < 3 and defined $checked_at) {
my $check;
if ($checked_at == 1) {
$check = 0;
} elsif ($checked_at == 0) {
$check = 1;
}
if (defined $check) {
my $char = C_stringify (substr $name, $check, 1);
# Placate 5.005 with a break in the string. I can't see a good way of
# getting it to not take [ as introducing an array lookup, even with
# ${name_param}[$check]
return $indent . "if ($name_param" . "[$check] == '$char') {\n";
}
}
if (($len == 2 and !defined $checked_at)
or ($len == 3 and defined ($checked_at) and $checked_at == 2)) {
my $char1 = C_stringify (substr $name, 0, 1);
my $char2 = C_stringify (substr $name, 1, 1);
return $indent .
"if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n";
}
if (($len == 3 and defined ($checked_at) and $checked_at == 1)) {
my $char1 = C_stringify (substr $name, 0, 1);
my $char2 = C_stringify (substr $name, 2, 1);
return $indent .
"if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n";
}
my $pointer = '^';
my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1;
if ($have_checked_last) {
# Checked at the last character, so no need to memEQ it.
$pointer = C_stringify (chop $name);
$len--;
}
$name = C_stringify ($name);
my $memEQ = $self->memEQ();
my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n";
# Put a little ^ under the letter we checked at
# Screws up for non printable and non-7 bit stuff, but that's too hard to
# get right.
if (defined $checked_at) {
$body .= $indent . "/* " . (' ' x length $memEQ)
. (' ' x length $name_param)
. (' ' x $checked_at) . $pointer
. (' ' x ($len - $checked_at + length $len)) . " */\n";
} elsif (defined $front_chop) {
$body .= $indent . "/* $front_chop"
. (' ' x ($len + 1 + length $len)) . " */\n";
}
return $body;
}
=item dump_names arg_hashref, ITEM...
An internal function to generate the embedded perl code that will regenerate
the constant subroutines. I<default_type>, I<types> and I<ITEM>s are the
same as for C_constant. I<indent> is treated as number of spaces to indent
by. If C<declare_types> is true a C<$types> is always declared in the perl
code generated, if defined and false never declared, and if undefined C<$types>
is only declared if the values in I<types> as passed in cannot be inferred from
I<default_types> and the I<ITEM>s.
=cut
sub dump_names {
my ($self, $args, @items) = @_;
my ($default_type, $what, $indent, $declare_types)
= @{$args}{qw(default_type what indent declare_types)};
$indent = ' ' x ($indent || 0);
my $result;
my (@simple, @complex, %used_types);
foreach (@items) {
my $type;
if (ref $_) {
$type = $_->{type} || $default_type;
if ($_->{utf8}) {
# For simplicity always skip the bytes case, and reconstitute this entry
# from its utf8 twin.
next if $_->{utf8} eq 'no';
# Copy the hashref, as we don't want to mess with the caller's hashref.
$_ = {%$_};
unless (is_perl56) {
utf8::decode ($_->{name});
} else {
$_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
}
delete $_->{utf8};
}
} else {
$_ = {name=>$_};
$type = $default_type;
}
$used_types{$type}++;
if ($type eq $default_type
# grr 5.6.1
and length $_->{name}
and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
and !defined ($_->{macro}) and !defined ($_->{value})
and !defined ($_->{default}) and !defined ($_->{pre})
and !defined ($_->{post}) and !defined ($_->{def_pre})
and !defined ($_->{def_post}) and !defined ($_->{weight})) {
# It's the default type, and the name consists only of A-Za-z0-9_
push @simple, $_->{name};
} else {
push @complex, $_;
}
}
if (!defined $declare_types) {
# Do they pass in any types we weren't already using?
foreach (keys %$what) {
next if $used_types{$_};
$declare_types++; # Found one in $what that wasn't used.
last; # And one is enough to terminate this loop
}
}
if ($declare_types) {
$result = $indent . 'my $types = {map {($_, 1)} qw('
. join (" ", sort keys %$what) . ")};\n";
}
local $Text::Wrap::huge = 'overflow';
local $Text::Wrap::columns = 80;
$result .= wrap ($indent . "my \@names = (qw(",
$indent . " ", join (" ", sort @simple) . ")");
if (@complex) {
foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
my $name = perl_stringify $item->{name};
my $line = ",\n$indent {name=>\"$name\"";
$line .= ", type=>\"$item->{type}\"" if defined $item->{type};
foreach my $thing (qw (macro value default pre post def_pre def_post)) {
my $value = $item->{$thing};
if (defined $value) {
if (ref $value) {
$line .= ", $thing=>[\""
. join ('", "', map {perl_stringify $_} @$value) . '"]';
} else {
$line .= ", $thing=>\"" . perl_stringify($value) . "\"";
}
}
}
$line .= "}";
# Ensure that the enclosing C comment doesn't end
# by turning */ into *" . "/
$line =~ s!\*\/!\*" . "/!gs;
# gcc -Wall doesn't like finding /* inside a comment
$line =~ s!\/\*!/" . "\*!gs;
$result .= $line;
}
}
$result .= ");\n";
$result;
}
=item assign arg_hashref, VALUE...
A method to return a suitable assignment clause. If I<type> is aggregate
(eg I<PVN> expects both pointer and length) then there should be multiple
I<VALUE>s for the components. I<pre> and I<post> if defined give snippets
of C code to proceed and follow the assignment. I<pre> will be at the start
of a block, so variables may be defined in it.
=cut
# Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
sub assign {
my $self = shift;
my $args = shift;
my ($indent, $type, $pre, $post, $item)
= @{$args}{qw(indent type pre post item)};
$post ||= '';
my $clause;
my $close;
if ($pre) {
chomp $pre;
$close = "$indent}\n";
$clause = $indent . "{\n";
$indent .= " ";
$clause .= "$indent$pre";
$clause .= ";" unless $pre =~ /;$/;
$clause .= "\n";
}
confess "undef \$type" unless defined $type;
confess "Can't generate code for type $type"
unless $self->valid_type($type);
$clause .= join '', map {"$indent$_\n"}
$self->assignment_clause_for_type({type=>$type,item=>$item}, @_);
chomp $post;
if (length $post) {
$clause .= "$post";
$clause .= ";" unless $post =~ /;$/;
$clause .= "\n";
}
my $return = $self->return_statement_for_type($type);
$clause .= "$indent$return\n" if defined $return;
$clause .= $close if $close;
return $clause;
}
=item return_clause arg_hashref, ITEM
A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
(as passed to C<C_constant> and C<match_clause>. I<indent> is the number
of spaces to indent, defaulting to 6.
=cut
sub return_clause {
##ifdef thingy
# *iv_return = thingy;
# return PERL_constant_ISIV;
##else
# return PERL_constant_NOTDEF;
##endif
my ($self, $args, $item) = @_;
my $indent = $args->{indent};
my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type)
= @$item{qw (name value default pre post def_pre def_post type)};
$value = $name unless defined $value;
my $macro = $self->macro_from_item($item);
$indent = ' ' x ($indent || 6);
unless (defined $type) {
# use Data::Dumper; print STDERR Dumper ($item);
confess "undef \$type";
}
##ifdef thingy
my $clause = $self->macro_to_ifdef($macro);
# *iv_return = thingy;
# return PERL_constant_ISIV;
$clause
.= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post,
item=>$item}, ref $value ? @$value : $value);
if (defined $macro && $macro ne "" && $macro ne "1") {
##else
$clause .= "#else\n";
# return PERL_constant_NOTDEF;
if (!defined $default) {
my $notdef = $self->return_statement_for_notdef();
$clause .= "$indent$notdef\n" if defined $notdef;
} else {
my @default = ref $default ? @$default : $default;
$type = shift @default;
$clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre,
post=>$post, item=>$item}, @default);
}
}
##endif
$clause .= $self->macro_to_endif($macro);
return $clause;
}
sub match_clause {
# $offset defined if we have checked an offset.
my ($self, $args, $item) = @_;
my ($offset, $indent) = @{$args}{qw(checked_at indent)};
$indent = ' ' x ($indent || 4);
my $body = '';
my ($no, $yes, $either, $name, $inner_indent);
if (ref $item eq 'ARRAY') {
($yes, $no) = @$item;
$either = $yes || $no;
confess "$item is $either expecting hashref in [0] || [1]"
unless ref $either eq 'HASH';
$name = $either->{name};
} else {
confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
if $item->{utf8};
$name = $item->{name};
$inner_indent = $indent;
}
$body .= $self->memEQ_clause ({name => $name, checked_at => $offset,
indent => length $indent});
# If we've been presented with an arrayref for $item, then the user string
# contains in the range 128-255, and we need to check whether it was utf8
# (or not).
# In the worst case we have two named constants, where one's name happens
# encoded in UTF8 happens to be the same byte sequence as the second's
# encoded in (say) ISO-8859-1.
# In this case, $yes and $no both have item hashrefs.
if ($yes) {
$body .= $indent . " if (" . $self->is_utf8_param . ") {\n";
} elsif ($no) {
$body .= $indent . " if (!" . $self->is_utf8_param . ") {\n";
}
if ($either) {
$body .= $self->return_clause ({indent=>4 + length $indent}, $either);
if ($yes and $no) {
$body .= $indent . " } else {\n";
$body .= $self->return_clause ({indent=>4 + length $indent}, $no);
}
$body .= $indent . " }\n";
} else {
$body .= $self->return_clause ({indent=>2 + length $indent}, $item);
}
$body .= $indent . "}\n";
}
=item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM...
An internal method to generate a suitable C<switch> clause, called by
C<C_constant> I<ITEM>s are in the hash ref format as given in the description
of C<C_constant>, and must all have the names of the same length, given by
I<NAMELEN>. I<ITEMHASH> is a reference to a hash, keyed by name, values being
the hashrefs in the I<ITEM> list. (No parameters are modified, and there can
be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without
causing problems - the hash is passed in to save generating it afresh for
each call).
=cut
sub switch_clause {
my ($self, $args, $namelen, $items, @items) = @_;
my ($indent, $comment) = @{$args}{qw(indent comment)};
$indent = ' ' x ($indent || 2);
local $Text::Wrap::huge = 'overflow';
local $Text::Wrap::columns = 80;
my @names = sort map {$_->{name}} @items;
my $leader = $indent . '/* ';
my $follower = ' ' x length $leader;
my $body = $indent . "/* Names all of length $namelen. */\n";
if (defined $comment) {
$body = wrap ($leader, $follower, $comment) . "\n";
$leader = $follower;
}
my @safe_names = @names;
foreach (@safe_names) {
confess sprintf "Name '$_' is length %d, not $namelen", length
unless length == $namelen;
# Argh. 5.6.1
# next unless tr/A-Za-z0-9_//c;
next if tr/A-Za-z0-9_// == length;
$_ = '"' . perl_stringify ($_) . '"';
# Ensure that the enclosing C comment doesn't end
# by turning */ into *" . "/
s!\*\/!\*"."/!gs;
# gcc -Wall doesn't like finding /* inside a comment
s!\/\*!/"."\*!gs;
}
$body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
# Figure out what to switch on.
# (RMS, Spread of jump table, Position, Hashref)
my @best = (1e38, ~0);
# Prefer the last character over the others. (As it lets us shorten the
# memEQ clause at no cost).
foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
my ($min, $max) = (~0, 0);
my %spread;
if (is_perl56) {
# Need proper Unicode preserving hash keys for bytes in range 128-255
# here too, for some reason. grr 5.6.1 yet again.
tie %spread, 'ExtUtils::Constant::Aaargh56Hash';
}
foreach (@names) {
my $char = substr $_, $i, 1;
my $ord = ord $char;
confess "char $ord is out of range" if $ord > 255;
$max = $ord if $ord > $max;
$min = $ord if $ord < $min;
push @{$spread{$char}}, $_;
# warn "$_ $char";
}
# I'm going to pick the character to split on that minimises the root
# mean square of the number of names in each case. Normally this should
# be the one with the most keys, but it may pick a 7 where the 8 has
# one long linear search. I'm not sure if RMS or just sum of squares is
# actually better.
# $max and $min are for the tie-breaker if the root mean squares match.
# Assuming that the compiler may be building a jump table for the
# switch() then try to minimise the size of that jump table.
# Finally use < not <= so that if it still ties the earliest part of
# the string wins. Because if that passes but the memEQ fails, it may
# only need the start of the string to bin the choice.
# I think. But I'm micro-optimising. :-)
# OK. Trump that. Now favour the last character of the string, before the
# rest.
my $ss;
$ss += @$_ * @$_ foreach values %spread;
my $rms = sqrt ($ss / keys %spread);
if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
@best = ($rms, $max - $min, $i, \%spread);
}
}
confess "Internal error. Failed to pick a switch point for @names"
unless defined $best[2];
# use Data::Dumper; print Dumper (@best);
my ($offset, $best) = @best[2,3];
$body .= $indent . "/* Offset $offset gives the best switch position. */\n";
my $do_front_chop = $offset == 0 && $namelen > 2;
if ($do_front_chop) {
$body .= $indent . "switch (*" . $self->name_param() . "++) {\n";
} else {
$body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n";
}
foreach my $char (sort keys %$best) {
confess sprintf "'$char' is %d bytes long, not 1", length $char
if length ($char) != 1;
confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255;
$body .= $indent . "case '" . C_stringify ($char) . "':\n";
foreach my $thisone (sort {
# Deal with the case of an item actually being an array ref to 1 or 2
# hashrefs. Don't assign to $a or $b, as they're aliases to the orignal
my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a;
my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b;
# Sort by weight first
($r->{weight} || 0) <=> ($l->{weight} || 0)
# Sort equal weights by name
or $l->{name} cmp $r->{name}}
# If this looks evil, maybe it is. $items is a
# hashref, and we're doing a hash slice on it
@{$items}{@{$best->{$char}}}) {
# warn "You are here";
if ($do_front_chop) {
$body .= $self->match_clause ({indent => 2 + length $indent,
checked_at => \$char}, $thisone);
} else {
$body .= $self->match_clause ({indent => 2 + length $indent,
checked_at => $offset}, $thisone);
}
}
$body .= $indent . " break;\n";
}
$body .= $indent . "}\n";
return $body;
}
sub C_constant_return_type {
"static int";
}
sub C_constant_prefix_param {
'';
}
sub C_constant_prefix_param_defintion {
'';
}
sub name_param_definition {
"const char *" . $_[0]->name_param;
}
sub namelen_param {
'len';
}
sub namelen_param_definition {
'size_t ' . $_[0]->namelen_param;
}
sub C_constant_other_params {
'';
}
sub C_constant_other_params_defintion {
'';
}
=item params WHAT
An "internal" method, subject to change, currently called to allow an
overriding class to cache information that will then be passed into all
the C<*param*> calls. (Yes, having to read the source to make sense of this is
considered a known bug). I<WHAT> is be a hashref of types the constant
function will return. In ExtUtils::Constant::XS this method is used to
returns a hashref keyed IV NV PV SV to show which combination of pointers will
be needed in the C argument list generated by
C_constant_other_params_definition and C_constant_other_params
=cut
sub params {
'';
}
=item dogfood arg_hashref, ITEM...
An internal function to generate the embedded perl code that will regenerate
the constant subroutines. Parameters are the same as for C_constant.
Currently the base class does nothing and returns an empty string.
=cut
sub dogfood {
''
}
=item normalise_items args, default_type, seen_types, seen_items, ITEM...
Convert the items to a normalised form. For 8 bit and Unicode values converts
the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded.
=cut
sub normalise_items
{
my $self = shift;
my $args = shift;
my $default_type = shift;
my $what = shift;
my $items = shift;
my @new_items;
foreach my $orig (@_) {
my ($name, $item);
if (ref $orig) {
# Make a copy which is a normalised version of the ref passed in.
$name = $orig->{name};
my ($type, $macro, $value) = @$orig{qw (type macro value)};
$type ||= $default_type;
$what->{$type} = 1;
$item = {name=>$name, type=>$type};
undef $macro if defined $macro and $macro eq $name;
$item->{macro} = $macro if defined $macro;
undef $value if defined $value and $value eq $name;
$item->{value} = $value if defined $value;
foreach my $key (qw(default pre post def_pre def_post weight
not_constant)) {
my $value = $orig->{$key};
$item->{$key} = $value if defined $value;
# warn "$key $value";
}
} else {
$name = $orig;
$item = {name=>$name, type=>$default_type};
$what->{$default_type} = 1;
}
warn +(ref ($self) || $self)
. "doesn't know how to handle values of type $_ used in macro $name"
unless $self->valid_type ($item->{type});
# tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c
# doesn't work. Upgrade to 5.8
# if ($name !~ tr/\0-\177//c || $] < 5.005_50) {
if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50
|| $args->{disable_utf8_duplication}) {
# No characters outside 7 bit ASCII.
if (exists $items->{$name}) {
die "Multiple definitions for macro $name";
}
$items->{$name} = $item;
} else {
# No characters outside 8 bit. This is hardest.
if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
confess "Unexpected ASCII definition for macro $name";
}
# Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/;
# if ($name !~ tr/\0-\377//c) {
if ($name =~ tr/\0-\377// == length $name) {
# if ($] < 5.007) {
# $name = pack "C*", unpack "U*", $name;
# }
$item->{utf8} = 'no';
$items->{$name}[1] = $item;
push @new_items, $item;
# Copy item, to create the utf8 variant.
$item = {%$item};
}
# Encode the name as utf8 bytes.
unless (is_perl56) {
utf8::encode($name);
} else {
# warn "Was >$name< " . length ${name};
$name = pack 'C*', unpack 'C*', $name . pack 'U*';
# warn "Now '${name}' " . length ${name};
}
if ($items->{$name}[0]) {
die "Multiple definitions for macro $name";
}
$item->{utf8} = 'yes';
$item->{name} = $name;
$items->{$name}[0] = $item;
# We have need for the utf8 flag.
$what->{''} = 1;
}
push @new_items, $item;
}
@new_items;
}
=item C_constant arg_hashref, ITEM...
A function that returns a B<list> of C subroutine definitions that return
the value and type of constants when passed the name by the XS wrapper.
I<ITEM...> gives a list of constant names. Each can either be a string,
which is taken as a C macro name, or a reference to a hash with the following
keys
=over 8
=item name
The name of the constant, as seen by the perl code.
=item type
The type of the constant (I<IV>, I<NV> etc)
=item value
A C expression for the value of the constant, or a list of C expressions if
the type is aggregate. This defaults to the I<name> if not given.
=item macro
The C pre-processor macro to use in the C<#ifdef>. This defaults to the
I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
array is passed then the first element is used in place of the C<#ifdef>
line, and the second element in place of the C<#endif>. This allows
pre-processor constructions such as
#if defined (foo)
#if !defined (bar)
...
#endif
#endif
to be used to determine if a constant is to be defined.
A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
test is omitted.
=item default
Default value to use (instead of C<croak>ing with "your vendor has not
defined...") to return if the macro isn't defined. Specify a reference to
an array with type followed by value(s).
=item pre
C code to use before the assignment of the value of the constant. This allows
you to use temporary variables to extract a value from part of a C<struct>
and return this as I<value>. This C code is places at the start of a block,
so you can declare variables in it.
=item post
C code to place between the assignment of value (to a temporary) and the
return from the function. This allows you to clear up anything in I<pre>.
Rarely needed.
=item def_pre
=item def_post
Equivalents of I<pre> and I<post> for the default value.
=item utf8
Generated internally. Is zero or undefined if name is 7 bit ASCII,
"no" if the name is 8 bit (and so should only match if SvUTF8() is false),
"yes" if the name is utf8 encoded.
The internals automatically clone any name with characters 128-255 but none
256+ (ie one that could be either in bytes or utf8) into a second entry
which is utf8 encoded.
=item weight
Optional sorting weight for names, to determine the order of
linear testing when multiple names fall in the same case of a switch clause.
Higher comes earlier, undefined defaults to zero.
=back
In the argument hashref, I<package> is the name of the package, and is only
used in comments inside the generated C code. I<subname> defaults to
C<constant> if undefined.
I<default_type> is the type returned by C<ITEM>s that don't specify their
type. It defaults to the value of C<default_type()>. I<types> should be given
either as a comma separated list of types that the C subroutine I<subname>
will generate or as a reference to a hash. I<default_type> will be added to
the list if not present, as will any types given in the list of I<ITEM>s. The
resultant list should be the same list of types that C<XS_constant> is
given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of
parameters to the constant function. I<indent> is currently unused and
ignored. In future it may be used to pass in information used to change the C
indentation style used.] The best way to maintain consistency is to pass in a
hash reference and let this function update it.
I<breakout> governs when child functions of I<subname> are generated. If there
are I<breakout> or more I<ITEM>s with the same length of name, then the code
to switch between them is placed into a function named I<subname>_I<len>, for
example C<constant_5> for names 5 characters long. The default I<breakout> is
3. A single C<ITEM> is always inlined.
=cut
# The parameter now BREAKOUT was previously documented as:
#
# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
# this length, and that the constant name passed in by perl is checked and
# also of this length. It is used during recursion, and should be C<undef>
# unless the caller has checked all the lengths during code generation, and
# the generated subroutine is only to be called with a name of this length.
#
# As you can see it now performs this function during recursion by being a
# scalar reference.
sub C_constant {
my ($self, $args, @items) = @_;
my ($package, $subname, $default_type, $what, $indent, $breakout) =
@{$args}{qw(package subname default_type types indent breakout)};
$package ||= 'Foo';
$subname ||= 'constant';
# I'm not using this. But a hashref could be used for full formatting without
# breaking this API
# $indent ||= 0;
my ($namelen, $items);
if (ref $breakout) {
# We are called recursively. We trust @items to be normalised, $what to
# be a hashref, and pinch %$items from our parent to save recalculation.
($namelen, $items) = @$breakout;
} else {
$items = {};
if (is_perl56) {
# Need proper Unicode preserving hash keys.
require ExtUtils::Constant::Aaargh56Hash;
tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
}
$breakout ||= 3;
$default_type ||= $self->default_type();
if (!ref $what) {
# Convert line of the form IV,UV,NV to hash
$what = {map {$_ => 1} split /,\s*/, ($what || '')};
# Figure out what types we're dealing with, and assign all unknowns to the
# default type
}
@items = $self->normalise_items ({}, $default_type, $what, $items, @items);
# use Data::Dumper; print Dumper @items;
}
my $params = $self->params ($what);
# Probably "static int"
my ($body, @subs);
$body = $self->C_constant_return_type($params) . "\n$subname ("
# Eg "pTHX_ "
. $self->C_constant_prefix_param_defintion($params)
# Probably "const char *name"
. $self->name_param_definition($params);
# Something like ", STRLEN len"
$body .= ", " . $self->namelen_param_definition($params)
unless defined $namelen;
$body .= $self->C_constant_other_params_defintion($params);
$body .= ") {\n";
if (defined $namelen) {
# We are a child subroutine. Print the simple description
my $comment = 'When generated this function returned values for the list'
. ' of names given here. However, subsequent manual editing may have'
. ' added or removed some.';
$body .= $self->switch_clause ({indent=>2, comment=>$comment},
$namelen, $items, @items);
} else {
# We are the top level.
$body .= " /* Initially switch on the length of the name. */\n";
$body .= $self->dogfood ({package => $package, subname => $subname,
default_type => $default_type, what => $what,
indent => $indent, breakout => $breakout},
@items);
$body .= ' switch ('.$self->namelen_param().") {\n";
# Need to group names of the same length
my @by_length;
foreach (@items) {
push @{$by_length[length $_->{name}]}, $_;
}
foreach my $i (0 .. $#by_length) {
next unless $by_length[$i]; # None of this length
$body .= " case $i:\n";
if (@{$by_length[$i]} == 1) {
my $only_thing = $by_length[$i]->[0];
if ($only_thing->{utf8}) {
if ($only_thing->{utf8} eq 'yes') {
# With utf8 on flag item is passed in element 0
$body .= $self->match_clause (undef, [$only_thing]);
} else {
# With utf8 off flag item is passed in element 1
$body .= $self->match_clause (undef, [undef, $only_thing]);
}
} else {
$body .= $self->match_clause (undef, $only_thing);
}
} elsif (@{$by_length[$i]} < $breakout) {
$body .= $self->switch_clause ({indent=>4},
$i, $items, @{$by_length[$i]});
} else {
# Only use the minimal set of parameters actually needed by the types
# of the names of this length.
my $what = {};
foreach (@{$by_length[$i]}) {
$what->{$_->{type}} = 1;
$what->{''} = 1 if $_->{utf8};
}
$params = $self->params ($what);
push @subs, $self->C_constant ({package=>$package,
subname=>"${subname}_$i",
default_type => $default_type,
types => $what, indent => $indent,
breakout => [$i, $items]},
@{$by_length[$i]});
$body .= " return ${subname}_$i ("
# Eg "aTHX_ "
. $self->C_constant_prefix_param($params)
# Probably "name"
. $self->name_param($params);
$body .= $self->C_constant_other_params($params);
$body .= ");\n";
}
$body .= " break;\n";
}
$body .= " }\n";
}
my $notfound = $self->return_statement_for_notfound();
$body .= " $notfound\n" if $notfound;
$body .= "}\n";
return (@subs, $body);
}
1;
__END__
=back
=head1 BUGS
Not everything is documented yet.
Probably others.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
PK ()�ZK, <� � Constant/XS.pmnu �[��� package ExtUtils::Constant::XS;
use strict;
use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
use Carp;
use ExtUtils::Constant::Utils 'perl_stringify';
require ExtUtils::Constant::Base;
@ISA = qw(ExtUtils::Constant::Base Exporter);
@EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
$VERSION = '0.03';
$is_perl56 = ($] < 5.007 && $] > 5.005_50);
=head1 NAME
ExtUtils::Constant::XS - generate C code for XS modules' constants.
=head1 SYNOPSIS
require ExtUtils::Constant::XS;
=head1 DESCRIPTION
ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
code for XS modules' constants.
=head1 BUGS
Nothing is documented.
Probably others.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
=cut
# '' is used as a flag to indicate non-ascii macro names, and hence the need
# to pass in the utf8 on/off flag.
%XS_Constant = (
'' => '',
IV => 'PUSHi(iv)',
UV => 'PUSHu((UV)iv)',
NV => 'PUSHn(nv)',
PV => 'PUSHp(pv, strlen(pv))',
PVN => 'PUSHp(pv, iv)',
SV => 'PUSHs(sv)',
YES => 'PUSHs(&PL_sv_yes)',
NO => 'PUSHs(&PL_sv_no)',
UNDEF => '', # implicit undef
);
%XS_TypeSet = (
IV => '*iv_return = ',
UV => '*iv_return = (IV)',
NV => '*nv_return = ',
PV => '*pv_return = ',
PVN => ['*pv_return = ', '*iv_return = (IV)'],
SV => '*sv_return = ',
YES => undef,
NO => undef,
UNDEF => undef,
);
sub header {
my $start = 1;
my @lines;
push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
foreach (sort keys %XS_Constant) {
next if $_ eq '';
push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
}
push @lines, << 'EOT';
#ifndef NVTYPE
typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
#endif
#ifndef aTHX_
#define aTHX_ /* 5.6 or later define this for threading support. */
#endif
#ifndef pTHX_
#define pTHX_ /* 5.6 or later define this for threading support. */
#endif
EOT
return join '', @lines;
}
sub valid_type {
my ($self, $type) = @_;
return exists $XS_TypeSet{$type};
}
# This might actually be a return statement
sub assignment_clause_for_type {
my $self = shift;
my $args = shift;
my $type = $args->{type};
my $typeset = $XS_TypeSet{$type};
if (ref $typeset) {
die "Type $type is aggregate, but only single value given"
if @_ == 1;
return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
} elsif (defined $typeset) {
confess "Aggregate value given for type $type"
if @_ > 1;
return "$typeset$_[0];";
}
return ();
}
sub return_statement_for_type {
my ($self, $type) = @_;
# In the future may pass in an options hash
$type = $type->{type} if ref $type;
"return PERL_constant_IS$type;";
}
sub return_statement_for_notdef {
# my ($self) = @_;
"return PERL_constant_NOTDEF;";
}
sub return_statement_for_notfound {
# my ($self) = @_;
"return PERL_constant_NOTFOUND;";
}
sub default_type {
'IV';
}
sub macro_from_name {
my ($self, $item) = @_;
my $macro = $item->{name};
$macro = $item->{value} unless defined $macro;
$macro;
}
sub macro_from_item {
my ($self, $item) = @_;
my $macro = $item->{macro};
$macro = $self->macro_from_name($item) unless defined $macro;
$macro;
}
# Keep to the traditional perl source macro
sub memEQ {
"memEQ";
}
sub params {
my ($self, $what) = @_;
foreach (sort keys %$what) {
warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
}
my $params = {};
$params->{''} = 1 if $what->{''};
$params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
$params->{NV} = 1 if $what->{NV};
$params->{PV} = 1 if $what->{PV} || $what->{PVN};
$params->{SV} = 1 if $what->{SV};
return $params;
}
sub C_constant_prefix_param {
"aTHX_ ";
}
sub C_constant_prefix_param_defintion {
"pTHX_ ";
}
sub namelen_param_definition {
'STRLEN ' . $_[0] -> namelen_param;
}
sub C_constant_other_params_defintion {
my ($self, $params) = @_;
my $body = '';
$body .= ", int utf8" if $params->{''};
$body .= ", IV *iv_return" if $params->{IV};
$body .= ", NV *nv_return" if $params->{NV};
$body .= ", const char **pv_return" if $params->{PV};
$body .= ", SV **sv_return" if $params->{SV};
$body;
}
sub C_constant_other_params {
my ($self, $params) = @_;
my $body = '';
$body .= ", utf8" if $params->{''};
$body .= ", iv_return" if $params->{IV};
$body .= ", nv_return" if $params->{NV};
$body .= ", pv_return" if $params->{PV};
$body .= ", sv_return" if $params->{SV};
$body;
}
sub dogfood {
my ($self, $args, @items) = @_;
my ($package, $subname, $default_type, $what, $indent, $breakout) =
@{$args}{qw(package subname default_type what indent breakout)};
my $result = <<"EOT";
/* When generated this function returned values for the list of names given
in this section of perl code. Rather than manually editing these functions
to add or remove constants, which would result in this comment and section
of code becoming inaccurate, we recommend that you edit this section of
code, and use it to regenerate a new set of constant functions which you
then use to replace the originals.
Regenerate these constant functions by feeding this entire source file to
perl -x
#!$^X -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
EOT
$result .= $self->dump_names ({default_type=>$default_type, what=>$what,
indent=>0, declare_types=>1},
@items);
$result .= <<'EOT';
print constant_types(), "\n"; # macro defs
EOT
$package = perl_stringify($package);
$result .=
"foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
# The form of the indent parameter isn't defined. (Yet)
if (defined $indent) {
require Data::Dumper;
$Data::Dumper::Terse=1;
$Data::Dumper::Terse=1; # Not used once. :-)
chomp ($indent = Data::Dumper::Dumper ($indent));
$result .= $indent;
} else {
$result .= 'undef';
}
$result .= ", $breakout" . ', @names) ) {
print $_, "\n"; # C constant subs
}
print "\n#### XS Section:\n";
print XS_constant ("' . $package . '", $types);
__END__
*/
';
$result;
}
1;
PK ()�Z-_|�&M &M Constant/ProxySubs.pmnu �[��� package ExtUtils::Constant::ProxySubs;
use strict;
use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
%type_to_C_value %type_is_a_problem %type_num_args
%type_temporary);
use Carp;
require ExtUtils::Constant::XS;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_TypeSet);
$VERSION = '0.08';
@ISA = 'ExtUtils::Constant::XS';
%type_to_struct =
(
IV => '{const char *name; I32 namelen; IV value;}',
NV => '{const char *name; I32 namelen; NV value;}',
UV => '{const char *name; I32 namelen; UV value;}',
PV => '{const char *name; I32 namelen; const char *value;}',
PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
YES => '{const char *name; I32 namelen;}',
NO => '{const char *name; I32 namelen;}',
UNDEF => '{const char *name; I32 namelen;}',
'' => '{const char *name; I32 namelen;} ',
);
%type_from_struct =
(
IV => sub { $_[0] . '->value' },
NV => sub { $_[0] . '->value' },
UV => sub { $_[0] . '->value' },
PV => sub { $_[0] . '->value' },
PVN => sub { $_[0] . '->value', $_[0] . '->len' },
YES => sub {},
NO => sub {},
UNDEF => sub {},
'' => sub {},
);
%type_to_sv =
(
IV => sub { "newSViv($_[0])" },
NV => sub { "newSVnv($_[0])" },
UV => sub { "newSVuv($_[0])" },
PV => sub { "newSVpv($_[0], 0)" },
PVN => sub { "newSVpvn($_[0], $_[1])" },
YES => sub { '&PL_sv_yes' },
NO => sub { '&PL_sv_no' },
UNDEF => sub { '&PL_sv_undef' },
'' => sub { '&PL_sv_yes' },
SV => sub {"SvREFCNT_inc($_[0])"},
);
%type_to_C_value =
(
YES => sub {},
NO => sub {},
UNDEF => sub {},
'' => sub {},
);
sub type_to_C_value {
my ($self, $type) = @_;
return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
}
# TODO - figure out if there is a clean way for the type_to_sv code to
# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
# SvREFCNT_inc
%type_is_a_problem =
(
# The documentation says *mortal SV*, but we now need a non-mortal copy.
SV => 1,
);
%type_temporary =
(
SV => ['SV *'],
PV => ['const char *'],
PVN => ['const char *', 'STRLEN'],
);
$type_temporary{$_} = [$_] foreach qw(IV UV NV);
while (my ($type, $value) = each %XS_TypeSet) {
$type_num_args{$type}
= defined $value ? ref $value ? scalar @$value : 1 : 0;
}
$type_num_args{''} = 0;
sub partition_names {
my ($self, $default_type, @items) = @_;
my (%found, @notfound, @trouble);
while (my $item = shift @items) {
my $default = delete $item->{default};
if ($default) {
# If we find a default value, convert it into a regular item and
# append it to the queue of items to process
my $default_item = {%$item};
$default_item->{invert_macro} = 1;
$default_item->{pre} = delete $item->{def_pre};
$default_item->{post} = delete $item->{def_post};
$default_item->{type} = shift @$default;
$default_item->{value} = $default;
push @items, $default_item;
} else {
# It can be "not found" unless it's the default (invert the macro)
# or the "macro" is an empty string (ie no macro)
push @notfound, $item unless $item->{invert_macro}
or !$self->macro_to_ifdef($self->macro_from_item($item));
}
if ($item->{pre} or $item->{post} or $item->{not_constant}
or $type_is_a_problem{$item->{type}}) {
push @trouble, $item;
} else {
push @{$found{$item->{type}}}, $item;
}
}
# use Data::Dumper; print Dumper \%found;
(\%found, \@notfound, \@trouble);
}
sub boottime_iterator {
my ($self, $type, $iterator, $hash, $subname, $push) = @_;
my $extractor = $type_from_struct{$type};
die "Can't find extractor code for type $type"
unless defined $extractor;
my $generator = $type_to_sv{$type};
die "Can't find generator code for type $type"
unless defined $generator;
my $athx = $self->C_constant_prefix_param();
if ($push) {
return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
while ($iterator->name) {
he = $subname($athx $hash, $iterator->name,
$iterator->namelen, %s);
av_push(push, newSVhek(HeKEY_hek(he)));
++$iterator;
}
EOBOOT
} else {
return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
while ($iterator->name) {
$subname($athx $hash, $iterator->name,
$iterator->namelen, %s);
++$iterator;
}
EOBOOT
}
}
sub name_len_value_macro {
my ($self, $item) = @_;
my $name = $item->{name};
my $value = $item->{value};
$value = $item->{name} unless defined $value;
my $namelen = length $name;
if ($name =~ tr/\0-\377// != $namelen) {
# the hash API signals UTF-8 by passing the length negated.
utf8::encode($name);
$namelen = -length $name;
}
$name = C_stringify($name);
my $macro = $self->macro_from_item($item);
($name, $namelen, $value, $macro);
}
sub WriteConstants {
my $self = shift;
my $ARGS = {@_};
my ($c_fh, $xs_fh, $c_subname, $default_type, $package)
= @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)};
my $xs_subname
= exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant';
my $options = $ARGS->{PROXYSUBS};
$options = {} unless ref $options;
my $push = $options->{push};
my $explosives = $options->{croak_on_read};
my $croak_on_error = $options->{croak_on_error};
my $autoload = $options->{autoload};
{
my $exclusive = 0;
++$exclusive if $explosives;
++$exclusive if $croak_on_error;
++$exclusive if $autoload;
# Until someone patches this (with test cases):
carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together")
if $exclusive > 1;
}
# Strictly it requires Perl_caller_cx
carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later")
if $croak_on_error && $^V < v5.13.5;
# Strictly this is actually 5.8.9, but it's not well tested there
my $can_do_pcs = $] >= 5.009;
# Until someone patches this (with test cases)
carp ("PROXYSUBS option 'push' requires v5.10 or later")
if $push && !$can_do_pcs;
# Until someone patches this (with test cases)
carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together")
if $explosives && $push;
# If anyone is insane enough to suggest a package name containing %
my $package_sprintf_safe = $package;
$package_sprintf_safe =~ s/%/%%/g;
# All the types we see
my $what = {};
# A hash to lookup items with.
my $items = {};
my @items = $self->normalise_items ({disable_utf8_duplication => 1},
$default_type, $what, $items,
@{$ARGS->{NAMES}});
# Partition the values by type. Also include any defaults in here
# Everything that doesn't have a default needs alternative code for
# "I'm missing"
# And everything that has pre or post code ends up in a private block
my ($found, $notfound, $trouble)
= $self->partition_names($default_type, @items);
my $pthx = $self->C_constant_prefix_param_defintion();
my $athx = $self->C_constant_prefix_param();
my $symbol_table = C_stringify($package) . '::';
$push = C_stringify($package . '::' . $push) if $push;
my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';
print $c_fh $self->header();
if ($autoload || $croak_on_error) {
print $c_fh <<'EOC';
/* This allows slightly more efficient code on !USE_ITHREADS: */
#ifdef USE_ITHREADS
# define COP_FILE(c) CopFILE(c)
# define COP_FILE_F "s"
#else
# define COP_FILE(c) CopFILESV(c)
# define COP_FILE_F SVf
#endif
EOC
}
my $return_type = $push ? 'HE *' : 'void';
print $c_fh <<"EOADD";
static $return_type
${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
EOADD
if (!$can_do_pcs) {
print $c_fh <<'EO_NOPCS';
if (namelen == namelen) {
EO_NOPCS
} else {
print $c_fh <<"EO_PCS";
HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
0);
SV *sv;
if (!he) {
Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
name);
}
sv = HeVAL(he);
if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) {
/* Someone has been here before us - have to make a real sub. */
EO_PCS
}
# This piece of code is common to both
print $c_fh <<"EOADD";
newCONSTSUB(hash, ${cast_CONSTSUB}name, value);
EOADD
if ($can_do_pcs) {
print $c_fh <<'EO_PCS';
} else {
SvUPGRADE(sv, SVt_RV);
SvRV_set(sv, value);
SvROK_on(sv);
SvREADONLY_on(value);
}
EO_PCS
} else {
print $c_fh <<'EO_NOPCS';
}
EO_NOPCS
}
print $c_fh " return he;\n" if $push;
print $c_fh <<'EOADD';
}
EOADD
print $c_fh $explosives ? <<"EXPLODE" : "\n";
static int
Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
{
PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_
"Your vendor has not defined $package_sprintf_safe macro %"SVf
" used", sv);
NORETURN_FUNCTION_END;
}
static MGVTBL not_defined_vtbl = {
Im_sorry_Dave, /* get - I'm afraid I can't do that */
Im_sorry_Dave, /* set */
0, /* len */
0, /* clear */
0, /* free */
0, /* copy */
0, /* dup */
};
EXPLODE
{
my $key = $symbol_table;
# Just seems tidier (and slightly more space efficient) not to have keys
# such as Fcntl::
$key =~ s/::$//;
my $key_len = length $key;
print $c_fh <<"MISSING";
#ifndef SYMBIAN
/* Store a hash of all symbols missing from the package. To avoid trampling on
the package namespace (uninvited) put each package's hash in our namespace.
To avoid creating lots of typeblogs and symbol tables for sub-packages, put
each package's hash into one hash in our namespace. */
static HV *
get_missing_hash(pTHX) {
HV *const parent
= get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
/* We could make a hash of hashes directly, but this would confuse anything
at Perl space that looks at us, and as we're visible in Perl space,
best to play nice. */
SV *const *const ref
= hv_fetch(parent, "$key", $key_len, TRUE);
HV *new_hv;
if (!ref)
return NULL;
if (SvROK(*ref))
return (HV*) SvRV(*ref);
new_hv = newHV();
SvUPGRADE(*ref, SVt_RV);
SvRV_set(*ref, (SV *)new_hv);
SvROK_on(*ref);
return new_hv;
}
#endif
MISSING
}
print $xs_fh <<"EOBOOT";
BOOT:
{
#ifdef dTHX
dTHX;
#endif
HV *symbol_table = get_hv("$symbol_table", GV_ADD);
EOBOOT
if ($push) {
print $xs_fh <<"EOC";
AV *push = get_av(\"$push\", GV_ADD);
HE *he;
EOC
}
my %iterator;
$found->{''}
= [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
foreach my $type (sort keys %$found) {
my $struct = $type_to_struct{$type};
my $type_to_value = $self->type_to_C_value($type);
my $number_of_args = $type_num_args{$type};
die "Can't find structure definition for type $type"
unless defined $struct;
my $lc_type = $type ? lc($type) : 'notfound';
my $struct_type = $lc_type . '_s';
my $array_name = 'values_for_' . $lc_type;
$iterator{$type} = 'value_for_' . $lc_type;
# Give the notfound struct file scope. The others are scoped within the
# BOOT block
my $struct_fh = $type ? $xs_fh : $c_fh;
print $c_fh "struct $struct_type $struct;\n";
print $struct_fh <<"EOBOOT";
static const struct $struct_type $array_name\[] =
{
EOBOOT
foreach my $item (@{$found->{$type}}) {
my ($name, $namelen, $value, $macro)
= $self->name_len_value_macro($item);
my $ifdef = $self->macro_to_ifdef($macro);
if (!$ifdef && $item->{invert_macro}) {
carp("Attempting to supply a default for '$name' which has no conditional macro");
next;
}
if ($item->{invert_macro}) {
print $struct_fh $self->macro_to_ifndef($macro);
print $struct_fh
" /* This is the default value: */\n" if $type;
} else {
print $struct_fh $ifdef;
}
print $struct_fh " { ", join (', ', "\"$name\"", $namelen,
&$type_to_value($value)),
" },\n",
$self->macro_to_endif($macro);
}
# Terminate the list with a NULL
print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
print $xs_fh <<"EOBOOT" if $type;
const struct $struct_type *$iterator{$type} = $array_name;
EOBOOT
}
delete $found->{''};
my $add_symbol_subname = $c_subname . '_add_symbol';
foreach my $type (sort keys %$found) {
print $xs_fh $self->boottime_iterator($type, $iterator{$type},
'symbol_table',
$add_symbol_subname, $push);
}
print $xs_fh <<"EOBOOT";
if (C_ARRAY_LENGTH(values_for_notfound) > 1) {
#ifndef SYMBIAN
HV *const ${c_subname}_missing = get_missing_hash(aTHX);
#endif
const struct notfound_s *value_for_notfound = values_for_notfound;
do {
EOBOOT
print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
SV *tripwire = newSV(0);
sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0);
SvPV_set(tripwire, (char *)value_for_notfound->name);
if(value_for_notfound->namelen >= 0) {
SvCUR_set(tripwire, value_for_notfound->namelen);
} else {
SvCUR_set(tripwire, -value_for_notfound->namelen);
SvUTF8_on(tripwire);
}
SvPOKp_on(tripwire);
SvREADONLY_on(tripwire);
assert(SvLEN(tripwire) == 0);
$add_symbol_subname($athx symbol_table, value_for_notfound->name,
value_for_notfound->namelen, tripwire);
EXPLODE
/* Need to add prototypes, else parsing will vary by platform. */
HE *he = (HE*) hv_common_key_len(symbol_table,
value_for_notfound->name,
value_for_notfound->namelen,
HV_FETCH_LVALUE, NULL, 0);
SV *sv;
#ifndef SYMBIAN
HEK *hek;
#endif
if (!he) {
Perl_croak($athx
"Couldn't add key '%s' to %%$package_sprintf_safe\::",
value_for_notfound->name);
}
sv = HeVAL(he);
if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
/* Nothing was here before, so mark a prototype of "" */
sv_setpvn(sv, "", 0);
} else if (SvPOK(sv) && SvCUR(sv) == 0) {
/* There is already a prototype of "" - do nothing */
} else {
/* Someone has been here before us - have to make a real
typeglob. */
/* It turns out to be incredibly hard to deal with all the
corner cases of sub foo (); and reporting errors correctly,
so lets cheat a bit. Start with a constant subroutine */
CV *cv = newCONSTSUB(symbol_table,
${cast_CONSTSUB}value_for_notfound->name,
&PL_sv_yes);
/* and then turn it into a non constant declaration only. */
SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
CvXSUB(cv) = NULL;
CvXSUBANY(cv).any_ptr = NULL;
}
#ifndef SYMBIAN
hek = HeKEY_hek(he);
if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek),
HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE,
&PL_sv_yes, HEK_HASH(hek)))
Perl_croak($athx "Couldn't add key '%s' to missing_hash",
value_for_notfound->name);
#endif
DONT
print $xs_fh " av_push(push, newSVhek(hek));\n"
if $push;
print $xs_fh <<"EOBOOT";
} while ((++value_for_notfound)->name);
}
EOBOOT
foreach my $item (@$trouble) {
my ($name, $namelen, $value, $macro)
= $self->name_len_value_macro($item);
my $ifdef = $self->macro_to_ifdef($macro);
my $type = $item->{type};
my $type_to_value = $self->type_to_C_value($type);
print $xs_fh $ifdef;
if ($item->{invert_macro}) {
print $xs_fh
" /* This is the default value: */\n" if $type;
print $xs_fh "#else\n";
}
my $generator = $type_to_sv{$type};
die "Can't find generator code for type $type"
unless defined $generator;
print $xs_fh " {\n";
# We need to use a temporary value because some really troublesome
# items use C pre processor directives in their values, and in turn
# these don't fit nicely in the macro-ised generator functions
my $counter = 0;
printf $xs_fh " %s temp%d;\n", $_, $counter++
foreach @{$type_temporary{$type}};
print $xs_fh " $item->{pre}\n" if $item->{pre};
# And because the code in pre might be both declarations and
# statements, we can't declare and assign to the temporaries in one.
$counter = 0;
printf $xs_fh " temp%d = %s;\n", $counter++, $_
foreach &$type_to_value($value);
my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
${c_subname}_add_symbol($athx symbol_table, "%s",
$namelen, %s);
EOBOOT
print $xs_fh " $item->{post}\n" if $item->{post};
print $xs_fh " }\n";
print $xs_fh $self->macro_to_endif($macro);
}
if ($] >= 5.009) {
print $xs_fh <<EOBOOT;
/* As we've been creating subroutines, we better invalidate any cached
methods */
mro_method_changed_in(symbol_table);
}
EOBOOT
} else {
print $xs_fh <<EOBOOT;
/* As we've been creating subroutines, we better invalidate any cached
methods */
++PL_sub_generation;
}
EOBOOT
}
return if !defined $xs_subname;
if ($croak_on_error || $autoload) {
print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA';
void
$xs_subname(sv)
INPUT:
SV * sv;
PREINIT:
const PERL_CONTEXT *cx = caller_cx(0, NULL);
/* cx is NULL if we've been called from the top level. PL_curcop isn't
ideal, but it's much cheaper than other ways of not going SEGV. */
const COP *cop = cx ? cx->blk_oldcop : PL_curcop;
EOC
void
AUTOLOAD()
PROTOTYPE: DISABLE
PREINIT:
SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
const COP *cop = PL_curcop;
EOA
print $xs_fh <<"EOC";
PPCODE:
#ifndef SYMBIAN
/* It's not obvious how to calculate this at C pre-processor time.
However, any compiler optimiser worth its salt should be able to
remove the dead code, and hopefully the now-obviously-unused static
function too. */
HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
? get_missing_hash(aTHX) : NULL;
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used at %" COP_FILE_F " line %" UVuf "\\n",
sv, COP_FILE(cop), (UV)CopLINE(cop));
} else
#endif
{
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
COP_FILE_F " line %" UVuf "\\n",
sv, COP_FILE(cop), (UV)CopLINE(cop));
}
croak_sv(sv_2mortal(sv));
EOC
} else {
print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
void
$xs_subname(sv)
INPUT:
SV * sv;
PPCODE:
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used", sv);
PUSHs(sv_2mortal(sv));
EXPLODE
void
$xs_subname(sv)
INPUT:
SV * sv;
PPCODE:
#ifndef SYMBIAN
/* It's not obvious how to calculate this at C pre-processor time.
However, any compiler optimiser worth its salt should be able to
remove the dead code, and hopefully the now-obviously-unused static
function too. */
HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
? get_missing_hash(aTHX) : NULL;
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used", sv);
} else
#endif
{
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
sv);
}
PUSHs(sv_2mortal(sv));
DONT
}
}
1;
PK ()�Z��`z�
�
Constant/Utils.pmnu �[��� package ExtUtils::Constant::Utils;
use strict;
use vars qw($VERSION @EXPORT_OK @ISA);
use Carp;
@ISA = 'Exporter';
@EXPORT_OK = qw(C_stringify perl_stringify);
$VERSION = '0.03';
use constant is_perl55 => ($] < 5.005_50);
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
use constant is_sane_perl => $] > 5.007;
=head1 NAME
ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant
=head1 SYNOPSIS
use ExtUtils::Constant::Utils qw (C_stringify);
$C_code = C_stringify $stuff;
=head1 DESCRIPTION
ExtUtils::Constant::Utils packages up utility subroutines used by
ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its
functions are explicitly exportable.
=head1 USAGE
=over 4
=item C_stringify NAME
A function which returns a 7 bit ASCII correctly \ escaped version of the
string passed suitable for C's "" or ''. It will die if passed Unicode
characters.
=cut
# Hopefully make a happy C identifier.
sub C_stringify {
local $_ = shift;
return unless defined $_;
# grr 5.6.1
confess "Wide character in '$_' intended as a C identifier"
if tr/\0-\377// != length;
# grr 5.6.1 moreso because its regexps will break on data that happens to
# be utf8, which includes my 8 bit test cases.
$_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if is_perl56;
s/\\/\\\\/g;
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
s/\r/\\r/g;
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
unless (is_perl55) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
my $cheat = '([[:^print:]])';
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
}
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
require POSIX;
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
}
$_;
}
=item perl_stringify NAME
A function which returns a 7 bit ASCII correctly \ escaped version of the
string passed suitable for a perl "" string.
=cut
# Hopefully make a happy perl identifier.
sub perl_stringify {
local $_ = shift;
return unless defined $_;
s/\\/\\\\/g;
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
s/\r/\\r/g;
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
unless (is_perl55) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
my $cheat = '([[:^print:]])';
if (is_sane_perl) {
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
s/$cheat/sprintf "\\x{%X}", ord $1/ge;
} else {
s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
}
} else {
# Grr 5.6.1. And I don't think I can use utf8; to force the regexp
# because 5.005_03 will fail.
# This is grim, but I also can't split on //
my $copy;
foreach my $index (0 .. length ($_) - 1) {
my $char = substr ($_, $index, 1);
$copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
}
$_ = $copy;
}
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
# Turns out "\x{}" notation only arrived with 5.6
s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
require POSIX;
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
}
$_;
}
1;
__END__
=back
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
PK ()�ZnMu��: �: Constant.pmnu �[��� 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 = 0; /* avoid uninit var warning */\n";
} else {
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
}
if ($params->{NV}) {
$xs .= " NV nv = 0.0; /* avoid uninit var warning */\n";
} else {
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
}
if ($params->{PV}) {
$xs .= " const char *pv = NULL; /* avoid uninit var warning */\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
PK ()�Z��F�1 �1 Embed.pmnu �[��� package ExtUtils::Embed;
require Exporter;
use Config;
require File::Spec;
use vars qw(@ISA @EXPORT $VERSION
@Extensions $Verbose $lib_ext
$opt_o $opt_s
);
use strict;
# This is not a dual-life module, so no need for development version numbers
$VERSION = '1.34';
@ISA = qw(Exporter);
@EXPORT = qw(&xsinit &ldopts
&ccopts &ccflags &ccdlflags &perl_inc
&xsi_header &xsi_protos &xsi_body);
$Verbose = 0;
$lib_ext = $Config{lib_ext} || '.a';
sub is_cmd { $0 eq '-e' }
sub my_return {
my $val = shift;
if(is_cmd) {
print $val;
}
else {
return $val;
}
}
sub xsinit {
my($file, $std, $mods) = @_;
my($fh,@mods,%seen);
$file ||= "perlxsi.c";
my $xsinit_proto = "pTHX";
if (@_) {
@mods = @$mods if $mods;
}
else {
require Getopt::Std;
Getopt::Std::getopts('o:s:');
$file = $opt_o if defined $opt_o;
$std = $opt_s if defined $opt_s;
@mods = @ARGV;
}
$std = 1 unless scalar @mods;
if ($file eq "STDOUT") {
$fh = \*STDOUT;
}
else {
open $fh, '>', $file
or die "Can't open '$file': $!";
}
push(@mods, static_ext()) if defined $std;
@mods = grep(!$seen{$_}++, @mods);
print $fh &xsi_header();
print $fh "\nEXTERN_C void xs_init ($xsinit_proto);\n\n";
print $fh &xsi_protos(@mods);
print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
print $fh &xsi_body(@mods);
print $fh "}\n";
}
sub xsi_header {
return <<EOF;
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
EOF
}
sub xsi_protos {
my @exts = @_;
my %seen;
my $retval = '';
foreach my $cname (canon('__', @exts)) {
my $ccode = "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n";
$retval .= $ccode
unless $seen{$ccode}++;
}
return $retval;
}
sub xsi_body {
my @exts = @_;
my %seen;
my $retval;
$retval .= " static const char file[] = __FILE__;\n"
if @exts;
$retval .= <<'EOT';
dXSUB_SYS;
PERL_UNUSED_CONTEXT;
EOT
$retval .= "\n"
if @exts;
foreach my $pname (canon('/', @exts)) {
next
if $seen{$pname}++;
(my $mname = $pname) =~ s!/!::!g;
(my $cname = $pname) =~ s!/!__!g;
my $fname;
if ($pname eq 'DynaLoader'){
# Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
# boot_DynaLoader is called directly in DynaLoader.pm
$retval .= " /* DynaLoader is a special case */\n";
$fname = "${mname}::boot_DynaLoader";
} else {
$fname = "${mname}::bootstrap";
}
$retval .= " newXS(\"$fname\", boot_${cname}, file);\n"
}
return $retval;
}
sub static_ext {
@Extensions = ('DynaLoader', sort $Config{static_ext} =~ /(\S+)/g)
unless @Extensions;
@Extensions;
}
sub _escape {
my $arg = shift;
return $$arg if $^O eq 'VMS'; # parens legal in qualifier lists
$$arg =~ s/([\(\)])/\\$1/g;
}
sub _ldflags {
my $ldflags = $Config{ldflags};
_escape(\$ldflags);
return $ldflags;
}
sub _ccflags {
my $ccflags = $Config{ccflags};
_escape(\$ccflags);
return $ccflags;
}
sub _ccdlflags {
my $ccdlflags = $Config{ccdlflags};
_escape(\$ccdlflags);
return $ccdlflags;
}
sub ldopts {
require ExtUtils::MakeMaker;
require ExtUtils::Liblist;
my($std,$mods,$link_args,$path) = @_;
my(@mods,@link_args,@argv);
my($dllib,$config_libs,@potential_libs,@path);
local($") = ' ' unless $" eq ' ';
if (scalar @_) {
@link_args = @$link_args if $link_args;
@mods = @$mods if $mods;
}
else {
@argv = @ARGV;
#hmm
while($_ = shift @argv) {
/^-std$/ && do { $std = 1; next; };
/^--$/ && do { @link_args = @argv; last; };
/^-I(.*)/ && do { $path = $1 || shift @argv; next; };
push(@mods, $_);
}
}
$std = 1 unless scalar @link_args;
my $sep = $Config{path_sep} || ':';
@path = $path ? split(/\Q$sep/, $path) : @INC;
push(@potential_libs, @link_args) if scalar @link_args;
# makemaker includes std libs on windows by default
if ($^O ne 'MSWin32' and defined($std)) {
push(@potential_libs, $Config{perllibs});
}
push(@mods, static_ext()) if $std;
my($mod,@ns,$root,$sub,$extra,$archive,@archives);
print STDERR "Searching (@path) for archives\n" if $Verbose;
foreach $mod (@mods) {
@ns = split(/::|\/|\\/, $mod);
$sub = $ns[-1];
$root = File::Spec->catdir(@ns);
print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
foreach (@path) {
next unless -e ($archive = File::Spec->catdir($_,"auto",$root,"$sub$lib_ext"));
push @archives, $archive;
if(-e ($extra = File::Spec->catdir($_,"auto",$root,"extralibs.ld"))) {
local(*FH);
if(open(FH, '<', $extra)) {
my($libs) = <FH>; chomp $libs;
push @potential_libs, split /\s+/, $libs;
}
else {
warn "Couldn't open '$extra'";
}
}
last;
}
}
#print STDERR "\@potential_libs = @potential_libs\n";
my $libperl;
if ($^O eq 'MSWin32') {
$libperl = $Config{libperl};
}
elsif ($^O eq 'os390' && $Config{usedl}) {
# Nothing for OS/390 (z/OS) dynamic.
} else {
$libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0]
|| ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/
? "-l$1" : '')
|| "-lperl";
}
my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE');
$lpath = qq["$lpath"] if $^O eq 'MSWin32';
my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs);
my $ld_or_bs = $bsloadlibs || $ldloadlibs;
print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
my $ccdlflags = _ccdlflags();
my $ldflags = _ldflags();
my $linkage = "$ccdlflags $ldflags @archives $ld_or_bs";
print STDERR "ldopts: '$linkage'\n" if $Verbose;
return $linkage if scalar @_;
my_return("$linkage\n");
}
sub ccflags {
my $ccflags = _ccflags();
my_return(" $ccflags ");
}
sub ccdlflags {
my $ccdlflags = _ccdlflags();
my_return(" $ccdlflags ");
}
sub perl_inc {
my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE');
$dir = qq["$dir"] if $^O eq 'MSWin32';
my_return(" -I$dir ");
}
sub ccopts {
ccflags . perl_inc;
}
sub canon {
my($as, @ext) = @_;
foreach(@ext) {
# might be X::Y or lib/auto/X/Y/Y.a
next
if s!::!/!g;
s!^(?:lib|ext|dist|cpan)/(?:auto/)?!!;
s!/\w+\.\w+$!!;
}
if ($as ne '/') {
s!/!$as!g
foreach @ext;
}
@ext;
}
__END__
=head1 NAME
ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
=head1 SYNOPSIS
perl -MExtUtils::Embed -e xsinit
perl -MExtUtils::Embed -e ccopts
perl -MExtUtils::Embed -e ldopts
=head1 DESCRIPTION
C<ExtUtils::Embed> provides utility functions for embedding a Perl interpreter
and extensions in your C/C++ applications.
Typically, an application F<Makefile> will invoke C<ExtUtils::Embed>
functions while building your application.
=head1 @EXPORT
C<ExtUtils::Embed> exports the following functions:
xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(),
ccdlflags(), xsi_header(), xsi_protos(), xsi_body()
=head1 FUNCTIONS
=over 4
=item xsinit()
Generate C/C++ code for the XS initializer function.
When invoked as C<`perl -MExtUtils::Embed -e xsinit --`>
the following options are recognized:
B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>)
B<-o STDOUT> will print to STDOUT.
B<-std> (Write code for extensions that are linked with the current Perl.)
Any additional arguments are expected to be names of modules
to generate code for.
When invoked with parameters the following are accepted and optional:
C<xsinit($filename,$std,[@modules])>
Where,
B<$filename> is equivalent to the B<-o> option.
B<$std> is boolean, equivalent to the B<-std> option.
B<[@modules]> is an array ref, same as additional arguments mentioned above.
=item Examples
perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket
This will generate code with an C<xs_init> function that glues the perl C<Socket::bootstrap> function
to the C C<boot_Socket> function and writes it to a file named F<xsinit.c>.
Note that L<DynaLoader> is a special case where it must call C<boot_DynaLoader> directly.
perl -MExtUtils::Embed -e xsinit
This will generate code for linking with C<DynaLoader> and
each static extension found in C<$Config{static_ext}>.
The code is written to the default file name F<perlxsi.c>.
perl -MExtUtils::Embed -e xsinit -- -o xsinit.c \
-std DBI DBD::Oracle
Here, code is written for all the currently linked extensions along with code
for C<DBI> and C<DBD::Oracle>.
If you have a working C<DynaLoader> then there is rarely any need to statically link in any
other extensions.
=item ldopts()
Output arguments for linking the Perl library and extensions to your
application.
When invoked as C<`perl -MExtUtils::Embed -e ldopts --`>
the following options are recognized:
B<-std>
Output arguments for linking the Perl library and any extensions linked
with the current Perl.
B<-I> E<lt>path1:path2E<gt>
Search path for ModuleName.a archives.
Default path is C<@INC>.
Library archives are expected to be found as
F</some/path/auto/ModuleName/ModuleName.a>
For example, when looking for F<Socket.a> relative to a search path,
we should find F<auto/Socket/Socket.a>
When looking for C<DBD::Oracle> relative to a search path,
we should find F<auto/DBD/Oracle/Oracle.a>
Keep in mind that you can always supply F</my/own/path/ModuleName.a>
as an additional linker argument.
B<--> E<lt>list of linker argsE<gt>
Additional linker arguments to be considered.
Any additional arguments found before the B<--> token
are expected to be names of modules to generate code for.
When invoked with parameters the following are accepted and optional:
C<ldopts($std,[@modules],[@link_args],$path)>
Where:
B<$std> is boolean, equivalent to the B<-std> option.
B<[@modules]> is equivalent to additional arguments found before the B<--> token.
B<[@link_args]> is equivalent to arguments found after the B<--> token.
B<$path> is equivalent to the B<-I> option.
In addition, when ldopts is called with parameters, it will return the argument string
rather than print it to STDOUT.
=item Examples
perl -MExtUtils::Embed -e ldopts
This will print arguments for linking with C<libperl> and
extensions found in C<$Config{static_ext}>. This includes libraries
found in C<$Config{libs}> and the first ModuleName.a library
for each extension that is found by searching C<@INC> or the path
specified by the B<-I> option.
In addition, when ModuleName.a is found, additional linker arguments
are picked up from the F<extralibs.ld> file in the same directory.
perl -MExtUtils::Embed -e ldopts -- -std Socket
This will do the same as the above example, along with printing additional
arguments for linking with the C<Socket> extension.
perl -MExtUtils::Embed -e ldopts -- -std Msql -- \
-L/usr/msql/lib -lmsql
Any arguments after the second '--' token are additional linker
arguments that will be examined for potential conflict. If there is no
conflict, the additional arguments will be part of the output.
=item perl_inc()
For including perl header files this function simply prints:
-I$Config{archlibexp}/CORE
So, rather than having to say:
perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"'
Just say:
perl -MExtUtils::Embed -e perl_inc
=item ccflags(), ccdlflags()
These functions simply print $Config{ccflags} and $Config{ccdlflags}
=item ccopts()
This function combines C<perl_inc()>, C<ccflags()> and C<ccdlflags()> into one.
=item xsi_header()
This function simply returns a string defining the same C<EXTERN_C> macro as
F<perlmain.c> along with #including F<perl.h> and F<EXTERN.h>.
=item xsi_protos(@modules)
This function returns a string of C<boot_$ModuleName> prototypes for each @modules.
=item xsi_body(@modules)
This function returns a string of calls to C<newXS()> that glue the module I<bootstrap>
function to I<boot_ModuleName> for each @modules.
C<xsinit()> uses the xsi_* functions to generate most of its code.
=back
=head1 EXAMPLES
For examples on how to use C<ExtUtils::Embed> for building C/C++ applications
with embedded perl, see L<perlembed>.
=head1 SEE ALSO
L<perlembed>
=head1 AUTHOR
Doug MacEachern E<lt>C<dougm@osf.org>E<gt>
Based on ideas from Tim Bunce E<lt>C<Tim.Bunce@ig.co.uk>E<gt> and
F<minimod.pl> by Andreas Koenig E<lt>C<k@anna.in-berlin.de>E<gt> and Tim Bunce.
=cut
PK ()�Z�� *'+ '+ typemapnu �[��� PK ()�Z
DA�� � ^+ Miniperl.pmnu �[��� PK ()�Z��3 � � =I Constant/Base.pmnu �[��� PK ()�ZK, <� � �� Constant/XS.pmnu �[��� PK ()�Z-_|�&M &M �� Constant/ProxySubs.pmnu �[��� PK ()�Z��`z�
�
2 Constant/Utils.pmnu �[��� PK ()�ZnMu��: �: @ Constant.pmnu �[��� PK ()�Z��F�1 �1 { Embed.pmnu �[��� PK i D�