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
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;
}
#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
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
$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');
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 @_;
}
# 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;
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);
$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;
}
}
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;
}
}
#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;
}
}
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;
}
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 */
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
pp_method(ARGS);
+ if(op == &myop)
+ op = Nullop;
return perl_call_sv(*stack_sp--, flags);
}
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,
(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
}
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;
}
}
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;
}
}
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;
}
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;
}
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));
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 */
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 *
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;
retval = n | ((tmp - hexdigit) & 15);
s++;
}
+ if (dowarn && !tmp) {
+ warn("Illegal hex digit ignored");
+ }
*retlen = s - start;
return retval;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff