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 != O_RDONLY);
-
- 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;
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;
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);
+ }
}
}
} /* & */
(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;
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);
if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
utbufp = NULL;
-
+
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */
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
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;