diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-01-01 08:59:00 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-01-01 08:59:00 +1200 |
commit | a60067777be62ee91d1318f9ae26d9ed713245de (patch) | |
tree | 9e312a824c6ef40aa10dd0e60451fd737098a965 | |
parent | a034a98d8bfd0fd904012bd5227ce209aaaa0b26 (diff) | |
download | perl-a60067777be62ee91d1318f9ae26d9ed713245de.tar.gz |
[inseparable changes from patch from perl5.003_17 to perl5.003_18]
CORE LANGUAGE CHANGES
Subject: Inherited overloading
Date: Sun, 29 Dec 1996 08:12:54 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: gv.c lib/overload.pm perl.h sv.c sv.h t/op/overload.t
Chip Salzenberg writes:
>
> Patch now, tarchive later:
Below is the fixed overloading patch.
Note that in between AMG_names got const on it (a good thing!), but as
a corollary I needed to cast away const-ness to actually use it
(since, say, newSVpv does not have const args).
Enjoy,
p5p-msgid: <199612291312.IAA02134@monk.mps.ohio-state.edu>
Subject: Closures at file scope must be anonymous
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c
Subject: 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
DOCUMENTATION
Subject: Re: perldiag.pod entry for "Scalar value @%s{%s} ..."
Date: Tue, 31 Dec 1996 11:50:19 -0500
From: Roderick Schertler <roderick@gate.net>
Files: pod/perldiag.pod
Msg-ID: <2043.852051019@eeyore.ibcinc.com>
(applied based on p5p patch as commit c885792efecf3f527b3b5099727cc16b03eee1dc)
OTHER CORE CHANGES
Subject: Get rid of 'Leaked scalars'
From: Chip Salzenberg <chip@atlantic.net>
Files: cop.h gv.c op.c
TESTS
Subject: Expanded locale.t and misc.t
From: Jarkko Hietaniemi <jhi@cc.hut.fi>
Files: t/lib/locale.t t/lib/misc.t
Subject: Expanded my.t
From: Chip Salzenberg <chip@atlantic.net>
Files: t/lib/my.t
-rw-r--r-- | Changes | 110 | ||||
-rwxr-xr-x | Configure | 10 | ||||
-rw-r--r-- | INSTALL | 26 | ||||
-rw-r--r-- | cop.h | 7 | ||||
-rw-r--r-- | embed.h | 3 | ||||
-rw-r--r-- | ext/IO/lib/IO/Handle.pm | 2 | ||||
-rw-r--r-- | ext/IO/lib/IO/Seekable.pm | 2 | ||||
-rw-r--r-- | gv.c | 113 | ||||
-rw-r--r-- | lib/Class/Template.pm | 2 | ||||
-rw-r--r-- | lib/ExtUtils/Embed.pm | 8 | ||||
-rw-r--r-- | lib/FileHandle.pm | 2 | ||||
-rw-r--r-- | lib/Net/netent.pm | 4 | ||||
-rw-r--r-- | lib/Tie/Hash.pm | 2 | ||||
-rwxr-xr-x | lib/diagnostics.pm | 4 | ||||
-rw-r--r-- | lib/overload.pm | 62 | ||||
-rw-r--r-- | op.c | 92 | ||||
-rw-r--r-- | patchlevel.h | 2 | ||||
-rw-r--r-- | perl.h | 80 | ||||
-rw-r--r-- | pod/perldiag.pod | 24 | ||||
-rw-r--r-- | pod/perldsc.pod | 4 | ||||
-rw-r--r-- | pod/perlembed.pod | 227 | ||||
-rw-r--r-- | pod/perllol.pod | 4 | ||||
-rw-r--r-- | pod/perlpod.pod | 12 | ||||
-rw-r--r-- | pod/perlref.pod | 10 | ||||
-rw-r--r-- | pod/perltoc.pod | 4 | ||||
-rw-r--r-- | pod/perltoot.pod | 8 | ||||
-rw-r--r-- | pod/perltrap.pod | 11 | ||||
-rw-r--r-- | pod/perlxs.pod | 2 | ||||
-rw-r--r-- | pod/perlxstut.pod | 10 | ||||
-rw-r--r-- | sv.c | 3 | ||||
-rw-r--r-- | sv.h | 5 | ||||
-rwxr-xr-x | t/lib/locale.t | 195 | ||||
-rwxr-xr-x | t/op/misc.t | 51 | ||||
-rwxr-xr-x | t/op/my.t | 43 | ||||
-rwxr-xr-x | t/op/overload.t | 89 |
35 files changed, 954 insertions, 279 deletions
@@ -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 ---------------- @@ -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 @@ -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 @@ -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) \ @@ -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 @@ -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. @@ -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. @@ -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: @@ -4051,9 +4051,6 @@ SV* sv; strcat(d, " ),"); } } -#ifdef OVERLOAD - if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,"); -#endif /* OVERLOAD */ } d += strlen(d); @@ -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 +######## @@ -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} |