/* pp_sys.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1995, 1996, 1997, 1998, 1999,
+ * 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"
# include <shadow.h>
#endif
-#ifdef HAS_SYSCALL
-#ifdef __cplusplus
-extern "C" int syscall(unsigned long,...);
-#endif
-#endif
-
#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif
# undef my_chsize
# endif
# define my_chsize PerlLIO_chsize
+#else
+# ifdef HAS_TRUNCATE
+# define my_chsize PerlLIO_chsize
+# else
+I32 my_chsize(int fd, Off_t length);
+# endif
#endif
#ifdef HAS_FLOCK
#endif /* no flock() */
#define ZBTLEN 10
-static char zero_but_true[ZBTLEN + 1] = "0 but true";
+static const char zero_but_true[ZBTLEN + 1] = "0 but true";
#if defined(I_SYS_ACCESS) && !defined(R_OK)
# include <sys/access.h>
#include "reentr.h"
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+void sethostent(int);
+void endhostent(void);
+void setnetent(int);
+void endnetent(void);
+void setprotoent(int);
+void endprotoent(void);
+void setservent(int);
+void endservent(void);
+#endif
+
#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK
PerlIO *fp;
STRLEN n_a;
char *tmps = POPpx;
- I32 gimme = GIMME_V;
- char *mode = "r";
+ const I32 gimme = GIMME_V;
+ const char *mode = "r";
TAINT_PROPER("``");
if (PL_op->op_private & OPpOPEN_IN_RAW)
mode = "rb";
else if (PL_op->op_private & OPpOPEN_IN_CRLF)
mode = "rt";
- fp = PerlProc_popen(tmps, mode);
+ fp = PerlProc_popen(tmps, (char *)mode);
if (fp) {
- char *type = NULL;
+ const char *type = NULL;
if (PL_curcop->cop_io) {
type = SvPV_nolen(PL_curcop->cop_io);
}
;
}
else if (gimme == G_SCALAR) {
- SV *oldrs = PL_rs;
+ ENTER;
+ SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpv(TARG, ""); /* note that this preserves previous buffer */
+ sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
/*SUPPRESS 530*/
;
- PL_rs = oldrs;
+ LEAVE;
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
}
XPUSHs(sv_2mortal(sv));
if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvLEN_set(sv, SvCUR(sv)+1);
- Renew(SvPVX(sv), SvLEN(sv), char);
+ SvPV_shrink_to_cur(sv);
}
SvTAINTED_on(sv);
}
PP(pp_glob)
{
+ dVAR;
OP *result;
tryAMAGICunTARGET(iter, -1);
{
dSP; dMARK;
SV *tmpsv;
- char *tmps;
+ const char *tmps;
STRLEN len;
if (SP - MARK != 1) {
dTARGET;
tmpsv = TOPs;
}
tmps = SvPV(tmpsv, len);
- if (!tmps || !len) {
+ if ((!tmps || !len) && PL_errgv) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
PP(pp_die)
{
dSP; dMARK;
- char *tmps;
+ const char *tmps;
SV *tmpsv;
STRLEN len;
bool multiarg = 0;
}
else {
tmpsv = TOPs;
- tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
}
if (!tmps || !len) {
SV *error = ERRSV;
sv_setsv(error,*PL_stack_sp--);
}
}
- DIE(aTHX_ Nullformat);
+ DIE_NULL;
}
else {
if (SvPOK(error) && SvCUR(error))
PP(pp_open)
{
- dSP;
+ dVAR; dSP;
dMARK; dORIGMARK;
dTARGET;
GV *gv;
PP(pp_close)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
MAGIC *mg;
if (PerlProc_pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
- IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
PP(pp_fileno)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io;
PerlIO *fp;
PP(pp_umask)
{
- dSP; dTARGET;
+ dSP;
#ifdef HAS_UMASK
+ dTARGET;
Mode_t anum;
if (MAXARG < 1) {
PP(pp_binmode)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
PerlIO *fp;
if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
PUTBACK;
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
(discp) ? SvPV_nolen(discp) : Nullch)) {
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
+ mode_from_discipline(discp),
+ (discp) ? SvPV_nolen(discp) : Nullch)) {
+ SPAGAIN;
+ RETPUSHUNDEF;
+ }
+ }
SPAGAIN;
RETPUSHYES;
}
PP(pp_tie)
{
- dSP;
- dMARK;
+ dVAR; dSP; dMARK;
SV *varsv;
HV* stash;
GV *gv;
SV *sv;
I32 markoff = MARK - PL_stack_base;
- char *methname;
+ const char *methname;
int how = PERL_MAGIC_tied;
U32 items;
- STRLEN n_a;
varsv = *++MARK;
switch(SvTYPE(varsv)) {
*/
stash = gv_stashsv(*MARK, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
- methname, SvPV(*MARK,n_a));
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
+ methname, *MARK);
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PP(pp_untie)
{
- dSP;
+ dVAR; dSP;
MAGIC *mg;
SV *sv = POPs;
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
- SV *obj = SvRV(mg->mg_obj);
+ SV *obj = SvRV(SvTIED_obj(sv, mg));
GV *gv;
CV *cv = NULL;
if (obj) {
(UV)SvREFCNT(obj) - 1 ) ;
}
}
- sv_unmagic(sv, how) ;
}
+ sv_unmagic(sv, how) ;
RETPUSHYES;
}
PP(pp_dbmopen)
{
- dSP;
+ dVAR; dSP;
HV *hv;
dPOPPOPssrl;
HV* stash;
Zero(&fd_sets[0], 4, char*);
#endif
-# if SELECT_MIN_BITS > 1
+# if SELECT_MIN_BITS == 1
+ growsize = sizeof(fd_set);
+# else
+# if defined(__GLIBC__) && defined(__FD_SETSIZE)
+# undef SELECT_MIN_BITS
+# define SELECT_MIN_BITS __FD_SETSIZE
+# endif
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
* UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
* on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
-# else
- growsize = sizeof(fd_set);
# endif
sv = SP[4];
#endif
}
+#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
+ /* Can't make just the (void*) conditional because that would be
+ * cpp #if within cpp macro, and not all compilers like that. */
+ nfound = PerlSock_select(
+ maxlen * 8,
+ (Select_fd_set_t) fd_sets[1],
+ (Select_fd_set_t) fd_sets[2],
+ (Select_fd_set_t) fd_sets[3],
+ (void*) tbuf); /* Workaround for compiler bug. */
+#else
nfound = PerlSock_select(
maxlen * 8,
(Select_fd_set_t) fd_sets[1],
(Select_fd_set_t) fd_sets[2],
(Select_fd_set_t) fd_sets[3],
tbuf);
+#endif
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
sv = SP[i];
}
}
- PUSHi(nfound);
+ if (nfound == -1)
+ PUSHs(&PL_sv_undef);
+ else
+ PUSHi(nfound);
if (GIMME == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
PP(pp_getc)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io = NULL;
MAGIC *mg;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)
&& (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
TAINT;
- sv_setpv(TARG, " ");
+ sv_setpvn(TARG, " ", 1);
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
/* Find out how many bytes the char needs */
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
+ dVAR;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
- push_return(retop);
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[1]);
+ cx->blk_sub.retop = retop;
+ PAD_SET_CUR(CvPADLIST(cv), 1);
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
PP(pp_leavewrite)
{
- dSP;
+ dVAR; dSP;
GV *gv = cxstack[cxstack_ix].blk_sub.gv;
register IO *io = GvIOp(gv);
PerlIO *ofp = IoOFP(io);
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
- topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
+ 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)) {
- IoLINES_LEFT(io) = 100000000;
+ IoLINES_LEFT(io) = IoPAGE_LEN(io);
goto forget_top;
}
IoTOP_GV(io) = topgv;
}
if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
I32 lines = IoLINES_LEFT(io);
- char *s = SvPVX(PL_formtarget);
+ const char *s = SvPVX(PL_formtarget);
if (lines <= 0) /* Yow, header didn't even fit!!! */
goto forget_top;
while (lines-- > 0) {
s++;
}
if (s) {
- STRLEN save = SvCUR(PL_formtarget);
+ const STRLEN save = SvCUR(PL_formtarget);
SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
do_print(PL_formtarget, ofp);
SvCUR_set(PL_formtarget, save);
fp = IoOFP(io);
if (!fp) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- if (IoIFP(io)) {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(gv)) {
- SV* sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for input", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for input");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
else if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
/* bad_ofp: */
PL_formtarget = PL_bodytarget;
PUTBACK;
- return pop_return();
+ return cx->blk_sub.retop;
}
PP(pp_prtf)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
PerlIO *fp;
if (!(io = GvIO(gv))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- /* integrate with report_evil_fh()? */
- if (IoIFP(io)) {
- char *name = NULL;
- if (isGV(gv)) {
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for input", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for input");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
else if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
- SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
goto just_say_no;
}
else {
PP(pp_sysread)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
int offset;
GV *gv;
IO *io;
STRLEN blen;
MAGIC *mg;
int fp_utf8;
+ int buffer_utf8;
+ SV *read_target;
Size_t got = 0;
Size_t wanted;
bool charstart = FALSE;
else
offset = 0;
io = GvIO(gv);
- if (!io || !IoIFP(io))
+ if (!io || !IoIFP(io)) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
goto say_undef;
+ }
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
buffer = SvPVutf8_force(bufsv, blen);
- /* UTF8 may not have been set if they are all low bytes */
+ /* 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 */
+ if (offset > 0 && (Sock_size_t)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();
+ (void)SvUPGRADE(read_target, SVt_PV);
+ buffer = SvGROW(read_target, (STRLEN)(length + 1));
+ }
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
}
if (count < 0) {
if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
- {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(gv)) {
- SV* sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for output", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for output");
- }
+ 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))
PP(pp_syswrite)
{
- dSP;
+ dVAR; dSP;
int items = (SP - PL_stack_base) - TOPMARK;
if (items == 2) {
SV *sv;
PP(pp_send)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
SV *bufsv;
retval = -1;
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
if (PerlIO_isutf8(IoIFP(io))) {
- buffer = SvPVutf8(bufsv, blen);
+ if (!SvUTF8(bufsv)) {
+ bufsv = sv_2mortal(newSVsv(bufsv));
+ buffer = sv_2pvutf8(bufsv, &blen);
+ } else
+ buffer = SvPV(bufsv, blen);
}
else {
- if (DO_UTF8(bufsv))
- sv_utf8_downgrade(bufsv, FALSE);
- buffer = SvPV(bufsv, blen);
+ 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(bufsv, blen);
}
if (PL_op->op_type == OP_SYSWRITE) {
PP(pp_eof)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
MAGIC *mg;
if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
+ do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp);
sv_setpvn(GvSV(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
}
PP(pp_tell)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
GV *gv;
IO *io;
MAGIC *mg;
PP(pp_sysseek)
{
- dSP;
+ dVAR; dSP;
GV *gv;
IO *io;
int whence = POPi;
* might not be signed: if it is not, clever compilers will moan. */
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
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:
- TAINT_PROPER("truncate");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
- result = 0;
+ do_ftruncate_gv:
+ if (!GvIO(tmpgv))
+ result = 0;
else {
- PerlIO_flush(IoIFP(GvIOp(tmpgv)));
+ PerlIO *fp;
+ io = GvIOp(tmpgv);
+ do_ftruncate_io:
+ TAINT_PROPER("truncate");
+ if (!(fp = IoIFP(io))) {
+ result = 0;
+ }
+ else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(fp), len) < 0)
#else
- if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (my_chsize(PerlIO_fileno(fp), len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
}
else {
SV *sv = POPs;
char *name;
-
+ STRLEN n_a;
+
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
- goto do_ftruncate;
+ goto do_ftruncate_gv;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
- goto do_ftruncate;
+ goto do_ftruncate_gv;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+ io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
+ goto do_ftruncate_io;
}
name = SvPV(sv, n_a);
if (result)
RETPUSHYES;
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
-#else
- DIE(aTHX_ "truncate not implemented");
-#endif
}
PP(pp_fcntl)
dSP; dTARGET;
SV *argsv = POPs;
unsigned int func = POPu;
- int optype = PL_op->op_type;
+ const int optype = PL_op->op_type;
char *s;
IV retval;
GV *gv = (GV*)POPs;
if (!io || !argsv || !IoIFP(io)) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
+ SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
+#endif
+#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
value = 0;
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
}
PUSHi(value);
RETURN;
report_evil_fh(gv, io, PL_op->op_type);
if (IoIFP(io))
do_close(gv, FALSE);
- SETERRNO(EBADF,LIB$_INVARG);
+ SETERRNO(EBADF,LIB_INVARG);
RETPUSHUNDEF;
}
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0)
RETPUSHUNDEF;
- IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
- IoOFP(io) = PerlIO_fdopen(fd, "w");
+ IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
+ IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
IoTYPE(io) = IoTYPE_SOCKET;
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
IoTYPE(io1) = IoTYPE_SOCKET;
- IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
+ IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
IoTYPE(io2) = IoTYPE_SOCKET;
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
GV *ggv;
register IO *nstio;
register IO *gstio;
- struct sockaddr saddr; /* use a struct to avoid alignment problems */
- Sock_size_t len = sizeof saddr;
+ char namebuf[MAXPATHLEN];
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+ Sock_size_t len = sizeof (struct sockaddr_in);
+#else
+ Sock_size_t len = sizeof namebuf;
+#endif
int fd;
- int fd2;
ggv = (GV*)POPs;
ngv = (GV*)POPs;
goto nuts;
nstio = GvIOn(ngv);
- fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
if (fd < 0)
goto badexit;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- IoIFP(nstio) = PerlIO_fdopen(fd, "r");
- /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
- fclose of IoOFP's FILE * - and hence leak memory.
- Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
- */
- IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */
#endif
#ifdef EPOC
- len = sizeof saddr; /* EPOC somehow truncates info */
+ 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
- PUSHp((char *)&saddr, len);
+ PUSHp(namebuf, len);
RETURN;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
badexit:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
if (gv != PL_defgv) {
PL_laststype = OP_STAT;
PL_statgv = gv;
- sv_setpv(PL_statname, "");
+ sv_setpvn(PL_statname, "", 0);
PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
}
}
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'))
PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
#if Off_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
+ PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
#else
PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
#endif
RETURN;
}
+/* This macro is used by the stacked filetest operators :
+ * if the previous filetest failed, short-circuit and pass its value.
+ * Else, discard it from the stack and continue. --rgs
+ */
+#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
+ if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
+ else { (void)POPs; PUTBACK; } \
+ }
+
PP(pp_ftrread)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(R_OK)
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, R_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = access(POPpx, R_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(W_OK)
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, W_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = access(POPpx, W_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(X_OK)
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, X_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = access(POPpx, X_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_R_OK
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_R_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = PERL_EFF_ACCESS_R_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_W_OK
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_W_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = PERL_EFF_ACCESS_W_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_X_OK
- STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_X_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
+ result = PERL_EFF_ACCESS_X_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
PP(pp_ftis)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
RETPUSHYES;
PP(pp_ftrowned)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
PP(pp_ftzero)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (PL_statcache.st_size == 0)
PP(pp_ftsize)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
#if Off_t_size > IVSIZE
PP(pp_ftmtime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
RETURN;
}
PP(pp_ftatime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
RETURN;
}
PP(pp_ftctime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
RETURN;
}
PP(pp_ftsock)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISSOCK(PL_statcache.st_mode))
PP(pp_ftchr)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISCHR(PL_statcache.st_mode))
PP(pp_ftblk)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISBLK(PL_statcache.st_mode))
PP(pp_ftfile)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISREG(PL_statcache.st_mode))
PP(pp_ftdir)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISDIR(PL_statcache.st_mode))
PP(pp_ftpipe)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISFIFO(PL_statcache.st_mode))
{
dSP;
#ifdef S_ISUID
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
dSP;
#ifdef S_ISGID
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
dSP;
#ifdef S_ISVTX
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
dSP;
int fd;
GV *gv;
- char *tmps = Nullch;
- STRLEN n_a;
+ SV *tmpsv = Nullsv;
+
+ STACKED_FTEST_CHECK;
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
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))
STRLEN n_a;
PerlIO *fp;
+ STACKED_FTEST_CHECK;
+
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else if (isGV(TOPs))
else {
PL_statgv = gv;
PL_laststatval = -1;
- sv_setpv(PL_statname, "");
+ sv_setpvn(PL_statname, "", 0);
io = GvIO(PL_statgv);
}
if (io && IoIFP(io)) {
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
}
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
}
sv = POPs;
really_filename:
PL_statgv = Nullgv;
- PL_laststatval = -1;
PL_laststype = OP_STAT;
sv_setpv(PL_statname, SvPV(sv, n_a));
if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
#define EACCES EPERM
#endif
if (instr(s, "cannot make"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "existing file"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "ile exists"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "non-exist"))
- SETERRNO(ENOENT,RMS$_FNF);
+ SETERRNO(ENOENT,RMS_FNF);
else if (instr(s, "does not exist"))
- SETERRNO(ENOENT,RMS$_FNF);
+ SETERRNO(ENOENT,RMS_FNF);
else if (instr(s, "not empty"))
- SETERRNO(EBUSY,SS$_DEVOFFLINE);
+ SETERRNO(EBUSY,SS_DEVOFFLINE);
else if (instr(s, "cannot access"))
- SETERRNO(EACCES,RMS$_PRV);
+ SETERRNO(EACCES,RMS_PRV);
else
- SETERRNO(EPERM,RMS$_PRV);
+ SETERRNO(EPERM,RMS_PRV);
return 0;
}
else { /* some mkdirs return no failure indication */
if (anum)
SETERRNO(0,0);
else
- SETERRNO(EACCES,RMS$_PRV); /* a guess */
+ SETERRNO(EACCES,RMS_PRV); /* a guess */
}
return anum;
}
}
#endif
+/* This macro removes trailing slashes from a directory name.
+ * Different operating and file systems take differently to
+ * trailing slashes. According to POSIX 1003.1 1996 Edition
+ * any number of trailing slashes should be allowed.
+ * Thusly we snip them away so that even non-conforming
+ * systems are happy.
+ * We should probably do this "filtering" for all
+ * the functions that expect (potentially) directory names:
+ * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
+ * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
+
+#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \
+ if ((len) > 1 && (tmps)[(len)-1] == '/') { \
+ do { \
+ (len)--; \
+ } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
+ (tmps) = savepvn((tmps), (len)); \
+ (copy) = TRUE; \
+ }
+
PP(pp_mkdir)
{
dSP; dTARGET;
else
mode = 0777;
- tmps = SvPV(TOPs, len);
- /* Different operating and file systems take differently to
- * trailing slashes. According to POSIX 1003.1 1996 Edition
- * any number of trailing slashes should be allowed.
- * Thusly we snip them away so that even non-conforming
- * systems are happy. */
- /* We should probably do this "filtering" for all
- * the functions that expect (potentially) directory names:
- * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
- * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
- if (len > 1 && tmps[len-1] == '/') {
- while (tmps[len] == '/' && len > 1)
- len--;
- tmps = savepvn(tmps, len);
- copy = TRUE;
- }
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
PP(pp_rmdir)
{
dSP; dTARGET;
+ STRLEN len;
char *tmps;
- STRLEN n_a;
+ bool copy = FALSE;
- tmps = POPpx;
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
- XPUSHi( PerlDir_rmdir(tmps) >= 0 );
+ SETi( PerlDir_rmdir(tmps) >= 0 );
#else
- XPUSHi( dooneliner("rmdir", tmps) );
+ SETi( dooneliner("rmdir", tmps) );
#endif
+ if (copy)
+ Safefree(tmps);
RETURN;
}
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_DIR);
+ SETERRNO(EBADF,RMS_DIR);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "opendir");
PP(pp_readdir)
{
-#if defined(Direntry_t) && defined(HAS_READDIR)
- dSP;
+#if !defined(Direntry_t) || !defined(HAS_READDIR)
+ DIE(aTHX_ PL_no_dir_func, "readdir");
+#else
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
+ dSP;
+
+ SV *sv;
+ const I32 gimme = GIMME;
+ GV *gv = (GV *)POPs;
register Direntry_t *dp;
- GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
- SV *sv;
if (!io || !IoDIRP(io))
goto nope;
- if (GIMME == G_ARRAY) {
- /*SUPPRESS 560*/
- while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
+ do {
+ dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
+ if (!dp)
+ break;
#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
- sv = newSVpv(dp->d_name, 0);
+ sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- if (!(IoFLAGS(io) & IOf_UNTAINT))
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
- XPUSHs(sv_2mortal(sv));
- }
- }
- else {
- if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
- goto nope;
-#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
-#else
- sv = newSVpv(dp->d_name, 0);
-#endif
-#ifndef INCOMPLETE_TAINTS
- if (!(IoFLAGS(io) & IOf_UNTAINT))
- SvTAINTED_on(sv);
-#endif
- XPUSHs(sv_2mortal(sv));
+ XPUSHs(sv_2mortal(sv));
}
+ while (gimme == G_ARRAY);
+
+ if (!dp && gimme != G_ARRAY)
+ goto nope;
+
RETURN;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
if (GIMME == G_ARRAY)
RETURN;
else
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}
PP(pp_telldir)
{
#if defined(HAS_TELLDIR) || defined(telldir)
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
/* XXX does _anyone_ need this? --AD 2/20/1998 */
/* XXX netbsd still seemed to.
XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
RETURN;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "telldir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "seekdir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "rewinddir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
Pid_t childpid;
int argflags;
-#ifdef PERL_OLD_SIGNALS
- childpid = wait4pid(-1, &argflags, 0);
-#else
- while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ childpid = wait4pid(-1, &argflags, 0);
+ else {
+ while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
+ errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
}
-#endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
dSP; dTARGET;
- Pid_t childpid;
+ Pid_t pid;
+ Pid_t result;
int optype;
int argflags;
optype = POPi;
- childpid = TOPi;
-#ifdef PERL_OLD_SIGNALS
- childpid = wait4pid(childpid, &argflags, optype);
-#else
- while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ pid = TOPi;
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ result = wait4pid(pid, &argflags, optype);
+ else {
+ while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
+ errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
}
-#endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
+ STATUS_NATIVE_SET((result && result != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ STATUS_NATIVE_SET((result > 0) ? argflags : -1);
# endif
- SETi(childpid);
+ SETi(result);
RETURN;
#else
DIE(aTHX_ PL_no_func, "waitpid");
I32 value;
STRLEN n_a;
int result;
- I32 did_pipes = 0;
if (PL_tainting) {
TAINT_ENV();
{
Pid_t childpid;
int pp[2];
+ I32 did_pipes = 0;
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
-# ifdef WIN32
+# if defined(WIN32) || defined(OS2) || defined(SYMBIAN)
value = (I32)do_aspawn(really, MARK, SP);
# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
# endif
}
else if (SP - MARK != 1) {
-# ifdef WIN32
+# if defined(WIN32) || defined(OS2) || defined(SYMBIAN)
value = (I32)do_aspawn(Nullsv, MARK, SP);
# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
#ifdef HAS_GETPPID
dSP; dTARGET;
# ifdef THREADS_HAVE_PIDS
+ {
+ IV cur_ppid = getppid();
+ if (cur_ppid == 1)
+ /* maybe the parent process has died. Refresh ppid cache */
+ PL_ppid = cur_ppid;
+ }
XPUSHi( PL_ppid );
# else
XPUSHi( getppid() );
}
RETURN;
#else
+# ifdef PERL_MICRO
+ dSP;
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ EXTEND(SP, 4);
+ if (GIMME == G_ARRAY) {
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ }
+ RETURN;
+# else
DIE(aTHX_ "times not implemented");
+# endif
#endif /* HAS_TIMES */
}
{
dSP;
Time_t when;
- struct tm *tmbuf;
- static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
- static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
+ const struct tm *tmbuf;
+ static const char * const dayname[] =
+ {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
+ static const char * const monname[] =
+ {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
if (MAXARG < 1)
(void)time(&when);
char *proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
+ if (proto && !*proto)
+ proto = Nullch;
+
#ifdef HAS_HTONS
port = PerlSock_htons(port);
#endif
* AIX getpwnam() is clever enough to return the encrypted password
* only if the caller (euid?) is root.
*
- * There are at least two other shadow password APIs. Many platforms
+ * There are at least three other shadow password APIs. Many platforms
* seem to contain more than one interface for accessing the shadow
* password databases, possibly for compatibility reasons.
* The getsp*() is by far he simplest one, the other two interfaces
* char *(getespw*(...).ufld.fd_encrypt)
* Mention HAS_GETESPWNAM here so that Configure probes for it.
*
+ * <userpw.h> (AIX)
+ * struct userpw *getuserpw();
+ * The password is in
+ * char *(getuserpw(...)).spw_upw_passwd
+ * (but the de facto standard getpwnam() should work okay)
+ *
* Mention I_PROT here so that Configure probes for it.
*
* In HP-UX for getprpw*() the manual page claims that one should include
* --jhi
*/
+# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
+ /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
+ * the pw_comment is left uninitialized. */
+ PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
+# endif
+
switch (which) {
case OP_GPWNAM:
{
* Divert the urge to writing an extension instead.
*
* --jhi */
-# ifdef HAS_GETSPNAM
+ /* Some AIX setups falsely(?) detect some getspnam(), which
+ * has a different API than the Solaris/IRIX one. */
+# if defined(HAS_GETSPNAM) && !defined(_AIX)
{
struct spwd *spwent;
int saverrno; /* Save and restore errno so that
}
#endif /* LOCKF_EMULATE_FLOCK */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */