/* pp_sys.c
*
* Copyright (C) 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* a rumour and a trouble as of great engines throbbing and labouring.
*/
+/* This file contains system pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * By 'system', we mean ops which interact with the OS, such as pp_open().
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_SYS_C
#include "perl.h"
sv_setsv(error,*PL_stack_sp--);
}
}
- DIE(aTHX_ Nullformat);
+ DIE_NULL;
}
else {
if (SvPOK(error) && SvCUR(error))
ENTER;
SAVETMPS;
- push_return(retop);
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
+ cx->blk_sub.retop = retop;
PAD_SET_CUR(CvPADLIST(cv), 1);
setdefout(gv); /* locally select filehandle so $% et al work */
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
- topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
+ topgv = gv_fetchsv(topname, FALSE, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
!gv_fetchpv("top",FALSE,SVt_PVFM))
- IoTOP_NAME(io) = savepv(SvPVX(topname));
+ IoTOP_NAME(io) = savesvpv(topname);
else
- IoTOP_NAME(io) = savepv("top");
+ IoTOP_NAME(io) = savepvn("top", 3);
}
topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
if (!topgv || !GvFORM(topgv)) {
/* bad_ofp: */
PL_formtarget = PL_bodytarget;
PUTBACK;
- return pop_return();
+ return cx->blk_sub.retop;
}
PP(pp_prtf)
STRLEN blen;
MAGIC *mg;
int fp_utf8;
+ int buffer_utf8;
+ SV *read_target;
Size_t got = 0;
Size_t wanted;
bool charstart = FALSE;
buffer = SvPVutf8_force(bufsv, blen);
/* UTF-8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
+ buffer_utf8 = 0;
}
else {
buffer = SvPV_force(bufsv, blen);
+ buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
if (length < 0)
DIE(aTHX_ "Negative length");
}
if (DO_UTF8(bufsv)) {
/* convert offset-as-chars to offset-as-bytes */
- offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
+ if (offset >= (int)blen)
+ offset += SvCUR(bufsv) - blen;
+ else
+ offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
}
more_bytes:
bufsize = SvCUR(bufsv);
+ /* Allocating length + offset + 1 isn't perfect in the case of reading
+ bytes from a byte file handle into a UTF8 buffer, but it won't harm us
+ unduly.
+ (should be 2 * length + offset + 1, or possibly something longer if
+ PL_encoding is true) */
buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
if (offset > bufsize) { /* Zero any newly allocated space */
Zero(buffer+bufsize, offset-bufsize, char);
}
buffer = buffer + offset;
+ if (!buffer_utf8) {
+ read_target = bufsv;
+ } else {
+ /* Best to read the bytes into a new SV, upgrade that to UTF8, then
+ concatenate it to the current buffer. */
+
+ /* Truncate the existing buffer to the start of where we will be
+ reading to: */
+ SvCUR_set(bufsv, offset);
+
+ read_target = sv_newmortal();
+ SvUPGRADE(read_target, SVt_PV);
+ buffer = SvGROW(read_target, length + 1);
+ }
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
goto say_undef;
}
- SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
- *SvEND(bufsv) = '\0';
- (void)SvPOK_only(bufsv);
+ SvCUR_set(read_target, count+(buffer - SvPVX(read_target)));
+ *SvEND(read_target) = '\0';
+ (void)SvPOK_only(read_target);
if (fp_utf8 && !IN_BYTES) {
/* Look at utf8 we got back and count the characters */
char *bend = buffer + count;
count = got;
SvUTF8_on(bufsv);
}
+ else if (buffer_utf8) {
+ /* Let svcatsv upgrade the bytes we read in to utf8.
+ The buffer is a mortal so will be freed soon. */
+ sv_catsv_nomg(bufsv, read_target);
+ }
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
if (!(IoFLAGS(io) & IOf_UNTAINT))
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
{
- STRLEN n_a;
int result = 1;
GV *tmpgv;
IO *io;
if (PL_op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
+ tmpgv = gv_fetchsv(POPs, FALSE, SVt_PVIO);
do_ftruncate_gv:
if (!GvIO(tmpgv))
else {
SV *sv = POPs;
char *name;
-
+ STRLEN n_a;
+
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
goto do_ftruncate_gv;
}
sv_setpv(PL_statname, SvPV(sv,n_a));
PL_statgv = Nullgv;
-#ifdef HAS_LSTAT
PL_laststype = PL_op->op_type;
if (PL_op->op_type == OP_LSTAT)
PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
else
-#endif
PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
if (PL_laststatval < 0) {
if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
dSP;
int fd;
GV *gv;
- char *tmps = Nullch;
- STRLEN n_a;
+ SV *tmpsv = Nullsv;
STACKED_FTEST_CHECK;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
gv = (GV*)SvRV(POPs);
else
- gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
+ gv = gv_fetchsv(tmpsv = POPs, FALSE, SVt_PVIO);
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (tmps && isDIGIT(*tmps))
- fd = atoi(tmps);
+ else if (tmpsv && SvOK(tmpsv)) {
+ STRLEN n_a;
+ char *tmps = SvPV(tmpsv, n_a);
+ if (isDIGIT(*tmps))
+ fd = atoi(tmps);
+ else
+ RETPUSHUNDEF;
+ }
else
RETPUSHUNDEF;
if (PerlLIO_isatty(fd))
}
#endif /* LOCKF_EMULATE_FLOCK */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/
https://perl5.git.perl.org / perl5.git / blobdiff