This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[differences between cumulative patch application and perl5.003_18] perl-5.003_18
authorChip Salzenberg <chip@atlantic.net>
Tue, 31 Dec 1996 20:59:00 +0000 (08:59 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 31 Dec 1996 20:59:00 +0000 (08:59 +1200)
35 files changed:
Changes
Configure
INSTALL
cop.h
embed.h
ext/IO/lib/IO/Handle.pm
ext/IO/lib/IO/Seekable.pm
gv.c
lib/Class/Template.pm
lib/ExtUtils/Embed.pm
lib/FileHandle.pm
lib/Net/netent.pm
lib/Tie/Hash.pm
lib/diagnostics.pm
lib/overload.pm
op.c
patchlevel.h
perl.h
pod/perldiag.pod
pod/perldsc.pod
pod/perlembed.pod
pod/perllol.pod
pod/perlpod.pod
pod/perlref.pod
pod/perltoc.pod
pod/perltoot.pod
pod/perltrap.pod
pod/perlxs.pod
pod/perlxstut.pod
sv.c
sv.h
t/lib/locale.t
t/op/misc.t
t/op/my.t
t/op/overload.t

diff --git a/Changes b/Changes
index 158a737..7eb79fe 100644 (file)
--- 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
 ----------------
 
index 3ae746c..464e54c 100755 (executable)
--- 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 876e2cd..3443d29 100644 (file)
--- 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 543c039..9728962 100644 (file)
--- 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 84c3371..2399d0a 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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
index 59741c1..af706cf 100644 (file)
@@ -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
index e8a9530..3bae914 100644 (file)
@@ -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 6dd8ad0..45b6aec 100644 (file)
--- 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 {
index 311c72a..23a0d5b 100644 (file)
@@ -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.
 
index fb2664c..c663d64 100644 (file)
@@ -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>
index e2ce83d..aa8282b 100644 (file)
@@ -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
index 9f385b0..c21096d 100644 (file)
@@ -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
index 20b6777..2117c54 100644 (file)
@@ -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 {
index 31e7670..3492bd3 100755 (executable)
@@ -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.
index 20411ea..ec874ec 100644 (file)
@@ -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 eecde67..ac7b1a6 100644 (file)
--- 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++;
index fcdf883..ccdc725 100644 (file)
@@ -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 470a44d..f048d73 100644 (file)
--- 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,
index 780aefc..6e4a3cf 100644 (file)
@@ -1829,7 +1829,7 @@ L<perlref>.
 
 =item Scalar value @%s{%s} better written as $%s{%s}
 
-(W) You've used a slice (indicated by @) to select a single element of
+(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
@@ -2363,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
index 5beaa8b..5a3a83e 100644 (file)
@@ -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:
index ea0e833..30c6e0a 100644 (file)
@@ -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
index 37adac7..b2d5dbe 100644 (file)
@@ -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 (<>) {
index 5485f6c..5c4466d 100644 (file)
@@ -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
index bbbe57f..7b522ee 100644 (file)
@@ -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:
 
index 2821fa3..8cac0fa 100644 (file)
@@ -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
 
index ff8e24f..aae3b73 100644 (file)
@@ -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
index 391c98b..b8247a4 100644 (file)
@@ -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 @_... "; 
index cc83c8b..26418b5 100644 (file)
@@ -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) )
index 7371cb6..afb018b 100644 (file)
@@ -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 db34eb0..ab08ea9 100644 (file)
--- 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 36fa72d..29342f0 100644 (file)
--- 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 */
 };
index 83fa46b..7f8c858 100755 (executable)
@@ -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";
index 5bcc6a0..5b94e03 100755 (executable)
@@ -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
+########
index 4ce020f..06c6963 100755 (executable)
--- 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";
index fca26b4..9c897c3 100755 (executable)
@@ -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}