diff options
| -rwxr-xr-x | Configure | 40 | ||||
| -rw-r--r-- | doio.c | 174 | ||||
| -rw-r--r-- | embed.h | 43 | ||||
| -rwxr-xr-x | embed.pl | 12 | ||||
| -rw-r--r-- | makedef.pl | 13 | ||||
| -rw-r--r-- | perl.h | 13 | ||||
| -rw-r--r-- | perlio.c | 6 | ||||
| -rw-r--r-- | perlio.h | 3 | ||||
| -rw-r--r-- | perlsdio.h | 33 | ||||
| -rw-r--r-- | proto.h | 12 | ||||
| -rwxr-xr-x | t/lib/io_sock.t | 130 |
11 files changed, 175 insertions, 304 deletions
@@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Tue Nov 21 20:33:35 EET 2000 [metaconfig 3.0 PL70] +# Generated on Sat Nov 25 20:16:14 EET 2000 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >/tmp/c1$$ <<EOF @@ -3673,7 +3673,8 @@ esac cat <<EOM Perl can be built to use the SOCKS proxy protocol library. To do so, -Configure must be run with -Dusesocks. +Configure must be run with -Dusesocks. If you use SOCKS you also need +to use the PerlIO abstraction layer, this will be implicitly selected. If this doesn't make any sense to you, just accept the default '$dflt'. EOM @@ -3686,6 +3687,10 @@ esac set usesocks eval $setvar +case "$usesocks" in +$define|true|[yY]*) useperlio="$define";; +esac + : Looking for optional libraries echo " " echo "Checking for optional libraries..." >&4 @@ -7428,13 +7433,12 @@ $define|true|[yY]*) dflt='y';; esac cat <<EOM -Previous version of $package used the standard IO mechanisms as defined -in <stdio.h>. Versions 5.003_02 and later of perl allow alternate IO -mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still -the default. This abstraction layer can use AT&T's sfio (if you already -have sfio installed) or regular stdio. Using PerlIO with sfio may cause -problems with some extension modules. Using PerlIO with stdio is safe, -but it is slower than plain stdio and therefore is not the default. +Previous version of $package used the standard IO mechanisms as +defined in <stdio.h>. Versions 5.003_02 and later of perl allow +alternate IO mechanisms via the PerlIO abstraction layer, but the +stdio mechanism is still the default. This abstraction layer can +use AT&T's sfio (if you already have sfio installed) or regular stdio. +Using PerlIO with sfio may cause problems with some extension modules. If this doesn't make any sense to you, just accept the default '$dflt'. EOM @@ -7445,13 +7449,29 @@ y|Y) val="$define" ;; *) - echo "Ok, doing things the stdio way" + echo "Ok, doing things the stdio way." val="$undef" ;; esac set useperlio eval $setvar +case "$usesocks" in +$define|true|[yY]*) + case "$useperlio" in + $define|true|[yY]*) ;; + *) cat >&4 <<EOM + +You are using the SOCKS proxy protocol library which means that you +should also use the PerlIO layer. You may be headed for trouble. + +EOM + ;; + esac + ;; +esac + + case "$vendorprefix" in '') d_vendorbin="$undef" vendorbin='' @@ -2039,177 +2039,3 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #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. - **/ - -/* Not threadsafe? */ -static S64_IOB *s64_buffer = (S64_IOB *) NULL; - -/* initialize the buffer area */ -/* required after a fork(2) call in order to remove side effects */ -void -Perl_do_s64_init_buffer(void) -{ - s64_buffer = (S64_IOB *) NULL; -} - -/* get a buffered stream pointer */ -STATIC S64_IOB* -S_s64_get_buffer(pTHX_ 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* -S_s64_create_buffer(pTHX_ 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(pTHX_ PerlIO *f) -{ - S64_IOB *ptr = S_s64_get_buffer(aTHX_ 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 -S_s64_malloc(pTHX_ 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(pTHX_ PerlIO *f) -{ - S64_IOB *ptr = S_s64_get_buffer(aTHX_ f); - if( ptr) { - if( ptr->cnt) - return( ptr->buffer[--ptr->cnt]); - } - return( getc(f)); -} - -/* SOCKS 64 bit ungetc replacement */ -int -Perl_do_s64_ungetc(pTHX_ int ch, PerlIO *f) -{ - S64_IOB *ptr = S_s64_get_buffer(aTHX_ f); - - if( !ptr) ptr = S_s64_create_buffer(aTHX_ f); - if( !ptr) return( EOF); - if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size)) - if( !S_s64_malloc(aTHX_ ptr)) return( EOF); - ptr->buffer[ptr->cnt++] = ch; - - return( ch); -} - -/* SOCKS 64 bit fread replacement */ -SSize_t -Perl_do_s64_fread(pTHX_ void *buf, SSize_t count, PerlIO* f) -{ - SSize_t len = 0; - char *bufptr = (char *) buf; - S64_IOB *ptr = S_s64_get_buffer(aTHX_ 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(pTHX_ PerlIO* f, Off_t offset, int whence) -{ - S64_IOB *ptr = S_s64_get_buffer(aTHX_ 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(pTHX_ PerlIO* f) -{ - Off_t offset = 0; - S64_IOB *ptr = S_s64_get_buffer(aTHX_ f); - if( ptr) - offset = ptr->cnt; - return( ftello(f) - offset); -} - -#endif /* SOCKS_64BIT_BUG */ - @@ -193,17 +193,6 @@ #define do_vecget Perl_do_vecget #define do_vecset Perl_do_vecset #define do_vop Perl_do_vop -#if defined(SOCKS_64BIT_BUG) -#define do_s64_tell Perl_do_s64_tell -#define do_s64_fread Perl_do_s64_fread -#define do_s64_getc Perl_do_s64_getc -#define do_s64_seek Perl_do_s64_seek -#define do_s64_ungetc Perl_do_s64_ungetc -#define do_s64_delete_buffer Perl_do_s64_delete_buffer -#define s64_get_buffer S_s64_get_buffer -#define s64_create_buffer S_s64_create_buffer -#define s64_malloc S_s64_malloc -#endif #define dofile Perl_dofile #define dowantarray Perl_dowantarray #define dump_all Perl_dump_all @@ -1672,17 +1661,6 @@ #define do_vecget(a,b,c) Perl_do_vecget(aTHX_ a,b,c) #define do_vecset(a) Perl_do_vecset(aTHX_ a) #define do_vop(a,b,c,d) Perl_do_vop(aTHX_ a,b,c,d) -#if defined(SOCKS_64BIT_BUG) -#define do_s64_tell(a) Perl_do_s64_tell(aTHX_ a) -#define do_s64_fread(a,b,c) Perl_do_s64_fread(aTHX_ a,b,c) -#define do_s64_getc(a) Perl_do_s64_getc(aTHX_ a) -#define do_s64_seek(a,b,c) Perl_do_s64_seek(aTHX_ a,b,c) -#define do_s64_ungetc(a,b) Perl_do_s64_ungetc(aTHX_ a,b) -#define do_s64_delete_buffer(a) Perl_do_s64_delete_buffer(aTHX_ a) -#define s64_get_buffer(a) S_s64_get_buffer(aTHX_ a) -#define s64_create_buffer(a) S_s64_create_buffer(aTHX_ a) -#define s64_malloc(a) S_s64_malloc(aTHX_ a) -#endif #define dofile(a) Perl_dofile(aTHX_ a) #define dowantarray() Perl_dowantarray(aTHX) #define dump_all() Perl_dump_all(aTHX) @@ -3277,27 +3255,6 @@ #define do_vecset Perl_do_vecset #define Perl_do_vop CPerlObj::Perl_do_vop #define do_vop Perl_do_vop -#if defined(SOCKS_64BIT_BUG) -#define Perl_do_s64_tell CPerlObj::Perl_do_s64_tell -#define do_s64_tell Perl_do_s64_tell -#define Perl_do_s64_fread CPerlObj::Perl_do_s64_fread -#define do_s64_fread Perl_do_s64_fread -#define Perl_do_s64_getc CPerlObj::Perl_do_s64_getc -#define do_s64_getc Perl_do_s64_getc -#define Perl_do_s64_seek CPerlObj::Perl_do_s64_seek -#define do_s64_seek Perl_do_s64_seek -#define Perl_do_s64_ungetc CPerlObj::Perl_do_s64_ungetc -#define do_s64_ungetc Perl_do_s64_ungetc -#define Perl_do_s64_delete_buffer CPerlObj::Perl_do_s64_delete_buffer -#define do_s64_delete_buffer Perl_do_s64_delete_buffer -#define do_s64_init_buffer Perl_do_s64_init_buffer -#define S_s64_get_buffer CPerlObj::S_s64_get_buffer -#define s64_get_buffer S_s64_get_buffer -#define S_s64_create_buffer CPerlObj::S_s64_create_buffer -#define s64_create_buffer S_s64_create_buffer -#define S_s64_malloc CPerlObj::S_s64_malloc -#define s64_malloc S_s64_malloc -#endif #define Perl_dofile CPerlObj::Perl_dofile #define dofile Perl_dofile #define Perl_dowantarray CPerlObj::Perl_dowantarray @@ -1505,18 +1505,6 @@ p |I32 |do_trans |SV* sv p |UV |do_vecget |SV* sv|I32 offset|I32 size p |void |do_vecset |SV* sv p |void |do_vop |I32 optype|SV* sv|SV* left|SV* right -#if defined(SOCKS_64BIT_BUG) -p |Off_t |do_s64_tell |PerlIO* fp -p |SSize_t|do_s64_fread |void *buf|SSize_t count|PerlIO* fp -p |int |do_s64_getc |PerlIO* fp -p |int |do_s64_seek |PerlIO* fp|Off_t pos|int whence -p |int |do_s64_ungetc |int ch|PerlIO* fp -p |void |do_s64_delete_buffer|PerlIO* fp -Ajnop |void |do_s64_init_buffer -s |S64_IOB * |s64_get_buffer |PerlIO *f -s |S64_IOB * |s64_create_buffer |PerlIO *f -s |int |s64_malloc |S64_IOB *ptr -#endif p |OP* |dofile |OP* term Ap |I32 |dowantarray Ap |void |dump_all diff --git a/makedef.pl b/makedef.pl index 4de7c26f9a..3e0271ab7a 100644 --- a/makedef.pl +++ b/makedef.pl @@ -476,19 +476,6 @@ unless ($define{'FAKE_THREADS'}) { skip_symbols [qw(PL_curthr)]; } -# All quad int platforms are assumed to have broken SOCKS -unless ($define{USE_SOCKS} && $define{USE_64_BIT_ALL}) { - skip_symbols [qw( - Perl_do_s64_delete_buffer - Perl_do_s64_fread - Perl_do_s64_getc - Perl_do_s64_init_buffer - Perl_do_s64_seek - Perl_do_s64_tell - Perl_do_s64_ungetc - )]; -} - sub readvar { my $file = shift; my $proc = shift || sub { "PL_$_[2]" }; @@ -737,9 +737,6 @@ typedef struct perl_mstats perl_mstats_t; # undef INCLUDE_PROTOTYPES # undef PERL_SOCKS_NEED_PROTOTYPES # endif -# ifdef USE_64_BIT_ALL -# define SOCKS_64BIT_BUG /* until proven otherwise */ -# endif # endif # ifdef I_NETDB # include <netdb.h> @@ -2819,16 +2816,6 @@ typedef void *Thread; #define PERL_CKDEF(s) OP *s (pTHX_ OP *o); #define PERL_PPDEF(s) OP *s (pTHX); -#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; -#endif - #include "proto.h" #ifdef PERL_OBJECT @@ -1368,8 +1368,12 @@ PerlIOStdio_tell(PerlIO *f) IV PerlIOStdio_close(PerlIO *f) { + int optval, optlen = sizeof(int); FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return fclose(stdio); + return( + (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? + fclose(stdio) : + close(PerlIO_fileno(f))); } IV @@ -303,7 +303,8 @@ extern int PerlIO_getpos (PerlIO *,Fpos_t *); extern int PerlIO_setpos (PerlIO *,const Fpos_t *); #endif #ifndef PerlIO_fdupopen -extern PerlIO * PerlIO_fdupopen (PerlIO *); +#define PerlIO_fdupopen(f) (f) +/* extern PerlIO * PerlIO_fdupopen (PerlIO *); */ #endif #ifndef PerlIO_isutf8 extern int PerlIO_isutf8 (PerlIO *); diff --git a/perlsdio.h b/perlsdio.h index 7895d310b0..aaedec4541 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -18,11 +18,7 @@ #define PerlIO_open fopen #define PerlIO_fdopen fdopen #define PerlIO_reopen freopen -#ifdef SOCKS_64BIT_BUG -# define PerlIO_close(f) (Perl_do_s64_delete_buffer(aTHX_ f), fclose(f)) -#else -# define PerlIO_close(f) fclose(f) -#endif +#define PerlIO_close(f) fclose(f) #define PerlIO_puts(f,s) fputs(s,f) #define PerlIO_putc(f,c) fputc(c,f) #if defined(VMS) @@ -47,17 +43,10 @@ (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f)) # define PerlIO_tell(f) ftell(f) #else -# ifdef SOCKS_64BIT_BUG -# define PerlIO_getc(f) Perl_do_s64_getc(aTHX_ f) -# define PerlIO_ungetc(f,c) Perl_do_s64_ungetc(aTHX_ c,f) -# define PerlIO_read(f,buf,count) Perl_do_s64_fread(aTHX_ buf,count,f) -# define PerlIO_tell(f) Perl_do_s64_tell(aTHX_ f) -# else -# define PerlIO_getc(f) getc(f) -# define PerlIO_ungetc(f,c) ungetc(c,f) -# define PerlIO_read(f,buf,count) (SSize_t)fread(buf,1,count,f) -# define PerlIO_tell(f) ftell(f) -# endif /* SOCKS_64BIT_BUG */ +# define PerlIO_getc(f) getc(f) +# define PerlIO_ungetc(f,c) ungetc(c,f) +# define PerlIO_read(f,buf,count) (SSize_t)fread(buf,1,count,f) +# define PerlIO_tell(f) ftell(f) #endif #define PerlIO_eof(f) feof(f) #define PerlIO_getname(f,b) fgetname(f,b) @@ -65,15 +54,11 @@ #define PerlIO_fileno(f) fileno(f) #define PerlIO_clearerr(f) clearerr(f) #define PerlIO_flush(f) Fflush(f) -#ifdef SOCKS_64BIT_BUG -# define PerlIO_seek(f,o,w) Perl_do_s64_seek(aTHX_ f,o,w) +#if defined(VMS) && !defined(__DECC) +/* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ +#define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) #else -# if defined(VMS) && !defined(__DECC) - /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ -# define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) -# else -# define PerlIO_seek(f,o,w) fseek(f,o,w) -# endif +# define PerlIO_seek(f,o,w) fseek(f,o,w) #endif #ifdef HAS_FGETPOS #define PerlIO_getpos(f,p) fgetpos(f,p) @@ -247,18 +247,6 @@ PERL_CALLCONV I32 Perl_do_trans(pTHX_ SV* sv); PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, I32 offset, I32 size); PERL_CALLCONV void Perl_do_vecset(pTHX_ SV* sv); PERL_CALLCONV void Perl_do_vop(pTHX_ I32 optype, SV* sv, SV* left, SV* right); -#if defined(SOCKS_64BIT_BUG) -PERL_CALLCONV Off_t Perl_do_s64_tell(pTHX_ PerlIO* fp); -PERL_CALLCONV SSize_t Perl_do_s64_fread(pTHX_ void *buf, SSize_t count, PerlIO* fp); -PERL_CALLCONV int Perl_do_s64_getc(pTHX_ PerlIO* fp); -PERL_CALLCONV int Perl_do_s64_seek(pTHX_ PerlIO* fp, Off_t pos, int whence); -PERL_CALLCONV int Perl_do_s64_ungetc(pTHX_ int ch, PerlIO* fp); -PERL_CALLCONV void Perl_do_s64_delete_buffer(pTHX_ PerlIO* fp); -PERL_CALLCONV void Perl_do_s64_init_buffer(void); -STATIC S64_IOB * S_s64_get_buffer(pTHX_ PerlIO *f); -STATIC S64_IOB * S_s64_create_buffer(pTHX_ PerlIO *f); -STATIC int S_s64_malloc(pTHX_ S64_IOB *ptr); -#endif PERL_CALLCONV OP* Perl_dofile(pTHX_ OP* term); PERL_CALLCONV I32 Perl_dowantarray(pTHX); PERL_CALLCONV void Perl_dump_all(pTHX); diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 4ac4e352ce..38292a7a59 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -30,7 +30,7 @@ BEGIN { } $| = 1; -print "1..14\n"; +print "1..20\n"; use IO::Socket; @@ -203,3 +203,131 @@ print "ok 13\n"; $server->blocking(0); print "not " if $server->blocking; print "ok 14\n"; + +### TEST 15 +### Set up some data to be transfered between the server and +### the client. We'll use own source code ... +# +local @data; +if( !open( SRC, "< $0")) { + print "not ok 15 - $!"; +} else { + @data = <SRC>; + close( SRC); +} +print "ok 15\n"; + +### TEST 16 +### Start the server +# +my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || + print "not "; +print "ok 16\n"; +die if( !defined( $listen)); +my $serverport = $listen->sockport; + +my $server_pid = fork(); +if( $server_pid) { + + ### TEST 17 Client/Server establishment + # + print "ok 17\n"; + + ### TEST 18 + ### Get data from the server using a single stream + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( <$sock>) { + push( @array, $_); + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 18\n"; + + ### TEST 19 + ### Get data from the server using a stream, which is + ### interrupted by eof calls. + ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof + ### did an getc followed by an ungetc in order to check for the streams + ### end. getc(3) got replaced by the SOCKS funktion, which ended up in + ### a recv(2) call on the socket, while ungetc(3) put back a character + ### to an IO buffer, which never again was read. + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( !eof( $sock ) ){ + while( <$sock>) { + push( @array, $_); + last; + } + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 19\n"; + + ### TEST 20 + ### Stop the server + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("done\n"); + $sock->close; + + print "not " if( 1 != kill 0, $server_pid); + } else { + print "not "; + } + print "ok 20\n"; + +} elsif( defined( $server_pid)) { + + ### Child + # + SERVER_LOOP: while (1) { + last SERVER_LOOP unless $sock = $listen->accept; + while (<$sock>) { + last SERVER_LOOP if /^quit/; + last if /^done/; + if( /^send/) { + print $sock @data; + last; + } + print; + } + $sock = undef; + } + $listen->close; + +} else { + + ### Fork failed + # + print "not ok 17\n"; + die; +} + |