/* 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.
# 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
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
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);
/* 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;
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 (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
+#if LSEEKSIZE > IVSIZE
+ XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+#else
XPUSHs(sv_2mortal(newSViv((IV) offset)));
+#endif
XPUSHs(sv_2mortal(newSViv((IV) whence)));
PUTBACK;
ENTER;
#ifdef FLOCK
argtype = POPi;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = (GV*)POPs;
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
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
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
PUSHp((char *)&saddr, len);
RETURN;
#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, 9);
EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
- dTARGET;
SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
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;
else if (which == OP_GPWUID)
pwent = getpwuid(POPi);
else
+#ifdef HAS_GETPWENT
pwent = (struct passwd *)getpwent();
+#else
+ DIE(aTHX_ PL_no_func, "getpwent");
+#endif
#ifdef HAS_GETSPNAM
if (which == OP_GPWNAM) {
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) {
projects / p5sagit/p5-mst-13.2.git / blobdiff