/* sysopen style args, i.e. integer mode and permissions */
STRLEN ix = 0;
if (num_svs != 0) {
- Perl_croak(aTHX_ "panic:sysopen with multiple args");
+ Perl_croak(aTHX_ "panic: sysopen with multiple args");
}
+ if (rawmode & (O_WRONLY|O_RDWR|O_CREAT
+#ifdef O_APPEND /* Not fully portable. */
+ |O_APPEND
+#endif
+#ifdef O_TRUNC /* Not fully portable. */
+ |O_TRUNC
+#endif
+ ))
+ TAINT_PROPER("sysopen");
mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */
#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
- rawmode |= O_LARGEFILE;
+ rawmode |= O_LARGEFILE; /* Transparently largefiley. */
#endif
-#ifndef O_ACCMODE
-#define O_ACCMODE 3 /* Assume traditional implementation */
-#endif
-
- switch (result = rawmode & O_ACCMODE) {
- case O_RDONLY:
- IoTYPE(io) = IoTYPE_RDONLY;
- break;
- case O_WRONLY:
- IoTYPE(io) = IoTYPE_WRONLY;
- break;
- case O_RDWR:
- default:
- IoTYPE(io) = IoTYPE_RDWR;
- break;
- }
- writing = (result > 0);
-
- if (result == O_RDONLY) {
- mode[ix++] = 'r';
- }
-#ifdef O_APPEND
- else if (rawmode & O_APPEND) {
- mode[ix++] = 'a';
- if (result != O_WRONLY)
- mode[ix++] = '+';
- }
-#endif
- else {
- if (result == O_WRONLY)
- mode[ix++] = 'w';
- else {
- mode[ix++] = 'r';
- mode[ix++] = '+';
- }
- }
- if (rawmode & O_BINARY)
- mode[ix++] = 'b';
- mode[ix] = '\0';
+ IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
namesv = sv_2mortal(newSVpvn(name,strlen(name)));
num_svs = 1;
svp = &namesv;
type = Nullch;
- fp = PerlIO_openn(aTHX_ type,mode, -1, rawmode, rawperm, NULL, num_svs, svp);
+ fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp);
}
else {
/* Regular (non-sys) open */
STRLEN olen = len;
char *tend;
int dodup = 0;
+ PerlIO *that_fp = NULL;
type = savepvn(name, len);
tend = type+len;
SAVEFREEPV(type);
- /* Loose trailing white space */
- while (tend > type && isSPACE(tend[-1]))
- *tend-- = '\0';
+
+ /* Lose leading and trailing white space */
+ /*SUPPRESS 530*/
+ for (; isSPACE(*type); type++) ;
+ while (tend > type && isSPACE(tend[-1]))
+ *--tend = '\0';
+
if (num_svs) {
/* New style explict name, type is just mode and discipline/layer info */
STRLEN l = 0;
len = (I32)l;
name = savepvn(name, len);
SAVEFREEPV(name);
- /*SUPPRESS 530*/
- for (; isSPACE(*type); type++) ;
}
else {
name = type;
len = tend-type;
}
IoTYPE(io) = *type;
- if ((*type == IoTYPE_RDWR) && ((!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE))) { /* scary */
+ 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");
mode[1] = *type++;
writing = 1;
}
if (*type == '&') {
duplicity:
- dodup = 1;
+ dodup = PERLIO_DUP_FD;
type++;
if (*type == '=') {
dodup = 0;
goto say_false;
}
if (IoIFP(thatio)) {
- PerlIO *fp = IoIFP(thatio);
+ that_fp = IoIFP(thatio);
/* Flush stdio buffer before dup. --mjd
* Unfortunately SEEK_CURing 0 seems to
* be optimized away on most platforms;
/* sfio fails to clear error on next
sfwrite, contrary to documentation.
-- Nick Clark */
- if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
- PerlIO_clearerr(fp);
+ if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
+ PerlIO_clearerr(that_fp);
#endif
/* On the other hand, do all platforms
* take gracefully to flushing a read-only
* filehandle? Perhaps we should do
* fsetpos(src)+fgetpos(dst)? --nik */
- PerlIO_flush(fp);
- fd = PerlIO_fileno(fp);
+ PerlIO_flush(that_fp);
+ fd = PerlIO_fileno(that_fp);
/* When dup()ing STDIN, STDOUT or STDERR
* explicitly set appropriate access mode */
if (IoIFP(thatio) == PerlIO_stdout()
else
fd = -1;
}
- if (dodup)
- fd = PerlLIO_dup(fd);
- else
- was_fdopen = TRUE;
if (!num_svs)
type = Nullch;
- if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+ if (that_fp) {
+ fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
+ }
+ else {
if (dodup)
- PerlLIO_close(fd);
+ fd = PerlLIO_dup(fd);
+ else
+ was_fdopen = TRUE;
+ if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+ if (dodup)
+ PerlLIO_close(fd);
+ }
}
}
} /* & */
if (ckWARN(WARN_IO)) {
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
- Perl_warner(aTHX_ WARN_IO, "'std%s' opened only for input",
- (fp == PerlIO_stdout()) ? "out" : "err");
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle STD%s opened only for input",
+ (fp == PerlIO_stdout()) ? "OUT" : "ERR");
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
- Perl_warner(aTHX_ WARN_IO, "'stdin' opened only for output");
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle STDIN opened only for output");
}
}
(void)PerlIO_close(fp);
goto say_false;
}
+#ifndef PERL_MICRO
if (S_ISSOCK(PL_statbuf.st_mode))
IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
/* but some return 0 for streams too, sigh */
}
+#endif /* !PERL_MICRO */
#endif
}
if (saveifp) { /* must use old fp? */
if (savefd != fd) {
Pid_t pid;
SV *sv;
+ /* Still a small can-of-worms here if (say) PerlIO::Scalar
+ is assigned to (say) STDOUT - for now let dup2() fail
+ and provide the error
+ */
if (PerlLIO_dup2(fd, savefd) < 0) {
(void)PerlIO_close(fp);
goto say_false;
#ifdef VMS
if (savefd != PerlIO_fileno(PerlIO_stdin())) {
char newname[FILENAME_MAX+1];
- if (fgetname(fp, newname)) {
- if (savefd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname);
- if (savefd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname);
+ if (PerlIO_getname(fp, newname)) {
+ if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
+ if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
}
}
#endif
UNLOCK_FDPID_MUTEX;
(void)SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
- if (!was_fdopen)
+ if (!was_fdopen) {
PerlIO_close(fp);
+ }
}
fp = saveifp;
PerlIO_clearerr(fp);
Off_t
Perl_do_tell(pTHX_ GV *gv)
{
- register IO *io;
+ register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bool
Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
{
- register IO *io;
+ register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
Off_t
Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
{
- register IO *io;
+ register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
sv_utf8_upgrade(sv = sv_mortalcopy(sv));
}
else if (DO_UTF8(sv)) {
- if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)) {
+ if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
+ && ckWARN(WARN_UTF8))
+ {
Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
}
}
Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
#else
register char **a;
- char *tmps;
+ char *tmps = Nullch;
STRLEN n_a;
if (sp > mark) {
{
register char **a;
register char *s;
- char flags[10];
while (*cmd && isSPACE(*cmd))
cmd++;
/* save an extra exec if possible */
#ifdef CSH
- if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
- strcpy(flags,"-c");
- s = cmd+PL_cshlen+3;
- if (*s == 'f') {
- s++;
- strcat(flags,"f");
- }
- if (*s == ' ')
- s++;
- if (*s++ == '\'') {
- char *ncmd = s;
-
- while (*s)
- s++;
- if (s[-1] == '\n')
- *--s = '\0';
- if (s[-1] == '\'') {
- *--s = '\0';
- PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
- *s = '\'';
- return FALSE;
- }
+ {
+ char flags[10];
+ if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
+ strnEQ(cmd+PL_cshlen," -c",3)) {
+ strcpy(flags,"-c");
+ s = cmd+PL_cshlen+3;
+ if (*s == 'f') {
+ s++;
+ strcat(flags,"f");
+ }
+ if (*s == ' ')
+ s++;
+ if (*s++ == '\'') {
+ char *ncmd = s;
+
+ while (*s)
+ s++;
+ if (s[-1] == '\n')
+ *--s = '\0';
+ if (s[-1] == '\'') {
+ *--s = '\0';
+ PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
+ *s = '\'';
+ return FALSE;
+ }
+ }
}
}
#endif /* CSH */
goto doshell;
for (s = cmd; *s; s++) {
- if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+ if (*s != ' ' && !isALPHA(*s) &&
+ strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && !s[1]) {
*s = '\0';
break;
} utbuf;
#endif
+ SV* accessed = *++mark;
+ 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" */
+
+ if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
+ utbufp = NULL;
+
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
- utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
- utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
+ utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */
+ utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
#else
- utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */
- utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */
+ utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */
+ utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
#endif
APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
- if (PerlLIO_utime(name, &utbuf))
+ if (PerlLIO_utime(name, utbufp))
tot--;
}
}
id = SvIVx(*++mark);
opstr = *++mark;
opbuf = SvPV(opstr, opsize);
- if (opsize < sizeof(struct sembuf)
- || (opsize % sizeof(struct sembuf)) != 0) {
+ if (opsize < 3 * SHORTSIZE
+ || (opsize % (3 * SHORTSIZE))) {
SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
SETERRNO(0,0);
- return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
+ /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
+ {
+ int nsops = opsize / (3 * sizeof (short));
+ int i = nsops;
+ short *ops = (short *) opbuf;
+ short *o = ops;
+ struct sembuf *temps, *t;
+ I32 result;
+
+ New (0, temps, nsops, struct sembuf);
+ t = temps;
+ while (i--) {
+ t->sem_num = *o++;
+ t->sem_op = *o++;
+ t->sem_flg = *o++;
+ t++;
+ }
+ result = semop(id, temps, nsops);
+ t = temps;
+ o = ops;
+ i = nsops;
+ while (i--) {
+ *o++ = t->sem_num;
+ *o++ = t->sem_op;
+ *o++ = t->sem_flg;
+ t++;
+ }
+ Safefree(temps);
+ return result;
+ }
#else
Perl_croak(aTHX_ "semop not implemented");
#endif
Function called by C<do_readline> to spawn a glob (or do the glob inside
perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build proccess.
+this glob starter is only used by miniperl during the build process.
Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
=cut
char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
char vmsspec[NAM$C_MAXRSS+1];
char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
- char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
$DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
PerlIO *tmpfp;
STRLEN i;
((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
but that's unsupported, so I don't want to do it now and
have it bite someone in the future. */
- strcat(tmpfnam,PerlLIO_tmpnam(NULL));
cp = SvPV(tmpglob,i);
for (; i; i--) {
if (cp[i] == ';') hasver = 1;
break;
}
}
- if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
+ if ((tmpfp = PerlIO_tmpfile()) != NULL) {
Stat_t st;
if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
+ for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
+ if (*cp == '?') *cp = '%'; /* VMS style single-char wildcard */
while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
&dfltdsc,NULL,NULL,NULL))&1)) {
end = rstr + (unsigned long int) *rslt;