# define vfork fork
#endif
-/* Put this after #includes because <unistd.h> defines _XOPEN_*.
- * Sock_size_t is defined identically in doio.c. */
-#ifndef Sock_size_t
-# ifdef HAS_SOCKLEN_T
-# define Sock_size_t socklen_t
-# else
-# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
-# define Sock_size_t Size_t
-# else
-# define Sock_size_t int
-# endif
-# endif
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
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) {
if (gimme == G_VOID) {
char tmpbuf[256];
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
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 (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;
IO *io;
PerlIO *fp;
MAGIC *mg;
+ SV *discp = Nullsv;
if (MAXARG < 1)
RETPUSHUNDEF;
+ if (MAXARG > 1)
+ discp = 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);
if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
RETPUSHUNDEF;
- if (do_binmode(fp,IoTYPE(io),TRUE))
+ if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
RETPUSHYES;
else
RETPUSHUNDEF;
}
-
PP(pp_tie)
{
djSP;
if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
- if (mg = SvTIED_mg(sv, how)) {
+ if ((mg = SvTIED_mg(sv, how))) {
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
Perl_warner(aTHX_ WARN_UNTIE,
"untie attempted while %"UVuf" inner references still exist",
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 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
GV *gv;
MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_stdingv;
else
gv = (GV*)POPs;
- 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));
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;
djSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
- Off_t offset;
SV *bufsv;
char *buffer;
- Off_t length;
+ Size_t length;
+ SSize_t retval;
+ IV offset;
STRLEN blen;
MAGIC *mg;
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;
+ retval = -1;
if (ckWARN(WARN_CLOSED)) {
if (PL_op->op_type == OP_SYSWRITE)
report_closed_fh(gv, io, "syswrite", "filehandle");
}
else if (PL_op->op_type == OP_SYSWRITE) {
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");
length = blen - offset;
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
if (IoTYPE(io) == 's') {
- length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
buffer+offset, length, 0);
}
else
#endif
{
/* See the note at doio.c:do_print about filesize limits. --jhi */
- length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
+ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
buffer+offset, length);
}
}
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
- (struct sockaddr *)sockbuf, mlen);
+ 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);
+ 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;
GV *gv;
MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = PL_last_in_gv = (GV*)POPs;
#if LSEEKSIZE > IVSIZE
XPUSHs(sv_2mortal(newSVnv((NV) offset)));
#else
- XPUSHs(sv_2mortal(newSViv((IV) offset)));
+ XPUSHs(sv_2mortal(newSViv(offset)));
#endif
- XPUSHs(sv_2mortal(newSViv((IV) whence)));
+ 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) {
#ifdef FLOCK
argtype = POPi;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = (GV*)POPs;
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
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)));
(void)PerlIO_close(fp);
RETPUSHUNDEF;
}
- do_binmode(fp, '<', TRUE);
+ do_binmode(fp, '<', O_BINARY);
len = PerlIO_read(fp, tbuf, sizeof(tbuf));
(void)PerlIO_close(fp);
if (len <= 0) {
#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' &&
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, 9);
EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
- dTARGET;
SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
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_passwd);
# endif
#endif
+#ifndef INCOMPLETE_TAINTS
+ /* passwd is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+#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);
-
+#else
+ sv_setuv(sv, (UV)pwent->pw_gid);
+#endif
/* pw_change, pw_quota, and pw_age are mutually exclusive. */
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef PWCHANGE
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
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
unsigned long a[20];
register I32 i = 0;
I32 retval = -1;
- MAGIC *mg;
STRLEN n_a;
if (PL_tainting) {
https://perl5.git.perl.org / perl5.git / blobdiff