# include <unistd.h>
#endif
-#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
-# include <sys/socket.h>
-# if defined(USE_SOCKS) && defined(I_SOCKS)
-# include <socks.h>
-# endif
-# ifdef I_NETBSD
-# include <netdb.h>
-# endif
-# ifndef ENOTSOCK
-# ifdef I_NET_ERRNO
-# include <net/errno.h>
-# endif
-# endif
+#ifdef SOCKS_64BIT_BUG
+typedef struct __s64_iobuffer {
+ struct __s64_iobuffer *next, *last; /* Queue pointer */
+ PerlIO *fp; /* assigned file pointer */
+ int cnt; /* Buffer counter */
+ int size; /* Buffer size */
+ int *buffer; /* the buffer */
+} S64_IOB;
+
+static S64_IOB *_s64_get_buffer( PerlIO *f);
+static S64_IOB *_s64_create_buffer( PerlIO *f);
+static int _s64_malloc( S64_IOB *ptr);
#endif
bool
register IO *io = GvIOn(gv);
PerlIO *saveifp = Nullfp;
PerlIO *saveofp = Nullfp;
- char savetype = ' ';
+ char savetype = IoTYPE_CLOSED;
int writing = 0;
PerlIO *fp;
int fd;
int result;
bool was_fdopen = FALSE;
bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
+ char *type = NULL;
+ char *deftype = NULL;
+ char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
+ Zero(mode,sizeof(mode),char);
PL_forkprocess = 1; /* assume true if no fork */
+ /* Collect default raw/crlf info from the op */
if (PL_op && PL_op->op_type == OP_OPEN) {
/* set up disciplines */
U8 flags = PL_op->op_private;
out_crlf = (flags & OPpOPEN_OUT_CRLF);
}
+ /* If currently open - close before we re-open */
if (IoIFP(io)) {
fd = PerlIO_fileno(IoIFP(io));
if (IoTYPE(io) == IoTYPE_STD)
}
if (as_raw) {
+ /* sysopen style args, i.e. integer mode and permissions */
+
#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
rawmode |= O_LARGEFILE;
#endif
if (fd == -1)
fp = NULL;
else {
- char fpmode[4];
STRLEN ix = 0;
- if (result == O_RDONLY)
- fpmode[ix++] = 'r';
+ if (result == O_RDONLY) {
+ mode[ix++] = 'r';
+ }
#ifdef O_APPEND
else if (rawmode & O_APPEND) {
- fpmode[ix++] = 'a';
+ mode[ix++] = 'a';
if (result != O_WRONLY)
- fpmode[ix++] = '+';
+ mode[ix++] = '+';
}
#endif
else {
if (result == O_WRONLY)
- fpmode[ix++] = 'w';
+ mode[ix++] = 'w';
else {
- fpmode[ix++] = 'r';
- fpmode[ix++] = '+';
+ mode[ix++] = 'r';
+ mode[ix++] = '+';
}
}
if (rawmode & O_BINARY)
- fpmode[ix++] = 'b';
- fpmode[ix] = '\0';
- fp = PerlIO_fdopen(fd, fpmode);
+ mode[ix++] = 'b';
+ mode[ix] = '\0';
+ fp = PerlIO_fdopen(fd, mode);
if (!fp)
PerlLIO_close(fd);
}
}
else {
- char *type;
+ /* Regular (non-sys) open */
char *oname = name;
- STRLEN tlen;
STRLEN olen = len;
- char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
- int dodup;
+ char *tend;
+ int dodup = 0;
type = savepvn(name, len);
- tlen = len;
+ tend = type+len;
SAVEFREEPV(type);
+ /* Loose trailing white space */
+ 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;
name = SvPV(svs, l) ;
len = (I32)l;
name = savepvn(name, len);
SAVEFREEPV(name);
+ /*SUPPRESS 530*/
+ for (; isSPACE(*type); type++) ;
}
else {
- while (tlen && isSPACE(type[tlen-1]))
- type[--tlen] = '\0';
name = type;
- len = tlen;
+ len = tend-type;
}
- mode[0] = mode[1] = mode[2] = mode[3] = '\0';
IoTYPE(io) = *type;
- if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
+ if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */
mode[1] = *type++;
- --tlen;
writing = 1;
}
- if (*type == '|') {
- if (num_svs && (tlen != 2 || type[1] != '-')) {
- unknown_desr:
- Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
+ if (*type == IoTYPE_PIPE) {
+ if (num_svs) {
+ if (type[1] != IoTYPE_STD) {
+ unknown_desr:
+ Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
+ }
+ type++;
}
/*SUPPRESS 530*/
- for (type++, tlen--; isSPACE(*type); type++, tlen--) ;
+ for (type++; isSPACE(*type); type++) ;
if (!num_svs) {
name = type;
- len = tlen;
+ len = tend-type;
}
if (*name == '\0') { /* command is missing 19990114 */
dTHR;
if (strNE(name,"-") || num_svs)
TAINT_ENV();
TAINT_PROPER("piped open");
- if (name[len-1] == '|') {
+ if (!num_svs && name[len-1] == '|') {
dTHR;
name[--len] = '\0' ;
if (ckWARN(WARN_PIPE))
Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
}
- {
- char *mode;
- if (out_raw)
- mode = "wb";
- else if (out_crlf)
- mode = "wt";
- else
- mode = "w";
- fp = PerlProc_popen(name,mode);
- }
+ mode[0] = 'w';
writing = 1;
+ if (out_raw)
+ strcat(mode, "b");
+ else if (out_crlf)
+ strcat(mode, "t");
+ fp = PerlProc_popen(name,mode);
}
- else if (*type == '>') {
+ else if (*type == IoTYPE_WRONLY) {
TAINT_PROPER("open");
type++;
- if (*type == '>') {
+ if (*type == IoTYPE_WRONLY) {
+ /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
mode[0] = IoTYPE(io) = IoTYPE_APPEND;
type++;
- tlen--;
}
else
mode[0] = 'w';
else if (out_crlf)
strcat(mode, "t");
- if (num_svs && tlen != 1)
- goto unknown_desr;
if (*type == '&') {
name = type;
duplicity:
+ if (num_svs)
+ goto unknown_desr;
dodup = 1;
name++;
if (*name == '=') {
* be optimized away on most platforms;
* only Solaris and Linux seem to flush
* on that. --jhi */
- PerlIO_seek(fp, 0, SEEK_CUR);
+#ifdef USE_SFIO
+ /* sfio fails to clear error on next
+ sfwrite, contrary to documentation.
+ -- Nick Clark */
+ if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
+ PerlIO_clearerr(fp);
+#endif
/* On the other hand, do all platforms
* take gracefully to flushing a read-only
* filehandle? Perhaps we should do
else {
/*SUPPRESS 530*/
for (; isSPACE(*type); type++) ;
- if (strEQ(type,"-")) {
+ if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
+ /*SUPPRESS 530*/
+ type++;
fp = PerlIO_stdout();
IoTYPE(io) = IoTYPE_STD;
}
}
}
}
- else if (*type == '<') {
- if (num_svs && tlen != 1)
- goto unknown_desr;
+ else if (*type == IoTYPE_RDONLY) {
/*SUPPRESS 530*/
for (type++; isSPACE(*type); type++) ;
mode[0] = 'r';
name = type;
goto duplicity;
}
- if (strEQ(type,"-")) {
+ if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
+ /*SUPPRESS 530*/
+ type++;
fp = PerlIO_stdin();
IoTYPE(io) = IoTYPE_STD;
}
else
fp = PerlIO_open((num_svs ? name : type), mode);
}
- else if (tlen > 1 && type[tlen-1] == '|') {
+ else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
+ (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
if (num_svs) {
- if (tlen != 2 || type[0] != '-')
- goto unknown_desr;
+ type += 2; /* skip over '-|' */
}
else {
- type[--tlen] = '\0';
- while (tlen && isSPACE(type[tlen-1]))
- type[--tlen] = '\0';
+ *--tend = '\0';
+ while (tend > type && isSPACE(tend[-1]))
+ *--tend = '\0';
/*SUPPRESS 530*/
for (; isSPACE(*type); type++) ;
name = type;
+ len = tend-type;
}
if (*name == '\0') { /* command is missing 19990114 */
dTHR;
if (strNE(name,"-") || num_svs)
TAINT_ENV();
TAINT_PROPER("piped open");
- {
- char *mode;
- if (in_raw)
- mode = "rb";
- else if (in_crlf)
- mode = "rt";
- else
- mode = "r";
- fp = PerlProc_popen(name,mode);
- }
+ mode[0] = 'r';
+ if (in_raw)
+ strcat(mode, "b");
+ else if (in_crlf)
+ strcat(mode, "t");
+ fp = PerlProc_popen(name,mode);
IoTYPE(io) = IoTYPE_PIPE;
}
else {
IoTYPE(io) = IoTYPE_RDONLY;
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
+ mode[0] = 'r';
+ if (in_raw)
+ strcat(mode, "b");
+ else if (in_crlf)
+ strcat(mode, "t");
if (strEQ(name,"-")) {
fp = PerlIO_stdin();
IoTYPE(io) = IoTYPE_STD;
}
else {
- char *mode;
- if (in_raw)
- mode = "rb";
- else if (in_crlf)
- mode = "rt";
- else
- mode = "r";
fp = PerlIO_open(name,mode);
}
}
Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
goto say_false;
}
- if (IoTYPE(io) &&
- IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
+ if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
dTHR;
if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
(void)PerlIO_close(fp);
}
#endif
IoIFP(io) = fp;
+ if (!num_svs) {
+ /* Need to supply default type info from open.pm */
+ SV *layers = PL_curcop->cop_io;
+ type = NULL;
+ if (layers) {
+ STRLEN len;
+ type = SvPV(layers,len);
+ if (type && mode[0] != 'r') {
+ /* Skip to write part */
+ char *s = strchr(type,0);
+ if (s && (s-type) < len) {
+ type = s+1;
+ }
+ }
+ }
+ else if (O_BINARY != O_TEXT) {
+ type = ":crlf";
+ }
+ }
+ if (type) {
+ while (isSPACE(*type)) type++;
+ if (*type) {
+ if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) {
+ goto say_false;
+ }
+ }
+ }
+
IoFLAGS(io) &= ~IOf_NOLINE;
if (writing) {
dTHR;
if (IoTYPE(io) == IoTYPE_SOCKET
|| (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
{
- char *mode;
- if (out_raw)
- mode = "wb";
- else if (out_crlf)
- mode = "wt";
- else
- mode = "w";
-
+ mode[0] = 'w';
if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) {
PerlIO_close(fp);
IoIFP(io) = Nullfp;
goto say_false;
}
+ if (type && *type) {
+ if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) {
+ PerlIO_close(IoOFP(io));
+ PerlIO_close(fp);
+ IoIFP(io) = Nullfp;
+ IoOFP(io) = Nullfp;
+ goto say_false;
+ }
+ }
}
else
IoOFP(io) = fp;
#if !defined(DOSISH) && !defined(__CYGWIN__)
if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
if (ckWARN_d(WARN_INPLACE))
- Perl_warner(aTHX_ WARN_INPLACE,
+ Perl_warner(aTHX_ WARN_INPLACE,
"Can't rename %s to %s: %s, skipping file",
PL_oldname, SvPVX(sv), Strerror(errno) );
do_close(gv,FALSE);
|| IoIFP(io) == PerlIO_stderr()))
{
/* integrate to report_evil_fh()? */
- char *name = NULL;
+ char *name = NULL;
if (isGV(gv)) {
SV* sv = sv_newmortal();
gv_efullname4(sv, gv, Nullch, FALSE);
(void)PerlIO_ungetc(IoIFP(io),ch);
return FALSE;
}
+
if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
if (PerlIO_get_cnt(IoIFP(io)) < -1)
PerlIO_set_cnt(IoIFP(io),-1);
}
/* FALL THROUGH */
default:
+#if 0
+ /* XXX Fix this when the I/O disciplines arrive. XXX */
+ if (DO_UTF8(sv))
+ sv_utf8_downgrade(sv, FALSE);
+#endif
tmps = SvPV(sv, len);
break;
}
* but only until the system hard limit/the filesystem limit,
* at which we would get EPERM. Note that when using buffered
* io the write failure can be delayed until the flush/close. --jhi */
- if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
+ if (len && (PerlIO_write(fp,tmps,len) == 0))
return FALSE;
return !PerlIO_error(fp);
}
else
PerlProc_execvp(PL_Argv[0],PL_Argv);
if (ckWARN(WARN_EXEC))
- Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
+ Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
PL_Argv[0], Strerror(errno));
if (do_report) {
int e = errno;
int e = errno;
if (ckWARN(WARN_EXEC))
- Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
+ Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
PL_Argv[0], Strerror(errno));
if (do_report) {
PerlLIO_write(fd, (void*)&e, sizeof(int));
}
break;
#endif
-/*
+/*
XXX Should we make lchown() directly available from perl?
For now, we'll let Configure test for HAS_LCHOWN, but do
nothing in the core.
flags = SvIVx(*++mark);
SvPV_force(mstr, len);
mbuf = SvGROW(mstr, sizeof(long)+msize+1);
-
+
SETERRNO(0,0);
ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
if (ret >= 0) {
#endif /* SYSV IPC */
+#ifdef SOCKS_64BIT_BUG
+
+/**
+ ** getc and ungetc wrappers for the 64 bit problems with SOCKS 5 support
+ ** Workaround to the problem, that SOCKS maps a socket 'getc' to revc
+ ** without checking the ungetc buffer.
+ **/
+
+static S64_IOB *s64_buffer = (S64_IOB *) NULL;
+
+/* get a buffered stream pointer */
+static S64_IOB *S_s64_get_buffer( PerlIO *fp) {
+ S64_IOB *ptr = s64_buffer;
+ while( ptr && ptr->fp != fp)
+ ptr = ptr->next;
+ return( ptr);
+}
+
+/* create a buffered stream pointer */
+static S64_IOB *_s64_create_buffer( PerlIO *f) {
+ S64_IOB *ptr = malloc( sizeof( S64_IOB));
+ if( ptr) {
+ ptr->fp = f;
+ ptr->cnt = ptr->size = 0;
+ ptr->buffer = (int *) NULL;
+ ptr->next = s64_buffer;
+ ptr->last = (S64_IOB *) NULL;
+ if( s64_buffer) s64_buffer->last = ptr;
+ s64_buffer = ptr;
+ }
+ return( ptr);
+}
+
+/* delete a buffered stream pointer */
+void Perl_do_s64_delete_buffer( PerlIO *f) {
+ S64_IOB *ptr = _s64_get_buffer(f);
+ if( ptr) {
+ /* fix the stream pointer according to the bytes buffered */
+ /* required, if this is called in a seek-context */
+ if( ptr->cnt) fseek(f,-ptr->cnt,SEEK_CUR);
+ if( ptr->buffer) free( ptr->buffer);
+ if( ptr->last)
+ ptr->last->next = ptr->next;
+ else
+ s64_buffer = ptr->next;
+ free( ptr);
+ }
+}
+
+/* internal buffer management */
+#define _S64_BUFFER_SIZE 32
+static int _s64_malloc( S64_IOB *ptr) {
+ if( ptr) {
+ if( !ptr->buffer) {
+ ptr->buffer = (int *) calloc( _S64_BUFFER_SIZE, sizeof( int));
+ ptr->size = ptr->cnt = 0;
+ } else {
+ ptr->buffer = (int *) realloc( ptr->buffer, ptr->size + _S64_BUFFER_SIZE);
+ }
+
+ if( !ptr->buffer)
+ return( 0);
+
+ ptr->size += _S64_BUFFER_SIZE;
+
+ return( 1);
+ }
+
+ return( 0);
+}
+
+/* SOCKS 64 bit getc replacement */
+int Perl_do_s64_getc( PerlIO *f) {
+ S64_IOB *ptr = _s64_get_buffer(f);
+ if( ptr) {
+ if( ptr->cnt)
+ return( ptr->buffer[--ptr->cnt]);
+ }
+ return( getc(f));
+}
+
+/* SOCKS 64 bit ungetc replacement */
+int Perl_do_s64_ungetc( int ch, PerlIO *f) {
+ S64_IOB *ptr = _s64_get_buffer(f);
+
+ if( !ptr) ptr=_s64_create_buffer(f);
+ if( !ptr) return( EOF);
+ if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size))
+ if( !_s64_malloc( ptr)) return( EOF);
+ ptr->buffer[ptr->cnt++] = ch;
+
+ return( ch);
+}
+
+/* SOCKS 64 bit fread replacement */
+SSize_t Perl_do_s64_fread(void *buf, SSize_t count, PerlIO* f) {
+ SSize_t len = 0;
+ char *bufptr = (char *) buf;
+ S64_IOB *ptr = _s64_get_buffer(f);
+ if( ptr) {
+ while( ptr->cnt && count) {
+ *bufptr++ = ptr->buffer[--ptr->cnt];
+ count--, len++;
+ }
+ }
+ if( count)
+ len += (SSize_t)fread(bufptr,1,count,f);
+
+ return( len);
+}
+
+/* SOCKS 64 bit fseek replacement */
+int Perl_do_s64_seek(PerlIO* f, Off_t offset, int whence) {
+ S64_IOB *ptr = _s64_get_buffer(f);
+
+ /* Simply clear the buffer and seek if the position is absolute */
+ if( SEEK_SET == whence || SEEK_END == whence) {
+ if( ptr) ptr->cnt = 0;
+
+ /* In case of relative positioning clear the buffer and calculate */
+ /* a fixed offset */
+ } else if( SEEK_CUR == whence) {
+ if( ptr) {
+ offset -= (Off_t)ptr->cnt;
+ ptr->cnt = 0;
+ }
+ }
+
+ /* leave out buffer untouched otherwise, because fseek will fail */
+ /* seek now */
+ return( fseeko( f, offset, whence));
+}
+
+/* SOCKS 64 bit ftell replacement */
+Off_t Perl_do_s64_tell(PerlIO* f) {
+ Off_t offset = 0;
+ S64_IOB *ptr = _s64_get_buffer(f);
+ if( ptr)
+ offset = ptr->cnt;
+ return( ftello(f) - offset);
+}
+
+#endif
projects / p5sagit/p5-mst-13.2.git / blobdiff