dVAR;
OP *result;
dSP;
+ GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
+
+ PUTBACK;
+
/* make a copy of the pattern if it is gmagical, to ensure that magic
* is called once and only once */
- if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+ if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
- tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+ tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
if (PL_op->op_flags & OPf_SPECIAL) {
/* call Perl-level glob function instead. Stack args are:
- * MARK, wildcard, csh_glob context index
+ * MARK, wildcard
* and following OPs should be: gv(CORE::GLOBAL::glob), entersub
* */
return NORMAL;
}
- /* stack args are: wildcard, gv(_GEN_n) */
-
if (PL_globhook) {
- SETs(GvSV(TOPs));
PL_globhook(aTHX);
return NORMAL;
}
ENTER_with_name("glob");
#ifndef VMS
- if (PL_tainting) {
+ if (TAINTING_get) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
#endif /* !VMS */
SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ PL_last_in_gv = gv;
SAVESPTR(PL_rs); /* This is not permanent, either. */
PL_rs = newSVpvs_flags("\000", SVs_TEMP);
/* well-formed exception supplied */
}
else {
- SvGETMAGIC(ERRSV);
- if (SvROK(ERRSV)) {
- if (SvGMAGICAL(ERRSV)) {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ if (SvGMAGICAL(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
}
- else exsv = ERRSV;
+ else exsv = errsv;
}
- else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
+ else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
sv_catpvs(exsv, "\t...caught");
}
else {
if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- if (sv_isobject(exsv)) {
- HV * const stash = SvSTASH(SvRV(exsv));
- GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
- if (gv) {
- SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
- EXTEND(SP, 3);
- PUSHMARK(SP);
- PUSHs(exsv);
- PUSHs(file);
- PUSHs(line);
- PUTBACK;
- call_sv(MUTABLE_SV(GvCV(gv)),
- G_SCALAR|G_EVAL|G_KEEPERR);
- exsv = sv_mortalcopy(*PL_stack_sp--);
+ else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ exsv = errsv;
+ if (sv_isobject(exsv)) {
+ HV * const stash = SvSTASH(SvRV(exsv));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+ SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(exsv);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ call_sv(MUTABLE_SV(GvCV(gv)),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ exsv = sv_mortalcopy(*PL_stack_sp--);
+ }
}
}
- }
- else if (SvPV_const(ERRSV, len), len) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...propagated");
- }
- else {
- exsv = newSVpvs_flags("Died", SVs_TEMP);
+ else if (SvPOK(errsv) && SvCUR(errsv)) {
+ exsv = sv_mortalcopy(errsv);
+ sv_catpvs(exsv, "\t...propagated");
+ }
+ else {
+ exsv = newSVpvs_flags("Died", SVs_TEMP);
+ }
}
return die_sv(exsv);
}
/* I/O. */
OP *
-Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
const MAGIC *const mg, const U32 flags, U32 argc, ...)
{
SV **orig_sp = sp;
SAVEGENERICSV(PL_ors_sv);
PL_ors_sv = newSVpvs("\n");
}
- ret_args = call_method(methname, flags & G_WANT);
+ ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
SPAGAIN;
orig_sp = sp;
POPSTACK;
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
}
}
}
if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
}
if (!io || !(fp = IoIFP(io))) {
function, which I don't think that the optimiser will be able to
figure out. Although, as it's a static function, in theory it
could. */
- return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
discp ? 1 : 0, discp);
}
switch(SvTYPE(varsv)) {
case SVt_PVHV:
+ {
+ HE *entry;
methname = "TIEHASH";
+ if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+ HvLAZYDEL_off(varsv);
+ hv_free_ent((HV *)varsv, entry);
+ }
HvEITER_set(MUTABLE_HV(varsv), 0);
break;
+ }
case SVt_PVAV:
methname = "TIEARRAY";
if (!AvREAL(varsv)) {
varsv = MUTABLE_SV(GvIOp(varsv));
break;
}
+ if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
+ vivify_defelem(varsv);
+ varsv = LvTARG(varsv);
+ }
/* FALL THROUGH */
default:
methname = "TIESCALAR";
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
if (obj) {
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
if ((mg = SvTIED_mg(sv, how))) {
PUSHs(SvTIED_obj(sv, mg));
RETURN;
if (!SvOK(sv))
continue;
if (SvREADONLY(sv)) {
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- Perl_croak_no_modify(aTHX);
+ if (!(SvPOK(sv) && SvCUR(sv) == 0))
+ Perl_croak_no_modify();
}
+ else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
if (!SvPOK(sv)) {
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
const U32 gimme = GIMME_V;
- Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
+ Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- do_print(GvSV(gv_fetchpv("\f", TRUE, SVt_PV)), ofp);
+ do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
PL_formtarget = PL_toptarget;
IoFLAGS(io) |= IOf_DIDTOP;
fgv = IoTOP_GV(io);
- if (!fgv)
- DIE(aTHX_ "bad top format reference");
+ assert(fgv); /* IoTOP_GV(io) should have been set above */
cv = GvFORM(fgv);
if (!cv) {
SV * const sv = sv_newmortal();
{
dVAR; dSP; dMARK; dORIGMARK;
PerlIO *fp;
- SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
IO *const io = GvIO(gv);
+ /* Treat empty list as "" */
+ if (MARK == SP) XPUSHs(&PL_sv_no);
+
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
+ return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
}
- sv = newSV(0);
if (!io) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else {
+ SV *sv = sv_newmortal();
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_undef);
RETURN;
{
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- /* SV's length cache is only safe for non-magical values */
- if (SvGMAGICAL(bufsv))
- blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
- else
- blen = sv_len_utf8(bufsv);
+ blen = sv_len_utf8_nomg(bufsv);
}
charstart = TRUE;
if (PL_op->op_type == OP_RECV) {
Sock_size_t bufsize;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
/* MSG_TRUNC can give oversized count; quietly lose it */
if (count > length)
count = length;
-#ifdef EPOC
- /* Bogus return without padding */
- bufsize = sizeof (struct sockaddr_in);
-#endif
SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
PUTBACK;
}
- return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
blen_chars = orig_blen_bytes;
} else {
/* The SV really is UTF-8. */
- if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
- /* Don't call sv_len_utf8 again because it will call magic
- or overloading a second time, and we might get back a
- different result. */
- blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
- } else {
- /* It's safe, and it may well be cached. */
- blen_chars = sv_len_utf8(bufsv);
- }
+ /* Don't call sv_len_utf8 on a magical or overloaded
+ scalar, as we might get back a different result. */
+ blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
}
} else {
blen_chars = blen;
RETPUSHNO;
if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
+ return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
}
if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
}
}
else if (!gv) {
SV *const offset_sv = newSViv(offset);
#endif
- return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
+ return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
newSViv(whence));
}
}
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif
-#ifdef EPOC
- setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
-#endif
-
RETPUSHYES;
}
#endif
IO *nstio;
IO *gstio;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
Sock_size_t len = sizeof (struct sockaddr_in);
#else
Sock_size_t len = sizeof namebuf;
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif
-#ifdef EPOC
- len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
- setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
-#endif
#ifdef __SCO_VERSION__
len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
#endif
#endif
mPUSHu(PL_statcache.st_mode);
mPUSHu(PL_statcache.st_nlink);
-#if Uid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_uid);
-#else
-# if Uid_t_sign <= 0
- mPUSHi(PL_statcache.st_uid);
-# else
- mPUSHu(PL_statcache.st_uid);
-# endif
-#endif
-#if Gid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_gid);
-#else
-# if Gid_t_sign <= 0
- mPUSHi(PL_statcache.st_gid);
-# else
- mPUSHu(PL_statcache.st_gid);
-# endif
-#endif
+
+ sv_setuid(PUSHmortal, PL_statcache.st_uid);
+ sv_setgid(PUSHmortal, PL_statcache.st_gid);
+
#ifdef USE_STAT_RDEV
mPUSHi(PL_statcache.st_rdev);
#else
; e++)
{
/* you don't see this */
- const char * const errmsg =
-#ifdef HAS_SYS_ERRLIST
- sys_errlist[e]
-#else
- strerror(e)
-#endif
- ;
+ const char * const errmsg = Strerror(e) ;
if (!errmsg)
break;
if (instr(s, errmsg)) {
}
#endif
if (childpid < 0)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (!childpid) {
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
if (childpid == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
# else
I32 value;
int result;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
#ifdef HAS_GETSERVBYPORT
const char * const proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
-#ifdef HAS_HTONS
port = PerlSock_htons(port);
-#endif
sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyport");
PUSHs(sv = sv_newmortal());
if (sent) {
if (which == OP_GSBYNAME) {
-#ifdef HAS_NTOHS
sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
-#else
- sv_setiv(sv, (IV)(sent->s_port));
-#endif
}
else
sv_setpv(sv, sent->s_name);
if (sent) {
mPUSHs(newSVpv(sent->s_name, 0));
PUSHs(space_join_names_mortal(sent->s_aliases));
-#ifdef HAS_NTOHS
mPUSHi(PerlSock_ntohs(sent->s_port));
-#else
- mPUSHi(sent->s_port);
-#endif
mPUSHs(newSVpv(sent->s_proto, 0));
}
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
-# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
-# else
- sv_setuv(sv, (UV)pwent->pw_uid);
-# endif
+ sv_setuid(sv, pwent->pw_uid);
else
sv_setpv(sv, pwent->pw_name);
}
SvTAINTED_on(sv);
# endif
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_uid);
-# else
- mPUSHu(pwent->pw_uid);
-# endif
+ sv_setuid(PUSHmortal, pwent->pw_uid);
+ sv_setgid(PUSHmortal, pwent->pw_gid);
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_gid);
-# else
- mPUSHu(pwent->pw_gid);
-# endif
/* pw_change, pw_quota, and pw_age are mutually exclusive--
* because of the poor interface of the Perl getpw*(),
* not because there's some standard/convention saying so.
PUSHs(sv);
if (grent) {
if (which == OP_GGRNAM)
-#if Gid_t_sign <= 0
- sv_setiv(sv, (IV)grent->gr_gid);
-#else
- sv_setuv(sv, (UV)grent->gr_gid);
-#endif
+ sv_setgid(sv, grent->gr_gid);
else
sv_setpv(sv, grent->gr_name);
}
PUSHs(sv_mortalcopy(&PL_sv_no));
#endif
-#if Gid_t_sign <= 0
- mPUSHi(grent->gr_gid);
-#else
- mPUSHu(grent->gr_gid);
-#endif
+ sv_setgid(PUSHmortal, grent->gr_gid);
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
/* In UNICOS/mk (_CRAYMPP) the multithreading
I32 i = 0;
IV retval = -1;
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
https://perl5.git.perl.org / perl5.git / blobdiff