summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changes110
-rwxr-xr-xConfigure10
-rw-r--r--INSTALL26
-rw-r--r--cop.h7
-rw-r--r--embed.h3
-rw-r--r--ext/IO/lib/IO/Handle.pm2
-rw-r--r--ext/IO/lib/IO/Seekable.pm2
-rw-r--r--gv.c113
-rw-r--r--lib/Class/Template.pm2
-rw-r--r--lib/ExtUtils/Embed.pm8
-rw-r--r--lib/FileHandle.pm2
-rw-r--r--lib/Net/netent.pm4
-rw-r--r--lib/Tie/Hash.pm2
-rwxr-xr-xlib/diagnostics.pm4
-rw-r--r--lib/overload.pm62
-rw-r--r--op.c92
-rw-r--r--patchlevel.h2
-rw-r--r--perl.h80
-rw-r--r--pod/perldiag.pod24
-rw-r--r--pod/perldsc.pod4
-rw-r--r--pod/perlembed.pod227
-rw-r--r--pod/perllol.pod4
-rw-r--r--pod/perlpod.pod12
-rw-r--r--pod/perlref.pod10
-rw-r--r--pod/perltoc.pod4
-rw-r--r--pod/perltoot.pod8
-rw-r--r--pod/perltrap.pod11
-rw-r--r--pod/perlxs.pod2
-rw-r--r--pod/perlxstut.pod10
-rw-r--r--sv.c3
-rw-r--r--sv.h5
-rwxr-xr-xt/lib/locale.t195
-rwxr-xr-xt/op/misc.t51
-rwxr-xr-xt/op/my.t43
-rwxr-xr-xt/op/overload.t89
35 files changed, 954 insertions, 279 deletions
diff --git a/Changes b/Changes
index 158a7377f1..7eb79febb1 100644
--- a/Changes
+++ b/Changes
@@ -9,6 +9,116 @@ releases.)
----------------
+Version 5.003_18
+----------------
+
+Yet further down the road to 5.004....
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Inherited overloading"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199612291312.IAA02134@monk.mps.ohio-state.edu>
+ Date: Sun, 29 Dec 1996 08:12:54 -0500 (EST)
+ Files: gv.c lib/overload.pm perl.h sv.c sv.h t/op/overload.t
+
+ Title: "Hide lexicals from C<use>d or C<require>d module (!)"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_ctl.c
+
+ Title: "Closures at file scope must be anonymous"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c
+
+ Title: "Warn on '{if,while} ($x = X)' where X is glob, readdir, or <FH>"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c pod/perldiag.pod
+
+ Title: "Warn on 'undef $x; $x OP 1' where OP is *=, /=, %=, or **="
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ CORE PORTABILITY
+
+ Title: "Ultrix setlocale() workaround"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: hints/ultrix_4.sh util.c
+
+ OTHER CORE CHANGES
+
+ Title: "Get rid of 'Leaked scalars'"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: cop.h gv.c op.c
+
+ Title: "Don't forget $c in C<(($a,$b,$c)=(1,2))=(3,4,5)>"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_hot.c
+
+ Title: "Fix core dump on perl_construct()/perl_destruct() loop"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: perl.c
+
+ Title: "Add missing syms to global.sym; update magic doc"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: global.sym pod/perlguts.pod
+
+ TESTS
+
+ Title: "Expanded locale.t and misc.t"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Files: t/lib/locale.t t/lib/misc.t
+
+ Title: "Expanded my.t"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: t/lib/my.t
+
+ Title: "test harness for C<use x.xxxx>"
+ From: Graham Barr <bodg@tiuk.ti.com>
+ Msg-ID: <32C76882.3F3C7999@tiuk.ti.com>
+ Date: Mon, 30 Dec 1996 07:00:18 +0000
+ Files: MANIFEST t/op/use.t
+
+ Title: "More tests"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.95.961229170736.15213M-100000@solaris.teleport.co
+ Date: Sun, 29 Dec 1996 17:46:21 -0800 (PST)
+ Files: t/op/each.t t/op/oct.t t/op/quotemeta.t t/op/rand.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Improving Config.pm"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.95.961230091244.13467L-100000@solaris.teleport.co
+ Date: Mon, 30 Dec 1996 09:24:16 -0800 (PST)
+ Files: configpm
+
+ Title: "File::Copy under OS/2"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199612280347.WAA00293@monk.mps.ohio-state.edu>
+ Date: Fri, 27 Dec 1996 22:47:24 -0500 (EST)
+ Files: lib/File/Copy.pm t/lib/filecopy.t
+
+ DOCUMENTATION
+
+ Title: "Updates to perllocale.pod"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Files: pod/perllocale.pod
+
+ Title: "Locale-related pod patches, take 2"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03007800aeea9e488b36@[194.51.248.77]>
+ Date: Sat, 28 Dec 1996 10:56:41 +0100
+ Files: pod/perl.pod pod/perlform.pod pod/perlfunc.pod pod/perlop.pod
+ pod/perlre.pod pod/perlsec.pod
+
+ Title: "Re: perldiag.pod entry for "Scalar value @%s{%s} ...""
+ From: Roderick Schertler <roderick@gate.net>
+ Msg-ID: <2043.852051019@eeyore.ibcinc.com>
+ Date: Tue, 31 Dec 1996 11:50:19 -0500
+ Files: pod/perldiag.pod
+
+
+----------------
Version 5.003_17
----------------
diff --git a/Configure b/Configure
index 3ae746cb41..464e54cb9e 100755
--- a/Configure
+++ b/Configure
@@ -5133,11 +5133,13 @@ case "$myhostname" in
echo "(Attempting domain name extraction from $tans)"
: Why was there an Egrep here, when Sed works?
: Look for either a search or a domain directive.
- dflt=.`$sed -n -e 's/^search[ ]*\(.*\)/\1/p' $tans \
- | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
+ dflt=.`$sed -n -e 's/ / /g' \
+ -e 's/^search.* \([^ ]*\) *$/\1/p' $tans \
+ | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
case "$dflt" in
- .) dflt=.`$sed -n -e 's/^domain[ ]*\(.*\)/\1/p' $tans \
- | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
+ .) dflt=.`$sed -n -e 's/ / /g' \
+ -e 's/^domain.* \([^ ]*\) *$/\1/p' $tans \
+ | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
;;
esac
fi
diff --git a/INSTALL b/INSTALL
index 876e2cdb7e..3443d29f9c 100644
--- a/INSTALL
+++ b/INSTALL
@@ -315,11 +315,11 @@ just put their local extensions in with the standard distribution.
In order to support using things like #!/usr/local/bin/perl5.002 after
a later version is released, architecture-dependent libraries are
stored in a version-specific directory, such as
-/usr/local/lib/perl5/archname/5.002/. In 5.000 and 5.001, these files
-were just stored in /usr/local/lib/perl5/archname/. If you will not be
-using 5.001 binaries, you can delete the standard extensions from the
-/usr/local/lib/perl5/archname/ directory. Locally-added extensions can
-be moved to the site_perl and site_perl/archname directories.
+/usr/local/lib/perl5/archname/5.002/. In Perl 5.000 and 5.001, these
+files were just stored in /usr/local/lib/perl5/archname/. If you will
+not be using 5.001 binaries, you can delete the standard extensions from
+the /usr/local/lib/perl5/archname/ directory. Locally-added extensions
+can be moved to the site_perl and site_perl/archname directories.
Again, these are just the defaults, and can be changed as you run
Configure.
@@ -406,7 +406,7 @@ Your system and typical applications may well give quite different
results.
The default name for the shared library is typically something like
-libperl.so.3.2 (for perl5.003_02) or libperl.so.302 or simply
+libperl.so.3.2 (for Perl 5.003_02) or libperl.so.302 or simply
libperl.so. Configure tries to guess a sensible naming convention
based on your C library name. Since the library gets installed in a
version-specific architecture-dependent directory, the exact name
@@ -436,8 +436,8 @@ LD_LIBRARY_PATH above.
There is also an potential problem with the shared perl library if you
want to have more than one "flavor" of the same version of perl (e.g.
with and without -DDEBUGGING). For example, suppose you build and
-install a standard perl5.004 with a shared library. Then, suppose you
-try to build perl5.004 with -DDEBUGGING enabled, but everything else
+install a standard Perl 5.004 with a shared library. Then, suppose you
+try to build Perl 5.004 with -DDEBUGGING enabled, but everything else
the same, including all the installation directories. How can you
ensure that your newly built perl will link with your newly built
libperl.so.4 rather with the installed libperl.so.4? The answer is
@@ -645,7 +645,7 @@ various other operating systems.
=back
-=head1 Binary Compatibility With 5.003
+=head1 Binary Compatibility With Perl 5.003
Perl 5.003 turned on the EMBED feature by default, which tries to
avoid possible symbol name conflict by prefixing all global symbols
@@ -1012,14 +1012,14 @@ You can safely install the current version of perl5 and still run scripts
under the old binaries for versions 5.003 and later ONLY. Instead of
starting your script with #!/usr/local/bin/perl, just start it with
#!/usr/local/bin/perl5.003 (or whatever version you want to run.)
-If you want to retain a version of perl5 prior to perl5.003, you'll
+If you want to retain a version of Perl 5 prior to 5.003, you'll
need to install the current version in a separate directory tree,
since some of the architecture-independent library files have changed
in incompatible ways.
The architecture-dependent files are stored in a version-specific
directory (such as F</usr/local/lib/perl5/sun4-sunos/5.002>) so that
-they are still accessible. I<Note:> perl5.000 and perl5.001 did not
+they are still accessible. I<Note:> Perl 5.000 and 5.001 did not
put their architecture-dependent libraries in a version-specific
directory. They are simply in F</usr/local/lib/perl5/$archname>. If
you will not be using 5.000 or 5.001, you may safely remove those
@@ -1032,7 +1032,7 @@ Most extensions will probably not need to be recompiled to use with a newer
version of perl. If you do run into problems, and you want to continue
to use the old version of perl along with your extension, simply move
those extension files to the appropriate version directory, such as
-F</usr/local/lib/perl/archname/5.002>. Then perl5.002 will find your
+F</usr/local/lib/perl/archname/5.002>. Then Perl 5.002 will find your
files in the 5.002 directory, and newer versions of perl will find your
newer extension in the site_perl directory.
@@ -1046,7 +1046,7 @@ and adding /opt/perl5.002/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
-B<NOTE>: Starting with 5.002_01, all functions in the perl C source
+B<NOTE>: Starting with Perl 5.002_01, all functions in the perl C source
code are protected by default by the prefix Perl_ (or perl_) so that
you may link with third-party libraries without fear of namespace
collisons. This breaks compatability with
diff --git a/cop.h b/cop.h
index 543c039f85..9728962312 100644
--- a/cop.h
+++ b/cop.h
@@ -48,15 +48,12 @@ struct block_sub {
#define POPSUB(cx) \
if (cx->blk_sub.hasargs) { /* put back old @_ */ \
+ SvREFCNT_dec(GvAV(defgv)); \
GvAV(defgv) = cx->blk_sub.savearray; \
} \
if (cx->blk_sub.cv) { \
- if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
- if (cx->blk_sub.hasargs) { \
- SvREFCNT_inc((SV*)cx->blk_sub.argarray); \
- } \
+ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) \
SvREFCNT_dec((SV*)cx->blk_sub.cv); \
- } \
}
#define POPFORMAT(cx) \
diff --git a/embed.h b/embed.h
index 84c3371552..2399d0a4d5 100644
--- a/embed.h
+++ b/embed.h
@@ -67,12 +67,14 @@
#define check_uni Perl_check_uni
#define checkcomma Perl_checkcomma
#define ck_aelem Perl_ck_aelem
+#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
#define ck_delete Perl_ck_delete
#define ck_eof Perl_ck_eof
#define ck_eval Perl_ck_eval
#define ck_exec Perl_ck_exec
+#define ck_exists Perl_ck_exists
#define ck_ftst Perl_ck_ftst
#define ck_fun Perl_ck_fun
#define ck_fun_locale Perl_ck_fun_locale
@@ -1073,6 +1075,7 @@
#define vtbl_glob Perl_vtbl_glob
#define vtbl_isa Perl_vtbl_isa
#define vtbl_isaelem Perl_vtbl_isaelem
+#define vtbl_itervar Perl_vtbl_itervar
#define vtbl_mglob Perl_vtbl_mglob
#define vtbl_nkeys Perl_vtbl_nkeys
#define vtbl_pack Perl_vtbl_pack
diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm
index 59741c1c11..af706cfc69 100644
--- a/ext/IO/lib/IO/Handle.pm
+++ b/ext/IO/lib/IO/Handle.pm
@@ -76,7 +76,7 @@ result!
See L<perlfunc> for complete descriptions of each of the following
supported C<IO::Handle> methods, which are just front ends for the
corresponding built-in functions:
-
+
close
fileno
getc
diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm
index e8a9530e80..3bae914087 100644
--- a/ext/IO/lib/IO/Seekable.pm
+++ b/ext/IO/lib/IO/Seekable.pm
@@ -26,7 +26,7 @@ that value to return to a previously visited position.
See L<perlfunc> for complete descriptions of each of the following
supported C<IO::Seekable> methods, which are just front ends for the
corresponding built-in functions:
-
+
clearerr
seek
tell
diff --git a/gv.c b/gv.c
index 6dd8ad0f3c..45b6aecbf0 100644
--- a/gv.c
+++ b/gv.c
@@ -818,8 +818,7 @@ GV* gv;
SvREFCNT_dec(gp->gp_av);
SvREFCNT_dec(gp->gp_hv);
SvREFCNT_dec(gp->gp_io);
- if ((cv = gp->gp_cv) && !GvCVGEN(gv))
- SvREFCNT_dec(cv);
+ SvREFCNT_dec(gp->gp_cv);
SvREFCNT_dec(gp->gp_form);
Safefree(gp);
@@ -863,14 +862,14 @@ HV* stash;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+ AMT amt;
if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
amtp->was_ok_sub == sub_generation)
- return HV_AMAGIC(stash)? TRUE: FALSE;
- gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
- if (amtp && amtp->table) {
+ return AMT_AMAGIC(amtp);
+ if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
int i;
- for (i=1;i<NofAMmeth*2;i++) {
+ for (i=1; i<NofAMmeth; i++) {
if (amtp->table[i]) {
SvREFCNT_dec(amtp->table[i]);
}
@@ -880,38 +879,32 @@ HV* stash;
DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
+ amt.was_ok_am = amagic_generation;
+ amt.was_ok_sub = sub_generation;
+ amt.fallback = AMGfallNO;
+ amt.flags = 0;
+
+#ifdef OVERLOAD_VIA_HASH
+ gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
int filled=0;
int i;
char *cp;
- AMT amt;
SV* sv;
SV** svp;
- GV** gvp;
-
-/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
- DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
-);
- return HV_AMAGIC(stash)? TRUE: FALSE;
- }*/
-
- amt.was_ok_am=amagic_generation;
- amt.was_ok_sub=sub_generation;
- amt.fallback=AMGfallNO;
/* Work with "fallback" key, which we assume to be first in AMG_names */
- if ((cp=((char**)(*AMG_names))[0]) &&
- (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
+ if (( cp = (char *)AMG_names[0] ) &&
+ (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
if (SvTRUE(sv)) amt.fallback=AMGfallYES;
else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
}
-
- for (i=1;i<NofAMmeth*2;i++) {
- cv=0;
-
- if ( (cp=((char**)(*AMG_names))[i]) ) {
- svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
+ for (i = 1; i < NofAMmeth; i++) {
+ cv = 0;
+ cp = (char *)AMG_names[i];
+
+ svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
if (svp && ((sv = *svp) != &sv_undef)) {
switch (SvTYPE(sv)) {
default:
@@ -927,7 +920,7 @@ HV* stash;
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- die("Not a subroutine reference in overload table");
+ croak("Not a subroutine reference in overload table");
return FALSE;
case SVt_PVCV:
cv = (CV*)sv;
@@ -939,23 +932,51 @@ HV* stash;
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %.256s during blessing\n",
+ croak("Method for operation %s not found in package %.256s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
}
- }
- amt.table[i]=(CV*)SvREFCNT_inc(cv);
+#else
+ {
+ int filled = 0;
+ int i;
+ char *cp;
+ SV* sv = NULL;
+ SV** svp;
+
+ /* Work with "fallback" key, which we assume to be first in AMG_names */
+
+ if ( cp = (char *)AMG_names[0] ) {
+ /* Try to find via inheritance. */
+ gv = gv_fetchmeth(stash, "()", 2, 0); /* A cooky: "()". */
+ if (gv) sv = GvSV(gv);
+
+ if (!sv) /* Empty */;
+ else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
+ else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
+ }
+
+ for (i = 1; i < NofAMmeth; i++) {
+ cv = 0;
+ cp = (char *)AMG_names[i];
+
+ *buf = '('; /* A cooky: "(". */
+ strcpy(buf + 1, cp);
+ gv = gv_fetchmeth(stash, buf, strlen(buf), 0); /* fills the stash! */
+ if(gv && (cv = GvCV(gv))) filled = 1;
+#endif
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
if (filled) {
-/* HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_on(stash);
+ AMT_AMAGIC_on(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
return TRUE;
}
}
-/*HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_off(stash);
+ /* Here we have no table: */
+ AMT_AMAGIC_off(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
return FALSE;
}
@@ -978,7 +999,9 @@ int flags;
HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
- && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
+ && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
@@ -1071,7 +1094,9 @@ int flags;
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
- && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
+ && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
@@ -1108,7 +1133,7 @@ int flags;
goto not_found;
}
} else {
- not_found: /* No method found, either report or die */
+ not_found: /* No method found, either report or croak */
if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
@@ -1116,7 +1141,7 @@ int flags;
} else {
if (off==-1) off=method;
sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
- ((char**)AMG_names)[method + assignshift],
+ AMG_names[method + assignshift],
SvAMAGIC(left)?
"in overloaded package ":
"has no overloaded magic",
@@ -1132,7 +1157,7 @@ int flags;
if (amtp && amtp->fallback >= AMGfallYES) {
DEBUG_o( deb(buf) );
} else {
- die(buf);
+ croak(buf);
}
return NULL;
}
@@ -1140,11 +1165,11 @@ int flags;
}
if (!notfound) {
DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
- ((char**)AMG_names)[off],
+ AMG_names[off],
method+assignshift==off? "" :
" (initially `",
method+assignshift==off? "" :
- ((char**)AMG_names)[method+assignshift],
+ AMG_names[method+assignshift],
method+assignshift==off? "" : "')",
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
@@ -1182,7 +1207,7 @@ int flags;
PUSHs(lr>0? left: right);
PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) );
+ PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
@@ -1230,7 +1255,7 @@ ans=!SvOK(res); break;
return ans? &sv_yes: &sv_no;
} else if (method==copy_amg) {
if (!SvROK(res)) {
- die("Copy method did not return a reference");
+ croak("Copy method did not return a reference");
}
return SvREFCNT_inc(SvRV(res));
} else {
diff --git a/lib/Class/Template.pm b/lib/Class/Template.pm
index 311c72ae5e..23a0d5ba83 100644
--- a/lib/Class/Template.pm
+++ b/lib/Class/Template.pm
@@ -84,7 +84,7 @@ This module uses perl5 classes to create nested data types.
}
=head1 NOTES
-
+
Use '%' if the member should point to an anonymous hash. Use '@' if the
member should point to an anonymous array.
diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm
index fb2664c86f..c663d64dd7 100644
--- a/lib/ExtUtils/Embed.pm
+++ b/lib/ExtUtils/Embed.pm
@@ -265,7 +265,7 @@ functions while building your application.
=head1 @EXPORT
ExtUtils::Embed exports the following functions:
-
+
xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(),
ccdlflags(), xsi_header(), xsi_protos(), xsi_body()
@@ -301,7 +301,7 @@ B<[@modules]> is an array ref, same as additional arguments mentioned above.
=item Examples
-
+
perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket
@@ -395,7 +395,7 @@ are picked up from the B<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 B<Socket> extension.
@@ -457,7 +457,7 @@ B<xsinit()> uses the xsi_* functions to generate most of it's code.
For examples on how to use B<ExtUtils::Embed> for building C/C++ applications
with embedded perl, see the eg/ directory and L<perlembed>.
-
+
=head1 SEE ALSO
L<perlembed>
diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm
index e2ce83d44a..aa8282b68d 100644
--- a/lib/FileHandle.pm
+++ b/lib/FileHandle.pm
@@ -184,7 +184,7 @@ result!
See L<perlfunc> for complete descriptions of each of the following
supported C<FileHandle> methods, which are just front ends for the
corresponding built-in functions:
-
+
close
fileno
getc
diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm
index 9f385b06d1..c21096d724 100644
--- a/lib/Net/netent.pm
+++ b/lib/Net/netent.pm
@@ -113,7 +113,7 @@ The gethost() functions do this in the Perl core:
That means that the address comes back in binary for the
host functions, and as a regular perl integer for the net ones.
This seems a bug, but here's how to deal with it:
-
+
use strict;
use Socket;
use Net::netent;
@@ -154,7 +154,7 @@ This seems a bug, but here's how to deal with it:
}
}
}
-
+
=head1 NOTE
While this class is currently implemented using the Class::Template
diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm
index 20b6777978..2117c54c18 100644
--- a/lib/Tie/Hash.pm
+++ b/lib/Tie/Hash.pm
@@ -98,7 +98,7 @@ L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
good working examples.
=cut
-
+
use Carp;
sub new {
diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index 31e7670b82..3492bd3e28 100755
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -150,8 +150,8 @@ You have to to this instead, and I<before> you load the module.
BEGIN { $diagnostics::PRETTY = 1 }
I could start up faster by delaying compilation until it should be
-needed, but this gets a "panic: top_level"
-when using the pragma form in 5.001e.
+needed, but this gets a "panic: top_level" when using the pragma form
+in Perl 5.001e.
While it's true that this documentation is somewhat subserious, if you use
a program named I<splain>, you should expect a bit of whimsy.
diff --git a/lib/overload.pm b/lib/overload.pm
index 20411ea576..ec874ec8d7 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -1,12 +1,26 @@
package overload;
+sub nil {}
+
sub OVERLOAD {
$package = shift;
my %arg = @_;
- my $hash = \%{$package . "::OVERLOAD"};
+ my ($sub, $fb);
+ $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
+ *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
- $hash->{$_} = $arg{$_};
+ if ($_ eq 'fallback') {
+ $fb = $arg{$_};
+ } else {
+ $sub = $arg{$_};
+ if (not ref $sub and $sub !~ /::/) {
+ $sub = "${'package'}::$sub";
+ }
+ #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
+ *{$package . "::(" . $_} = \&{ $sub };
+ }
}
+ ${$package . "::()"} = $fb; # Make it findable too (fallback only).
}
sub import {
@@ -18,41 +32,47 @@ sub import {
sub unimport {
$package = (caller())[0];
- my $hash = \%{$package . "::OVERLOAD"};
+ ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
shift;
for (@_) {
- delete $hash->{$_};
+ if ($_ eq 'fallback') {
+ undef $ {$package . "::()"};
+ } else {
+ delete $ {$package . "::"}{"(" . $_};
+ }
}
}
sub Overloaded {
- ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"};
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('()');
}
sub OverloadedStringify {
- ($package = ref $_[0]) and
- defined %{$package . "::OVERLOAD"} and
- exists $ {$package . "::OVERLOAD"}{'""'} and
- defined &{$ {$package . "::OVERLOAD"}{'""'}};
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('(""')
}
sub Method {
- ($package = ref $_[0]) and
- defined %{$package . "::OVERLOAD"} and
- $ {$package . "::OVERLOAD"}{$_[1]};
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('(' . shift)
}
sub AddrRef {
- $package = ref $_[0];
- bless $_[0], Overload::Fake; # Non-overloaded package
+ my $package = ref $_[0];
+ return "$_[0]" unless $package;
+ bless $_[0], overload::Fake; # Non-overloaded package
my $str = "$_[0]";
bless $_[0], $package; # Back
- $str;
+ $package . substr $str, index $str, '=';
}
sub StrVal {
- (OverloadedStringify) ?
- (AddrRef) :
+ (OverloadedStringify($_[0])) ?
+ (AddrRef(shift)) :
"$_[0]";
}
@@ -486,9 +506,13 @@ induces diagnostic messages.
=head1 BUGS
Because it is used for overloading, the per-package associative array
-%OVERLOAD now has a special meaning in Perl.
+%OVERLOAD now has a special meaning in Perl. The symbol table is
+filled with names looking like line-noise.
-As shipped, mathemagical properties are not inherited via the @ISA tree.
+For the purpose of inheritance every overloaded package behaves as if
+C<fallback> is present (possibly undefined). This may create
+interesting effects if some package is not overloaded, but inherits
+from two overloaded packages.
This document is confusing.
diff --git a/op.c b/op.c
index eecde67660..ac7b1a619c 100644
--- a/op.c
+++ b/op.c
@@ -210,16 +210,14 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
SvNVX(sv) = (double)curcop->cop_seq;
SvIVX(sv) = 999999999; /* A ref, intro immediately */
SvFLAGS(sv) |= SVf_FAKE;
- if (!CvUNIQUE(cv)) {
- /* "It's closures all the way down." */
- CvCLONE_on(compcv);
- if (cv != startcv) {
- CV *bcv;
- for (bcv = startcv;
- bcv && bcv != cv && !CvCLONE(bcv);
- bcv = CvOUTSIDE(bcv))
- CvCLONE_on(bcv);
- }
+ /* "It's closures all the way down." */
+ CvCLONE_on(compcv);
+ if (cv != startcv) {
+ CV *bcv;
+ for (bcv = startcv;
+ bcv && bcv != cv && !CvCLONE(bcv);
+ bcv = CvOUTSIDE(bcv))
+ CvCLONE_on(bcv);
}
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
@@ -454,8 +452,13 @@ OP *op;
case OP_ENTEREVAL:
op->op_targ = 0; /* Was holding hints. */
break;
+ default:
+ if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst))
+ break;
+ /* FALL THROUGH */
case OP_GVSV:
case OP_GV:
+ case OP_AELEMFAST:
SvREFCNT_dec(cGVOP->op_gv);
break;
case OP_NEXTSTATE:
@@ -484,8 +487,6 @@ OP *op;
pregfree(cPMOP->op_pmregexp);
SvREFCNT_dec(cPMOP->op_pmshort);
break;
- default:
- break;
}
if (op->op_targ > 0)
@@ -2444,6 +2445,27 @@ OP* other;
else
scalar(other);
}
+ else if (dowarn && (first->op_flags & OPf_KIDS)) {
+ OP *k1 = ((UNOP*)first)->op_first;
+ OP *k2 = k1->op_sibling;
+ OPCODE warnop = 0;
+ switch (first->op_type)
+ {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV))
+ warnop = k2->op_type;
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB)
+ warnop = k1->op_type;
+ break;
+ }
+ if (warnop)
+ warn("Value of %s may be \"0\"; use \"defined\"", op_desc[warnop]);
+ }
if (!other)
return first;
@@ -2982,8 +3004,11 @@ OP *block;
if (op)
sub_generation++;
if (cv = GvCV(gv)) {
- if (GvCVGEN(gv))
- cv = 0; /* just a cached method */
+ if (GvCVGEN(gv)) {
+ /* just a cached method */
+ SvREFCNT_dec(cv);
+ cv = 0;
+ }
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
SV* const_sv = cv_const_sv(cv);
@@ -3009,6 +3034,7 @@ OP *block;
}
if (cv) { /* must reuse cv if autoloaded */
cv_undef(cv);
+ CvFLAGS(cv) = (CvFLAGS(cv)&~CVf_CLONE) | (CvFLAGS(compcv)&CVf_CLONE);
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE(compcv) = 0;
CvPADLIST(cv) = CvPADLIST(compcv);
@@ -3044,6 +3070,10 @@ OP *block;
return cv;
}
+ /* XXX: Named functions at file scope cannot be closures */
+ if (op && CvUNIQUE(CvOUTSIDE(cv)))
+ CvCLONE_off(cv);
+
av = newAV(); /* Will be @_ */
av_extend(av, 0);
av_store(comppad, 0, (SV*)av);
@@ -3061,40 +3091,37 @@ OP *block;
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
+
if (s = strrchr(name,':'))
s++;
else
s = name;
if (strEQ(s, "BEGIN") && !error_count) {
- line_t oldline = compiling.cop_line;
- SV *oldrs = rs;
-
ENTER;
SAVESPTR(compiling.cop_filegv);
+ SAVEI16(compiling.cop_line);
SAVEI32(perldb);
+ save_svref(&rs);
+ sv_setsv(rs, nrs);
+
if (!beginav)
beginav = newAV();
- av_push(beginav, (SV *)cv);
DEBUG_x( dump_sub(gv) );
- rs = SvREFCNT_inc(nrs);
- SvREFCNT_inc(cv);
+ av_push(beginav, (SV *)cv);
+ GvCV(gv) = 0;
calllist(beginav);
- if (GvCV(gv) == cv) { /* Detach it. */
- SvREFCNT_dec(cv);
- GvCV(gv) = 0; /* Was above calllist, why? IZ */
- }
- SvREFCNT_dec(rs);
- rs = oldrs;
+
curcop = &compiling;
- curcop->cop_line = oldline; /* might have recursed to yylex */
LEAVE;
}
else if (strEQ(s, "END") && !error_count) {
if (!endav)
endav = newAV();
av_unshift(endav, 1);
- av_store(endav, 0, SvREFCNT_inc(cv));
+ av_store(endav, 0, (SV *)cv);
+ GvCV(gv) = 0;
}
+
if (perldb && curstash != debstash) {
SV *sv;
SV *tmpstr = sv_newmortal();
@@ -3122,13 +3149,14 @@ OP *block;
perl_call_sv((SV*)cv, G_DISCARD);
}
}
- op_free(op);
- copline = NOLINE;
- LEAVE_SCOPE(floor);
+
if (!op) {
GvCV(gv) = 0; /* Will remember in SVOP instead. */
CvANON_on(cv);
}
+ op_free(op);
+ copline = NOLINE;
+ LEAVE_SCOPE(floor);
return cv;
}
@@ -4397,7 +4425,7 @@ register OP* o;
o->op_type = OP_AELEMFAST;
o->op_ppaddr = ppaddr[OP_AELEMFAST];
o->op_private = (U8)i;
- GvAVn((GV*)(((SVOP*)o)->op_sv));
+ GvAVn(((GVOP*)o)->op_gv);
}
}
o->op_seq = op_seqmax++;
diff --git a/patchlevel.h b/patchlevel.h
index fcdf88372d..ccdc7255f2 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1,5 +1,5 @@
#define PATCHLEVEL 3
-#define SUBVERSION 17
+#define SUBVERSION 18
/*
local_patches -- list of locally applied less-than-subversion patches.
diff --git a/perl.h b/perl.h
index 470a44d03c..f048d73f79 100644
--- a/perl.h
+++ b/perl.h
@@ -1950,55 +1950,67 @@ EXT MGVTBL vtbl_amagicelem;
#ifdef OVERLOAD
EXT long amagic_generation;
-#define NofAMmeth 29
+#define NofAMmeth 58
#ifdef DOINIT
-EXTCONST char * AMG_names[NofAMmeth][2] = {
- {"fallback","abs"},
- {"bool", "nomethod"},
- {"\"\"", "0+"},
- {"+","+="},
- {"-","-="},
- {"*", "*="},
- {"/", "/="},
- {"%", "%="},
- {"**", "**="},
- {"<<", "<<="},
- {">>", ">>="},
- {"&", "&="},
- {"|", "|="},
- {"^", "^="},
- {"<", "<="},
- {">", ">="},
- {"==", "!="},
- {"<=>", "cmp"},
- {"lt", "le"},
- {"gt", "ge"},
- {"eq", "ne"},
- {"!", "~"},
- {"++", "--"},
- {"atan2", "cos"},
- {"sin", "exp"},
- {"log", "sqrt"},
- {"x","x="},
- {".",".="},
- {"=","neg"}
+EXTCONST char * AMG_names[NofAMmeth] = {
+ "fallback", "abs", /* "fallback" should be the first. */
+ "bool", "nomethod",
+ "\"\"", "0+",
+ "+", "+=",
+ "-", "-=",
+ "*", "*=",
+ "/", "/=",
+ "%", "%=",
+ "**", "**=",
+ "<<", "<<=",
+ ">>", ">>=",
+ "&", "&=",
+ "|", "|=",
+ "^", "^=",
+ "<", "<=",
+ ">", ">=",
+ "==", "!=",
+ "<=>", "cmp",
+ "lt", "le",
+ "gt", "ge",
+ "eq", "ne",
+ "!", "~",
+ "++", "--",
+ "atan2", "cos",
+ "sin", "exp",
+ "log", "sqrt",
+ "x", "x=",
+ ".", ".=",
+ "=", "neg"
};
#else
-EXTCONST char * AMG_names[NofAMmeth][2];
+EXTCONST char * AMG_names[NofAMmeth];
#endif /* def INITAMAGIC */
-struct am_table {
+struct am_table {
long was_ok_sub;
long was_ok_am;
- CV* table[NofAMmeth*2];
+ U32 flags;
+ CV* table[NofAMmeth];
long fallback;
};
+struct am_table_short {
+ long was_ok_sub;
+ long was_ok_am;
+ U32 flags;
+};
typedef struct am_table AMT;
+typedef struct am_table_short AMTS;
#define AMGfallNEVER 1
#define AMGfallNO 2
#define AMGfallYES 3
+#define AMTf_AMAGIC 1
+#define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC)
+#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC)
+#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC)
+
enum {
fallback_amg, abs_amg,
bool__amg, nomethod_amg,
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 49d30fcab0..6e4a3cf6c9 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1815,7 +1815,7 @@ shifting or popping (for array variables). See L<perlform>.
=item Scalar value @%s[%s] better written as $%s[%s]
-(W) You've used an array slice (indicated by @) to select a single value of
+(W) You've used an array slice (indicated by @) to select a single element of
an array. Generally it's better to ask for a scalar value (indicated by $).
The difference is that C<$foo[&bar]> always behaves like a scalar, both when
assigning to it and when evaluating its argument, while C<@foo[&bar]> behaves
@@ -1827,6 +1827,20 @@ element as a list, you need to look into how references work, because
Perl will not magically convert between scalars and lists for you. See
L<perlref>.
+=item Scalar value @%s{%s} better written as $%s{%s}
+
+(W) You've used a hash slice (indicated by @) to select a single element of
+a hash. Generally it's better to ask for a scalar value (indicated by $).
+The difference is that C<$foo{&bar}> always behaves like a scalar, both when
+assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves
+like a list when you assign to it, and provides a list context to its
+subscript, which can do weird things if you're expecting only one subscript.
+
+On the other hand, if you were actually hoping to treat the hash
+element as a list, you need to look into how references work, because
+Perl will not magically convert between scalars and lists for you. See
+L<perlref>.
+
=item Script is not setuid/setgid in suidperl
(F) Oddly, the suidperl program was invoked on a script with its setuid
@@ -2349,6 +2363,14 @@ L<perlref> for more on this.
(W) A copy of the object returned from C<tie> (or C<tied>) was still
valid when C<untie> was called.
+=item Value of %s may be "0"; use "defined"
+
+(W) In a conditional expression, you used <HANDLE>, <*> (glob), or
+C<readdir> as a boolean value. Each of these operators may return a
+value of "0"; that would make the conditional expression false, which
+is probably not what you intended. So, when using these operators in
+conditional expressions, test their values with the C<defined> operator.
+
=item Variable "%s" is not exported
(F) While "use strict" in effect, you referred to a global variable
diff --git a/pod/perldsc.pod b/pod/perldsc.pod
index 5beaa8bbe9..5a3a83ea5e 100644
--- a/pod/perldsc.pod
+++ b/pod/perldsc.pod
@@ -303,8 +303,8 @@ variable, and it would thereby remind you to write instead:
=head1 DEBUGGING
-Before 5.002, the standard Perl debugger didn't do a very nice job of
-printing out complex data structures. With version 5.002 or above, the
+Before version 5.002, the standard Perl debugger didn't do a very nice job of
+printing out complex data structures. With 5.002 or above, the
debugger includes several new features, including command line editing as
well as the C<x> command to dump out complex data structures. For
example, given the assignment to $LoL above, here's the debugger output:
diff --git a/pod/perlembed.pod b/pod/perlembed.pod
index ea0e8331f2..30c6e0a0a7 100644
--- a/pod/perlembed.pod
+++ b/pod/perlembed.pod
@@ -37,7 +37,7 @@ Read on...
L<Compiling your C program>
-There's one example in each of the six sections:
+There's one example in each of the eight sections:
L<Adding a Perl interpreter to your C program>
@@ -49,6 +49,8 @@ L<Performing Perl pattern matches and substitutions from your C program>
L<Fiddling with the Perl stack from your C program>
+L<Maintaining a persistent interpreter>
+
L<Using Perl modules, which themselves use C libraries, from your C program>
This documentation is UNIX specific.
@@ -69,7 +71,7 @@ Your C program will--usually--allocate, "run", and deallocate a
I<PerlInterpreter> object, which is defined in the perl library.
If your copy of Perl is recent enough to contain this documentation
-(5.002 or later), then the perl library (and I<EXTERN.h> and
+(version 5.002 or later), then the perl library (and I<EXTERN.h> and
I<perl.h>, which you'll also need) will
reside in a directory resembling this:
@@ -225,13 +227,10 @@ L<Fiddling with the Perl stack from your C program>
=head2 Evaluating a Perl statement from your C program
-NOTE: This section, and the next, employ some very brittle techniques
-for evaluating strings of Perl code. Perl 5.002 contains some nifty
-features that enable A Better Way (such as with L<perlguts/perl_eval_sv>).
-Look for updates to this document soon.
-
-One way to evaluate a Perl string is to define a function (we'll call
-ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>.
+One way to evaluate pieces of Perl code is to use L<perlguts/perl_eval_sv>.
+We have wrapped this function with our own I<perl_eval()> function, which
+converts a command string to an SV, passing this and the L<perlcall/G_DISCARD>
+flag to L<perlguts/perl_eval_sv>.
Arguably, this is the only routine you'll ever need to execute
snippets of Perl code from within your C program. Your string can be
@@ -250,17 +249,14 @@ the first, a C<float> from the second, and a C<char *> from the third.
static PerlInterpreter *my_perl;
- int perl_eval(char *string)
+ I32 perl_eval(char *string)
{
- char *argv[2];
- argv[0] = string;
- argv[1] = NULL;
- perl_call_argv("_eval_", 0, argv);
+ return perl_eval_sv(newSVpv(string,0), G_DISCARD);
}
main (int argc, char **argv, char **env)
{
- char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
+ char *embedding[] = { "", "-e", "0" };
STRLEN length;
my_perl = perl_alloc();
@@ -328,12 +324,9 @@ been wrapped here):
#include <EXTERN.h>
#include <perl.h>
static PerlInterpreter *my_perl;
- int perl_eval(char *string)
+ I32 perl_eval(char *string)
{
- char *argv[2];
- argv[0] = string;
- argv[1] = NULL;
- perl_call_argv("_eval_", 0, argv);
+ return perl_eval_sv(newSVpv(string,0), G_DISCARD);
}
/** match(string, pattern)
**
@@ -401,7 +394,7 @@ been wrapped here):
}
main (int argc, char **argv, char **env)
{
- char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
+ char *embedding[] = { "", "-e", "0" };
char *text, **match_list;
int num_matches, i;
int j;
@@ -555,6 +548,198 @@ Compile and run:
% power
3 to the 4th power is 81.
+=head2 Maintaining a persistent interpreter
+
+When developing interactive, potentially long-running applications, it's
+a good idea to maintain a persistent interpreter rather than allocating
+and constructing a new interpreter multiple times. The major gain here is
+speed, avoiding the penalty of Perl start-up time. However, a persistent
+interpreter will require you to be more cautious in your use of namespace
+and variable scoping. In previous examples we've been using global variables
+in the default package B<main>. We knew exactly what code would be run,
+making it safe to assume we'd avoid any variable collision or outrageous
+symbol table growth.
+
+Let's say your application is a server, which must run perl code from an
+arbitrary file during each transaction. Your server has no way of knowing
+what code is inside anyone of these files.
+If the file was pulled in by B<perl_parse()>, compiled into a newly
+constructed interpreter, then cleaned out with B<perl_destruct()> after the
+the transaction, you'd be shielded from most namespace troubles.
+
+One way to avoid namespace collisions in this scenerio, is to translate the
+file name into a valid Perl package name, which is most likely to be unique,
+then compile the code into that package using L<perlfunc/eval>.
+In the example below, each file will only be compiled once, unless it is
+updated on disk.
+Optionally, the application may choose to clean out the symbol table
+associated with the file after we are done with it. We'll call the subroutine
+B<Embed::Persistent::eval_file> which lives in the file B<persistent.pl>, with
+L<perlcall/perl_call_argv>, passing the filename and boolean cleanup/cache
+flag as arguments.
+
+Note that the process will continue to grow for each file that is compiled,
+and each file it pulls in via L<perlfunc/require>, L<perlfunc/use> or
+L<perlfunc/do>. In addition, there maybe B<AUTOLOAD>ed subroutines and
+other conditions that cause Perl's symbol table to grow. You may wish to
+add logic which keeps track of process size or restarts itself after n number
+of requests to ensure memory consumption is kept to a minimum. You also need
+to consider the importance of variable scoping with L<perlfunc/my> to futher
+reduce symbol table growth.
+
+
+ package Embed::Persistent;
+ #persistent.pl
+
+ use strict;
+ use vars '%Cache';
+
+ #use Devel::Symdump ();
+
+ sub valid_package_name {
+ my($string) = @_;
+ $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
+ # second pass only for words starting with a digit
+ $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
+
+ # Dress it up as a real package name
+ $string =~ s|/|::|g;
+ return "Embed" . $string;
+ }
+
+ #borrowed from Safe.pm
+ sub delete_package {
+ my $pkg = shift;
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ my $stem_symtab = *{$stem}{HASH};
+
+ delete $stem_symtab->{$leaf};
+ }
+
+ sub eval_file {
+ my($filename, $delete) = @_;
+ my $package = valid_package_name($filename);
+ my $mtime = -M $filename;
+ if(defined $Cache{$package}{mtime}
+ &&
+ $Cache{$package}{mtime} <= $mtime)
+ {
+ # we have compiled this subroutine already,
+ # it has not been updated on disk, nothing left to do
+ print STDERR "already compiled $package->handler\n";
+ }
+ else {
+ local *FH;
+ open FH, $filename or die "open '$filename' $!";
+ local($/) = undef;
+ my $sub = <FH>;
+ close FH;
+
+ #wrap the code into a subroutine inside our unique package
+ my $eval = qq{package $package; sub handler { $sub; }};
+ {
+ # hide our variables within this block
+ my($r,$filename,$mtime,$package,$sub);
+ eval $eval;
+ }
+ die $@ if $@;
+
+ #cache it unless we're cleaning out each time
+ $Cache{$package}{mtime} = $mtime unless $delete;
+ }
+
+ eval {$package->handler;};
+ die $@ if $@;
+
+ delete_package($package) if $delete;
+
+ #take a look if you want
+ #print Devel::Symdump->rnew($package)->as_string, $/;
+ }
+
+ 1;
+
+ __END__
+
+ /* persistent.c */
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ /* 1 = clean out filename's symbol table after each request, 0 = don't */
+ #ifndef DO_CLEAN
+ #define DO_CLEAN 0
+ #endif
+
+ static PerlInterpreter *perl = NULL;
+
+ int
+ main(int argc, char **argv, char **env)
+ {
+ char *embedding[] = { "", "persistent.pl" };
+ char *args[] = { "", DO_CLEAN, NULL };
+ char filename [1024];
+ int exitstatus = 0;
+
+ if((perl = perl_alloc()) == NULL) {
+ fprintf(stderr, "no memory!");
+ exit(1);
+ }
+ perl_construct(perl);
+
+ exitstatus = perl_parse(perl, NULL, 2, embedding, NULL);
+
+ if(!exitstatus) {
+ exitstatus = perl_run(perl);
+
+ while(printf("Enter file name: ") && gets(filename)) {
+
+ /* call the subroutine, passing it the filename as an argument */
+ args[0] = filename;
+ perl_call_argv("Embed::Persistent::eval_file",
+ G_DISCARD | G_EVAL, args);
+
+ /* check $@ */
+ if(SvTRUE(GvSV(errgv)))
+ fprintf(stderr, "eval error: %s\n", SvPV(GvSV(errgv),na));
+ }
+ }
+
+ perl_destruct_level = 0;
+ perl_destruct(perl);
+ perl_free(perl);
+ exit(exitstatus);
+ }
+
+
+Now compile:
+
+ % cc -o persistent persistent.c `perl -MExtUtils::Embed -e ldopts`
+
+Here's a example script file:
+
+ #test.pl
+ my $string = "hello";
+ foo($string);
+
+ sub foo {
+ print "foo says: @_\n";
+ }
+
+Now run:
+
+ % persistent
+ Enter file name: test.pl
+ foo says: hello
+ Enter file name: test.pl
+ already compiled Embed::test_2epl->handler
+ foo says: hello
+ Enter file name: ^C
+
=head2 Using Perl modules, which themselves use C libraries, from your C program
If you've played with the examples above and tried to embed a script
diff --git a/pod/perllol.pod b/pod/perllol.pod
index 37adac7ef5..b2d5dbe537 100644
--- a/pod/perllol.pod
+++ b/pod/perllol.pod
@@ -146,8 +146,8 @@ you'd have to do something like this:
Actually, if you were using strict, you'd have to declare not only
$ref_to_LoL as you had to declare @LoL, but you'd I<also> having to
-initialize it to a reference to an empty list. (This was a bug in 5.001m
-that's been fixed for the 5.002 release.)
+initialize it to a reference to an empty list. (This was a bug in
+perl version 5.001m that's been fixed for the 5.002 release.)
my $ref_to_LoL = [];
while (<>) {
diff --git a/pod/perlpod.pod b/pod/perlpod.pod
index 5485f6c3b9..5c4466d398 100644
--- a/pod/perlpod.pod
+++ b/pod/perlpod.pod
@@ -72,20 +72,20 @@ paragraph with a matching =end are treated as a particular format.
Here are some examples of how to use these:
=begin html
-
+
<br>Figure 1.<IMG SRC="figure1.png"><br>
-
+
=end html
-
+
=begin text
-
+
---------------
| foo |
| bar |
---------------
-
+
^^^^ Figure 1. ^^^^
-
+
=end text
Some format names that formatters currently are known to accept include
diff --git a/pod/perlref.pod b/pod/perlref.pod
index bbbe57feba..7b522eee4d 100644
--- a/pod/perlref.pod
+++ b/pod/perlref.pod
@@ -236,8 +236,8 @@ open the filehandle for you, because *HANDLE{IO} will be undef if HANDLE
hasn't been used yet. Use \*HANDLE for that sort of thing instead.
Using \*HANDLE (or *HANDLE) is another way to use and store non-bareword
-filehandles (before 5.002 it was the only way). The two methods are
-largely interchangeable, you can do
+filehandles (before perl version 5.002 it was the only way). The two
+methods are largely interchangeable, you can do
splutter(\*STDOUT);
$rec = get_rec(\*STDIN);
@@ -431,8 +431,8 @@ variables, which are all "global" to the package.
=head2 Not-so-symbolic references
-A new feature contributing to readability in 5.001 is that the brackets
-around a symbolic reference behave more like quotes, just as they
+A new feature contributing to readability in perl version 5.001 is that the
+brackets around a symbolic reference behave more like quotes, just as they
always have within a string. That is,
$push = "pop on ";
@@ -449,7 +449,7 @@ and even
print ${ push } . "over";
will have the same effect. (This would have been a syntax error in
-5.000, though Perl 4 allowed it in the spaceless form.) Note that this
+Perl 5.000, though Perl 4 allowed it in the spaceless form.) Note that this
construct is I<not> considered to be a symbolic reference when you're
using strict refs:
diff --git a/pod/perltoc.pod b/pod/perltoc.pod
index 2821fa363a..8cac0fa7af 100644
--- a/pod/perltoc.pod
+++ b/pod/perltoc.pod
@@ -900,7 +900,7 @@ R, |dbcmd, ||dbcmd, = [alias value], command, p expr
TTY, noTTY, ReadLine, NonStop, LineInfo
-
+
=item Other resources
@@ -936,7 +936,7 @@ TTY, noTTY, ReadLine, NonStop, LineInfo
=item Security Bugs
-
+
=back
diff --git a/pod/perltoot.pod b/pod/perltoot.pod
index ff8e24fb3e..aae3b7393d 100644
--- a/pod/perltoot.pod
+++ b/pod/perltoot.pod
@@ -448,7 +448,7 @@ of magicalness to a C programmer. It's really just a mnemonic device
to remind ourselves that this field is special and not to be used as
a public data member in the same way that NAME, AGE, and PEERS are.
(Because we've been developing this code under the strict pragma, prior
-to 5.004 we'll have to quote the field name.)
+to perl version 5.004 we'll have to quote the field name.)
sub new {
my $proto = shift;
@@ -1087,10 +1087,10 @@ base class? That way you could give every object common methods without
having to go and add it to each and every @ISA. Well, it turns out that
you can. You don't see it, but Perl tacitly and irrevocably assumes
that there's an extra element at the end of @ISA: the class UNIVERSAL.
-In 5.003, there were no predefined methods there, but you could put
+In version 5.003, there were no predefined methods there, but you could put
whatever you felt like into it.
-However, as of 5.004 (or some subversive releases, like 5.003_08),
+However, as of version 5.004 (or some subversive releases, like 5.003_08),
UNIVERSAL has some methods in it already. These are built-in to your Perl
binary, so they don't take any extra time to load. Predefined methods
include isa(), can(), and VERSION(). isa() tells you whether an object or
@@ -1196,7 +1196,7 @@ replace the variables above like $AGE with literal numbers, like 1.
A bigger difference between the two approaches can be found in memory use.
A hash representation takes up more memory than an array representation
because you have to allocation memory for the keys as well as the values.
-However, it really isn't that bad, especially since as of 5.004,
+However, it really isn't that bad, especially since as of version 5.004,
memory is only allocated once for a given hash key, no matter how many
hashes have that key. It's expected that sometime in the future, even
these differences will fade into obscurity as more efficient underlying
diff --git a/pod/perltrap.pod b/pod/perltrap.pod
index 391c98b129..b8247a4208 100644
--- a/pod/perltrap.pod
+++ b/pod/perltrap.pod
@@ -654,7 +654,8 @@ Formatted output and significant digits
This specific item has been deleted. It demonstrated how the auto-increment
operator would not catch when a number went over the signed int limit. Fixed
-in 5.003_04. But always be wary when using large integers. If in doubt:
+in version 5.003_04. But always be wary when using large integers.
+If in doubt:
use Math::BigInt;
@@ -663,10 +664,10 @@ in 5.003_04. But always be wary when using large integers. If in doubt:
Assignment of return values from numeric equality tests
does not work in perl5 when the test evaluates to false (0).
Logical tests now return an null, instead of 0
-
+
$p = ($test == 1);
print $p,"\n";
-
+
# perl4 prints: 0
# perl5 prints:
@@ -934,7 +935,7 @@ of assignment. Perl 4 mistakenly gave them the precedence of the associated
operator. So you now must parenthesize them in expressions like
/foo/ ? ($a += 2) : ($a -= 2);
-
+
Otherwise
/foo/ ? $a += 2 : $a -= 2
@@ -1164,7 +1165,7 @@ within the signal handler function, each time a signal was handled with
perl4. With perl5, the reset is now done correctly. Any code relying
on the handler _not_ being reset will have to be reworked.
-5.002 and beyond uses sigaction() under SysV
+Since version 5.002, Perl uses sigaction() under SysV.
sub gotit {
print "Got @_... ";
diff --git a/pod/perlxs.pod b/pod/perlxs.pod
index cc83c8b843..26418b51a9 100644
--- a/pod/perlxs.pod
+++ b/pod/perlxs.pod
@@ -953,7 +953,7 @@ example.
# char* having the name of the package for the blessing.
O_OBJECT
sv_setref_pv( $arg, CLASS, (void*)$var );
-
+
INPUT
O_OBJECT
if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod
index 7371cb677d..afb018b28e 100644
--- a/pod/perlxstut.pod
+++ b/pod/perlxstut.pod
@@ -25,21 +25,21 @@ features were added to Perl 5.
=item *
-In versions of 5.002 prior to the gamma version, the test script in Example
-1 will not function properly. You need to change the "use lib" line to
-read:
+In versions of Perl 5.002 prior to the gamma version, the test script
+in Example 1 will not function properly. You need to change the "use
+lib" line to read:
use lib './blib';
=item *
-In versions of 5.002 prior to version beta 3, the line in the .xs file
+In versions of Perl 5.002 prior to version beta 3, the line in the .xs file
about "PROTOTYPES: DISABLE" will cause a compiler error. Simply remove that
line from the file.
=item *
-In versions of 5.002 prior to version 5.002b1h, the test.pl file was not
+In versions of Perl 5.002 prior to version 5.002b1h, the test.pl file was not
automatically created by h2xs. This means that you cannot say "make test"
to run the test script. You will need to add the following line before the
"use extension" statement:
diff --git a/sv.c b/sv.c
index db34eb0cd0..ab08ea945e 100644
--- a/sv.c
+++ b/sv.c
@@ -4051,9 +4051,6 @@ SV* sv;
strcat(d, " ),");
}
}
-#ifdef OVERLOAD
- if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,");
-#endif /* OVERLOAD */
}
d += strlen(d);
diff --git a/sv.h b/sv.h
index 36fa72d749..29342f0922 100644
--- a/sv.h
+++ b/sv.h
@@ -131,11 +131,6 @@ struct io {
#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
-#ifdef OVERLOAD
-#define SVpgv_AM 0x40000000
-/* #define SVpgv_badAM 0x20000000 */
-#endif /* OVERLOAD */
-
struct xrv {
SV * xrv_rv; /* pointer to another SV */
};
diff --git a/t/lib/locale.t b/t/lib/locale.t
index 83fa46bd73..7f8c858f1f 100755
--- a/t/lib/locale.t
+++ b/t/lib/locale.t
@@ -1,6 +1,6 @@
#!./perl -wT
-print "1..67\n";
+print "1..104\n";
BEGIN {
chdir 't' if -d 't';
@@ -74,15 +74,15 @@ check_taint 19, $+;
check_taint 20, $1;
check_taint_not 21, $2;
-/(\W)/; # taint $&, $`, $', $+, $1.
-check_taint 22, $&;
-check_taint 23, $`;
-check_taint 24, $';
-check_taint 25, $+;
-check_taint 26, $1;
+/(.)/; # untaint $&, $`, $', $+, $1.
+check_taint_not 22, $&;
+check_taint_not 23, $`;
+check_taint_not 24, $';
+check_taint_not 25, $+;
+check_taint_not 26, $1;
check_taint_not 27, $2;
-/(\s)/; # taint $&, $`, $', $+, $1.
+/(\W)/; # taint $&, $`, $', $+, $1.
check_taint 28, $&;
check_taint 29, $`;
check_taint 30, $';
@@ -90,7 +90,7 @@ check_taint 31, $+;
check_taint 32, $1;
check_taint_not 33, $2;
-/(\S)/; # taint $&, $`, $', $+, $1.
+/(\s)/; # taint $&, $`, $', $+, $1.
check_taint 34, $&;
check_taint 35, $`;
check_taint 36, $';
@@ -98,45 +98,105 @@ check_taint 37, $+;
check_taint 38, $1;
check_taint_not 39, $2;
+/(\S)/; # taint $&, $`, $', $+, $1.
+check_taint 40, $&;
+check_taint 41, $`;
+check_taint 42, $';
+check_taint 43, $+;
+check_taint 44, $1;
+check_taint_not 45, $2;
+
$_ = $a; # untaint $_
-check_taint_not 40, $_;
+check_taint_not 46, $_;
/(b)/; # this must not taint
-check_taint_not 41, $&;
-check_taint_not 42, $`;
-check_taint_not 43, $';
-check_taint_not 44, $+;
-check_taint_not 45, $1;
-check_taint_not 46, $2;
+check_taint_not 47, $&;
+check_taint_not 48, $`;
+check_taint_not 49, $';
+check_taint_not 50, $+;
+check_taint_not 51, $1;
+check_taint_not 52, $2;
$_ = $a; # untaint $_
-check_taint_not 47, $_;
+check_taint_not 53, $_;
$b = uc($a); # taint $b
s/(.+)/$b/; # this must taint only the $_
-check_taint 48, $_;
-check_taint_not 49, $&;
-check_taint_not 50, $`;
-check_taint_not 51, $';
-check_taint_not 52, $+;
-check_taint_not 53, $1;
-check_taint_not 54, $2;
+check_taint 54, $_;
+check_taint_not 55, $&;
+check_taint_not 56, $`;
+check_taint_not 57, $';
+check_taint_not 58, $+;
+check_taint_not 59, $1;
+check_taint_not 60, $2;
$_ = $a; # untaint $_
s/(.+)/b/; # this must not taint
-check_taint_not 55, $_;
-check_taint_not 56, $&;
-check_taint_not 57, $`;
-check_taint_not 58, $';
-check_taint_not 59, $+;
-check_taint_not 60, $1;
-check_taint_not 61, $2;
+check_taint_not 61, $_;
+check_taint_not 62, $&;
+check_taint_not 63, $`;
+check_taint_not 64, $';
+check_taint_not 65, $+;
+check_taint_not 66, $1;
+check_taint_not 67, $2;
+
+$b = $a; # untaint $b
+
+($b = $a) =~ s/\w/$&/;
+check_taint 68, $b; # $b should be tainted.
+check_taint_not 69, $a; # $a should be not.
+
+$_ = $a; # untaint $_
+
+s/(\w)/\l$1/; # this must taint
+check_taint 70, $_;
+check_taint 71, $&;
+check_taint 72, $`;
+check_taint 73, $';
+check_taint 74, $+;
+check_taint 75, $1;
+check_taint_not 76, $2;
+
+$_ = $a; # untaint $_
+
+s/(\w)/\L$1/; # this must taint
+check_taint 77, $_;
+check_taint 78, $&;
+check_taint 79, $`;
+check_taint 80, $';
+check_taint 81, $+;
+check_taint 82, $1;
+check_taint_not 83, $2;
+
+$_ = $a; # untaint $_
+
+s/(\w)/\u$1/; # this must taint
+check_taint 84, $_;
+check_taint 85, $&;
+check_taint 86, $`;
+check_taint 87, $';
+check_taint 88, $+;
+check_taint 89, $1;
+check_taint_not 90, $2;
-check_taint_not 62, $a;
+$_ = $a; # untaint $_
+
+s/(\w)/\U$1/; # this must taint
+check_taint 91, $_;
+check_taint 92, $&;
+check_taint 93, $`;
+check_taint 94, $';
+check_taint 95, $+;
+check_taint 96, $1;
+check_taint_not 97, $2;
+
+# After all this tainting $a should be cool.
+
+check_taint_not 98, $a;
# I think we've seen quite enough of taint.
# Let us do some *real* locale work now.
@@ -246,7 +306,8 @@ for (@Locale) {
# Cross-check the upper and the lower.
# Yes, this is broken when the upper<->lower changes the number of
-# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature.
+# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature,
+# or the Dutch IJ or the Spanish LL or ...)
# But so far all the implementations do this wrong so we can do it wrong too.
for (keys %UPPER) {
@@ -257,7 +318,7 @@ for (keys %UPPER) {
}
}
}
-print "ok 63\n";
+print "ok 99\n";
for (keys %lower) {
if (defined $UPPER{$lower{$_}}) {
@@ -267,7 +328,7 @@ for (keys %lower) {
}
}
}
-print "ok 64\n";
+print "ok 100\n";
# Find the alphabets that are not alphabets in the default locale.
@@ -290,15 +351,18 @@ print "ok 64\n";
print 'not ' if ($1 ne $word);
}
-print "ok 65\n";
+print "ok 101\n";
# Find places where the collation order differs from the default locale.
{
- no locale;
+ my (@k, $i, $j, @d);
- my @k = sort (keys %UPPER, keys %lower);
- my ($i, $j, @d);
+ {
+ no locale;
+
+ @k = sort (keys %UPPER, keys %lower);
+ }
for ($i = 0; $i < @k; $i++) {
for ($j = $i + 1; $j < @k; $j++) {
@@ -312,10 +376,15 @@ print "ok 65\n";
for (@d) {
($i, $j) = @$_;
- print 'not ' if ($i le $j or not (($i cmp $j) == 1));
+ if ($i gt $j) {
+ print "# i = $i, j = $j, i ",
+ $i le $j ? 'le' : 'gt', " j\n";
+ print 'not ';
+ last;
+ }
}
}
-print "ok 66\n";
+print "ok 102\n";
# Cross-check whole character set.
@@ -325,7 +394,47 @@ for (map { chr } 0..255) {
if (/\s/ and /\S/) { print 'not '; last }
if (/\w/ and /\D/ and not /_/ and
not (exists $UPPER{$_} or exists $lower{$_})) {
- print 'not '; last
+ print 'not ';
+ last;
+ }
+}
+print "ok 103\n";
+
+# The @Locale should be internally consistent.
+
+{
+ my ($from, $to, , $lesser, $greater);
+
+ for (0..9) {
+ # Select a slice.
+ $from = int(($_*@Locale)/10);
+ $to = $from + int(@Locale/10);
+ $to = $#Locale if ($to > $#Locale);
+ $lesser = join('', @Locale[$from..$to]);
+ # Select a slice one character on.
+ $from++; $to++;
+ $to = $#Locale if ($to > $#Locale);
+ $greater = join('', @Locale[$from..$to]);
+ if (not ($lesser lt $greater) or
+ not ($lesser le $greater) or
+ not ($lesser ne $greater) or
+ ($lesser eq $greater) or
+ ($lesser ge $greater) or
+ ($lesser gt $greater) or
+ ($greater lt $lesser ) or
+ ($greater le $lesser ) or
+ not ($greater ne $lesser ) or
+ ($greater eq $lesser ) or
+ not ($greater ge $lesser ) or
+ not ($greater gt $lesser ) or
+ # Well, these two are sort of redundant because @Locale
+ # was derived using cmp.
+ not (($lesser cmp $greater) == -1) or
+ not (($greater cmp $lesser ) == 1)
+ ) {
+ print 'not ';
+ last;
+ }
}
}
-print "ok 67\n";
+print "ok 104\n";
diff --git a/t/op/misc.t b/t/op/misc.t
index 5bcc6a02a8..5b94e034bb 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -204,3 +204,54 @@ EXPECT
This is a reversed sentence.
-- Out of inspiration --
and destroyed as well
+########
+my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
+EXPECT
+2 2 2
+########
+@a = ($a, $b, $c, $d) = (5, 6);
+print "ok\n"
+ if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
+EXPECT
+ok
+########
+print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
+EXPECT
+ok
+########
+print "ok\n" if ("\0" cmp "\xFF");
+EXPECT
+ok
+########
+open(H,'op/misc.t'); # must be in the 't' directory
+stat(H);
+print "ok\n" if (-e _ and -f _ and -r _);
+EXPECT
+ok
+########
+sub thing { 0 || return qw(now is the time) }
+print thing(), "\n";
+EXPECT
+nowisthetime
+########
+$ren = 'joy';
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print $ren, ' ' }
+print $ren, "\n";
+EXPECT
+happy joy
+########
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
+print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
+EXPECT
+happy joy
+########
+package p;
+sub func { print 'really ' unless wantarray; 'p' }
+sub groovy { 'groovy' }
+package main;
+print p::func()->groovy(), "\n"
+EXPECT
+really groovy
+########
diff --git a/t/op/my.t b/t/op/my.t
index 4ce020f206..06c6963534 100755
--- a/t/op/my.t
+++ b/t/op/my.t
@@ -1,8 +1,8 @@
#!./perl
-# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
+# $RCSfile: my.t,v $
-print "1..20\n";
+print "1..28\n";
sub foo {
my($a, $b) = @_;
@@ -44,3 +44,42 @@ $d{''} = "ok 18\n";
print &foo2("ok 11\n","ok 12\n");
print $a,@b,@c,%d,$x,$y;
+
+my $i = "outer";
+
+if (my $i = "inner") {
+ print "not " if $i ne "inner";
+}
+print "ok 21\n";
+
+if ((my $i = 1) == 0) {
+ print "not ";
+}
+else {
+ print "not" if $i != 1;
+}
+print "ok 22\n";
+
+my $j = 5;
+while (my $i = --$j) {
+ print("not "), last unless $i > 0;
+}
+continue {
+ print("not "), last unless $i > 0;
+}
+print "ok 23\n";
+
+$j = 5;
+for (my $i = 0; (my $k = $i) < $j; ++$i) {
+ print("not "), last unless $i >= 0 && $i < $j && $i == $k;
+}
+print "ok 24\n";
+print "not " if defined $k;
+print "ok 25\n";
+
+foreach my $i (26, 27) {
+ print "ok $i\n";
+}
+
+print "not " if $i ne "outer";
+print "ok 28\n";
diff --git a/t/op/overload.t b/t/op/overload.t
index fca26b4085..9c897c31dc 100755
--- a/t/op/overload.t
+++ b/t/op/overload.t
@@ -33,7 +33,7 @@ qw(
sub new {
my $foo = $_[1];
- bless \$foo;
+ bless \$foo, $_[0];
}
sub stringify { "${$_[0]}" }
@@ -55,7 +55,9 @@ $a = new Oscalar "087";
$b= "$a";
# All test numbers in comments are off by 1.
-# So much for hard-wiring them in :-)
+# So much for hard-wiring them in :-) To fix this:
+test(1); # 1
+
test ($b eq $a); # 2
test ($b eq "087"); # 3
test (ref $a eq "Oscalar"); # 4
@@ -255,16 +257,89 @@ $a=new Oscalar "xx";
test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
+# Check inheritance of overloading;
+{
+ package OscalarI;
+ @ISA = 'Oscalar';
+}
+
+$aI = new OscalarI "$a";
+test (ref $aI eq "OscalarI"); # 89
+test ("$aI" eq "xx"); # 90
+test ($aI eq "xx"); # 91
+test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92
+
# Here we test blessing to a package updates hash
eval "package Oscalar; no overload '.'";
-test ("b${a}" eq "_.b.__.xx._"); # 89
+test ("b${a}" eq "_.b.__.xx._"); # 93
$x="1";
bless \$x, Oscalar;
-test ("b${a}c" eq "bxxc"); # 90
+test ("b${a}c" eq "bxxc"); # 94
new Oscalar 1;
-test ("b${a}c" eq "bxxc"); # 91
+test ("b${a}c" eq "bxxc"); # 95
+
+# Negative overloading:
+
+$na = eval { ~$a };
+test($@ =~ /no method found/); # 96
+
+# Check AUTOLOADING:
+
+*Oscalar::AUTOLOAD =
+ sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
+ goto &{"Oscalar::$AUTOLOAD"}};
+
+eval "package Oscalar; use overload '~' => 'comple'";
+
+$na = eval { ~$a }; # Hash was not updated
+test($@ =~ /no method found/); # 97
+
+bless \$x, Oscalar;
+
+$na = eval { ~$a }; # Hash updated
+test !$@; # 98
+test($na eq '_!_xx_!_'); # 99
+
+$na = 0;
+
+$na = eval { ~$aI }; # Hash was not updated
+test($@ =~ /no method found/); # 100
+
+bless \$x, OscalarI;
+
+$na = eval { ~$aI };
+print $@;
+
+test !$@; # 101
+test($na eq '_!_xx_!_'); # 102
+
+eval "package Oscalar; use overload '>>' => 'rshft'";
+
+$na = eval { $aI >> 1 }; # Hash was not updated
+test($@ =~ /no method found/); # 103
+
+bless \$x, OscalarI;
+
+$na = 0;
+
+$na = eval { $aI >> 1 };
+print $@;
+
+test !$@; # 104
+test($na eq '_!_xx_!_'); # 105
+
+test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
+test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
+test (overload::Overloaded($aI)); # 108
+test (!overload::Overloaded('overload')); # 109
+
+test (! defined overload::Method($aI, '<<')); # 110
+test (! defined overload::Method($a, '<')); # 111
+
+test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
+test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
-# Last test is number 90.
-sub last {90}
+# Last test is:
+sub last {113}
View Lorry Controller Status