if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
- Perl_warn(aTHX_ "%"SVf, tmpsv);
+ Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
RETSETYES;
}
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvs("Died"));
- DIE(aTHX_ "%"SVf, tmpsv);
+ DIE(aTHX_ "%"SVf, (void*)tmpsv);
}
/* I/O. */
stash = gv_stashsv(*MARK, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
- methname, *MARK);
+ methname, (void*)*MARK);
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
GV *gv;
HV * const hv = (HV*)POPs;
- SV * const sv = sv_mortalcopy(&PL_sv_no);
-
- sv_setpv(sv, "AnyDBM_File");
+ SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
stash = gv_stashsv(sv, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
if (GIMME == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setnv(sv, value);
+ PUSHs(sv_2mortal(newSVnv(value)));
}
RETURN;
#else
else
fgv = gv;
+ if (!fgv) {
+ DIE(aTHX_ "Not a format reference");
+ }
cv = GvFORM(fgv);
if (!cv) {
- if (fgv) {
- SV * const tmpsv = sv_newmortal();
- const char *name;
- gv_efullname4(tmpsv, fgv, NULL, FALSE);
- name = SvPV_nolen_const(tmpsv);
- if (name && *name)
- DIE(aTHX_ "Undefined format \"%s\" called", name);
- }
+ SV * const tmpsv = sv_newmortal();
+ const char *name;
+ gv_efullname4(tmpsv, fgv, NULL, FALSE);
+ name = SvPV_nolen_const(tmpsv);
+ if (name && *name)
+ DIE(aTHX_ "Undefined format \"%s\" called", name);
DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
dVAR; dSP;
GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
register IO * const io = GvIOp(gv);
- PerlIO * const ofp = IoOFP(io);
+ PerlIO *ofp;
PerlIO *fp;
SV **newsp;
I32 gimme;
register PERL_CONTEXT *cx;
+ if (!io || !(ofp = IoOFP(io)))
+ goto forget_top;
+
DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
(long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
- if (!io || !ofp)
- goto forget_top;
+
if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
PL_formtarget != PL_toptarget)
{
gv_efullname4(sv, fgv, NULL, FALSE);
name = SvPV_nolen_const(sv);
if (name && *name)
- DIE(aTHX_ "Undefined top format \"%s\" called",name);
+ DIE(aTHX_ "Undefined top format \"%s\" called", name);
+ else
+ DIE(aTHX_ "Undefined top format called");
}
- /* why no:
- else
- DIE(aTHX_ "Undefined top format called");
- ?*/
- if (CvCLONE(cv))
+ if (cv && CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- return doform(cv,gv,PL_op);
+ return doform(cv, gv, PL_op);
}
forget_top:
IO *io;
SV *bufsv;
const char *buffer;
- Size_t length = 0;
SSize_t retval;
STRLEN blen;
+ STRLEN orig_blen_bytes;
MAGIC *mg;
const int op_type = PL_op->op_type;
+ bool doing_utf8;
+ U8 *tmpbuf = NULL;
GV *const gv = (GV*)*++MARK;
if (PL_op->op_type == OP_SYSWRITE
bufsv = *++MARK;
- if (op_type == OP_SYSWRITE) {
- if (MARK >= SP) {
- length = (Size_t) sv_len(bufsv);
- } else {
-#if Size_t_size > IVSIZE
- length = (Size_t)SvNVx(*++MARK);
-#else
- length = (Size_t)SvIVx(*++MARK);
-#endif
- if ((SSize_t)length < 0)
- DIE(aTHX_ "Negative length");
- }
- }
SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
goto say_undef;
}
+ /* Do this first to trigger any overloading. */
+ buffer = SvPV_const(bufsv, blen);
+ orig_blen_bytes = blen;
+ doing_utf8 = DO_UTF8(bufsv);
+
if (PerlIO_isutf8(IoIFP(io))) {
if (!SvUTF8(bufsv)) {
- bufsv = sv_2mortal(newSVsv(bufsv));
- buffer = sv_2pvutf8(bufsv, &blen);
- } else
- buffer = SvPV_const(bufsv, blen);
+ /* We don't modify the original scalar. */
+ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
+ buffer = (char *) tmpbuf;
+ doing_utf8 = TRUE;
+ }
}
- else {
- if (DO_UTF8(bufsv)) {
- /* Not modifying source SV, so making a temporary copy. */
- bufsv = sv_2mortal(newSVsv(bufsv));
- sv_utf8_downgrade(bufsv, FALSE);
- }
- buffer = SvPV_const(bufsv, blen);
+ else if (doing_utf8) {
+ STRLEN tmplen = blen;
+ U8 *result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
+ if (!doing_utf8) {
+ tmpbuf = result;
+ buffer = (char *) tmpbuf;
+ blen = tmplen;
+ }
+ else {
+ assert((char *)result == buffer);
+ Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
+ }
}
if (op_type == OP_SYSWRITE) {
+ Size_t length = 0; /* This length is in characters. */
+ STRLEN blen_chars;
IV offset;
- if (DO_UTF8(bufsv)) {
- /* length and offset are in chars */
- blen = sv_len_utf8(bufsv);
+
+ if (doing_utf8) {
+ if (tmpbuf) {
+ /* The SV is bytes, and we've had to upgrade it. */
+ 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(buffer, buffer + blen);
+ } else {
+ /* It's safe, and it may well be cached. */
+ blen_chars = sv_len_utf8(bufsv);
+ }
+ }
+ } else {
+ blen_chars = blen;
}
+
+ if (MARK >= SP) {
+ length = blen_chars;
+ } else {
+#if Size_t_size > IVSIZE
+ length = (Size_t)SvNVx(*++MARK);
+#else
+ length = (Size_t)SvIVx(*++MARK);
+#endif
+ if ((SSize_t)length < 0)
+ DIE(aTHX_ "Negative length");
+ }
+
if (MARK < SP) {
offset = SvIVx(*++MARK);
if (offset < 0) {
- if (-offset > (IV)blen)
+ if (-offset > (IV)blen_chars)
DIE(aTHX_ "Offset outside string");
- offset += blen;
- } else if (offset >= (IV)blen && blen > 0)
+ offset += blen_chars;
+ } else if (offset >= (IV)blen_chars && blen_chars > 0)
DIE(aTHX_ "Offset outside string");
} else
offset = 0;
- if (length > blen - offset)
- length = blen - offset;
- if (DO_UTF8(bufsv)) {
- buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
- length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ if (length > blen_chars - offset)
+ length = blen_chars - offset;
+ if (doing_utf8) {
+ /* Here we convert length from characters to bytes. */
+ if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
+ /* Either we had to convert the SV, or the SV is magical, or
+ the SV has overloading, in which case we can't or mustn't
+ or mustn't call it again. */
+
+ buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
+ length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ } else {
+ /* It's a real UTF-8 SV, and it's not going to change under
+ us. Take advantage of any cache. */
+ I32 start = offset;
+ I32 len_I32 = length;
+
+ /* Convert the start and end character positions to bytes.
+ Remember that the second argument to sv_pos_u2b is relative
+ to the first. */
+ sv_pos_u2b(bufsv, &start, &len_I32);
+
+ buffer += start;
+ length = len_I32;
+ }
}
else {
buffer = buffer+offset;
else
DIE(aTHX_ PL_no_sock_func, "send");
#endif
+ if (tmpbuf)
+ Safefree(tmpbuf);
+
if (retval < 0)
goto say_undef;
SP = ORIGMARK;
- if (DO_UTF8(bufsv))
+ if (doing_utf8)
retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
#if Size_t_size > IVSIZE
PUSHn(retval);
if (!gv || !io) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- if (IoIFP(io))
+ if (io && IoIFP(io))
do_close(gv, FALSE);
SETERRNO(EBADF,LIB_INVARG);
RETPUSHUNDEF;
if (!gv2 || !io2)
report_evil_fh(gv1, io2, PL_op->op_type);
}
- if (IoIFP(io1))
+ if (io1 && IoIFP(io1))
do_close(gv1, FALSE);
- if (IoIFP(io2))
+ if (io2 && IoIFP(io2))
do_close(gv2, FALSE);
RETPUSHUNDEF;
}
SP = ORIGMARK;
if (did_pipes) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
#endif
}
+/* I can't const this further without getting warnings about the types of
+ various arrays passed in from structures. */
+static SV *
+S_space_join_names_mortal(pTHX_ char *const *array)
+{
+ SV *target;
+
+ if (array && *array) {
+ target = sv_2mortal(newSVpvs(""));
+ while (1) {
+ sv_catpv(target, *array);
+ if (!*++array)
+ break;
+ sv_catpvs(target, " ");
+ }
+ } else {
+ target = sv_mortalcopy(&PL_sv_no);
+ }
+ return target;
+}
+
/* Get system info. */
PP(pp_ghostent)
}
if (hent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, (char*)hent->h_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = hent->h_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvs(sv, " ");
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)hent->h_addrtype);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ hent->h_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
len = hent->h_length;
- sv_setiv(sv, (IV)len);
+ PUSHs(sv_2mortal(newSViv((IV)len)));
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
- XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpvn(sv, *elem, len);
+ XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
}
#else
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
if (hent->h_addr)
- sv_setpvn(sv, hent->h_addr, len);
+ PUSHs(newSVpvn(hent->h_addr, len));
+ else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
#endif /* h_addr */
}
RETURN;
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *getnetbyaddr(Netdb_net_t, int);
}
if (nent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, nent->n_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = nent->n_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvs(sv, " ");
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)nent->n_addrtype);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)nent->n_net);
+ PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ nent->n_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
+ PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
}
RETURN;
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *getprotobyname(Netdb_name_t);
}
if (pent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pent->p_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = pent->p_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvs(sv, " ");
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)pent->p_proto);
+ PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ pent->p_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
}
RETURN;
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
}
if (sent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = sent->s_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvs(sv, " ");
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ sent->s_aliases));
#ifdef HAS_NTOHS
- sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
+ PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
#else
- sv_setiv(sv, (IV)(sent->s_port));
+ PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
#endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_proto);
+ PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
}
RETURN;
}
if (pwent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_name);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- SvPOK_off(sv);
+ PUSHs(sv = sv_2mortal(newSViv(0)));
/* If we have getspnam(), we try to dig up the shadow
* password. If we are underprivileged, the shadow
* interface will set the errno to EACCES or similar,
SvTAINTED_on(sv);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
# else
- sv_setuv(sv, (UV)pwent->pw_uid);
+ PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_gid);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
# else
- sv_setuv(sv, (UV)pwent->pw_gid);
+ PUSHs(sv_2mortal(newSVuv((UV)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.
* A better interface would have been to return a hash,
* but we are accursed by our history, alas. --jhi. */
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWCHANGE
- sv_setiv(sv, (IV)pwent->pw_change);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
# else
# ifdef PWQUOTA
- sv_setiv(sv, (IV)pwent->pw_quota);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
# else
# ifdef PWAGE
- sv_setpv(sv, pwent->pw_age);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
+# else
+ /* I think that you can never get this compiled, but just in case. */
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# endif
# endif
/* pw_class and pw_comment are mutually exclusive--.
* see the above note for pw_change, pw_quota, and pw_age. */
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWCLASS
- sv_setpv(sv, pwent->pw_class);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
# else
# ifdef PWCOMMENT
- sv_setpv(sv, pwent->pw_comment);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
+# else
+ /* I think that you can never get this compiled, but just in case. */
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWGECOS
- sv_setpv(sv, pwent->pw_gecos);
+ PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
+# else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_dir);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_shell);
+ PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
# ifndef INCOMPLETE_TAINTS
/* pw_shell is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
# endif
# ifdef PWEXPIRE
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)pwent->pw_expire);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
# endif
}
RETURN;
}
if (grent) {
- SV *sv;
- char **elem;
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, grent->gr_name);
+ PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef GRPASSWD
- sv_setpv(sv, grent->gr_passwd);
+ PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
+#else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
#endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)grent->gr_gid);
+ PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
/* In UNICOS/mk (_CRAYMPP) the multithreading
* versions (getgrnam_r, getgrgid_r)
* seem to return an illegal pointer
* but the gr_mem is poisonous anyway.
* So yes, you cannot get the list of group
* members if building multithreaded in UNICOS/mk. */
- for (elem = grent->gr_mem; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvs(sv, " ");
- }
+ PUSHs(S_space_join_names_mortal(aTHX_ grent->gr_mem));
#endif
}
https://perl5.git.perl.org / perl5.git / blobdiff