[win32] merge changes#906,907,909,910 from maintbranch
Gurusamy Sarathy [Fri, 15 May 1998 02:15:25 +0000 (02:15 +0000)]
p4raw-link: @910 on //depot/maint-5.004/perl: ae941ac0da8f453f0d31df7b7293e50b3e5a46f1
p4raw-link: @909 on //depot/maint-5.004/perl: 8b3d696ffd11cf2e49f6eaa575b829ab0a55352d
p4raw-link: @907 on //depot/maint-5.004/perl: 3cb3c1abada5765ba4166ebe59e2e20d737ec21b
p4raw-link: @906 on //depot/maint-5.004/perl: ae389c8a29b487f4434c465442dfb611507a4a38

p4raw-id: //depot/win32/perl@977

15 files changed:
doio.c
doop.c
embed.h
global.sym
lib/Carp.pm
lib/File/Basename.pm
mg.c
perl.c
perl.h
pod/perldiag.pod
pp.c
pp_hot.c
proto.h
sv.c
util.c

diff --git a/doio.c b/doio.c
index 94d78c4..f99a729 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -720,6 +720,46 @@ do_sysseek(GV *gv, long int pos, int whence)
     return -1L;
 }
 
+int
+do_binmode(PerlIO *fp, int iotype, int flag)
+{
+    if (flag != TRUE)
+       croak("panic: unsetting binmode"); /* Not implemented yet */
+#ifdef DOSISH
+#ifdef atarist
+    if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
+       return 1;
+    else
+       return 0;
+#else
+    if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
+#if defined(WIN32) && defined(__BORLANDC__)
+       /* The translation mode of the stream is maintained independent
+        * of the translation mode of the fd in the Borland RTL (heavy
+        * digging through their runtime sources reveal).  User has to
+        * set the mode explicitly for the stream (though they don't
+        * document this anywhere). GSAR 97-5-24
+        */
+       PerlIO_seek(fp,0L,0);
+       fp->flags |= _F_BIN;
+#endif
+       return 1;
+    }
+    else
+       return 0;
+#endif
+#else
+#if defined(USEMYBINMODE)
+    if (my_binmode(fp,iotype) != NULL)
+       return 1;
+    else
+       return 0;
+#else
+    return 1;
+#endif
+#endif
+}
+
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
        /* code courtesy of William Kucharski */
 #define HAS_CHSIZE
diff --git a/doop.c b/doop.c
index e92f49e..e527cde 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -483,7 +483,11 @@ do_kv(ARGSproto)
                sv_magic(TARG, Nullsv, 'k', Nullch, 0);
            }
            LvTYPE(TARG) = 'k';
-           LvTARG(TARG) = (SV*)hv;
+           if (LvTARG(TARG) != (SV*)hv) {
+               if (LvTARG(TARG))
+                   SvREFCNT_dec(LvTARG(TARG));
+               LvTARG(TARG) = SvREFCNT_inc(hv);
+           }
            PUSHs(TARG);
            RETURN;
        }
diff --git a/embed.h b/embed.h
index 02e4ce9..f26f1dd 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define magic_getarylen                Perl_magic_getarylen
 #define magic_getdefelem       Perl_magic_getdefelem
 #define magic_getglob          Perl_magic_getglob
+#define magic_getnkeys         Perl_magic_getnkeys
 #define magic_getpack          Perl_magic_getpack
 #define magic_getpos           Perl_magic_getpos
 #define magic_getsig           Perl_magic_getsig
+#define magic_getsubstr                Perl_magic_getsubstr
 #define magic_gettaint         Perl_magic_gettaint
 #define magic_getuvar          Perl_magic_getuvar
+#define magic_getvec           Perl_magic_getvec
 #define magic_len              Perl_magic_len
 #define magic_mutexfree                Perl_magic_mutexfree
 #define magic_nextpack         Perl_magic_nextpack
index 31a452b..ca97714 100644 (file)
@@ -389,11 +389,14 @@ magic_get
 magic_getarylen
 magic_getdefelem
 magic_getglob
