installed. It installs a /usr/local/include/arpa/inet.h that refers to
these symbols. Versions of BIND later than 8.1 do not install inet.h
in that location and avoid the errors. You should probably update to a
-newer version of BIND. If you can't, you can either link with the
-updated resolver library provided with BIND 8.1 or rename
-/usr/local/bin/arpa/inet.h during the Perl build and test process to
-avoid the problem.
+newer version of BIND (and remove the files the old one left behind).
+If you can't, you can either link with the updated resolver library provided
+with BIND 8.1 or rename /usr/local/bin/arpa/inet.h during the Perl build and
+test process to avoid the problem.
+
+=item *_r() prototype NOT found
+
+On a related note, if you see a bunch of complaints like the above about
+reentrant functions - specifically networking-related ones - being present
+but without prototypes available, check to see if BIND 8.1 (or possibly
+other BIND 8 versions) is (or has been) installed. They install
+header files such as netdb.h into places such as /usr/local/include (or into
+another directory as specified at build/install time), at least optionally.
+Remove them or put them in someplace that isn't in the C preprocessor's
+header file include search path (determined by -I options plus defaults,
+normally /usr/include).
=item #error "No DATAMODEL_NATIVE specified"
t/op/filetest.t See if file tests work
t/op/flip.t See if range operator works
t/op/fork.t See if fork works
+t/op/getpid.t See if $$ and getppid work with threads
t/op/glob.t See if <*> works
t/op/gmagic.t See if GMAGIC works
t/op/goto.t See if goto works
has not yet been patched, you'll get a warning from Configure when
selecting long doubles.
+=head2 db-hash.t failing on Tru64
+
+The Berkeley DB 1.85 coming with the Tru64 is unfortunately buggy.
+In general in Tru64 V4.* it seemed to be more stable, but in V5.*
+something broke (even though the DB stayed at release 1.85) and
+the DB_File extension test db-hash.t may fail by dumping core after
+the subtest 21. There really is no good cure as of Tru64 V5.1A expect
+installing a newer Berkeley DB and supplying the right directories for
+-Dlocincpth=/some/include and -Dloclibpth=/some/lib when running Configure.
+
+You can also work around the problem by disabling the DB_File by
+specifying -Ui_db to Configure, and then using the BerkeleyFile module
+from CPAN instead of DB_File. The BerkeleyFile works with Berkeley DB
+versions 2.* or greater.
+
+The Berkeley DB 4.0.14 has been tested with Tru64 V5.1A and found
+to work. The latest Berkeley DB can be found from F<http://www.sleepycat.com>.
+
=head2 64-bit Perl on Tru64
In Tru64 Perl's integers are automatically 64-bit wide, there is
#define PL_bufend (PERL_GET_INTERP->Ibufend)
#define PL_bufptr (PERL_GET_INTERP->Ibufptr)
#define PL_checkav (PERL_GET_INTERP->Icheckav)
+#define PL_checkav_save (PERL_GET_INTERP->Icheckav_save)
#define PL_collation_ix (PERL_GET_INTERP->Icollation_ix)
#define PL_collation_name (PERL_GET_INTERP->Icollation_name)
#define PL_collation_standard (PERL_GET_INTERP->Icollation_standard)
#define PL_bufend (vTHX->Ibufend)
#define PL_bufptr (vTHX->Ibufptr)
#define PL_checkav (vTHX->Icheckav)
+#define PL_checkav_save (vTHX->Icheckav_save)
#define PL_collation_ix (vTHX->Icollation_ix)
#define PL_collation_name (vTHX->Icollation_name)
#define PL_collation_standard (vTHX->Icollation_standard)
#define PL_Ibufend PL_bufend
#define PL_Ibufptr PL_bufptr
#define PL_Icheckav PL_checkav
+#define PL_Icheckav_save PL_checkav_save
#define PL_Icollation_ix PL_collation_ix
#define PL_Icollation_name PL_collation_name
#define PL_Icollation_standard PL_collation_standard
#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
#define PL_op_mutex (PL_Vars.Gop_mutex)
#define PL_patleave (PL_Vars.Gpatleave)
+#define PL_ppid (PL_Vars.Gppid)
#define PL_runops_dbg (PL_Vars.Grunops_dbg)
#define PL_runops_std (PL_Vars.Grunops_std)
#define PL_sharehook (PL_Vars.Gsharehook)
#define PL_Gmalloc_mutex PL_malloc_mutex
#define PL_Gop_mutex PL_op_mutex
#define PL_Gpatleave PL_patleave
+#define PL_Gppid PL_ppid
#define PL_Grunops_dbg PL_runops_dbg
#define PL_Grunops_std PL_runops_std
#define PL_Gsharehook PL_sharehook
amagic_generation perlstring
walkoptree_slow walkoptree walkoptree_exec walksymtable
parents comppadlist sv_undef compile_stats timing_info
- begin_av init_av end_av regex_padav);
+ begin_av init_av check_av end_av regex_padav);
sub OPf_KIDS ();
use strict;
package B::Section;
my $output_fh;
my %sections;
-
+
sub new {
my ($class, $section, $symtable, $default) = @_;
$output_fh ||= FileHandle->new_tmpfile;
$sections{$section} = $obj;
return $obj;
}
-
+
sub get {
my ($class, $section) = @_;
return $sections{$section};
my $section = shift;
return $section->[2];
}
-
+
sub default {
my $section = shift;
return $section->[3];
}
-
+
sub output {
my ($section, $fh, $format) = @_;
my $name = $section->name;
things as SVs, OPs and the internal symbol table and syntax tree
of a program.
+=head1 OVERVIEW
+
+The C<B> module contains a set of utility functions for querying the
+current state of the Perl interpreter; typically these functions
+return objects from the B::SV and B::OP classes, or their derived
+classes. These classes in turn define methods for querying the
+resulting objects about their own internal state.
+
+=head1 Utility Functions
+
+The C<B> module exports a variety of functions: some are simple
+utility functions, others provide a Perl program with a way to
+get an initial "handle" on an internal object.
+
+=head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects
+
+For descriptions of the class hierachy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"SV-RELATED CLASSES">.
+
+=over 4
+
+=item sv_undef
+
+Returns the SV object corresponding to the C variable C<sv_undef>.
+
+=item sv_yes
+
+Returns the SV object corresponding to the C variable C<sv_yes>.
+
+=item sv_no
+
+Returns the SV object corresponding to the C variable C<sv_no>.
+
+=item svref_2object(SVREF)
+
+Takes a reference to any Perl value, and turns the referred-to value
+into an object in the appropriate B::OP-derived or B::SV-derived
+class. Apart from functions such as C<main_root>, this is the primary
+way to get an initial "handle" on an internal perl data structure
+which can then be followed with the other access methods.
+
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
+=item C<init_av>
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
+=item check_av
+
+Returns the AV object (i.e. in class B::AV) representing CHECK blocks.
+
+=item begin_av
+
+Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
+
+=item end_av
+
+Returns the AV object (i.e. in class B::AV) representing END blocks.
+
+=item comppadlist
+
+Returns the AV object (i.e. in class B::AV) of the global comppadlist.
+
+=item regex_padav
+
+Only when perl was compiled with ithreads.
+
+=item C<main_cv>
+
+Return the (faked) CV corresponding to the main part of the Perl
+program.
+
+=back
+
+=head2 Functions for Examining the Symbol Table
+
+=over 4
+
+=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
+
+Walk the symbol table starting at SYMREF and call METHOD on each
+symbol (a B::GV object) visited. When the walk reaches package
+symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
+name, and only recurses into the package if that sub returns true.
+
+PREFIX is the name of the SYMREF you're walking.
+
+For example:
+
+ # Walk CGI's symbol table calling print_subs on each symbol.
+ # Recurse only into CGI::Util::
+ walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
+ 'CGI::');
+
+print_subs() is a B::GV method you have declared. Also see L<"B::GV
+Methods">, below.
+
+=back
+
+=head2 Functions Returning C<B::OP> objects or for walking op trees
+
+For descriptions of the class hierachy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"OP-RELATED CLASSES">.
+
+=over 4
+
+=item main_root
+
+Returns the root op (i.e. an object in the appropriate B::OP-derived
+class) of the main part of the Perl program.
+
+=item main_start
+
+Returns the starting op of the main part of the Perl program.
+
+=item walkoptree(OP, METHOD)
+
+Does a tree-walk of the syntax tree based at OP and calls METHOD on
+each op it visits. Each node is visited before its children. If
+C<walkoptree_debug> (see below) has been called to turn debugging on then
+the method C<walkoptree_debug> is called on each op before METHOD is
+called.
+
+=item walkoptree_debug(DEBUG)
+
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
+the description of C<walkoptree> above for what the debugging flag
+does.
+
+=back
+
+=head2 Miscellaneous Utility Functions
+
+=over 4
+
+=item ppname(OPNUM)
+
+Return the PP function name (e.g. "pp_add") of op number OPNUM.
+
+=item hash(STR)
+
+Returns a string in the form "0x..." representing the value of the
+internal hash function used by perl on string STR.
+
+=item cast_I32(I)
+
+Casts I to the internal I32 type used by that perl.
+
+=item minus_c
+
+Does the equivalent of the C<-c> command-line option. Obviously, this
+is only useful in a BEGIN block or else the flag is set too late.
+
+=item cstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in C source code.
+
+=item perlstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in Perl source code.
+
+=item class(OBJ)
+
+Returns the class of an object without the part of the classname
+preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
+C<"UNOP"> for example.
+
+=item threadsv_names
+
+In a perl compiled for threads, this returns a list of the special
+per-thread threadsv variables.
+
+=back
+
+
+
+
=head1 OVERVIEW OF CLASSES
The C structures used by Perl's internals to hold SV and OP
class hierarchy and the C<B> module gives access to them via a true
object hierarchy. Structure fields which point to other objects
(whether types of SV or types of OP) are represented by the C<B>
-module as Perl objects of the appropriate class. The bulk of the C<B>
-module is the methods for accessing fields of these structures. Note
-that all access is read-only: you cannot modify the internals by
+module as Perl objects of the appropriate class.
+
+The bulk of the C<B> module is the methods for accessing fields of
+these structures.
+
+Note that all access is read-only. You cannot modify the internals by
using this module.
=head2 SV-RELATED CLASSES
B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
the obvious way to the underlying C structures of similar names. The
-inheritance hierarchy mimics the underlying C "inheritance". Access
-methods correspond to the underlying C macros for field access,
+inheritance hierarchy mimics the underlying C "inheritance":
+
+ B::SV
+ |
+ +--------------+----------------------+
+ | | |
+ B::PV B::IV B::RV
+ | \ / \
+ | \ / \
+ | B::PVIV B::NV
+ \ /
+ \____ __/
+ \ /
+ B::PVNV
+ |
+ |
+ B::PVMG
+ |
+ +------+-----+----+------+-----+-----+
+ | | | | | | |
+ B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO
+ |
+ |
+ B::FM
+
+
+Access methods correspond to the underlying C macros for field access,
usually with the leading "class indication" prefix removed (Sv, Av,
Hv, ...). The leading prefix is only left in cases where its removal
would cause a clash in method name. For example, C<GvREFCNT> stays
as-is since its abbreviation would clash with the "superclass" method
C<REFCNT> (corresponding to the C function C<SvREFCNT>).
-=head2 B::SV METHODS
+=head2 B::SV Methods
=over 4
=back
-=head2 B::IV METHODS
+=head2 B::IV Methods
=over 4
=back
-=head2 B::NV METHODS
+=head2 B::NV Methods
=over 4
=back
-=head2 B::RV METHODS
+=head2 B::RV Methods
=over 4
=back
-=head2 B::PV METHODS
+=head2 B::PV Methods
=over 4
=back
-=head2 B::PVMG METHODS
+=head2 B::PVMG Methods
=over 4
=back
-=head2 B::MAGIC METHODS
+=head2 B::MAGIC Methods
=over 4
=back
-=head2 B::PVLV METHODS
+=head2 B::PVLV Methods
=over 4
=back
-=head2 B::BM METHODS
+=head2 B::BM Methods
=over 4
=back
-=head2 B::GV METHODS
+=head2 B::GV Methods
=over 4
=back
-=head2 B::IO METHODS
+=head2 B::IO Methods
=over 4
=back
-=head2 B::AV METHODS
+=head2 B::AV Methods
=over 4
=back
-=head2 B::CV METHODS
+=head2 B::CV Methods
=over 4
=back
-=head2 B::HV METHODS
+=head2 B::HV Methods
=over 4
=head2 OP-RELATED CLASSES
-B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
-B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
-These classes correspond in
-the obvious way to the underlying C structures of similar names. The
-inheritance hierarchy mimics the underlying C "inheritance". Access
-methods correspond to the underlying C structre field names, with the
-leading "class indication" prefix removed (op_).
-
-=head2 B::OP METHODS
+C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
+C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::CVOP>, C<B::LOOP>, C<B::COP>.
+
+These classes correspond in the obvious way to the underlying C
+structures of similar names. The inheritance hierarchy mimics the
+underlying C "inheritance":
+
+ B::OP
+ |
+ +---------------+--------+--------+------+
+ | | | | |
+ B::UNOP B::SVOP B::PADOP B::CVOP B::COP
+ ,' `-.
+ / `--.
+ B::BINOP B::LOGOP
+ |
+ |
+ B::LISTOP
+ ,' `.
+ / \
+ B::LOOP B::PMOP
+
+Access methods correspond to the underlying C structre field names,
+with the leading "class indication" prefix (C<"op_">) removed.
+
+=head2 B::OP Methods
=over 4
=back
-=head2 B::PMOP METHODS
+=head2 B::PMOP Methods
=over 4
=back
-=head2 B::LOOP METHODS
+=head2 B::LOOP Methods
=over 4
=back
-=head2 B::COP METHODS
+=head2 B::COP Methods
=over 4
=back
-=head1 FUNCTIONS EXPORTED BY C<B>
-
-The C<B> module exports a variety of functions: some are simple
-utility functions, others provide a Perl program with a way to
-get an initial "handle" on an internal object.
-
-=over 4
-
-=item main_cv
-
-Return the (faked) CV corresponding to the main part of the Perl
-program.
-
-=item init_av
-
-Returns the AV object (i.e. in class B::AV) representing INIT blocks.
-
-=item begin_av
-
-Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
-
-=item end_av
-
-Returns the AV object (i.e. in class B::AV) representing END blocks.
-
-=item main_root
-
-Returns the root op (i.e. an object in the appropriate B::OP-derived
-class) of the main part of the Perl program.
-
-=item main_start
-
-Returns the starting op of the main part of the Perl program.
-
-=item comppadlist
-
-Returns the AV object (i.e. in class B::AV) of the global comppadlist.
-
-=item regex_padav
-
-Only when perl was compiled with ithreads.
-
-=item sv_undef
-
-Returns the SV object corresponding to the C variable C<sv_undef>.
-
-=item sv_yes
-
-Returns the SV object corresponding to the C variable C<sv_yes>.
-
-=item sv_no
-
-Returns the SV object corresponding to the C variable C<sv_no>.
-
-=item amagic_generation
-
-Returns the SV object corresponding to the C variable C<amagic_generation>.
-
-=item walkoptree(OP, METHOD)
-
-Does a tree-walk of the syntax tree based at OP and calls METHOD on
-each op it visits. Each node is visited before its children. If
-C<walkoptree_debug> (q.v.) has been called to turn debugging on then
-the method C<walkoptree_debug> is called on each op before METHOD is
-called.
-
-=item walkoptree_debug(DEBUG)
-
-Returns the current debugging flag for C<walkoptree>. If the optional
-DEBUG argument is non-zero, it sets the debugging flag to that. See
-the description of C<walkoptree> above for what the debugging flag
-does.
-
-=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
-
-Walk the symbol table starting at SYMREF and call METHOD on each
-symbol (a B::GV object) visited. When the walk reaches package
-symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
-name, and only recurses into the package if that sub returns true.
-
-PREFIX is the name of the SYMREF you're walking.
-
-For example...
-
- # Walk CGI's symbol table calling print_subs on each symbol.
- # Only recurse into CGI::Util::
- walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
- 'CGI::');
-
-print_subs() is a B::GV method you have declared.
-
-
-=item svref_2object(SV)
-
-Takes any Perl variable and turns it into an object in the
-appropriate B::OP-derived or B::SV-derived class. Apart from functions
-such as C<main_root>, this is the primary way to get an initial
-"handle" on an internal perl data structure which can then be followed
-with the other access methods.
-
-=item ppname(OPNUM)
-
-Return the PP function name (e.g. "pp_add") of op number OPNUM.
-
-=item hash(STR)
-
-Returns a string in the form "0x..." representing the value of the
-internal hash function used by perl on string STR.
-
-=item cast_I32(I)
-
-Casts I to the internal I32 type used by that perl.
-
-
-=item minus_c
-
-Does the equivalent of the C<-c> command-line option. Obviously, this
-is only useful in a BEGIN block or else the flag is set too late.
-
-
-=item cstring(STR)
-
-Returns a double-quote-surrounded escaped version of STR which can
-be used as a string in C source code.
-
-=item perlstring(STR)
-
-Returns a double-quote-surrounded escaped version of STR which can
-be used as a string in Perl source code.
-
-=item class(OBJ)
-
-Returns the class of an object without the part of the classname
-preceding the first "::". This is used to turn "B::UNOP" into
-"UNOP" for example.
-
-=item threadsv_names
-
-In a perl compiled for threads, this returns a list of the special
-per-thread threadsv variables.
-
-=back
=head1 AUTHOR
#define B_main_cv() PL_main_cv
#define B_init_av() PL_initav
+#define B_check_av() PL_checkav_save
#define B_begin_av() PL_beginav_save
#define B_end_av() PL_endav
#define B_main_root() PL_main_root
B_init_av()
B::AV
+B_check_av()
+
+B::AV
B_begin_av()
B::AV
print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
}
my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+ my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
- for my $block (@BEGINs, @INITs, @ENDs) {
+ for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) {
$self->todo($block, 0);
}
$self->stash_subs();
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalnum(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalpha(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!iscntrl(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isdigit(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isgraph(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!islower(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isprint(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!ispunct(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isspace(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isupper(*s))
RETVAL = 0;
unsigned char * charstring
CODE:
unsigned char *s = charstring;
- unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ unsigned char *e = s + SvCUR(ST(0));
for (RETVAL = 1; RETVAL && s < e; s++)
if (!isxdigit(*s))
RETVAL = 0;
# the required -bE:$installarchlib/CORE/perl.exp is added by
# libperl.U (Configure) later.
+case "$cc" in
+*gcc*) ;;
+cc*|xlc*) # cc should've been set by line 116 or so if empty.
+ if test ! -x /usr/bin/$cc -a -x /usr/vac/bin/$cc; then
+ case ":$PATH:" in
+ *:/usr/vac/bin:*) ;;
+ *) cat <<EOF
+
+***
+*** You either implicitly or explicitly specified an IBM C compiler,
+*** but you do not seem to have one in /usr/bin, but you seem to have
+*** the VAC installed in /usr/vac, but you do not have the /usr/vac/bin
+*** in your PATH. I suggest adding that and retrying Configure.
+***
+EOF
+ exit 1
+ ;;
+ esac
+ fi
+ ;;
+esac
+
case "$ldlibpthname" in
'') ldlibpthname=LIBPATH ;;
esac
*[1-4].0*) d_modfl=undef ;; # must wait till 5.0
esac
-# Keep those leading tabs.
- needusrshlib=''
+# Keep that leading tab.
old_LD_LIBRARY_PATH=$LD_LIBRARY_PATH
for p in $loclibpth
do
- if test -n "`ls $p/libdb.so* 2>/dev/null`"; then
- needusrshlib=yes
- fi
if test -d $p; then
echo "Appending $p to LD_LIBRARY_PATH." >& 4
case "$LD_LIBRARY_PATH" in
"$old_LD_LIBRARY_PATH") ;;
*) echo "LD_LIBRARY_PATH is now $LD_LIBRARY_PATH." >& 4 ;;
esac
-# This is evil but I can't think of a nice workaround:
-# the /usr/shlib/libdb.so needs to be seen first,
-# or running Configure will fail.
-if test -n "$needusrshlib"; then
- echo "Prepending /usr/shlib to loclibpth." >& 4
- loclibpth="/usr/shlib $loclibpth"
- echo "loclibpth is now $loclibpth." >& 4
-fi
#
# Unset temporary variables no more needed.
# The compiler bug has been reported to SGI.
# -- Allen Smith <easmith@beatrice.rutgers.edu>
+case "$use64bitall" in
+$define|true|[yY]*)
+ case "`uname -s`" in
+ IRIX)
+ cat <<END >&2
+You have asked for use64bitall but you aren't running on 64-bit IRIX.
+I'll try changing it to use64bitint.
+END
+ use64bitall="$undef"
+
+ case "`uname -r`" in
+ [1-5]*|6.[01])
+ cat <<END >&2
+Sorry, can't do use64bitint either. Try upgrading to IRIX 6.2 or later.
+END
+ use64bitint="$undef"
+ ;;
+ *) use64bitint="$define"
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+esac
+
+# Until we figure out what to be probed for in Configure (ditto for hpux.sh)
+case "$usemorebits" in # Need to expand this now, then.
+$define|true|[yY]*)
+ case "`uname -r`" in
+ [1-5]*|6.[01])
+ uselongdouble="$define"
+ ;;
+ *) use64bitint="$define" uselongdouble="$define" ;;
+ esac
+esac
+
# Let's assume we want to use 'cc -n32' by default, unless the
# necessary libm is missing (which has happened at least twice)
case "$cc" in
esac
esac
+case "$use64bitint" in
+ "$define"|true|[yY]*) ;;
+ *) d_casti32="$undef" ;;
+esac
+
cc=${cc:-cc}
+cat > UU/cc.cbu <<'EOCCBU'
+# This script UU/cc.cbu will get 'called-back' by Configure after it
+# has prompted the user for the C compiler to use.
+
case "$cc" in
*gcc*) ;;
*) ccversion=`cc -version 2>&1` ;;
esac
-case "$use64bitint" in
-$define|true|[yY]*)
- case "`uname -r`" in
- [1-5]*|6.[01])
- cat >&4 <<EOM
-IRIX `uname -r` does not support 64-bit types.
-You should upgrade to at least IRIX 6.2.
-Cannot continue, aborting.
-EOM
- exit 1
- ;;
- esac
- ;;
-esac
-
-case "$use64bitall" in
-"$define"|true|[yY]*)
- case "`uname -s`" in
- IRIX)
- cat >&4 <<EOM
-You cannot use -Duse64bitall in 32-bit IRIX, sorry.
-
-Cannot continue, aborting.
-EOM
- exit 1
- ;;
- esac
- ;;
-esac
-
# Check for which compiler we're using
case "$cc" in
*"cc -n32"*)
+ test -z "$ldlibpthname" && ldlibpthname='LD_LIBRARYN32_PATH'
# If a library is requested to link against, make sure the
# objects in the library are of the same ABI we are compiling
# against. Albert Chin-A-Young <china@thewrittenword.com>
+
+ # In other words, you no longer have to worry regarding having old
+ # library paths (/usr/lib) in the searchpath for -n32 or -64; thank
+ # you very much, Albert! Now if we could just get more module authors
+ # to use something like this... - Allen
+
libscheck='case "$xxx" in
*.a) /bin/ar p $xxx `/bin/ar t $xxx | sed q` >$$.o;
case "`/usr/bin/file $$.o`" in
esac'
# NOTE: -L/usr/lib32 -L/lib32 are automatically selected by the linker
- ldflags=' -L/usr/local/lib32 -L/usr/local/lib'
+ test -z "$ldflags" && ldflags=' -L/usr/local/lib32 -L/usr/local/lib'
cccdlflags=' '
# From: David Billinghurst <David.Billinghurst@riotinto.com.au>
# If you get complaints about so_locations then change the following
# line to something like:
# lddlflags="-n32 -shared -check_registry /usr/lib32/so_locations"
- lddlflags="-n32 -shared"
- libc='/usr/lib32/libc.so'
- plibpth='/usr/lib32 /lib32 /usr/ccs/lib'
+ test -z "$lddlflags" && lddlflags="-n32 -shared"
+ test -z "$libc" && libc='/usr/lib32/libc.so'
+ test -z "$plibpth" && plibpth='/usr/lib32 /lib32 /usr/ccs/lib'
;;
*"cc -64"*)
-
+ case "`uname -s`" in
+ IRIX)
+ cat >&4 <<EOM
+You cannot use cc -64 or -Duse64bitall in 32-bit IRIX, sorry.
+Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+ esac
+ test -z "$ldlibpthname" && ldlibpthname='LD_LIBRARY64_PATH'
+ test -z "$use64bitall" && use64bitall="$define"
+ test -z "$use64bitint" && use64bitint="$define"
loclibpth="$loclibpth /usr/lib64"
libscheck='case "`/usr/bin/file $xxx`" in
*64-bit*) ;;
*) xxx=/no/64-bit$xxx ;;
esac'
# NOTE: -L/usr/lib64 -L/lib64 are automatically selected by the linker
- ldflags=' -L/usr/local/lib64 -L/usr/local/lib'
+ test -z "$ldflags" && ldflags=' -L/usr/local/lib64 -L/usr/local/lib'
cccdlflags=' '
+ test -z "$archname64" && archname64='64all'
# From: David Billinghurst <David.Billinghurst@riotinto.com.au>
# If you get complaints about so_locations then change the following
# line to something like:
# lddlflags="-64 -shared -check_registry /usr/lib64/so_locations"
- lddlflags="-64 -shared"
- libc='/usr/lib64/libc.so'
- plibpth='/usr/lib64 /lib64 /usr/ccs/lib'
+ test -z lddlflags="-64 -shared"
+ test -z "$libc" && libc='/usr/lib64/libc.so'
+ test -z "$plibpth" && plibpth='/usr/lib64 /lib64 /usr/ccs/lib'
;;
*gcc*)
ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -D_POSIX_C_SOURCE"
- optimize="-O3"
+ test -z "$optimize" && optimize="-O3"
usenm='undef'
case "`uname -s`" in
# Without the -mabi=64 gcc in 64-bit IRIX has problems passing
# Settings common to both native compiler modes.
case "$cc" in
*"cc -n32"*|*"cc -64"*)
- ld=$cc
+ test -z "$ld" && ld=$cc
# perl's malloc can return improperly aligned buffer
# which (under 5.6.0RC1) leads into really bizarre bus errors
# miniperl, as was Scott Henry with snapshots from just before
# the RC1. --jhi
usemymalloc='undef'
-#malloc_cflags='ccflags="-DSTRICT_ALIGNMENT $ccflags"'
- nm_opt='-p'
- nm_so_opt='-p'
+ # Was at the first of the line - Allen
+ #malloc_cflags='ccflags="-DSTRICT_ALIGNMENT $ccflags"'
+
+ nm_opt="$nm_opt -p"
+ nm_so_opt="$nm_so_opt -p"
# Warnings to turn off because the source code hasn't
# been cleaned up enough yet to satisfy the IRIX cc.
optimize='none'
;;
*7.1*|*7.2|*7.20) # Mongoose 7.1+
- ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff -OPT:Olimit=0"
- optimize='-O3'
-# This is a temporary fix for 5.005.
-# Leave pp_ctl_cflags line at left margin for Configure. See
-# hints/README.hints, especially the section
-# =head2 Propagating variables to config.sh
-pp_ctl_cflags='optimize=-O'
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff"
+ case "$optimize" in
+ '') optimize='-O3 -OPT:Olimit=0' ;;
+ '-O') optimize='-O3 -OPT:Olimit=0' ;;
+ *) ;;
+ esac
+
+ # This is a temporary fix for 5.005+.
+ # See hints/README.hints, especially the section
+ # =head2 Propagating variables to config.sh
+
+ # Note the part about case statements not working without
+ # weirdness like the below echo statement... and, since
+ # we're in a callback unit, it's to config.sh, not UU/config.sh
+ # - Allen
+
+
+ pp_ctl_cflags="$pp_ctl_flags optimize=\"$optimize -O1\""
+ echo "pp_ctl_cflags=\"$pp_ctl_flags optimize=\\\"\$optimize -O1\\\"\"" >> config.sh
;;
+
+
+
+# What is space=ON doing in here? - Allen
+
*7.*) # Mongoose 7.2.1+
- ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff -OPT:Olimit=0:space=ON"
- optimize='-O3'
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff"
+ case "$optimize" in
+ '') optimize='-O3 -OPT:Olimit=0:space=ON' ;;
+ '-O') optimize='-O3 -OPT:Olimit=0:space=ON' ;;
+ *) ;;
+ esac
;;
*6.2*) # Ragnarok 6.2
ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff"
;;
esac
-# Don't groan about unused libraries.
-ldflags="$ldflags -Wl,-woff,84"
-
# workaround for an optimizer bug
+# Made to work via UU/config.sh thing (or, rather, config.sh, since we're in
+# a callback) from README.hints, plus further stuff; doesn't handle -g still,
+# unfortunately - Allen
case "`$cc -version 2>&1`" in
-*7.2.*) op_cflags='optimize=-O1'; opmini_cflags='optimize=-O1' ;;
-*7.3.1.*) op_cflags='optimize=-O2'; opmini_cflags='optimize=-O2' ;;
+*7.2.*)
+ test -z "$op_cflags" && echo "op_cflags=\"optimize=\\\"\$optimize -O1\\\"\"" >> config.sh
+ test -z "$op_cflags" && op_cflags="optimize=\"\$optimize -O1\""
+ test -z "$opmini_cflags" && echo "opmini_cflags=\"optimize=\\\"\$optimize -O1\\\"\"" >> config.sh
+ test -z "$opmini_cflags" && opmini_cflags="optimize=\"\$optimize -O1\""
+ ;;
+*7.3.1.*)
+ test -z "$op_cflags" && echo "op_cflags=\"optimize=\\\"\$optimize -O2\\\"\"" >> config.sh
+ test -z "$op_cflags" && op_cflags="$op_cflags optimize=\"\$optimize -O2\""
+ test -z "$opmini_cflags" && echo "opmini_cflags=\"optimize=\\\"\$optimize -O2\\\"\"" >> config.sh
+ test -z "$opmini_cflags" && opmini_cflags="optimize=\"\$optimize -O2\""
+ ;;
esac
+EOCCBU
+
+# End of cc.cbu callback unit. - Allen
+
# We don't want these libraries.
# Socket networking is in libc, these are not installed by default,
# and just slow perl down. (scotth@sgi.com)
shift
libswanted="$*"
-# Irix 6.5.6 seems to have a broken header <sys/mode.h>
-# don't include that (it doesn't contain S_IFMT, S_IFREG, et al)
-
-i_sysmode="$undef"
-
# I have conflicting reports about the sun, crypt, bsd, and PW
# libraries on Irix 6.2.
#
shift
libswanted="$*"
+# libbind.{so|a} would be from a BIND/named installation - IRIX 6.5.* has
+# pretty much everything that would be useful in libbind in libc, including
+# accessing a local caching server (nsd) that will also look in /etc/hosts,
+# NIS (yuck!), etcetera. libbind also doesn't have the _r (thread-safe
+# reentrant) functions.
+# - Allen <easmith@beatrice.rutgers.edu>
+
+case "`uname -r`" in
+6.5)
+ set `echo X "$libswanted "|sed -e 's/ bind / /'`
+ shift
+ libswanted="$*"
+ ;;
+esac
+
+# Don't groan about unused libraries.
+case "$ldflags" in
+ *-Wl,-woff,84*) ;;
+ *) ldflags="$ldflags -Wl,-woff,84" ;;
+esac
+
+# Irix 6.5.6 seems to have a broken header <sys/mode.h>
+# don't include that (it doesn't contain S_IFMT, S_IFREG, et al)
+
+i_sysmode="$undef"
+
cat > UU/usethreads.cbu <<'EOCBU'
# This script UU/usethreads.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use threads.
exit 1
fi
set `echo X "$libswanted "| sed -e 's/ c / pthread /'`
- ld="${cc:-cc}"
shift
libswanted="$*"
# These are hidden behind a _POSIX1C ifdef that would
# require including <pthread.h> for the Configure hasproto
# to see these.
- d_asctime_r_proto="$define"
- d_ctime_r_proto="$define"
- d_gmtime_r_proto="$define"
- d_localtime_r_proto="$define"
+
+# d_asctime_r_proto="$define"
+# d_ctime_r_proto="$define"
+# d_gmtime_r_proto="$define"
+# d_localtime_r_proto="$define"
+
+ # Safer just to go ahead and include it, for other ifdefs like them
+ # (there are a lot, such as in netdb.h). - Allen
+ ccflags="$ccflags -DPTHREAD_H_FIRST"
+
+ pthread_h_first="$define"
+ echo "pthread_h_first='define'" >> config.sh
+
;;
+
esac
EOCBU
# The -n32 makes off_t to be 8 bytes, so we should have largefileness.
-# Until we figure out what to be probe for in Configure (ditto for hpux.sh)
-case "$usemorebits" in # Need to expand this now, then.
-$define|true|[yY]*) use64bitint="$define"; uselongdouble="$define" ;;
-esac
+cat > UU/use64bitint.cbu <<'EOCBU'
+# This script UU/use64bitint.cbu will get 'called-back' by Configure
+# after it has prompted the user for whether to use 64 bit integers.
+
case "$use64bitint" in
-$define|true|[yY]*) ;;
-*) d_casti32='undef' ;;
+$define|true|[yY]*)
+ case "`uname -r`" in
+ [1-5]*|6.[01])
+ cat >&4 <<EOM
+IRIX `uname -r` does not support 64-bit types.
+You should upgrade to at least IRIX 6.2.
+Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+ esac
+ usemymalloc="$undef"
+ ;;
+*) d_casti32="$undef" ;;
esac
+EOCBU
+
+cat > UU/use64bitall.cbu <<'EOCBU'
+# This script UU/use64bitall.cbu will get 'called-back' by Configure
+# after it has prompted the user for whether to be maximally 64 bitty.
+
+case "$use64bitall" in
+$define|true|[yY]*)
+ case "$cc" in
+ *-n32*|*-32*)
+ cat >&4 <<EOM
+You cannot use a non-64 bit cc for -Duse64bitall, sorry.
+Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+ esac
+ ;;
+esac
+
+EOCBU
+
# Helmut Jarausch reports that Perl's malloc is rather unusable
# with IRIX, and SGI confirms the problem.
usemymalloc=${usemymalloc:-false}
cat > UU/usethreads.cbu <<'EOCBU'
case "$usethreads" in
$define|true|[yY]*)
- ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
+ ccflags="-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS $ccflags"
set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
shift
libswanted="$*"
PERLVAR(Isort_RealCmp, SVCOMPARE_t)
+PERLVARI(Icheckav_save, AV*, Nullav) /* save CHECK{}s when compiling */
+
/* New variables must be added to the very end for binary compatibility.
* XSUB.h provides wrapper functions via perlapi.h that make this
* irrelevant, but not all code may be expected to #include XSUB.h. */
-
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
-our $VERSION = '5.566';
+our $VERSION = '5.567';
+our (%Cache);
$Carp::Internal{Exporter} = 1;
sub as_heavy {
my $callpkg = caller($ExportLevel);
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
- my($exports, $export_cache, $fail)
- = (\@{"$pkg\::EXPORT"}, \%{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
+ my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
return export $pkg, $callpkg, @_
if $Verbose or $Debug or @$fail > 1;
+ my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
local $_;
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $oops);
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
- \%{"${pkg}::EXPORT"});
+ $Exporter::Cache{$pkg} ||= {});
if (@imports) {
if (!%$export_cache) {
}
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
- \%{"${pkg}::EXPORT_FAIL"});
+ $Exporter::FailCache{$pkg} ||= {});
if (@$fail) {
if (!%$fail_cache) {
package ExtUtils::Constant;
use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
-$VERSION = '0.13';
+$VERSION = '0.14';
=head1 NAME
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 {
# Which could actually be a character comparison or even ""
my ($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 . "if (name[$check] == '$char') {\n";
}
}
- # Could optimise a memEQ on 3 to 2 single character checks here
+ 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[0] == '$char1' && name[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[0] == '$char1' && name[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 $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
- $body .= $indent . "/* ". (' ' x $checked_at) . '^'
- . (' ' x ($len - $checked_at + length $len)) . " */\n"
- if defined $checked_at;
+ # 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 $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;
}
# Figure out what to switch on.
# (RMS, Spread of jump table, Position, Hashref)
my @best = (1e38, ~0);
- foreach my $i (0 .. ($namelen - 1)) {
+ # Prefer the last character over the others. (As it lets us shortern the
+ # memEQ clause at no cost).
+ foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
my ($min, $max) = (~0, 0);
my %spread;
if ($is_perl56) {
# 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);
@best = ($rms, $max - $min, $i, \%spread);
}
}
- die "Internal error. Failed to pick a switch point for @names"
+ 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";
- $body .= $indent . "switch (name[$offset]) {\n";
+
+ my $do_front_chop = $offset == 0 && $namelen > 2;
+ if ($do_front_chop) {
+ $body .= $indent . "switch (*name++) {\n";
+ } else {
+ $body .= $indent . "switch (name[$offset]) {\n";
+ }
foreach my $char (sort keys %$best) {
confess sprintf "'$char' is %d bytes long, not 1", length $char
if length ($char) != 1;
foreach my $name (sort @{$best->{$char}}) {
my $thisone = $items->{$name};
# warn "You are here";
- $body .= match_clause ($thisone, $offset, 2 + length $indent);
+ if ($do_front_chop) {
+ $body .= match_clause ($thisone, \$char, 2 + length $indent);
+ } else {
+ $body .= match_clause ($thisone, $offset, 2 + length $indent);
+ }
}
$body .= $indent . " break;\n";
}
#!/usr/bin/perl -w
-print "1..52\n";
-
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't' if -d 't';
use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload);
use Config;
use File::Spec;
+use Cwd;
my $do_utf_tests = $] > 5.006;
my $better_than_56 = $] > 5.007;
+# For debugging set this to 1.
+my $keep_files = 0;
+$| = 1;
# Because were are going to be changing directory before running Makefile.PL
my $perl = $^X;
# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we
# only need it when $^X isn't absolute, which is going to be 5.8.0 or later
# (where ExtUtils::Constant is in the core, and tests against the uninstalled
-# perl
+# perl)
$perl = File::Spec->rel2abs ($perl) unless $] < 5.006;
# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
# compare output to ensure that it is the same. We were probably run as ./perl
# whereas we will run the child with the full path in $perl. So make $^X for
# us the same as our child will see.
$^X = $perl;
-
+my $lib = $ENV{PERL_CORE} ? '../../../lib' : '../../blib/lib';
+my $runperl = "$perl \"-I$lib\"";
print "# perl=$perl\n";
-my $lib = $ENV{PERL_CORE} ? '../../lib' : '../blib/lib';
-my $runperl = "$perl \"-I$lib\"";
+my $make = $Config{make};
+$make = $ENV{MAKE} if exists $ENV{MAKE};
+if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
-$| = 1;
+# Renamed by make clean
+my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile');
+my $makefile_ext = ($^O eq 'VMS' ? '.mms' : '');
+my $makefile_rename = $makefile . ($^O eq 'VMS' ? '.mms' : '.old');
+my $output = "output";
+my $package = "ExtTest";
my $dir = "ext-$$";
-my @files;
+my $subdir = 0;
+# The real test counter.
+my $realtest = 1;
+
+my $orig_cwd = cwd;
+my $updir = File::Spec->updir;
+die "Can't get current directory: $!" unless defined $orig_cwd;
print "# $dir being created...\n";
mkdir $dir, 0777 or die "mkdir: $!\n";
-my $output = "output";
-
-# For debugging set this to 1.
-my $keep_files = 0;
-
END {
+ if (defined $orig_cwd and length $orig_cwd) {
+ chdir $orig_cwd or die "Can't chdir back to '$orig_cwd': $!";
use File::Path;
print "# $dir being removed...\n";
rmtree($dir) unless $keep_files;
+ } else {
+ # Can't get here.
+ die "cwd at start was empty, but directory '$dir' was created" if $dir;
+ }
}
-my $package = "ExtTest";
+chdir $dir or die $!;
+push @INC, '../../lib', '../../../lib';
-# Test the code that generates 1 and 2 letter name comparisons.
-my %compass = (
-N => 0, 'NE' => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315
-);
+sub check_for_bonus_files {
+ my $dir = shift;
+ my %expect = map {($^O eq 'VMS' ? lc($_) : $_), 1} @_;
-my $parent_rfc1149 =
- 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
-# Check that 8 bit and unicode names don't cause problems.
-my $pound;
-if (ord('A') == 193) { # EBCDIC platform
- $pound = chr 177; # A pound sign. (Currency)
-} else { # ASCII platform
- $pound = chr 163; # A pound sign. (Currency)
-}
+ my $fail;
+ opendir DIR, $dir or die "opendir '$dir': $!";
+ while (defined (my $entry = readdir DIR)) {
+ $entry =~ s/\.$// if $^O eq 'VMS'; # delete trailing dot that indicates no extension
+ next if $expect{$entry};
+ print "# Extra file '$entry'\n";
+ $fail = 1;
+ }
-my ($inf, $pound_bytes, $pound_utf8);
-if ($do_utf_tests) {
- $inf = chr 0x221E;
- # Check that we can distiguish the pathological case of a string, and the
- # utf8 representation of that string.
- $pound_utf8 = $pound . '1';
- if ($better_than_56) {
- $pound_bytes = $pound_utf8;
- utf8::encode ($pound_bytes);
+ closedir DIR or warn "closedir '.': $!";
+ if ($fail) {
+ print "not ok $realtest\n";
} else {
- # Must have that "U*" to generate a zero length UTF string that forces
- # top bit set chars (such as the pound sign) into UTF8, so that the
- # unpack 'C*' then gets the byte form of the UTF8.
- $pound_bytes = pack 'C*', unpack 'C*', $pound_utf8 . pack "U*";
+ print "ok $realtest\n";
}
+ $realtest++;
}
-my @names = ("FIVE", {name=>"OK6", type=>"PV",},
- {name=>"OK7", type=>"PVN",
- value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
- {name => "FARTHING", type=>"NV"},
- {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
- {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
- {name => "CLOSE", type=>"PV", value=>'"*/"',
- macro=>["#if 1\n", "#endif\n"]},
- {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
- {name => "Yes", type=>"YES"},
- {name => "No", type=>"NO"},
- {name => "Undef", type=>"UNDEF"},
-# OK. It wasn't really designed to allow the creation of dual valued constants.
-# It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
- {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
- pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
- . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
- . "SvIVX(temp_sv) = 1149;"},
- {name=>"perl", type=>"PV",},
-);
+sub build_and_run {
+ my ($tests, $expect, $files) = @_;
+ my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : '';
+ my @perlout = `$runperl Makefile.PL $core`;
+ if ($?) {
+ print "not ok $realtest # $runperl Makefile.PL failed: $?\n";
+ print "# $_" foreach @perlout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
-push @names, $_ foreach keys %compass;
+ if (-f "$makefile$makefile_ext") {
+ print "ok $realtest\n";
+ } else {
+ print "not ok $realtest\n";
+ }
+ $realtest++;
-# Automatically compile the list of all the macro names, and make them
-# exported constants.
-my @names_only = map {(ref $_) ? $_->{name} : $_} @names;
+ my @makeout;
-# Exporter::Heavy (currently) isn't able to export these names:
-push @names, ({name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
- {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
- {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
- );
+ if ($^O eq 'VMS') { $make .= ' all'; }
-if ($do_utf_tests) {
- push @names, ({name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1},
- {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1},
- {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"',
- macro=>1},
- );
-}
+ print "# make = '$make'\n";
+ @makeout = `$make`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
-=pod
+ if ($^O eq 'VMS') { $make =~ s{ all}{}; }
-The above set of names seems to produce a suitably bad set of compile
-problems on a Unicode naive version of ExtUtils::Constant (ie 0.11):
+ if ($Config{usedl}) {
+ print "ok $realtest # This is dynamic linking, so no need to make perl\n";
+ } else {
+ my $makeperl = "$make perl";
+ print "# make = '$makeperl'\n";
+ @makeout = `$makeperl`;
+ if ($?) {
+ print "not ok $realtest # $makeperl failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok $realtest\n";
+ }
+ }
+ $realtest++;
-nick@thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t
-1..33
-# perl=/stuff/perl5/15439-32-utf/perl
-# ext-30370 being created...
-Wide character in print at lib/ExtUtils/t/Constant.t line 140.
-ok 1
-ok 2
-# make = 'make'
-ExtTest.xs: In function `constant_1':
-ExtTest.xs:80: warning: multi-character character constant
-ExtTest.xs:80: warning: case value out of range
-ok 3
+ my $maketest = "$make test";
+ print "# make = '$maketest'\n";
-=cut
+ @makeout = `$maketest`;
-# Grr `
+ if (open OUTPUT, "<$output") {
+ local $/; # Slurp it - faster.
+ print <OUTPUT>;
+ close OUTPUT or print "# Close $output failed: $!\n";
+ } else {
+ # Harness will report missing test results at this point.
+ print "# Open <$output failed: $!\n";
+ }
-my $types = {};
-my $constant_types = constant_types(); # macro defs
-my $C_constant = join "\n",
- C_constant ($package, undef, "IV", $types, undef, undef, @names);
-my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
-
-################ Header
-my $header = File::Spec->catdir($dir, "test.h");
-push @files, "test.h";
-open FH, ">$header" or die "open >$header: $!\n";
-print FH <<"EOT";
-#define FIVE 5
-#define OK6 "ok 6\\n"
-#define OK7 1
-#define FARTHING 0.25
-#define NOT_ZERO 1
-#define Yes 0
-#define No 1
-#define Undef 1
-#define RFC1149 "$parent_rfc1149"
-#undef NOTDEF
-#define perl "rules"
+ $realtest += $tests;
+ if ($?) {
+ print "not ok $realtest # $maketest failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest - maketest\n";
+ }
+ $realtest++;
+
+ # -x is busted on Win32 < 5.6.1, so we emulate it.
+ my $regen;
+ if( $^O eq 'MSWin32' && $] <= 5.006001 ) {
+ open(REGENTMP, ">regentmp") or die $!;
+ open(XS, "$package.xs") or die $!;
+ my $saw_shebang;
+ while(<XS>) {
+ $saw_shebang++ if /^#!.*/i ;
+ print REGENTMP $_ if $saw_shebang;
+ }
+ close XS; close REGENTMP;
+ $regen = `$runperl regentmp`;
+ unlink 'regentmp';
+ }
+ else {
+ $regen = `$runperl -x $package.xs`;
+ }
+ if ($?) {
+ print "not ok $realtest # $runperl -x $package.xs failed: $?\n";
+ } else {
+ print "ok $realtest - regen\n";
+ }
+ $realtest++;
+
+ if ($expect eq $regen) {
+ print "ok $realtest - regen worked\n";
+ } else {
+ print "not ok $realtest - regen worked\n";
+ # open FOO, ">expect"; print FOO $expect;
+ # open FOO, ">regen"; print FOO $regen; close FOO;
+ }
+ $realtest++;
+
+ my $makeclean = "$make clean";
+ print "# make = '$makeclean'\n";
+ @makeout = `$makeclean`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ check_for_bonus_files ('.', @$files, $output, $makefile_rename, '.', '..');
+
+ rename $makefile_rename, $makefile
+ or die "Can't rename '$makefile_rename' to '$makefile': $!";
+
+ unlink $output or warn "Can't unlink '$output': $!";
+
+ # Need to make distclean to remove ../../lib/ExtTest.pm
+ my $makedistclean = "$make distclean";
+ print "# make = '$makedistclean'\n";
+ @makeout = `$makedistclean`;
+ if ($?) {
+ print "not ok $realtest # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $realtest\n";
+ }
+ $realtest++;
+
+ check_for_bonus_files ('.', @$files, '.', '..');
+
+ unless ($keep_files) {
+ foreach (@$files) {
+ unlink $_ or warn "unlink $_: $!";
+ }
+ }
+
+ check_for_bonus_files ('.', '.', '..');
+}
+
+sub Makefile_PL {
+ my $package = shift;
+ ################ Makefile.PL
+ # We really need a Makefile.PL because make test for a no dynamic linking perl
+ # will run Makefile.PL again as part of the "make perl" target.
+ my $makefilePL = "Makefile.PL";
+ open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
+ print FH <<"EOT";
+#!$perl -w
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => "$package",
+ 'VERSION_FROM' => "$package.pm", # finds \$VERSION
+ (\$] >= 5.005 ?
+ (#ABSTRACT_FROM => "$package.pm", # XXX add this
+ AUTHOR => "$0") : ())
+ );
EOT
-while (my ($point, $bearing) = each %compass) {
- print FH "#define $point $bearing\n"
+ close FH or die "close $makefilePL: $!\n";
+ return $makefilePL;
+}
+
+sub MANIFEST {
+ my (@files) = @_;
+ ################ MANIFEST
+ # We really need a MANIFEST because make distclean checks it.
+ my $manifest = "MANIFEST";
+ push @files, $manifest;
+ open FH, ">$manifest" or die "open >$manifest: $!\n";
+ print FH "$_\n" foreach @files;
+ close FH or die "close $manifest: $!\n";
+ return @files;
}
-close FH or die "close $header: $!\n";
-################ XS
-my $xs = File::Spec->catdir($dir, "$package.xs");
-push @files, "$package.xs";
-open FH, ">$xs" or die "open >$xs: $!\n";
+sub write_and_run_extension {
+ my ($name, $items, $export_names, $package, $header, $testfile, $num_tests)
+ = @_;
+ my $types = {};
+ my $constant_types = constant_types(); # macro defs
+ my $C_constant = join "\n",
+ C_constant ($package, undef, "IV", $types, undef, undef, @$items);
+ my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
+
+ my $expect = $constant_types . $C_constant .
+ "\n#### XS Section:\n" . $XS_constant;
+
+ print "# $name\n# $dir/$subdir being created...\n";
+ mkdir $subdir, 0777 or die "mkdir: $!\n";
+ chdir $subdir or die $!;
-print FH <<'EOT';
+ my @files;
+
+ ################ Header
+ my $header_name = "test.h";
+ push @files, $header_name;
+ open FH, ">$header_name" or die "open >$header_name: $!\n";
+ print FH $header or die $!;
+ close FH or die "close $header_name: $!\n";
+
+ ################ XS
+ my $xs = "$package.xs";
+ push @files, $xs;
+ open FH, ">$xs" or die "open >$xs: $!\n";
+
+ print FH <<'EOT';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
EOT
-print FH "#include \"test.h\"\n\n";
-print FH $constant_types;
-print FH $C_constant, "\n";
-print FH "MODULE = $package PACKAGE = $package\n";
-print FH "PROTOTYPES: ENABLE\n";
-print FH $XS_constant;
-close FH or die "close $xs: $!\n";
-
-################ PM
-my $pm = File::Spec->catdir($dir, "$package.pm");
-push @files, "$package.pm";
-open FH, ">$pm" or die "open >$pm: $!\n";
-print FH "package $package;\n";
-print FH "use $];\n";
+ # XXX Here doc these:
+ print FH "#include \"$header_name\"\n\n";
+ print FH $constant_types;
+ print FH $C_constant, "\n";
+ print FH "MODULE = $package PACKAGE = $package\n";
+ print FH "PROTOTYPES: ENABLE\n";
+ print FH $XS_constant;
+ close FH or die "close $xs: $!\n";
+
+ ################ PM
+ my $pm = "$package.pm";
+ push @files, $pm;
+ open FH, ">$pm" or die "open >$pm: $!\n";
+ print FH "package $package;\n";
+ print FH "use $];\n";
-print FH <<'EOT';
+ print FH <<'EOT';
use strict;
EOT
-printf FH "use warnings;\n" unless $] < 5.006;
-print FH <<'EOT';
+ printf FH "use warnings;\n" unless $] < 5.006;
+ print FH <<'EOT';
use Carp;
require Exporter;
$VERSION = '0.01';
@ISA = qw(Exporter DynaLoader);
-@EXPORT_OK = qw(
EOT
+ # Having this qw( in the here doc confuses cperl mode far too much to be
+ # helpful. And I'm using cperl mode to edit this, even if you're not :-)
+ print FH "\@EXPORT_OK = qw(\n";
+
+ # Print the names of all our autoloaded constants
+ print FH "\t$_\n" foreach (@$export_names);
+ print FH ");\n";
+ # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
+ print FH autoload ($package, $]);
+ print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
+ close FH or die "close $pm: $!\n";
+
+ ################ test.pl
+ my $testpl = "test.pl";
+ push @files, $testpl;
+ open FH, ">$testpl" or die "open >$testpl: $!\n";
+ # Standard test header (need an option to suppress this?)
+ print FH <<"EOT" or die $!;
+use strict;
+use $package qw(@$export_names);
-# Print the names of all our autoloaded constants
-print FH "\t$_\n" foreach (@names_only);
-print FH ");\n";
-# Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
-print FH autoload ($package, $]);
-print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
-close FH or die "close $pm: $!\n";
-
-################ test.pl
-my $testpl = File::Spec->catdir($dir, "test.pl");
-push @files, "test.pl";
-open FH, ">$testpl" or die "open >$testpl: $!\n";
-
-print FH "use strict;\n";
-print FH "use $package qw(@names_only);\n\n";
-
-print FH "use utf8\n\n" if $do_utf_tests;
-
-print FH <<"EOT";
-
-print "1..1\n";
+print "1..2\n";
if (open OUTPUT, ">$output") {
print "ok 1\n";
select OUTPUT;
} else {
- print "not ok 1 # Failed to open '$output': $!\n";
+ print "not ok 1 # Failed to open '$output': \$!\n";
exit 1;
}
EOT
+ print FH $testfile or die $!;
+ print FH <<"EOT" or die $!;
+select STDOUT;
+if (close OUTPUT) {
+ print "ok 2\n";
+} else {
+ print "not ok 2 # Failed to close '$output': \$!\n";
+}
+EOT
+ close FH or die "close $testpl: $!\n";
-print FH << 'EOT';
+ push @files, Makefile_PL($package);
+ @files = MANIFEST (@files);
-my $better_than_56 = $] > 5.007;
+ build_and_run ($num_tests, $expect, \@files);
+
+ chdir $updir or die "chdir '$updir': $!";
+ ++$subdir;
+}
+# Tests are arrayrefs of the form
+# $name, [items], [export_names], $package, $header, $testfile, $num_tests
+my @tests;
+my $before_tests = 4; # Number of "ok"s emitted to build extension
+my $after_tests = 8; # Number of "ok"s emitted after make test run
+my $dummytest = 1;
+
+my $here;
+sub start_tests {
+ $dummytest += $before_tests;
+ $here = $dummytest;
+}
+sub end_tests {
+ my ($name, $items, $export_names, $header, $testfile) = @_;
+ push @tests, [$name, $items, $export_names, $package, $header, $testfile,
+ $dummytest - $here];
+ $dummytest += $after_tests;
+}
+
+my $pound;
+if (ord('A') == 193) { # EBCDIC platform
+ $pound = chr 177; # A pound sign. (Currency)
+} else { # ASCII platform
+ $pound = chr 163; # A pound sign. (Currency)
+}
+my @common_items = (
+ {name=>"perl", type=>"PV",},
+ {name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
+ {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
+ {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
+ );
+
+{
+ # Simple tests
+ start_tests();
+ my $parent_rfc1149 =
+ 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
+ # Test the code that generates 1 and 2 letter name comparisons.
+ my %compass = (
+ N => 0, 'NE' => 45, E => 90, SE => 135,
+ S => 180, SW => 225, W => 270, NW => 315
+ );
+
+ my $header = << "EOT";
+#define FIVE 5
+#define OK6 "ok 6\\n"
+#define OK7 1
+#define FARTHING 0.25
+#define NOT_ZERO 1
+#define Yes 0
+#define No 1
+#define Undef 1
+#define RFC1149 "$parent_rfc1149"
+#undef NOTDEF
+#define perl "rules"
+EOT
+
+ while (my ($point, $bearing) = each %compass) {
+ $header .= "#define $point $bearing\n"
+ }
+ my @items = ("FIVE", {name=>"OK6", type=>"PV",},
+ {name=>"OK7", type=>"PVN",
+ value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
+ {name => "FARTHING", type=>"NV"},
+ {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
+ {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
+ {name => "CLOSE", type=>"PV", value=>'"*/"',
+ macro=>["#if 1\n", "#endif\n"]},
+ {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
+ {name => "Yes", type=>"YES"},
+ {name => "No", type=>"NO"},
+ {name => "Undef", type=>"UNDEF"},
+ # OK. It wasn't really designed to allow the creation of dual valued
+ # constants.
+ # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
+ pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
+ . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
+ . "SvIVX(temp_sv) = 1149;"},
+ );
+
+ push @items, $_ foreach keys %compass;
+
+ # Automatically compile the list of all the macro names, and make them
+ # exported constants.
+ my @export_names = map {(ref $_) ? $_->{name} : $_} @items;
+
+ # Exporter::Heavy (currently) isn't able to export the last 3 of these:
+ push @items, @common_items;
+
+ # XXX there are hardwired still.
+ my $test_body = <<'EOT';
# What follows goes to the temporary file.
# IV
my $five = FIVE;
if ($five == 5) {
print "ok 5\n";
} else {
- print "not ok 5 # $five\n";
+ print "not ok 5 # \$five\n";
}
# PV
print "not ok 16 # \$undef='$undef'\n";
}
-
# invalid macro (chosen to look like a mix up between No and SW)
$notdef = eval { &ExtTest::So };
if (defined $notdef) {
EOT
while (my ($point, $bearing) = each %compass) {
- print FH "'$point' => $bearing, "
+ $test_body .= "'$point' => $bearing, "
}
-print FH <<'EOT';
+$test_body .= <<'EOT';
);
EOT
-print FH <<"EOT";
+$test_body .= <<"EOT";
my \$rfc1149 = RFC1149;
if (\$rfc1149 ne "$parent_rfc1149") {
print "not ok 20 # '\$rfc1149' ne '$parent_rfc1149'\n";
EOT
-print FH <<'EOT';
+$test_body .= <<'EOT';
# test macro=>1
my $open = OPEN;
if ($open eq '/*') {
print "not ok 22 # \$open='$open'\n";
}
EOT
+$dummytest+=18;
+
+ end_tests("Simple tests", \@items, \@export_names, $header, $test_body);
+}
if ($do_utf_tests) {
+ # utf8 tests
+ start_tests();
+ my ($inf, $pound_bytes, $pound_utf8);
+
+ $inf = chr 0x221E;
+ # Check that we can distiguish the pathological case of a string, and the
+ # utf8 representation of that string.
+ $pound_utf8 = $pound . '1';
+ if ($better_than_56) {
+ $pound_bytes = $pound_utf8;
+ utf8::encode ($pound_bytes);
+ } else {
+ # Must have that "U*" to generate a zero length UTF string that forces
+ # top bit set chars (such as the pound sign) into UTF8, so that the
+ # unpack 'C*' then gets the byte form of the UTF8.
+ $pound_bytes = pack 'C*', unpack 'C*', $pound_utf8 . pack "U*";
+ }
+
+ my @items = (@common_items,
+ {name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1},
+ {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1},
+ {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"',
+ macro=>1},
+ );
+
+=pod
+
+The above set of names seems to produce a suitably bad set of compile
+problems on a Unicode naive version of ExtUtils::Constant (ie 0.11):
+
+nick@thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t
+1..33
+# perl=/stuff/perl5/15439-32-utf/perl
+# ext-30370 being created...
+Wide character in print at lib/ExtUtils/t/Constant.t line 140.
+ok 1
+ok 2
+# make = 'make'
+ExtTest.xs: In function `constant_1':
+ExtTest.xs:80: warning: multi-character character constant
+ExtTest.xs:80: warning: case value out of range
+ok 3
+
+=cut
+
+# Grr `
+
# Do this in 7 bit in case someone is testing with some settings that cause
# 8 bit files incapable of storing this character.
my @values
($pound, $inf, $pound_bytes, $pound_utf8);
# Values is a list of strings, such as ('194,163,49', '163,49')
- print FH <<'EOT';
+ my $test_body .= "my \$test = $dummytest;\n";
+ $dummytest += 7 * 3; # 3 tests for each of the 7 things:
+
+ $test_body .= << 'EOT';
- # I can see that this child test program might be about to use parts of
- # Test::Builder
+use utf8;
+my $better_than_56 = $] > 5.007;
- my $test = 23;
- my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
+my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
EOT
- print FH join ",", @values;
+ $test_body .= join ",", @values;
- print FH << 'EOT';
+ $test_body .= << 'EOT';
;
foreach (["perl", "rules", "rules"],
}
EOT
- print FH "my (\$error, \$got) = ${package}::constant (\$string);\n";
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
- print FH <<'EOT';
+ $test_body .= <<'EOT';
if ($error or $got ne $expect) {
print "not ok $test # error '$error', got '$got'\n";
} else {
}
EOT
- print FH "my (\$error, \$got) = ${package}::constant (\$string);\n";
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
- print FH <<'EOT';
+ $test_body .= <<'EOT';
if ($error or $got ne $expect) {
print "not ok $test # error '$error', got '$got'\n";
} else {
}
EOT
- print FH "my (\$error, \$got) = ${package}::constant (\$string);\n";
+ $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
- print FH <<'EOT';
+ $test_body .= <<'EOT';
if (ref $expect_bytes) {
# Error expected.
if ($error) {
}
}
EOT
-} else {
- # Don't utf tests;
- print FH <<'EOT';
-print "ok $_ # Skipped on non Unicode perl\n" foreach 23..43;
-EOT
-}
-
-close FH or die "close $testpl: $!\n";
-
-# This is where the test numbers carry on after the test number above are
-# relayed
-my $test = 44;
-################ Makefile.PL
-# We really need a Makefile.PL because make test for a no dynamic linking perl
-# will run Makefile.PL again as part of the "make perl" target.
-my $makefilePL = File::Spec->catdir($dir, "Makefile.PL");
-push @files, "Makefile.PL";
-open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
-print FH <<"EOT";
-#!$perl -w
-use ExtUtils::MakeMaker;
-WriteMakefile(
- 'NAME' => "$package",
- 'VERSION_FROM' => "$package.pm", # finds \$VERSION
- (\$] >= 5.005 ?
- (#ABSTRACT_FROM => "$package.pm", # XXX add this
- AUTHOR => "$0") : ())
- );
-EOT
-
-close FH or die "close $makefilePL: $!\n";
-
-################ MANIFEST
-# We really need a MANIFEST because make distclean checks it.
-my $manifest = File::Spec->catdir($dir, "MANIFEST");
-push @files, "MANIFEST";
-open FH, ">$manifest" or die "open >$manifest: $!\n";
-print FH "$_\n" foreach @files;
-close FH or die "close $manifest: $!\n";
-
-chdir $dir or die $!; push @INC, '../../lib';
-END {chdir ".." or warn $!};
-
-my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : '';
-my @perlout = `$runperl Makefile.PL $core`;
-if ($?) {
- print "not ok 1 # $runperl Makefile.PL failed: $?\n";
- print "# $_" foreach @perlout;
- exit($?);
-} else {
- print "ok 1\n";
+ end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body);
}
+# XXX I think that I should merge this into the utf8 test above.
+sub explict_call_constant {
+ my ($string, $expect) = @_;
+ # This does assume simple strings suitable for ''
+ my $test_body = <<"EOT";
+{
+ my (\$error, \$got) = ${package}::constant ('$string');\n;
+EOT
-my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile');
-my $makefile_ext = ($^O eq 'VMS' ? '.mms' : '');
-if (-f "$makefile$makefile_ext") {
- print "ok 2\n";
-} else {
- print "not ok 2\n";
-}
-
-# Renamed by make clean
-my $makefile_rename = $makefile . ($^O eq 'VMS' ? '.mms' : '.old');
-
-my $make = $Config{make};
-
-$make = $ENV{MAKE} if exists $ENV{MAKE};
-
-if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
-
-my @makeout;
-
-if ($^O eq 'VMS') { $make .= ' all'; }
-print "# make = '$make'\n";
-@makeout = `$make`;
-if ($?) {
- print "not ok 3 # $make failed: $?\n";
- print "# $_" foreach @makeout;
- exit($?);
-} else {
- print "ok 3\n";
-}
-
-if ($^O eq 'VMS') { $make =~ s{ all}{}; }
-
-if ($Config{usedl}) {
- print "ok 4\n";
-} else {
- my $makeperl = "$make perl";
- print "# make = '$makeperl'\n";
- @makeout = `$makeperl`;
- if ($?) {
- print "not ok 4 # $makeperl failed: $?\n";
- print "# $_" foreach @makeout;
- exit($?);
+ if (defined $expect) {
+ # No error expected
+ $test_body .= <<"EOT";
+ if (\$error or \$got ne "$expect") {
+ print "not ok $dummytest # error '\$error', expect '$expect', got '\$got'\n";
} else {
- print "ok 4\n";
+ print "ok $dummytest\n";
+ }
}
+EOT
+ } else {
+ # Error expected.
+ $test_body .= <<"EOT";
+ if (\$error) {
+ print "ok $dummytest # error='\$error' (as expected)\n";
+ } else {
+ print "not ok $dummytest # expected error, got no error and '\$got'\n";
+ }
+EOT
+ }
+ $dummytest++;
+ return $test_body . <<'EOT';
}
-
-my $maketest = "$make test";
-print "# make = '$maketest'\n";
-
-@makeout = `$maketest`;
-
-if (open OUTPUT, "<$output") {
- print while <OUTPUT>;
- close OUTPUT or print "# Close $output failed: $!\n";
-} else {
- # Harness will report missing test results at this point.
- print "# Open <$output failed: $!\n";
+EOT
}
-if ($?) {
- print "not ok $test # $maketest failed: $?\n";
- print "# $_" foreach @makeout;
+# Simple tests to verify bits of the switch generation system work.
+sub simple {
+ start_tests();
+ # Deliberately leave $name in @_, so that it is indexed from 1.
+ my ($name, @items) = @_;
+ my $test_header;
+ my $test_body = "my \$value;\n";
+ foreach my $counter (1 .. $#_) {
+ my $thisname = $_[$counter];
+ $test_header .= "#define $thisname $counter\n";
+ $test_body .= <<"EOT";
+\$value = $thisname;
+if (\$value == $counter) {
+ print "ok $dummytest\n";
} else {
- print "ok $test - maketest\n";
+ print "not ok $dummytest # $thisname gave \$value\n";
}
-$test++;
-
-
-# -x is busted on Win32 < 5.6.1, so we emulate it.
-my $regen;
-if( $^O eq 'MSWin32' && $] <= 5.006001 ) {
- open(REGENTMP, ">regentmp") or die $!;
- open(XS, "$package.xs") or die $!;
- my $saw_shebang;
- while(<XS>) {
- $saw_shebang++ if /^#!.*/i ;
- print REGENTMP $_ if $saw_shebang;
+EOT
+ ++$dummytest;
+ # Yes, the last time round the loop appends a z to the string.
+ for my $i (0 .. length $thisname) {
+ my $copyname = $thisname;
+ substr ($copyname, $i, 1) = 'z';
+ $test_body .= explict_call_constant ($copyname,
+ $copyname eq $thisname
+ ? $thisname : undef);
}
- close XS; close REGENTMP;
- $regen = `$runperl regentmp`;
- unlink 'regentmp';
-}
-else {
- $regen = `$runperl -x $package.xs`;
-}
-if ($?) {
- print "not ok $test # $runperl -x $package.xs failed: $?\n";
-} else {
- print "ok $test - regen\n";
-}
-$test++;
-
-my $expect = $constant_types . $C_constant .
- "\n#### XS Section:\n" . $XS_constant;
-
-if ($expect eq $regen) {
- print "ok $test - regen worked\n";
-} else {
- print "not ok $test - regen worked\n";
- # open FOO, ">expect"; print FOO $expect;
- # open FOO, ">regen"; print FOO $regen; close FOO;
-}
-$test++;
-
-my $makeclean = "$make clean";
-print "# make = '$makeclean'\n";
-@makeout = `$makeclean`;
-if ($?) {
- print "not ok $test # $make failed: $?\n";
- print "# $_" foreach @makeout;
-} else {
- print "ok $test\n";
-}
-$test++;
-
-sub check_for_bonus_files {
- my $dir = shift;
- my %expect = map {($^O eq 'VMS' ? lc($_) : $_), 1} @_;
-
- my $fail;
- opendir DIR, $dir or die "opendir '$dir': $!";
- while (defined (my $entry = readdir DIR)) {
- $entry =~ s/\.$// if $^O eq 'VMS'; # delete trailing dot that indicates no extension
- next if $expect{$entry};
- print "# Extra file '$entry'\n";
- $fail = 1;
}
-
- closedir DIR or warn "closedir '.': $!";
- if ($fail) {
- print "not ok $test\n";
- } else {
- print "ok $test\n";
- }
- $test++;
+ # Ho. This seems to be buggy in 5.005_03:
+ # # Now remove $name from @_:
+ # shift @_;
+ end_tests($name, \@items, \@items, $test_header, $test_body);
}
-check_for_bonus_files ('.', @files, $output, $makefile_rename, '.', '..');
-
-rename $makefile_rename, $makefile
- or die "Can't rename '$makefile_rename' to '$makefile': $!";
-
-unlink $output or warn "Can't unlink '$output': $!";
+# Check that the memeq clauses work correctly when there isn't a switch
+# statement to bump off a character
+simple ("Singletons", "A", "AB", "ABC", "ABCD", "ABCDE");
+# Check the three code.
+simple ("Three start", qw(Bea kea Lea lea nea pea rea sea tea Wea yea Zea));
+# There were 162 2 letter words in /usr/share/dict/words on FreeBSD 4.6, which
+# I felt was rather too many. So I used words with 2 vowels.
+simple ("Twos and three middle", qw(aa ae ai ea eu ie io oe era eta));
+# Given the choice go for the end, else the earliest point
+simple ("Three end and four symetry", qw(ean ear eat barb marm tart));
-# Need to make distclean to remove ../../lib/ExtTest.pm
-my $makedistclean = "$make distclean";
-print "# make = '$makedistclean'\n";
-@makeout = `$makedistclean`;
-if ($?) {
- print "not ok $test # $make failed: $?\n";
- print "# $_" foreach @makeout;
-} else {
- print "ok $test\n";
-}
-$test++;
-
-check_for_bonus_files ('.', @files, '.', '..');
-unless ($keep_files) {
- foreach (@files) {
- unlink $_ or warn "unlink $_: $!";
- }
-}
+# Need this if the single test below is rolled into @tests :
+# --$dummytest;
+print "1..$dummytest\n";
-check_for_bonus_files ('.', '.', '..');
+write_and_run_extension @$_ foreach @tests;
# This was causing an assertion failure (a C<confess>ion)
+# Any single byte > 128 should do it.
C_constant ($package, undef, undef, undef, undef, undef, chr 255);
+print "ok $realtest\n"; $realtest++;
-print "ok $test\n"; $test++;
+print STDERR "# You were running with \$keep_files set to $keep_files\n"
+ if $keep_files;
package if;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
sub work {
my $method = shift() ? 'import' : 'unimport';
return unless shift; # CONDITION
- my $p = shift; # PACKAGE
+
+ my $p = $_[0]; # PACKAGE
eval "require $p" or die; # Adds .pm etc if needed
- $p->$method(@_) if $p->can($method);
+
+ my $m = $p->can($method);
+ goto &$m if $m;
}
sub import { shift; unshift @_, 1; goto &work }
SvREFCNT_dec(PL_beginav_save);
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
+ SvREFCNT_dec(PL_checkav_save);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_beginav_save = Nullav;
PL_endav = Nullav;
PL_checkav = Nullav;
+ PL_checkav_save = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
/* touch @F array to prevent spurious warnings 20020415 MJD */
if (PL_minus_a) {
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- if (PL_savebegin && (paramList == PL_beginav)) {
+ if (PL_savebegin) {
+ if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
+ if (! PL_beginav_save)
+ PL_beginav_save = newAV();
+ av_push(PL_beginav_save, (SV*)cv);
+ }
+ else if (paramList == PL_checkav) {
+ /* save PL_checkav for compiler */
+ if (! PL_checkav_save)
+ PL_checkav_save = newAV();
+ av_push(PL_checkav_save, (SV*)cv);
+ }
} else {
SAVEFREESV(cv);
}
#define PL_bufptr (*Perl_Ibufptr_ptr(aTHX))
#undef PL_checkav
#define PL_checkav (*Perl_Icheckav_ptr(aTHX))
+#undef PL_checkav_save
+#define PL_checkav_save (*Perl_Icheckav_save_ptr(aTHX))
#undef PL_collation_ix
#define PL_collation_ix (*Perl_Icollation_ix_ptr(aTHX))
#undef PL_collation_name
#define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL))
#undef PL_patleave
#define PL_patleave (*Perl_Gpatleave_ptr(NULL))
+#undef PL_ppid
+#define PL_ppid (*Perl_Gppid_ptr(NULL))
#undef PL_runops_dbg
#define PL_runops_dbg (*Perl_Grunops_dbg_ptr(NULL))
#undef PL_runops_std
PERLVARI(Gunlockhook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nounlocking))
PERLVARI(Gthreadhook, thrhook_proc_t, MEMBER_TO_FPTR(Perl_nothreadhook))
+/* Stores the PPID */
+#ifdef THREADS_HAVE_PIDS
+PERLVARI(Gppid, IV, 0)
+#endif
=item *
-Odd number of arguments to oveload::constant now elicits a warning.
+Odd number of arguments to overload::constant now elicits a warning.
=item *
-Odd number of elements to in anonymous hash now elicits a warning.
+Odd number of elements in anonymous hash now elicits a warning.
=item *
This assumes no funny games with newline translations.
+=head2 How can I use Perl's C<-i> option from within a program?
+
+C<-i> sets the value of Perl's C<$^I> variable, which in turn affects
+the behavior of C<< <> >>; see L<perlrun> for more details. By
+modifying the appropriate variables directly, you can get the same
+behavior within a larger program. For example:
+
+ # ...
+ {
+ local($^I, @ARGV) = ('.orig', glob("*.c"));
+ while (<>) {
+ if ($. == 1) {
+ print "This line should appear at the top of each file\n";
+ }
+ s/\b(p)earl\b/${1}erl/i; # Correct typos, preserving case
+ print;
+ close ARGV if eof; # Reset $.
+ }
+ }
+ # $^I and @ARGV return to their old values here
+
+This block modifies all the C<.c> files in the current directory,
+leaving a backup of the original data from each file in a new
+C<.c.orig> file.
+
=head2 How do I make a temporary file name?
Use the File::Temp module, see L<File::Temp> for more information.
Returns the process id of the parent process.
+Note for Linux users: on Linux, the C functions C<getpid()> and
+C<getppid()> return different values from different threads. In order to
+be portable, this behavior is not reflected by the perl-level function
+C<getppid()>, that returns a consistent value across threads. If you want
+to call the underlying C<getppid()>, consider using C<Inline::C> or
+another way to call a C library function.
+
=item getpriority WHICH,WHO
Returns the current priority for a process, a process group, or a user.
consider this variable read-only, although it will be altered
across fork() calls. (Mnemonic: same as shells.)
+Note for Linux users: on Linux, the C functions C<getpid()> and
+C<getppid()> return different values from different threads. In order to
+be portable, this behavior is not reflected by C<$$>, whose value remains
+consistent across threads. If you want to call the underlying C<getpid()>,
+consider using C<Inline::C> or another way to call a C library function.
+
=item $REAL_USER_ID
=item $UID
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
{
#ifdef HAS_GETPPID
dSP; dTARGET;
+# ifdef THREADS_HAVE_PIDS
+ XPUSHi( PL_ppid );
+# else
XPUSHi( getppid() );
+# endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
+ PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
--- /dev/null
+#!perl -w
+
+# Tests if $$ and getppid return consistent values across threads
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(../lib);
+}
+
+use strict;
+use Config;
+
+BEGIN {
+ if (!$Config{useithreads}) {
+ print "1..0 # Skip: no ithreads\n";
+ exit;
+ }
+ if (!$Config{d_getppid}) {
+ print "1..0 # Skip: no getppid\n";
+ exit;
+ }
+}
+
+use threads;
+use threads::shared;
+
+my ($pid, $ppid) = ($$, getppid());
+my $pid2 : shared = 0;
+my $ppid2 : shared = 0;
+
+new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join();
+
+print "1..2\n";
+print "not " if $pid != $pid2; print "ok 1 - pids\n";
+print "not " if $ppid != $ppid2; print "ok 2 - ppids\n";
#endif /* defined OS2 */
/*SUPPRESS 560*/
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
+ SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
+ SvREADONLY_on(GvSV(tmpgv));
+ }
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
projects / p5sagit/p5-mst-13.2.git / commitdiff