/* pp_sys.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef I_SHADOW
/* Shadow password support for solaris - pdo@cs.umd.edu
* Not just Solaris: at least HP-UX, IRIX, Linux.
- * the API is from SysV. --jhi */
-#ifdef __hpux__
+ * The API is from SysV.
+ *
+ * There are at least two more shadow interfaces,
+ * see the comments in pp_gpwent().
+ *
+ * --jhi */
+# ifdef __hpux__
/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
- * and another MAXINT from "perl.h" <- <sys/param.h>. */
-#undef MAXINT
-#endif
-#include <shadow.h>
-#endif
-
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-# include <unistd.h>
+ * and another MAXINT from "perl.h" <- <sys/param.h>. */
+# undef MAXINT
+# endif
+# include <shadow.h>
#endif
-#ifdef HAS_SYSCALL
-#ifdef __cplusplus
+#ifdef HAS_SYSCALL
+#ifdef __cplusplus
extern "C" int syscall(unsigned long,...);
#endif
#endif
# include <sys/resource.h>
#endif
-#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
-# include <sys/socket.h>
-# if defined(USE_SOCKS) && defined(I_SOCKS)
-# include <socks.h>
-# endif
-# ifdef I_NETDB
-# include <netdb.h>
-# endif
-# ifndef ENOTSOCK
-# ifdef I_NET_ERRNO
-# include <net/errno.h>
-# endif
-# endif
-#endif
-
#ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#include <sys/select.h>
-#endif
+# ifdef I_SYS_SELECT
+# include <sys/select.h>
+# endif
#endif
/* XXX Configure test needed.
compiling multithreaded and singlethreaded ($ccflags et al).
HOST_NOT_FOUND is typically defined in <netdb.h>.
*/
-#if defined(HOST_NOT_FOUND) && !defined(h_errno)
+#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
extern int h_errno;
#endif
# include <utime.h>
# endif
#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
/* Put this after #includes because fork and vfork prototypes may conflict. */
#ifndef HAS_VFORK
# define vfork fork
#endif
-/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
-#ifndef Sock_size_t
-# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
-# define Sock_size_t Size_t
-# else
-# define Sock_size_t int
-# endif
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
# include <fcntl.h>
# endif
-# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
+# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
# define FLOCK fcntl_emulate_flock
# define FCNTL_EMULATE_FLOCK
# else /* no flock() or fcntl(F_SETLK,...) */
#endif
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
-# if defined(I_SYS_SECURITY)
+# ifdef I_SYS_SECURITY
# include <sys/security.h>
# endif
- /* XXX Configure test needed for eaccess */
# ifdef ACC_SELF
/* HP SecureWare */
# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
STRLEN n_a;
char *tmps = POPpx;
I32 gimme = GIMME_V;
+ char *mode = "r";
TAINT_PROPER("``");
- fp = PerlProc_popen(tmps, "r");
+ 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);
if (fp) {
+ char *type = NULL;
+ if (PL_curcop->cop_io) {
+ type = SvPV_nolen(PL_curcop->cop_io);
+ }
+ if (type && *type)
+ PerlIO_apply_layers(aTHX_ fp,mode,type);
+
if (gimme == G_VOID) {
char tmpbuf[256];
while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
OP *result;
tryAMAGICunTARGET(iter, -1);
+ /* Note that we only ever get here if File::Glob fails to load
+ * without at the same time croaking, for some reason, or if
+ * perl was built with PERL_EXTERNAL_GLOB */
+
ENTER;
#ifndef VMS
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
- Perl_warn(aTHX_ "%_", tmpsv);
+ Perl_warn(aTHX_ "%"SVf, tmpsv);
RETSETYES;
}
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
+ tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
}
if (!tmps || !len) {
SV *error = ERRSV;
GV *gv = gv_fetchmethod(stash, "PROPAGATE");
if (gv) {
SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop)));
+ SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
EXTEND(SP, 3);
PUSHMARK(SP);
PUSHs(error);
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvn("Died", 4));
- DIE(aTHX_ "%_", tmpsv);
+ DIE(aTHX_ "%"SVf, tmpsv);
}
/* I/O. */
djSP; dTARGET;
GV *gv;
SV *sv;
- SV *name;
+ SV *name = Nullsv;
I32 have_name = 0;
char *tmps;
STRLEN len;
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
XPUSHs(sv);
else
gv = (GV*)POPs;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
IoIFP(wstio) = IoOFP(wstio);
- IoTYPE(rstio) = '<';
- IoTYPE(wstio) = '>';
+ IoTYPE(rstio) = IoTYPE_RDONLY;
+ IoTYPE(wstio) = IoTYPE_WRONLY;
if (!IoIFP(rstio) || !IoOFP(wstio)) {
if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
RETURN;
}
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
+ if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ /* Can't do this because people seem to do things like
+ defined(fileno($foo)) to check whether $foo is a valid fh.
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ */
RETPUSHUNDEF;
+ }
+
PUSHi(PerlIO_fileno(fp));
RETURN;
}
IO *io;
PerlIO *fp;
MAGIC *mg;
+ SV *discp = Nullsv;
+ STRLEN len = 0;
+ char *names = NULL;
if (MAXARG < 1)
RETPUSHUNDEF;
+ if (MAXARG > 1) {
+ discp = POPs;
+ }
- gv = (GV*)POPs;
+ gv = (GV*)POPs;
if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
+ if (discp)
+ XPUSHs(discp);
PUTBACK;
ENTER;
call_method("BINMODE", G_SCALAR);
}
EXTEND(SP, 1);
- if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETPUSHUNDEF;
+ if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ RETPUSHUNDEF;
+ }
- if (do_binmode(fp,IoTYPE(io),TRUE))
+ if (discp) {
+ names = SvPV(discp,len);
+ }
+
+ if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
+ (discp) ? SvPV_nolen(discp) : Nullch))
RETPUSHYES;
else
RETPUSHUNDEF;
}
-
PP(pp_tie)
{
djSP;
PUSHs(*MARK++);
PUTBACK;
call_method(methname, G_SCALAR);
- }
+ }
else {
/* Not clear why we don't call call_method here too.
* perhaps to get different error message ?
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));
+ methname, SvPV(*MARK,n_a));
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
POPSTACK;
if (sv_isobject(sv)) {
sv_unmagic(varsv, how);
- sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
+ /* Croak if a self-tie on an aggregate is attempted. */
+ if (varsv == SvRV(sv) &&
+ (SvTYPE(sv) == SVt_PVAV ||
+ SvTYPE(sv) == SVt_PVHV))
+ Perl_croak(aTHX_
+ "Self-ties of arrays and hashes are not supported");
+ sv_magic(varsv, sv, how, Nullch, 0);
}
LEAVE;
SP = PL_stack_base + markoff;
SV *sv = POPs;
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
- if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
- if (mg = SvTIED_mg(sv, how)) {
- if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
+ if ((mg = SvTIED_mg(sv, how))) {
+ SV *obj = SvRV(mg->mg_obj);
+ GV *gv;
+ CV *cv = NULL;
+ if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+ isGV(gv) && (cv = GvCV(gv))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+ PUTBACK;
+ ENTER;
+ call_sv((SV *)cv, G_VOID);
+ LEAVE;
+ SPAGAIN;
+ }
+ else if (ckWARN(WARN_UNTIE)) {
+ if (mg && SvREFCNT(obj) > 1)
Perl_warner(aTHX_ WARN_UNTIE,
"untie attempted while %"UVuf" inner references still exist",
- (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ (UV)SvREFCNT(obj) - 1 ) ;
}
}
-
sv_unmagic(sv, how);
RETPUSHYES;
}
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
MAGIC *mg;
- if (mg = SvTIED_mg(sv, how)) {
+ if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
if (osv == mg->mg_obj)
osv = sv_mortalcopy(osv);
PUSHs(sv);
PUSHs(left);
if (SvIV(right))
- PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
+ PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
else
- PUSHs(sv_2mortal(newSViv(O_RDWR)));
+ PUSHs(sv_2mortal(newSVuv(O_RDWR)));
PUSHs(right);
PUTBACK;
call_sv((SV*)GvCV(gv), G_SCALAR);
PUSHMARK(SP);
PUSHs(sv);
PUSHs(left);
- PUSHs(sv_2mortal(newSViv(O_RDONLY)));
+ PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
PUSHs(right);
PUTBACK;
call_sv((SV*)GvCV(gv), G_SCALAR);
}
if (sv_isobject(TOPs)) {
- sv_unmagic((SV *) hv, 'P');
+ sv_unmagic((SV *) hv, 'P');
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
}
LEAVE;
/* 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, Rhapsody) the smallest quantum select() operates
+ * 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
void
Perl_setdefout(pTHX_ GV *gv)
{
- dTHR;
if (gv)
(void)SvREFCNT_inc(gv);
if (PL_defoutgv)
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv) {
- gv_efullname3(TARG, PL_defoutgv, Nullch);
+ gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
XPUSHTARG;
}
else {
GV *gv;
MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_stdingv;
else
gv = (GV*)POPs;
- if (!gv)
- gv = PL_argvgv;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
TAINT;
sv_setpv(TARG, " ");
*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 */
+ Size_t len = UTF8SKIP(SvPVX(TARG));
+ if (len > 1) {
+ SvGROW(TARG,len+1);
+ len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
+ SvCUR_set(TARG,1+len);
+ }
+ SvUTF8_on(TARG);
+ }
PUSHTARG;
RETURN;
}
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
AV* padlist = CvPADLIST(cv);
cv = GvFORM(fgv);
if (!cv) {
+ char *name = NULL;
if (fgv) {
SV *tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, fgv, Nullch);
- DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
+ gv_efullname4(tmpsv, fgv, Nullch, FALSE);
+ name = SvPV_nolen(tmpsv);
}
+ if (name && *name)
+ DIE(aTHX_ "Undefined format \"%s\" called", name);
DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
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)
{
s++;
}
if (s) {
- PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
+ STRLEN save = SvCUR(PL_formtarget);
+ SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
+ do_print(PL_formtarget, ofp);
+ SvCUR_set(PL_formtarget, save);
sv_chop(PL_formtarget, s);
FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
+ do_print(PL_formfeed, ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
PL_formtarget = PL_toptarget;
if (!fgv)
DIE(aTHX_ "bad top format reference");
cv = GvFORM(fgv);
- if (!cv) {
- SV *tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, fgv, Nullch);
- DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
+ {
+ char *name = NULL;
+ if (!cv) {
+ SV *sv = sv_newmortal();
+ gv_efullname4(sv, fgv, Nullch, FALSE);
+ name = SvPV_nolen(sv);
+ }
+ if (name && *name)
+ DIE(aTHX_ "Undefined top format \"%s\" called",name);
+ /* why no:
+ else
+ DIE(aTHX_ "Undefined top format called");
+ ?*/
}
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
fp = IoOFP(io);
if (!fp) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- if (IoIFP(io))
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle %s opened only for input",
- SvPV_nolen(sv));
+ 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_ WARN_IO,
+ "Filehandle %s opened only for input", name);
+ else
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle opened only for input");
+ }
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED,
- "Write on closed filehandle %s", SvPV_nolen(sv));
+ report_evil_fh(gv, io, PL_op->op_type);
}
PUSHs(&PL_sv_no);
}
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ WARN_IO, "page overflow");
}
- if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
- PerlIO_error(fp))
+ if (!do_print(PL_formtarget, fp))
PUSHs(&PL_sv_no);
else {
FmLINES(PL_formtarget) = 0;
PUSHs(&PL_sv_yes);
}
}
+bad_ofp:
PL_formtarget = PL_bodytarget;
PUTBACK;
return pop_return();
else
gv = PL_defoutgv;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++MARK;
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
- if (ckWARN(WARN_UNOPENED)) {
- gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_UNOPENED,
- "Filehandle %s never opened", SvPV(sv,n_a));
- }
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- gv_efullname3(sv, gv, Nullch);
- if (IoIFP(io))
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle %s opened only for input",
- SvPV(sv,n_a));
+ /* 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_ WARN_IO,
+ "Filehandle %s opened only for input", name);
+ else
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle opened only for input");
+ }
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED,
- "printf on closed filehandle %s", SvPV(sv,n_a));
+ report_evil_fh(gv, io, PL_op->op_type);
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
IO *io;
char *buffer;
SSize_t length;
+ SSize_t count;
Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
MAGIC *mg;
+ int fp_utf8;
+ Size_t got = 0;
+ Size_t wanted;
gv = (GV*)*++MARK;
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
bufsv = *++MARK;
if (! SvOK(bufsv))
sv_setpvn(bufsv, "", 0);
- buffer = SvPV_force(bufsv, blen);
length = SvIVx(*++MARK);
- if (length < 0)
- DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
io = GvIO(gv);
if (!io || !IoIFP(io))
goto say_undef;
+ if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) {
+ buffer = SvPVutf8_force(bufsv, blen);
+ /* UTF8 may not have been set if they are all low bytes */
+ SvUTF8_on(bufsv);
+ }
+ else {
+ buffer = SvPV_force(bufsv, blen);
+ }
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
+ wanted = length;
+
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
char namebuf[MAXPATHLEN];
if (bufsize >= 256)
bufsize = 255;
#endif
-#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
- if (bufsize >= 256)
- bufsize = 255;
-#endif
buffer = SvGROW(bufsv, length+1);
/* 'offset' means 'flags' here */
- length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
- if (length < 0)
+ if (count < 0)
RETPUSHUNDEF;
- SvCUR_set(bufsv, length);
+ SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
+ if (fp_utf8)
+ SvUTF8_on(bufsv);
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
if (!(IoFLAGS(io) & IOf_UNTAINT))
if (PL_op->op_type == OP_RECV)
DIE(aTHX_ PL_no_sock_func, "recv");
#endif
+ if (DO_UTF8(bufsv)) {
+ /* offset adjust in characters not bytes */
+ blen = sv_len_utf8(bufsv);
+ }
if (offset < 0) {
if (-offset > blen)
DIE(aTHX_ "Offset outside string");
offset += blen;
}
+ if (DO_UTF8(bufsv)) {
+ /* convert offset-as-chars to offset-as-bytes */
+ offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
+ }
+ more_bytes:
bufsize = SvCUR(bufsv);
- buffer = SvGROW(bufsv, length+offset+1);
+ buffer = SvGROW(bufsv, length+offset+1);
if (offset > bufsize) { /* Zero any newly allocated space */
Zero(buffer+bufsize, offset-bufsize, char);
}
+ buffer = buffer + offset;
+
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
- if (IoTYPE(io) == 's') {
- length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer+offset, length, 0);
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
+ count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
+ buffer, length, 0);
}
else
#endif
{
- length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
- buffer+offset, length);
+ count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
+ buffer, length);
}
}
else
#ifdef HAS_SOCKET__bad_code_maybe
- if (IoTYPE(io) == 's') {
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
char namebuf[MAXPATHLEN];
#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
#endif
- length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
+ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
(struct sockaddr *)namebuf, &bufsize);
}
else
#endif
{
- length = PerlIO_read(IoIFP(io), buffer+offset, length);
- /* fread() returns 0 on both error and EOF */
- if (length == 0 && PerlIO_error(IoIFP(io)))
- length = -1;
+ count = PerlIO_read(IoIFP(io), buffer, length);
+ /* PerlIO_read() - like fread() returns 0 on both error and EOF */
+ if (count == 0 && PerlIO_error(IoIFP(io)))
+ count = -1;
}
- if (length < 0) {
- if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+ if (count < 0) {
+ if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
|| IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
{
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
- SvPV_nolen(sv));
+ /* 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_ WARN_IO,
+ "Filehandle %s opened only for output", name);
+ else
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle opened only for output");
}
goto say_undef;
}
- SvCUR_set(bufsv, length+offset);
+ SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
+ if (fp_utf8 && !IN_BYTE) {
+ /* Look at utf8 we got back and count the characters */
+ char *bend = buffer + count;
+ while (buffer < bend) {
+ STRLEN skip = UTF8SKIP(buffer);
+ if (buffer+skip > bend) {
+ /* partial character - try for rest of it */
+ length = skip - (bend-buffer);
+ offset = bend - SvPVX(bufsv);
+ goto more_bytes;
+ }
+ else {
+ got++;
+ buffer += skip;
+ }
+ }
+ /* If we have not 'got' the number of _characters_ we 'wanted' get some more
+ provided amount read (count) was what was requested (length)
+ */
+ if (got < wanted && count == length) {
+ length = (wanted-got);
+ offset = bend - SvPVX(bufsv);
+ goto more_bytes;
+ }
+ /* return value is character count */
+ count = got;
+ SvUTF8_on(bufsv);
+ }
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
- PUSHi(length);
+ PUSHi(count);
RETURN;
say_undef:
djSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
- Off_t offset;
SV *bufsv;
char *buffer;
- Off_t length;
+ Size_t length;
+ SSize_t retval;
STRLEN blen;
MAGIC *mg;
if (!gv)
goto say_undef;
bufsv = *++MARK;
- buffer = SvPV(bufsv, blen);
-#if Off_t_SIZE > IVSIZE
- length = SvNVx(*++MARK);
+#if Size_t_size > IVSIZE
+ length = (Size_t)SvNVx(*++MARK);
#else
- length = SvIVx(*++MARK);
+ length = (Size_t)SvIVx(*++MARK);
#endif
- if (length < 0)
+ if ((SSize_t)length < 0)
DIE(aTHX_ "Negative length");
SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
- length = -1;
- if (ckWARN(WARN_CLOSED)) {
- if (PL_op->op_type == OP_SYSWRITE)
- Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
- else
- Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
- }
+ retval = -1;
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ goto say_undef;
}
- else if (PL_op->op_type == OP_SYSWRITE) {
+
+ if (PerlIO_isutf8(IoIFP(io))) {
+ buffer = SvPVutf8(bufsv, blen);
+ }
+ else {
+ if (DO_UTF8(bufsv))
+ sv_utf8_downgrade(bufsv, FALSE);
+ buffer = SvPV(bufsv, blen);
+ }
+
+ if (PL_op->op_type == OP_SYSWRITE) {
+ IV offset;
+ if (DO_UTF8(bufsv)) {
+ /* length and offset are in chars */
+ blen = sv_len_utf8(bufsv);
+ }
if (MARK < SP) {
-#if Off_t_SIZE > IVSIZE
- offset = SvNVx(*++MARK);
-#else
offset = SvIVx(*++MARK);
-#endif
if (offset < 0) {
if (-offset > blen)
DIE(aTHX_ "Offset outside string");
offset = 0;
if (length > blen - offset)
length = blen - offset;
+ if (DO_UTF8(bufsv)) {
+ buffer = (char*)utf8_hop((U8 *)buffer, offset);
+ length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ }
+ else {
+ buffer = buffer+offset;
+ }
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
- if (IoTYPE(io) == 's') {
- length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
- buffer+offset, length, 0);
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
+ buffer, length, 0);
}
else
#endif
{
/* See the note at doio.c:do_print about filesize limits. --jhi */
- length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
- buffer+offset, length);
+ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
+ buffer, length);
}
}
#ifdef HAS_SOCKET
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
- (struct sockaddr *)sockbuf, mlen);
+ /* length is really flags */
+ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ length, (struct sockaddr *)sockbuf, mlen);
}
else
- length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
-
+ /* length is really flags */
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
DIE(aTHX_ PL_no_sock_func, "send");
#endif
- if (length < 0)
+ if (retval < 0)
goto say_undef;
SP = ORIGMARK;
- PUSHi(length);
+#if Size_t_size > IVSIZE
+ PUSHn(retval);
+#else
+ PUSHi(retval);
+#endif
RETURN;
say_undef:
GV *gv;
MAGIC *mg;
- if (MAXARG <= 0) {
+ if (MAXARG == 0) {
if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
IO *io;
gv = PL_last_in_gv = PL_argvgv;
PP(pp_tell)
{
djSP; dTARGET;
- GV *gv;
+ GV *gv;
MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = PL_last_in_gv = (GV*)POPs;
if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
- XPUSHs(sv_2mortal(newSViv((IV) offset)));
- XPUSHs(sv_2mortal(newSViv((IV) whence)));
+#if LSEEKSIZE > IVSIZE
+ XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+#else
+ XPUSHs(sv_2mortal(newSViv(offset)));
+#endif
+ XPUSHs(sv_2mortal(newSViv(whence)));
PUTBACK;
ENTER;
call_method("SEEK", G_SCALAR);
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
- Off_t n = do_sysseek(gv, offset, whence);
- if (n < 0)
+ Off_t sought = do_sysseek(gv, offset, whence);
+ if (sought < 0)
PUSHs(&PL_sv_undef);
else {
- SV* sv = n ?
+ SV* sv = sought ?
#if LSEEKSIZE > IVSIZE
- newSVnv((NV)n)
+ newSVnv((NV)sought)
#else
- newSViv((IV)n)
+ newSViv(sought)
#endif
: newSVpvn(zero_but_true, ZBTLEN);
PUSHs(sv_2mortal(sv));
PP(pp_truncate)
{
djSP;
- Off_t len = (Off_t)POPn;
+ /* There seems to be no consensus on the length type of truncate()
+ * and ftruncate(), both off_t and size_t have supporters. In
+ * general one would think that when using large files, off_t is
+ * at least as wide as size_t, so using an off_t should be okay. */
+ /* XXX Configure probe for the length type of *truncate() needed XXX */
+ Off_t len;
int result = 1;
GV *tmpgv;
STRLEN n_a;
+#if Size_t_size > IVSIZE
+ len = (Off_t)POPn;
+#else
+ len = (Off_t)POPi;
+#endif
+ /* Checking for length < 0 is problematic as the type might or
+ * 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)
if (PL_op->op_flags & OPf_SPECIAL) {
tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
do_ftruncate:
TAINT_PROPER("truncate");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+ if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
+ result = 0;
+ else {
+ PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
- ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
-#else
- my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#else
+ if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
else {
SV *sv = POPs;
char *s;
IV retval;
GV *gv = (GV*)POPs;
- IO *io = GvIOn(gv);
+ IO *io = gv ? GvIOn(gv) : 0;
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... */
RETPUSHUNDEF;
}
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
-#endif
+#endif
#else
DIE(aTHX_ "fcntl is not implemented");
#endif
I32 value;
int argtype;
GV *gv;
+ IO *io = NULL;
PerlIO *fp;
#ifdef FLOCK
argtype = POPi;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = (GV*)POPs;
- if (gv && GvIO(gv))
- fp = IoIFP(GvIOp(gv));
- else
+ if (gv && (io = GvIO(gv)))
+ fp = IoIFP(io);
+ else {
fp = Nullfp;
+ io = NULL;
+ }
if (fp) {
(void)PerlIO_flush(fp);
value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
}
- else
+ else {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
value = 0;
+ SETERRNO(EBADF,RMS$_IFI);
+ }
PUSHi(value);
RETURN;
#else
int fd;
gv = (GV*)POPs;
+ io = gv ? GvIOn(gv) : NULL;
- if (!gv) {
+ if (!gv || !io) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ if (IoIFP(io))
+ do_close(gv, FALSE);
SETERRNO(EBADF,LIB$_INVARG);
RETPUSHUNDEF;
}
- io = GvIOn(gv);
- if (IoIFP(io))
- do_close(gv, FALSE);
-
TAINT_PROPER("socket");
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");
- IoTYPE(io) = 's';
+ IoTYPE(io) = IoTYPE_SOCKET;
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
if (IoOFP(io)) PerlIO_close(IoOFP(io));
if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
RETPUSHUNDEF;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
RETPUSHYES;
#else
gv2 = (GV*)POPs;
gv1 = (GV*)POPs;
- if (!gv1 || !gv2)
+ io1 = gv1 ? GvIOn(gv1) : NULL;
+ io2 = gv2 ? GvIOn(gv2) : NULL;
+ if (!gv1 || !gv2 || !io1 || !io2) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+ if (!gv1 || !io1)
+ report_evil_fh(gv1, io1, PL_op->op_type);
+ if (!gv2 || !io2)
+ report_evil_fh(gv1, io2, PL_op->op_type);
+ }
+ if (IoIFP(io1))
+ do_close(gv1, FALSE);
+ if (IoIFP(io2))
+ do_close(gv2, FALSE);
RETPUSHUNDEF;
-
- io1 = GvIOn(gv1);
- io2 = GvIOn(gv2);
- if (IoIFP(io1))
- do_close(gv1, FALSE);
- if (IoIFP(io2))
- do_close(gv2, FALSE);
+ }
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");
- IoTYPE(io1) = 's';
+ IoTYPE(io1) = IoTYPE_SOCKET;
IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
- IoTYPE(io2) = 's';
+ IoTYPE(io2) = IoTYPE_SOCKET;
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
RETPUSHUNDEF;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
+ fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+#endif
RETPUSHYES;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
#ifdef HAS_SOCKET
int backlog = POPi;
GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ register IO *io = gv ? GvIOn(gv) : NULL;
- if (!io || !IoIFP(io))
+ if (!gv || !io || !IoIFP(io))
goto nuts;
if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
goto badexit;
IoIFP(nstio) = PerlIO_fdopen(fd, "r");
IoOFP(nstio) = PerlIO_fdopen(fd, "w");
- IoTYPE(nstio) = 's';
+ IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
goto badexit;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
+
+#ifdef EPOC
+ len = sizeof saddr; /* EPOC somehow truncates info */
+#endif
PUSHp((char *)&saddr, len);
RETURN;
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
+ report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
+ report_evil_fh(gv, io, optype);
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
!memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
sizeof(u_short) + sizeof(struct in_addr))) {
- goto nuts2;
+ goto nuts2;
}
}
#endif
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
+ report_evil_fh(gv, io, optype);
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
PP(pp_stat)
{
djSP;
- GV *tmpgv;
+ GV *gv;
I32 gimme;
I32 max = 13;
STRLEN n_a;
if (PL_op->op_flags & OPf_REF) {
- tmpgv = cGVOP_gv;
+ gv = cGVOP_gv;
+ if (PL_op->op_type == OP_LSTAT) {
+ if (PL_laststype != OP_LSTAT)
+ Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
+ if (ckWARN(WARN_IO) && gv != PL_defgv)
+ Perl_warner(aTHX_ WARN_IO,
+ "lstat() on filehandle %s", GvENAME(gv));
+ /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
+ }
+
do_fstat:
- if (tmpgv != PL_defgv) {
+ if (gv != PL_defgv) {
PL_laststype = OP_STAT;
- PL_statgv = tmpgv;
+ PL_statgv = gv;
sv_setpv(PL_statname, "");
- PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
- ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
+ PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
+ ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
}
- if (PL_laststatval < 0)
+ if (PL_laststatval < 0) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, GvIO(gv), PL_op->op_type);
max = 0;
+ }
}
else {
SV* sv = POPs;
if (SvTYPE(sv) == SVt_PVGV) {
- tmpgv = (GV*)sv;
+ gv = (GV*)sv;
goto do_fstat;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- tmpgv = (GV*)SvRV(sv);
+ gv = (GV*)SvRV(sv);
goto do_fstat;
}
sv_setpv(PL_statname, SvPV(sv,n_a));
EXTEND_MORTAL(max);
PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
#if Uid_t_size > IVSIZE
PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
#else
+# if Uid_t_sign <= 0
PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
+# else
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
+# endif
#endif
-#if Gid_t_size > IVSIZE
+#if Gid_t_size > IVSIZE
PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
#else
+# if Gid_t_sign <= 0
PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
+# else
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
+# endif
#endif
#ifdef USE_STAT_RDEV
PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
#endif
#ifdef USE_STAT_BLOCKS
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
#else
PUSHs(sv_2mortal(newSVpvn("", 0)));
PUSHs(sv_2mortal(newSVpvn("", 0)));
len = 512;
}
else {
- if (ckWARN(WARN_UNOPENED)) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
gv = cGVOP_gv;
- Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
- GvENAME(gv));
+ report_evil_fh(gv, GvIO(gv), PL_op->op_type);
}
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
(void)PerlIO_close(fp);
RETPUSHUNDEF;
}
- do_binmode(fp, '<', TRUE);
+ PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
len = PerlIO_read(fp, tbuf, sizeof(tbuf));
(void)PerlIO_close(fp);
if (len <= 0) {
break;
}
#ifdef EBCDIC
- else if (!(isPRINT(*s) || isSPACE(*s)))
+ else if (!(isPRINT(*s) || isSPACE(*s)))
odd++;
#else
else if (*s & 128) {
#ifdef USE_LOCALE
- if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
-#endif
- odd++;
+ if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
+ continue;
+#endif
+ /* utf8 characters don't count as odd */
+ if (*s & 0x40) {
+ int ulen = UTF8SKIP(s);
+ if (ulen < len - i) {
+ int j;
+ for (j = 1; j < ulen; j++) {
+ if ((s[j] & 0xc0) != 0x80)
+ goto not_utf8;
+ }
+ --ulen; /* loop does extra increment */
+ s += ulen;
+ i += ulen;
+ continue;
+ }
+ }
+ not_utf8:
+ odd++;
}
else if (*s < 32 &&
*s != '\n' && *s != '\r' && *s != '\b' &&
PP(pp_mkdir)
{
djSP; dTARGET;
- int mode = POPi;
+ int mode;
#ifndef HAS_MKDIR
int oldumask;
#endif
STRLEN n_a;
- char *tmps = SvPV(TOPs, n_a);
+ char *tmps;
+
+ if (MAXARG > 1)
+ mode = POPi;
+ else
+ mode = 0777;
+
+ tmps = SvPV(TOPs, n_a);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
if (GIMME == G_ARRAY) {
/*SUPPRESS 560*/
- while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
+ while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
#ifdef DIRNAMLEN
sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
XPUSHs(sv_2mortal(sv));
}
sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
XPUSHs(sv_2mortal(sv));
}
RETSETUNDEF;
if (!childpid) {
/*SUPPRESS 560*/
- if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
+ if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
}
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
+ if (childpid == -1)
+ RETSETUNDEF;
PUSHi(childpid);
RETURN;
# else
PP(pp_wait)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
djSP; dTARGET;
Pid_t childpid;
int argflags;
childpid = wait4pid(-1, &argflags, 0);
+# 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);
+# else
STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+# endif
XPUSHi(childpid);
RETURN;
#else
PP(pp_waitpid)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
djSP; dTARGET;
Pid_t childpid;
int optype;
optype = POPi;
childpid = TOPi;
childpid = wait4pid(childpid, &argflags, optype);
+# 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);
+# else
STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+# endif
SETi(childpid);
RETURN;
#else
}
}
PERL_FLUSHALL_FOR_CHILD;
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
while ((childpid = vfork()) == -1) {
if (childpid > 0) {
if (did_pipes)
PerlLIO_close(pp[1]);
+#ifndef PERL_MICRO
rsignal_save(SIGINT, SIG_IGN, &ihand);
rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+#endif
do {
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
+#ifndef PERL_MICRO
(void)rsignal_restore(SIGINT, &ihand);
(void)rsignal_restore(SIGQUIT, &qhand);
+#endif
STATUS_NATIVE_SET(result == -1 ? -1 : status);
do_execfree(); /* free any memory child malloced on vfork */
SP = ORIGMARK;
}
PerlProc__exit(-1);
#else /* ! FORK or VMS or OS/2 */
+ PL_statusvalue = 0;
+ result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
}
+ if (PL_statusvalue == -1) /* hint that value must be returned as is */
+ result = 1;
STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(STATUS_CURRENT);
+ PUSHi(result ? value : STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
EXTEND(SP, 9);
EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
- dTARGET;
SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
I32 which = PL_op->op_type;
register char **elem;
- register SV *sv;
+ register SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *PerlSock_getprotobyname(Netdb_name_t);
struct protoent *PerlSock_getprotobynumber(int);
PP(pp_gpwent)
{
djSP;
-#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
+#ifdef HAS_PASSWD
I32 which = PL_op->op_type;
register SV *sv;
- struct passwd *pwent;
STRLEN n_a;
-#if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
- struct spwd *spwent = NULL;
-#endif
-
- if (which == OP_GPWNAM)
- pwent = getpwnam(POPpx);
- else if (which == OP_GPWUID)
- pwent = getpwuid(POPi);
- else
- pwent = (struct passwd *)getpwent();
+ struct passwd *pwent = NULL;
+ /*
+ * We currently support only the SysV getsp* shadow password interface.
+ * The interface is declared in <shadow.h> and often one needs to link
+ * with -lsecurity or some such.
+ * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
+ * (and SCO?)
+ *
+ * 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
+ * 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
+ * are much more complicated, but also very similar to each other.
+ *
+ * <sys/types.h>
+ * <sys/security.h>
+ * <prot.h>
+ * struct pr_passwd *getprpw*();
+ * The password is in
+ * char getprpw*(...).ufld.fd_encrypt[]
+ * Mention HAS_GETPRPWNAM here so that Configure probes for it.
+ *
+ * <sys/types.h>
+ * <sys/security.h>
+ * <prot.h>
+ * struct es_passwd *getespw*();
+ * The password is in
+ * char *(getespw*(...).ufld.fd_encrypt)
+ * Mention HAS_GETESPWNAM here so that Configure probes for it.
+ *
+ * Mention I_PROT here so that Configure probes for it.
+ *
+ * In HP-UX for getprpw*() the manual page claims that one should include
+ * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
+ * if one includes <shadow.h> as that includes <hpsecurity.h>,
+ * and pp_sys.c already includes <shadow.h> if there is such.
+ *
+ * Note that <sys/security.h> is already probed for, but currently
+ * it is only included in special cases.
+ *
+ * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
+ * be preferred interface, even though also the getprpw*() interface
+ * is available) one needs to link with -lsecurity -ldb -laud -lm.
+ * One also needs to call set_auth_parameters() in main() before
+ * doing anything else, whether one is using getespw*() or getprpw*().
+ *
+ * Note that accessing the shadow databases can be magnitudes
+ * slower than accessing the standard databases.
+ *
+ * --jhi
+ */
-#ifdef HAS_GETSPNAM
- if (which == OP_GPWNAM) {
- if (pwent)
- spwent = getspnam(pwent->pw_name);
- }
-# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
- else if (which == OP_GPWUID) {
- if (pwent)
- spwent = getspnam(pwent->pw_name);
+ switch (which) {
+ case OP_GPWNAM:
+ pwent = getpwnam(POPpx);
+ break;
+ case OP_GPWUID:
+ pwent = getpwuid((Uid_t)POPi);
+ break;
+ case OP_GPWENT:
+# ifdef HAS_GETPWENT
+ pwent = getpwent();
+# else
+ DIE(aTHX_ PL_no_func, "getpwent");
+# endif
+ break;
}
-# endif
-# ifdef HAS_GETSPENT
- else
- spwent = (struct spwd *)getspent();
-# endif
-#endif
EXTEND(SP, 10);
if (GIMME != G_ARRAY) {
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
else
sv_setpv(sv, pwent->pw_name);
}
sv_setpv(sv, pwent->pw_name);
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWPASSWD
-# if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
- if (spwent)
- sv_setpv(sv, spwent->sp_pwdp);
- else
- sv_setpv(sv, pwent->pw_passwd);
-# else
- sv_setpv(sv, pwent->pw_passwd);
+ SvPOK_off(sv);
+ /* 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,
+ * and return a null pointer. If this happens, we will
+ * use the dummy password (usually "*" or "x") from the
+ * standard password database.
+ *
+ * In theory we could skip the shadow call completely
+ * if euid != 0 but in practice we cannot know which
+ * security measures are guarding the shadow databases
+ * on a random platform.
+ *
+ * Resist the urge to use additional shadow interfaces.
+ * Divert the urge to writing an extension instead.
+ *
+ * --jhi */
+# ifdef HAS_GETSPNAM
+ {
+ struct spwd *spwent;
+ int saverrno; /* Save and restore errno so that
+ * underprivileged attempts seem
+ * to have never made the unsccessful
+ * attempt to retrieve the shadow password. */
+
+ saverrno = errno;
+ spwent = getspnam(pwent->pw_name);
+ errno = saverrno;
+ if (spwent && spwent->sp_pwdp)
+ sv_setpv(sv, spwent->sp_pwdp);
+ }
+# endif
+# ifdef PWPASSWD
+ if (!SvPOK(sv)) /* Use the standard password, then. */
+ sv_setpv(sv, pwent->pw_passwd);
+# endif
+
+# ifndef INCOMPLETE_TAINTS
+ /* passwd is tainted because user himself can diddle with it.
+ * admittedly not much and in a very limited way, but nevertheless. */
+ SvTAINTED_on(sv);
# endif
-#endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# if Uid_t_sign <= 0
sv_setiv(sv, (IV)pwent->pw_uid);
+# else
+ sv_setuv(sv, (UV)pwent->pw_uid);
+# endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# if Uid_t_sign <= 0
sv_setiv(sv, (IV)pwent->pw_gid);
-
- /* pw_change, pw_quota, and pw_age are mutually exclusive. */
+# else
+ sv_setuv(sv, (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
+# ifdef PWCHANGE
sv_setiv(sv, (IV)pwent->pw_change);
-#else
-# ifdef PWQUOTA
- sv_setiv(sv, (IV)pwent->pw_quota);
# else
-# ifdef PWAGE
+# ifdef PWQUOTA
+ sv_setiv(sv, (IV)pwent->pw_quota);
+# else
+# ifdef PWAGE
sv_setpv(sv, pwent->pw_age);
+# endif
# endif
# endif
-#endif
- /* pw_class and pw_comment are mutually exclusive. */
+ /* 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
+# ifdef PWCLASS
sv_setpv(sv, pwent->pw_class);
-#else
-# ifdef PWCOMMENT
+# else
+# ifdef PWCOMMENT
sv_setpv(sv, pwent->pw_comment);
+# endif
# endif
-#endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWGECOS
+# ifdef PWGECOS
sv_setpv(sv, pwent->pw_gecos);
-#endif
-#ifndef INCOMPLETE_TAINTS
+# endif
+# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-#endif
+# endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_dir);
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_shell);
+# ifndef INCOMPLETE_TAINTS
+ /* pw_shell is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+# endif
-#ifdef PWEXPIRE
+# ifdef PWEXPIRE
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setiv(sv, (IV)pwent->pw_expire);
-#endif
+# endif
}
RETURN;
#else
djSP;
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
setpwent();
-# ifdef HAS_SETSPENT
- setspent();
-# endif
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setpwent");
djSP;
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
endpwent();
-# ifdef HAS_ENDSPENT
- endspent();
-# endif
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endpwent");
PP(pp_ggrent)
{
djSP;
-#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
+#ifdef HAS_GROUP
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
else if (which == OP_GGRGID)
grent = (struct group *)getgrgid(POPi);
else
+#ifdef HAS_GETGRENT
grent = (struct group *)getgrent();
+#else
+ DIE(aTHX_ PL_no_func, "getgrent");
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
unsigned long a[20];
register I32 i = 0;
I32 retval = -1;
- MAGIC *mg;
STRLEN n_a;
if (PL_tainting) {
a[i++] = SvIV(*MARK);
else if (*MARK == &PL_sv_undef)
a[i++] = 0;
- else
+ else
a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
if (i > 15)
break;
}
#ifdef FCNTL_EMULATE_FLOCK
-
+
/* XXX Emulate flock() with fcntl().
What's really needed is a good file locking module.
*/
fcntl_emulate_flock(int fd, int operation)
{
struct flock flock;
-
+
switch (operation & ~LOCK_NB) {
case LOCK_SH:
flock.l_type = F_RDLCK;
}
flock.l_whence = SEEK_SET;
flock.l_start = flock.l_len = (Off_t)0;
-
+
return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
}
https://perl5.git.perl.org / perl5.git / blobdiff