+magic_getnkeys
 magic_getpack
 magic_getpos
 magic_getsig
+magic_getsubstr
 magic_gettaint
 magic_getuvar
+magic_getvec
 magic_len
 magic_mutexfree
 magic_nextpack
index 6397d1b..6bac364 100644 (file)
@@ -60,6 +60,7 @@ $CarpLevel = 0;               # How many extra package levels to skip on carp.
 $MaxEvalLen = 0;       # How much eval '...text...' to show. 0 = all.
 $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
+$Verbose = 0;          # If true then make shortmess call longmess instead
 
 require Exporter;
 @ISA = ('Exporter');
@@ -75,11 +76,7 @@ require Exporter;
 
 sub export_fail {
     shift;
-    if ($_[0] eq 'verbose') {
-       local $^W = 0; # avoid "sub-routine redefined..." warning
-       *shortmess = \&longmess; # set shortmess() as an alias to longmess()
-       shift; # remove 'verbose' from the args to keep Exporter happy
-    }
+    $Verbose = shift if $_[0] eq 'verbose';
     return @_;
 }
 
@@ -188,10 +185,11 @@ sub longmess {
 # shortmess() is called by carp() and croak() to skip all the way up to
 # the top-level caller's package and report the error from there.  confess()
 # and cluck() generate a full stack trace so they call longmess() to
-# generate that.  In verbose mode shortmess() is aliased to longmess() so
+# generate that.  In verbose mode shortmess() calls longmess() so
 # you always get a stack trace
 
 sub shortmess {        # Short-circuit &longmess if called via multiple packages
+    goto &longmess if $Verbose;
     my $error = join '', @_;
     my ($prevpack) = caller(1);
     my $extra = $CarpLevel;
index 3333844..e21af92 100644 (file)
@@ -160,23 +160,23 @@ sub fileparse {
   if ($fstype =~ /^VMS/i) {
     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
     else {
-      ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
+      ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/t);
       $dirpath ||= '';  # should always be defined
     }
   }
   if ($fstype =~ /^MS(DOS|Win32)/i) {
-    ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
+    ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/t);
     $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
   }
   elsif ($fstype =~ /^MacOS/i) {
-    ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/);
+    ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/t);
   }
   elsif ($fstype =~ /^AmigaOS/i) {
-    ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
+    ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/t);
     $dirpath = './' unless $dirpath;
   }
   elsif ($fstype !~ /^VMS/i) {  # default to Unix
-    ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
+    ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#t);
     if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) {
       # dev:[000000] is top of VMS tree, similar to Unix '/'
       ($basename,$dirpath) = ('',$fullname);
@@ -188,7 +188,7 @@ sub fileparse {
     $tail = '';
     foreach $suffix (@suffices) {
       my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
-      if ($basename =~ s/$pat//) {
+      if ($basename =~ s/$pat//t) {
         $taint .= substr($suffix,0,0);
         $tail = $1 . $tail;
       }
@@ -226,30 +226,30 @@ sub dirname {
     }
     if ($fstype =~ /MacOS/i) { return $dirname }
     elsif ($fstype =~ /MSDOS/i) { 
-        $dirname =~ s/([^:])[\\\/]*$/$1/;
+        $dirname =~ s/([^:])[\\\/]*$/$1/t;
         unless( length($basename) ) {
            ($basename,$dirname) = fileparse $dirname;
-           $dirname =~ s/([^:])[\\\/]*$/$1/;
+           $dirname =~ s/([^:])[\\\/]*$/$1/t;
        }
     }
     elsif ($fstype =~ /MSWin32/i) { 
-        $dirname =~ s/([^:])[\\\/]*$/$1/;
+        $dirname =~ s/([^:])[\\\/]*$/$1/t;
         unless( length($basename) ) {
            ($basename,$dirname) = fileparse $dirname;
-           $dirname =~ s/([^:])[\\\/]*$/$1/;
+           $dirname =~ s/([^:])[\\\/]*$/$1/t;
        }
     }
     elsif ($fstype =~ /AmigaOS/i) {
         if ( $dirname =~ /:$/) { return $dirname }
         chop $dirname;
-        $dirname =~ s#[^:/]+$## unless length($basename);
+        $dirname =~ s#[^:/]+$##t unless length($basename);
     }
     else { 
         $dirname =~ s:(.)/*$:$1:;
         unless( length($basename) ) {
            local($File::Basename::Fileparse_fstype) = $fstype;
            ($basename,$dirname) = fileparse $dirname;
-           $dirname =~ s:(.)/*$:$1:;
+           $dirname =~ s:(.)/*$:$1:t;
        }
     }
 
diff --git a/mg.c b/mg.c
index 108644a..268ec80 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -946,11 +946,33 @@ magic_setamagic(SV *sv, MAGIC *mg)
 #endif /* OVERLOAD */
 
 int
+magic_getnkeys(SV *sv, MAGIC *mg)
+{
+    HV *hv = (HV*)LvTARG(sv);
+    HE *entry;
+    I32 i = 0;
+
+    if (hv) {
+       (void) hv_iterinit(hv);
+       if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
+           i = HvKEYS(hv);
+       else {
+           /*SUPPRESS 560*/
+           while (entry = hv_iternext(hv)) {
+               i++;
+           }
+       }
+    }
+
+    sv_setiv(sv, (IV)i);
+    return 0;
+}
+
+int
 magic_setnkeys(SV *sv, MAGIC *mg)
 {
     if (LvTARG(sv)) {
        hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
-       LvTARG(sv) = Nullsv;    /* Don't allow a ref to reassign this. */
     }
     return 0;
 }          
@@ -1219,6 +1241,23 @@ magic_setglob(SV *sv, MAGIC *mg)
 }
 
 int
+magic_getsubstr(SV *sv, MAGIC *mg)
+{
+    STRLEN len;
+    SV *lsv = LvTARG(sv);
+    char *tmps = SvPV(lsv,len);
+    I32 offs = LvTARGOFF(sv);
+    I32 rem = LvTARGLEN(sv);
+
+    if (offs > len)
+       offs = len;
+    if (rem + offs > len)
+       rem = len - offs;
+    sv_setpvn(sv, tmps + offs, (STRLEN)rem);
+    return 0;
+}
+
+int
 magic_setsubstr(SV *sv, MAGIC *mg)
 {
     STRLEN len;
@@ -1254,6 +1293,72 @@ magic_settaint(SV *sv, MAGIC *mg)
 }
 
 int
+magic_getvec(SV *sv, MAGIC *mg)
+{
+    SV *lsv = LvTARG(sv);
+    unsigned char *s;
+    unsigned long retnum;
+    STRLEN lsvlen;
+    I32 len;
+    I32 offset;
+    I32 size;
+
+    if (!lsv) {
+       SvOK_off(sv);
+       return 0;
+    }
+    s = (unsigned char *) SvPV(lsv, lsvlen);
+    offset = LvTARGOFF(sv);
+    size = LvTARGLEN(sv);
+    len = (offset + size + 7) / 8;
+
+    /* Copied from pp_vec() */
+
+    if (len > lsvlen) {
+       if (size <= 8)
+           retnum = 0;
+       else {
+           offset >>= 3;
+           if (size == 16) {
+               if (offset >= lsvlen)
+                   retnum = 0;
+               else
+                   retnum = (unsigned long) s[offset] << 8;
+           }
+           else if (size == 32) {
+               if (offset >= lsvlen)
+                   retnum = 0;
+               else if (offset + 1 >= lsvlen)
+                   retnum = (unsigned long) s[offset] << 24;
+               else if (offset + 2 >= lsvlen)
+                   retnum = ((unsigned long) s[offset] << 24) +
+                       ((unsigned long) s[offset + 1] << 16);
+               else
+                   retnum = ((unsigned long) s[offset] << 24) +
+                       ((unsigned long) s[offset + 1] << 16) +
+                       (s[offset + 2] << 8);
+           }
+       }
+    }
+    else if (size < 8)
+       retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+    else {
+       offset >>= 3;
+       if (size == 8)
+           retnum = s[offset];
+       else if (size == 16)
+           retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+       else if (size == 32)
+           retnum = ((unsigned long) s[offset] << 24) +
+               ((unsigned long) s[offset + 1] << 16) +
+               (s[offset + 2] << 8) + s[offset+3];
+    }
+
+    sv_setuv(sv, (UV)retnum);
+    return 0;
+}
+
+int
 magic_setvec(SV *sv, MAGIC *mg)
 {
     do_vecset(sv);     /* XXX slurp this routine */
diff --git a/perl.c b/perl.c
index 2fdac45..f4338b1 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1166,6 +1166,8 @@ perl_call_method(char *methname, I32 flags)
     XPUSHs(sv_2mortal(newSVpv(methname,0)));
     PUTBACK;
     pp_method(ARGS);
+       if(op == &myop)
+               op = Nullop;
     return perl_call_sv(*stack_sp--, flags);
 }
 
diff --git a/perl.h b/perl.h
index 42250ed..fc96064 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1809,13 +1809,15 @@ EXT MGVTBL vtbl_glob =  {magic_getglob,
                                        0,      0,      0};
 EXT MGVTBL vtbl_mglob =        {0,     magic_setmglob,
                                        0,      0,      0};
-EXT MGVTBL vtbl_nkeys =        {0,     magic_setnkeys,
+EXT MGVTBL vtbl_nkeys =        {magic_getnkeys,
+                               magic_setnkeys,
                                        0,      0,      0};
 EXT MGVTBL vtbl_taint =        {magic_gettaint,magic_settaint,
                                        0,      0,      0};
-EXT MGVTBL vtbl_substr =       {0,     magic_setsubstr,
+EXT MGVTBL vtbl_substr =       {magic_getsubstr, magic_setsubstr,
                                        0,      0,      0};
-EXT MGVTBL vtbl_vec =  {0,     magic_setvec,
+EXT MGVTBL vtbl_vec =  {magic_getvec,
+                               magic_setvec,
                                        0,      0,      0};
 EXT MGVTBL vtbl_pos =  {magic_getpos,
                                magic_setpos,
index d46ff33..cd4c876 100644 (file)
@@ -1279,6 +1279,12 @@ don't take to this kindly.
 (W) You may have tried to use an 8 or 9 in a octal number.  Interpretation
 of the octal number stopped before the 8 or 9.
 
+=item Illegal hex digit ignored
+
+(W) You may have tried to use a character other than 0 - 9 or A - F in a
+hexadecimal number.  Interpretation of the hexadecimal number stopped
+before the illegal character.
+
 =item Illegal switch in PERL5OPT: %s
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp.c b/pp.c
index 0ebb98b..bd5fd38 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -322,7 +322,11 @@ PP(pp_pos)
        }
 
        LvTYPE(TARG) = '.';
-       LvTARG(TARG) = sv;
+       if (LvTARG(TARG) != sv) {
+           if (LvTARG(TARG))
+               SvREFCNT_dec(LvTARG(TARG));
+           LvTARG(TARG) = SvREFCNT_inc(sv);
+       }
        PUSHs(TARG);    /* no SvSETMAGIC */
        RETURN;
     }
@@ -1880,7 +1884,11 @@ PP(pp_substr)
            }
 
            LvTYPE(TARG) = 'x';
-           LvTARG(TARG) = sv;
+           if (LvTARG(TARG) != sv) {
+               if (LvTARG(TARG))
+                   SvREFCNT_dec(LvTARG(TARG));
+               LvTARG(TARG) = SvREFCNT_inc(sv);
+           }
            LvTARGOFF(TARG) = pos;
            LvTARGLEN(TARG) = rem;
        }
@@ -1917,7 +1925,11 @@ PP(pp_vec)
            }
 
            LvTYPE(TARG) = 'v';
-           LvTARG(TARG) = src;
+           if (LvTARG(TARG) != src) {
+               if (LvTARG(TARG))
+                   SvREFCNT_dec(LvTARG(TARG));
+               LvTARG(TARG) = SvREFCNT_inc(src);
+           }
            LvTARGOFF(TARG) = offset;
            LvTARGLEN(TARG) = size;
        }
index 8322e89..9e9ee3c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -251,6 +251,7 @@ PP(pp_aelemfast)
     djSP;
     AV *av = GvAV((GV*)cSVOP->op_sv);
     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
+    EXTEND(SP, 1);
     PUSHs(svp ? *svp : &sv_undef);
     RETURN;
 }
diff --git a/proto.h b/proto.h
index 03c91d3..a689fe0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -218,11 +218,14 @@ int       magic_get       _((SV* sv, MAGIC* mg));
 int    magic_getarylen _((SV* sv, MAGIC* mg));
 int    magic_getdefelem _((SV* sv, MAGIC* mg));
 int    magic_getglob   _((SV* sv, MAGIC* mg));
+int    magic_getnkeys  _((SV* sv, MAGIC* mg));
 int    magic_getpack   _((SV* sv, MAGIC* mg));
 int    magic_getpos    _((SV* sv, MAGIC* mg));
 int    magic_getsig    _((SV* sv, MAGIC* mg));
+int    magic_getsubstr _((SV* sv, MAGIC* mg));
 int    magic_gettaint  _((SV* sv, MAGIC* mg));
 int    magic_getuvar   _((SV* sv, MAGIC* mg));
+int    magic_getvec    _((SV* sv, MAGIC* mg));
 U32    magic_len       _((SV* sv, MAGIC* mg));
 #ifdef USE_THREADS
 int    magic_mutexfree _((SV* sv, MAGIC* mg));
diff --git a/sv.c b/sv.c
index 3685252..8310047 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2638,10 +2638,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
     register char *midend;
     register char *bigend;
     register I32 i;
+    STRLEN curlen;
+    
 
     if (!bigstr)
        croak("Can't modify non-existent substring");
-    SvPV_force(bigstr, na);
+    SvPV_force(bigstr, curlen);
+    if (offset + len > curlen) {
+       SvGROW(bigstr, offset+len+1);
+       Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
+       SvCUR_set(bigstr, offset+len);
+    }
 
     i = littlelen - len;
     if (i > 0) {                       /* string might grow */
diff --git a/util.c b/util.c
index 866e598..22af921 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1835,46 +1835,6 @@ VTOH(vtohs,short)
 VTOH(vtohl,long)
 #endif
 
-int
-do_binmode(PerlIO *fp, int iotype, int flag)
-{
-    if (flag != TRUE)
-       croak("panic: unsetting binmode"); /* Not implemented yet */
-#ifdef DOSISH
-#ifdef atarist
-    if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
-       return 1;
-    else
-       return 0;
-#else
-    if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
-#if defined(WIN32) && defined(__BORLANDC__)
-       /* The translation mode of the stream is maintained independent
-        * of the translation mode of the fd in the Borland RTL (heavy
-        * digging through their runtime sources reveal).  User has to
-        * set the mode explicitly for the stream (though they don't
-        * document this anywhere). GSAR 97-5-24
-        */
-       PerlIO_seek(fp,0L,0);
-       fp->flags |= _F_BIN;
-#endif
-       return 1;
-    }
-    else
-       return 0;
-#endif
-#else
-#if defined(USEMYBINMODE)
-    if (my_binmode(fp,iotype) != NULL)
-       return 1;
-    else
-       return 0;
-#else
-    return 1;
-#endif
-#endif
-}
-
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
 PerlIO *
@@ -2429,7 +2389,7 @@ scan_hex(char *start, I32 len, I32 *retlen)
     register char *s = start;
     register UV retval = 0;
     bool overflowed = FALSE;
-    char *tmp;
+    char *tmp = s;
 
     while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) {
        register UV n = retval << 4;
@@ -2440,6 +2400,9 @@ scan_hex(char *start, I32 len, I32 *retlen)
        retval = n | ((tmp - hexdigit) & 15);
        s++;
     }
+    if (dowarn && !tmp) {
+       warn("Illegal hex digit ignored");
+    }
     *retlen = s - start;
     return retval;
 }