if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_gv);
+
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV *gv = (GV*) sv_newmortal();
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "a symbol");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a symbol");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, PL_na);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a symbol");
+ DIE(PL_no_symref, sym, "a symbol");
sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_sv);
+
sv = SvRV(sv);
switch (SvTYPE(sv)) {
case SVt_PVAV:
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "a SCALAR");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a SCALAR");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, PL_na);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a SCALAR");
+ DIE(PL_no_symref, sym, "a SCALAR");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
while (i < MAXO) { /* The slow way. */
- if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
+ if (strEQ(s + 6, PL_op_name[i])
+ || strEQ(s + 6, PL_op_desc[i]))
+ {
goto found;
+ }
i++;
}
goto nonesuch; /* Should not happen... */
found:
- oa = opargs[i] >> OASHIFT;
+ oa = PL_opargs[i] >> OASHIFT;
while (oa) {
if (oa & OA_OPTIONAL) {
seen_question = 1;
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
- if (PL_dowarn && len == 0)
- warn("Explicit blessing to '' (assuming package main)");
+ if (ckWARN(WARN_UNSAFE) && len == 0)
+ warner(WARN_UNSAFE,
+ "Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
EXTEND(SP,1);
}
TARG = sv_newmortal();
- PUSHi(do_trans(sv, PL_op));
+ PUSHi(do_trans(sv));
RETURN;
}
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (PL_dowarn && cv_const_sv((CV*)sv))
- warn("Constant subroutine %s undefined",
+ if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
+ warner(WARN_UNSAFE, "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(no_modify);
+ croak(PL_no_modify);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(no_modify);
+ croak(PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
djSP; dTARGET;
if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(no_modify);
+ croak(PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
sv_setsv(TARG, sv);
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
}
+ else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
+ sv_setpvn(TARG, "-", 1);
+ sv_catsv(TARG, sv);
+ }
else
sv_setnv(TARG, -SvNV(sv));
SETTARG;
compatibility by calling rand() but allow the user to override it.
See INSTALL for details. --Andy Dougherty 15 July 1998
*/
-#ifndef my_rand
-# define my_rand rand
-#endif
-#ifndef my_srand
-# define my_srand srand
+/* Now it's after 5.005, and Configure supports drand48() and random(),
+ in addition to rand(). So the overrides should not be needed any more.
+ --Jarkko Hietaniemi 27 September 1998
+ */
+
+#ifndef HAS_DRAND48_PROTO
+extern double drand48 _((void));
#endif
PP(pp_rand)
if (value == 0.0)
value = 1.0;
if (!srand_called) {
- (void)my_srand((unsigned)seed());
+ (void)seedDrand01((Rand_seed_t)seed());
srand_called = TRUE;
}
-#if RANDBITS == 31
- value = my_rand() * value / 2147483648.0;
-#else
-#if RANDBITS == 16
- value = my_rand() * value / 65536.0;
-#else
-#if RANDBITS == 15
- value = my_rand() * value / 32768.0;
-#else
- value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
-#endif
-#endif
-#endif
+ value *= Drand01();
XPUSHn(value);
RETURN;
}
anum = seed();
else
anum = POPu;
- (void)my_srand((unsigned)anum);
+ (void)seedDrand01((Rand_seed_t)anum);
srand_called = TRUE;
EXTEND(SP, 1);
RETPUSHYES;
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
* spreads the effect of every input bit onto every output bit,
- * if someone who knows about such tings would bother to write it.
+ * if someone who knows about such things would bother to write it.
* Might be a good idea to add that function to CORE as well.
- * No numbers below come from careful analysis or anyting here,
+ * No numbers below come from careful analysis or anything here,
* except they are primes and SEED_C1 > 1E6 to get a full-width
* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
* probably be bigger too.
#define SEED_C5 26107
dTHR;
+#ifndef PERL_NO_DEV_RANDOM
+ int fd;
+#endif
U32 u;
#ifdef VMS
# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
+#else
+# ifdef HAS_GETTIMEOFDAY
+ struct timeval when;
+# else
+ Time_t when;
+# endif
+#endif
+
+/* This test is an escape hatch, this symbol isn't set by Configure. */
+#ifndef PERL_NO_DEV_RANDOM
+#ifndef PERL_RANDOM_DEVICE
+ /* /dev/random isn't used by default because reads from it will block
+ * if there isn't enough entropy available. You can compile with
+ * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
+ * is enough real entropy to fill the seed. */
+# define PERL_RANDOM_DEVICE "/dev/urandom"
+#endif
+ fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
+ if (fd != -1) {
+ if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
+ u = 0;
+ PerlLIO_close(fd);
+ if (u)
+ return u;
+ }
+#endif
+
+#ifdef VMS
_ckvmssts(sys$gettim(when));
u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
#else
# ifdef HAS_GETTIMEOFDAY
- struct timeval when;
gettimeofday(&when,(struct timezone *) 0);
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
# else
- Time_t when;
(void)time(&when);
u = (U32)SEED_C1 * when;
# endif
else
curlen = utfcurlen;
}
+ else
+ utfcurlen = 0;
if (pos >= arybase) {
pos -= arybase;
rem -= pos;
}
if (fail < 0) {
- if (PL_dowarn || lvalue || repl)
- warn("substr outside of string");
+ if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+ warner(WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
SvPV_force(sv,PL_na);
- if (PL_dowarn)
- warn("Attempt to use reference as lvalue in substr");
+ if (ckWARN(WARN_SUBSTR))
+ warner(WARN_SUBSTR,
+ "Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
PP(pp_ord)
{
djSP; dTARGET;
- I32 value;
- char *tmps = POPp;
+ UV value;
+ U8 *tmps = (U8*)POPp;
I32 retlen;
if (IN_UTF8 && (*tmps & 0x80))
- value = (I32) utf8_to_uv(tmps, &retlen);
+ value = utf8_to_uv(tmps, &retlen);
else
- value = (I32) (*tmps & 255);
- XPUSHi(value);
+ value = (UV)(*tmps & 255);
+ XPUSHu(value);
RETURN;
}
{
djSP; dTARGET;
char *tmps;
- I32 value = POPi;
+ U32 value = POPu;
(void)SvUPGRADE(TARG,SVt_PV);
if (IN_UTF8 && value >= 128) {
SvGROW(TARG,8);
tmps = SvPVX(TARG);
- tmps = uv_to_utf8(tmps, (UV)value);
+ tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
SvCUR_set(TARG, tmps - SvPVX(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
register U8 *s;
STRLEN slen;
- if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
I32 ulen;
U8 tmpbuf[10];
U8 *tend;
if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
dTARGET;
- sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, s + ulen, slen - ulen);
+ sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SETs(TARG);
}
else {
- s = SvPV_force(sv, slen);
+ s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
RETURN;
sv = TARG;
SETs(sv);
}
- s = SvPV_force(sv, PL_na);
+ s = (U8*)SvPV_force(sv, PL_na);
if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
register U8 *s;
STRLEN slen;
- if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
I32 ulen;
U8 tmpbuf[10];
U8 *tend;
if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
dTARGET;
- sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, s + ulen, slen - ulen);
+ sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SETs(TARG);
}
else {
- s = SvPV_force(sv, slen);
+ s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
RETURN;
sv = TARG;
SETs(sv);
}
- s = SvPV_force(sv, PL_na);
+ s = (U8*)SvPV_force(sv, PL_na);
if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
register U8 *d;
U8 *send;
- s = SvPV(sv,len);
- if (!len)
+ s = (U8*)SvPV(sv,len);
+ if (!len) {
+ sv_setpvn(TARG, "", 0);
+ SETs(TARG);
RETURN;
+ }
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
(void)SvPOK_only(TARG);
- d = SvPVX(TARG);
+ d = (U8*)SvPVX(TARG);
send = s + len;
if (PL_op->op_private & OPpLOCALE) {
TAINT;
SETs(sv);
}
- s = SvPV_force(sv, len);
+ s = (U8*)SvPV_force(sv, len);
if (len) {
register U8 *send = s + len;
register U8 *d;
U8 *send;
- s = SvPV(sv,len);
- if (!len)
+ s = (U8*)SvPV(sv,len);
+ if (!len) {
+ sv_setpvn(TARG, "", 0);
+ SETs(TARG);
RETURN;
+ }
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
(void)SvPOK_only(TARG);
- d = SvPVX(TARG);
+ d = (U8*)SvPVX(TARG);
send = s + len;
if (PL_op->op_private & OPpLOCALE) {
TAINT;
SETs(sv);
}
- s = SvPV_force(sv, len);
+ s = (U8*)SvPV_force(sv, len);
if (len) {
register U8 *send = s + len;
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
- while (len--) {
- if (!(*s & 0x80) && !isALNUM(*s))
- *d++ = '\\';
- *d++ = *s++;
+ if (IN_UTF8) {
+ while (len) {
+ if (*s & 0x80) {
+ STRLEN ulen = UTF8SKIP(s);
+ if (ulen > len)
+ ulen = len;
+ len -= ulen;
+ while (ulen--)
+ *d++ = *s++;
+ }
+ else {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ len--;
+ }
+ }
+ }
+ else {
+ while (len--) {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
}
*d = '\0';
SvCUR_set(TARG, d - SvPVX(TARG));
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(no_aelem, elem);
+ DIE(PL_no_aelem, elem);
if (PL_op->op_private & OPpLVAL_INTRO)
save_aelem(av, elem, svp);
}
}
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(no_helem, SvPV(keysv, PL_na));
+ DIE(PL_no_helem, SvPV(keysv, PL_na));
if (PL_op->op_private & OPpLVAL_INTRO)
save_helem(hv, keysv, svp);
}
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (PL_dowarn)
- warn("Odd number of elements in hash assignment");
+ else if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
SV **tmparyval = 0;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
else
offset -= PL_curcop->cop_arybase;
if (offset < 0)
- DIE(no_aelem, i);
+ DIE(PL_no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0) {
register SV *sv = &PL_sv_undef;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
register I32 i = 0;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
up = SvPV_force(TARG, len);
if (len > 1) {
if (IN_UTF8) { /* first reverse each character */
- unsigned char* s = SvPVX(TARG);
- unsigned char* send = s + len;
+ U8* s = (U8*)SvPVX(TARG);
+ U8* send = (U8*)(s + len);
while (s < send) {
if (*s < 0x80) {
s++;
continue;
}
else {
- up = s;
+ up = (char*)s;
s += UTF8SKIP(s);
- down = s - 1;
+ down = (char*)(s - 1);
if (s > send || !((*down & 0xc0) == 0x80)) {
warn("Malformed UTF-8 character");
break;
unsigned int auint;
U32 aulong;
#ifdef HAS_QUAD
- unsigned Quad_t auquad;
+ Uquad_t auquad;
#endif
char *aptr;
float afloat;
default:
croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in unpack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
len = strend - s;
if (checksum) {
while (len-- > 0 && s < strend) {
- auint = utf8_to_uv(s, &along);
+ auint = utf8_to_uv((U8*)s, &along);
s += along;
- culong += auint;
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0 && s < strend) {
- auint = utf8_to_uv(s, &along);
+ auint = utf8_to_uv((U8*)s, &along);
s += along;
sv = NEWSV(37, 0);
- sv_setiv(sv, (IV)auint);
+ sv_setuv(sv, (UV)auint);
PUSHs(sv_2mortal(sv));
}
}
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- if (s + sizeof(unsigned Quad_t) > strend)
+ if (s + sizeof(Uquad_t) > strend)
auquad = 0;
else {
- Copy(s, &auquad, 1, unsigned Quad_t);
- s += sizeof(unsigned Quad_t);
+ Copy(s, &auquad, 1, Uquad_t);
+ s += sizeof(Uquad_t);
}
sv = NEWSV(43, 0);
if (auquad <= UV_MAX)
char hunk[4];
hunk[3] = '\0';
- len = (*s++ - ' ') & 077;
+ len = uudmap[*s++] & 077;
while (len > 0) {
if (s < strend && ISUUCHAR(*s))
a = uudmap[*s++] & 077;
if (checksum) {
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLN", datumtype)) ) {
+ (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
double trouble;
adouble = 1.0;
U32 aulong;
#ifdef HAS_QUAD
Quad_t aquad;
- unsigned Quad_t auquad;
+ Uquad_t auquad;
#endif
char *aptr;
float afloat;
default:
croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in pack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
fromstr = NEXTFROM;
auint = SvUV(fromstr);
SvGROW(cat, SvCUR(cat) + 10);
- SvCUR_set(cat, uv_to_utf8(SvEND(cat), auint) - SvPVX(cat));
+ SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
+ - SvPVX(cat));
}
*SvEND(cat) = '\0';
break;
case 'Q':
while (len-- > 0) {
fromstr = NEXTFROM;
- auquad = (unsigned Quad_t)SvIV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
+ auquad = (Uquad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
}
break;
case 'q':
* of pack() (and all copies of the result) are
* gone.
*/
- if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- warn("Attempt to pack pointer to temporary value");
+ if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warner(WARN_UNSAFE,
+ "Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,PL_na);
else
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)ary, mg));
}
else {
if (!AvREAL(ary)) {
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
(unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
save_destructor(unlock_condpair, sv);
}
#endif /* USE_THREADS */
projects / p5sagit/p5-mst-13.2.git / blobdiff