From: Gurusamy Sarathy Date: Fri, 15 May 1998 02:15:25 +0000 (+0000) Subject: [win32] merge changes#906,907,909,910 from maintbranch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6ff81951f79dec32e15a779d288c1047f0e4fefb;p=p5sagit%2Fp5-mst-13.2.git [win32] merge changes#906,907,909,910 from maintbranch 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 --- diff --git a/doio.c b/doio.c index 94d78c4..f99a729 100644 --- 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 --- 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 --- a/embed.h +++ b/embed.h @@ -289,11 +289,14 @@ #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 diff --git a/global.sym b/global.sym index 31a452b..ca97714 100644 --- a/global.sym +++ b/global.sym @@ -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 diff --git a/lib/Carp.pm b/lib/Carp.pm index 6397d1b..6bac364 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -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; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 3333844..e21af92 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -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 --- 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 --- 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 --- 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, diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d46ff33..cd4c876 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -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 --- 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; } diff --git a/pp_hot.c b/pp_hot.c index 8322e89..9e9ee3c 100644 --- 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 --- 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 --- 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 --- 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; }