X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=3bad8f343ba5e7787d10e6dedbf8c782e9fff9c6;hb=f8f79f57f467ffff4d31dc518ce3f6d2364090a0;hp=9cfcc4e1c5c8a3fc8aa795823d501b5e860d6cde;hpb=479b2847c3fbb8fe8ee4a5811514a771839458c4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index 9cfcc4e..3bad8f3 100644 --- a/doio.c +++ b/doio.c @@ -1,6 +1,7 @@ /* doio.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 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. @@ -93,7 +94,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* Collect default raw/crlf info from the op */ if (PL_op && PL_op->op_type == OP_OPEN) { - /* set up disciplines */ + /* set up IO layers */ U8 flags = PL_op->op_private; in_raw = (flags & OPpOPEN_IN_RAW); in_crlf = (flags & OPpOPEN_IN_CRLF); @@ -178,7 +179,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, (ismodifying & (O_CREAT|appendtrunc))) TAINT_PROPER("sysopen"); } - mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */ + mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; /* Transparently largefiley. */ @@ -211,7 +212,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, *--tend = '\0'; if (num_svs) { - /* New style explict name, type is just mode and discipline/layer info */ + /* New style explicit name, type is just mode and layer info */ STRLEN l = 0; #ifdef USE_STDIO if (SvROK(*svp) && !strchr(name,'&')) { @@ -235,7 +236,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if ((*type == IoTYPE_RDWR) && /* scary */ (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { - TAINT_PROPER("open"); + TAINT_PROPER("open"); mode[1] = *type++; writing = 1; } @@ -243,7 +244,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == IoTYPE_PIPE) { if (num_svs) { if (type[1] != IoTYPE_STD) { - unknown_desr: + unknown_open_mode: Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); } type++; @@ -288,7 +289,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } } - } + } /* IoTYPE_PIPE */ else if (*type == IoTYPE_WRONLY) { TAINT_PROPER("open"); type++; @@ -323,13 +324,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs > 1) { Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); } + /*SUPPRESS 530*/ + for (; isSPACE(*type); type++) ; if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) { fd = SvUV(*svp); num_svs = 0; } else if (isDIGIT(*type)) { - /*SUPPRESS 530*/ - for (; isSPACE(*type); type++) ; fd = atoi(type); } else { @@ -339,8 +340,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } else { GV *thatgv; - /*SUPPRESS 530*/ - for (; isSPACE(*type); type++) ; thatgv = gv_fetchpv(type,FALSE,SVt_PVIO); thatio = GvIO(thatgv); } @@ -423,7 +422,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } /* !& */ - } + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_WRONLY */ else if (*type == IoTYPE_RDONLY) { /*SUPPRESS 530*/ for (type++; isSPACE(*type); type++) ; @@ -454,8 +455,11 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } - } - else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_RDONLY */ + else if ((num_svs && /* '-|...' or '...|' */ + type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { if (num_svs) { type += 2; /* skip over '-|' */ @@ -500,9 +504,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } } - else { + else { /* layer(Args) */ if (num_svs) - goto unknown_desr; + goto unknown_open_mode; name = type; IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ @@ -642,8 +646,16 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* need to close fp without closing underlying fd */ int ofd = PerlIO_fileno(fp); int dupfd = PerlLIO_dup(ofd); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* Assume if we have F_SETFD we have F_GETFD */ + int coe = fcntl(ofd,F_GETFD); +#endif PerlIO_close(fp); PerlLIO_dup2(dupfd,ofd); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* The dup trick has lost close-on-exec on ofd */ + fcntl(ofd,F_SETFD, coe); +#endif PerlLIO_close(dupfd); } else @@ -667,8 +679,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (IoTYPE(io) == IoTYPE_SOCKET || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) { char *s = mode; - if (*s == 'I' || *s == '#') - s++; + if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) + s++; *s = 'w'; if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) { PerlIO_close(fp); @@ -719,6 +731,8 @@ Perl_nextargv(pTHX_ register GV *gv) #endif } PL_filemode = 0; + if (!GvAV(gv)) + return Nullfp; while (av_len(GvAV(gv)) >= 0) { STRLEN oldlen; sv = av_shift(GvAV(gv)); @@ -775,8 +789,8 @@ Perl_nextargv(pTHX_ register GV *gv) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s would not be unique", - SvPVX(sv)); + "Can't do inplace edit: %"SVf" would not be unique", + sv); do_close(gv,FALSE); continue; } @@ -786,8 +800,8 @@ Perl_nextargv(pTHX_ register GV *gv) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -802,8 +816,8 @@ Perl_nextargv(pTHX_ register GV *gv) if (link(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -1029,17 +1043,21 @@ Perl_do_eof(pTHX_ GV *gv) report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); while (IoIFP(io)) { + int saverrno; if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ return FALSE; /* this is the most usual case */ } + saverrno = errno; /* getc and ungetc can stomp on errno */ ch = PerlIO_getc(IoIFP(io)); if (ch != EOF) { (void)PerlIO_ungetc(IoIFP(io),ch); + errno = saverrno; return FALSE; } + errno = saverrno; if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { if (PerlIO_get_cnt(IoIFP(io)) < -1) @@ -1152,7 +1170,7 @@ fail_discipline: if (!end) end = s+len; #ifndef PERLIO_LAYERS - Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); + Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); #else s = end; #endif @@ -1268,7 +1286,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) default: if (PerlIO_isutf8(fp)) { if (!SvUTF8(sv)) - sv_utf8_upgrade(sv = sv_mortalcopy(sv)); + sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv), + SV_GMAGIC|SV_UTF8_NO_ENCODING); } else if (DO_UTF8(sv)) { if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE) @@ -1322,7 +1341,7 @@ Perl_my_stat(pTHX) else { SV* sv = POPs; char *s; - STRLEN n_a; + STRLEN len; PUTBACK; if (SvTYPE(sv) == SVt_PVGV) { gv = (GV*)sv; @@ -1333,9 +1352,10 @@ Perl_my_stat(pTHX) goto do_fstat; } - s = SvPV(sv, n_a); + s = SvPV(sv, len); PL_statgv = Nullgv; - sv_setpv(PL_statname, s); + sv_setpvn(PL_statname, s, len); + s = SvPVX(PL_statname); /* s now NUL-terminated */ PL_laststype = OP_STAT; PL_laststatval = PerlLIO_stat(s, &PL_statcache); if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) @@ -1380,11 +1400,13 @@ Perl_my_lstat(pTHX) return PL_laststatval; } +#ifndef OS2 bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) { return do_aexec5(really, mark, sp, 0, 0); } +#endif bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, @@ -1412,10 +1434,12 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, if ((!really && *PL_Argv[0] != '/') || (really && *tmps != '/')) /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ + PERL_FPU_PRE_EXEC if (really && *tmps) PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); else PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); + PERL_FPU_POST_EXEC if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", (really ? tmps : PL_Argv[0]), Strerror(errno)); @@ -1485,7 +1509,9 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) *--s = '\0'; if (s[-1] == '\'') { *--s = '\0'; + PERL_FPU_PRE_EXEC PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0); + PERL_FPU_POST_EXEC *s = '\''; return FALSE; } @@ -1528,7 +1554,9 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) } } doshell: + PERL_FPU_PRE_EXEC PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0); + PERL_FPU_POST_EXEC return FALSE; } } @@ -1546,7 +1574,9 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) } *a = Nullch; if (PL_Argv[0]) { + PERL_FPU_PRE_EXEC PerlProc_execvp(PL_Argv[0],PL_Argv); + PERL_FPU_POST_EXEC if (errno == ENOEXEC) { /* for system V NIH syndrome */ do_execfree(); goto doshell; @@ -1642,10 +1672,10 @@ nothing in the core. if (mark == sp) break; s = SvPVx(*++mark, n_a); - if (isUPPER(*s)) { + if (isALPHA(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; - if (!(val = whichsig(s))) + if ((val = whichsig(s)) < 0) Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s); } else @@ -1745,22 +1775,23 @@ nothing in the core. SV* modified = *++mark; void * utbufp = &utbuf; - /* be like C, and if both times are undefined, let the C - library figure out what to do. This usually means - "current time" */ + /* Be like C, and if both times are undefined, let the C + * library figure out what to do. This usually means + * "current time". */ if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) - utbufp = NULL; - - Zero(&utbuf, sizeof utbuf, char); + utbufp = NULL; + else { + Zero(&utbuf, sizeof utbuf, char); #ifdef BIG_TIME - utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */ - utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */ + utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */ #else - utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */ - utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */ + utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */ + utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */ #endif - APPLY_TAINT_PROPER(); + } + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { char *name = SvPVx(*mark, n_a);