development/chicken: Updated for version 4.8.0.4.

Signed-off-by: Robby Workman <rworkman@slackbuilds.org>

1 files changed, 309 insertions, 0 deletions

diff --git a/development/chicken/patches/04_all_CVE-2013-2075_2.patch b/development/chicken/patches/04_all_CVE-2013-2075_2.patch
new file mode 100644
index 0000000000..b85ea7c8b2
--- /dev/null
+++ b/development/chicken/patches/04_all_CVE-2013-2075_2.patch
@@ -0,0 +1,309 @@
+From http://code.call-cc.org/cgi-bin/gitweb.cgi?p=chicken-core.git;a=commitdiff;h=556108092774086b6c86c2e27daf3f740ffec091
+
+--- chicken-4.8.0.3/chicken.h
++++ chicken-4.8.0.3/chicken.h
+@@ -1668,6 +1668,7 @@
+ C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
+ C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
+ C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
++C_fctexport int C_fcall C_check_fd_ready(int fd) C_regparm;
+ C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
+ C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
+ C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
+--- chicken-4.8.0.3/posixunix.scm
++++ chicken-4.8.0.3/posixunix.scm
+@@ -493,16 +493,7 @@
+     "if(val == -1) C_return(0);"
+     "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
+ 
+-(define ##sys#file-select-one
+-  (foreign-lambda* int ([int fd])
+-    "fd_set in;"
+-    "struct timeval tm;"
+-    "FD_ZERO(&in);"
+-    "FD_SET(fd, &in);"
+-    "tm.tv_sec = tm.tv_usec = 0;"
+-    "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) C_return(-1);"
+-    "else C_return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
+-
++(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )
+ 
+ ;;; Lo-level I/O:
+ 
+--- chicken-4.8.0.3/runtime.c
++++ chicken-4.8.0.3/runtime.c
+@@ -60,6 +60,11 @@
+ # define EOVERFLOW  0
+ #endif
+ 
++/* TODO: Include sys/select.h? Windows doesn't seem to have it... */
++#ifdef HAVE_POSIX_POLL
++#  include <poll.h>
++#endif
++
+ #if !defined(C_NONUNIX)
+ 
+ # include <sys/types.h>
+@@ -4036,20 +4041,39 @@
+   return C_fix(n);
+ }
+ 
++/*
++ * TODO: Implement something for Windows that supports selecting on
++ * arbitrary fds (there, select() only works on network sockets and
++ * poll() is not available at all).
++ */
++C_regparm int C_fcall C_check_fd_ready(int fd)
++{
++#ifdef HAVE_POSIX_POLL
++  struct pollfd ps;
++  ps.fd = fd;
++  ps.events = POLLIN;
++  return poll(&ps, 1, 0);
++#else
++  fd_set in;
++  struct timeval tm;
++  int rv;
++  FD_ZERO(&in);
++  FD_SET(fd, &in);
++  tm.tv_sec = tm.tv_usec = 0;
++  rv = select(fd + 1, &in, NULL, NULL, &tm);
++  if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
++  return rv;
++#endif
++}
+ 
+ C_regparm C_word C_fcall C_char_ready_p(C_word port)
+ {
+-#if !defined(C_NONUNIX)
+-  fd_set fs;
+-  struct timeval to;
+-  int fd = C_fileno(C_port_file(port));
+-
+-  FD_ZERO(&fs);
+-  FD_SET(fd, &fs);
+-  to.tv_sec = to.tv_usec = 0;
+-  return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
+-#else
++#if defined(C_NONUNIX)
++  /* The best we can currently do on Windows... */
+   return C_SCHEME_TRUE;
++#else
++  int fd = C_fileno(C_port_file(port));
++  return C_mk_bool(C_check_fd_ready(fd) == 1);
+ #endif
+ }
+ 
+--- chicken-4.8.0.3/tcp.scm
++++ chicken-4.8.0.3/tcp.scm
+@@ -46,6 +46,7 @@
+ # define fcntl(a, b, c)  0
+ # define EWOULDBLOCK     0
+ # define EINPROGRESS     0
++# define EAGAIN          0
+ # define typecorrect_getsockopt(socket, level, optname, optval, optlen)	\
+     getsockopt(socket, level, optname, (char *)optval, optlen)
+ #else
+@@ -111,6 +112,7 @@
+ (define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
+ (define ##net#shutdown (foreign-lambda int "shutdown" int int))
+ (define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
++(define ##net#check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
+ 
+ (define ##net#send
+   (foreign-lambda* 
+@@ -177,30 +179,6 @@
+      if((se = getservbyname(serv, proto)) == NULL) C_return(0);
+      else C_return(ntohs(se->s_port));") )     
+ 
+-(define ##net#select
+-  (foreign-lambda* int ((int fd))
+-    "fd_set in;
+-     struct timeval tm;
+-     int rv;
+-     FD_ZERO(&in);
+-     FD_SET(fd, &in);
+-     tm.tv_sec = tm.tv_usec = 0;
+-     rv = select(fd + 1, &in, NULL, NULL, &tm);
+-     if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
+-     C_return(rv);") )
+-
+-(define ##net#select-write
+-  (foreign-lambda* int ((int fd))
+-    "fd_set out;
+-     struct timeval tm;
+-     int rv;
+-     FD_ZERO(&out);
+-     FD_SET(fd, &out);
+-     tm.tv_sec = tm.tv_usec = 0;
+-     rv = select(fd + 1, NULL, &out, NULL, &tm);
+-     if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
+-     C_return(rv);") )
+-
+ (define ##net#gethostaddr
+   (foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
+     "struct hostent *he = gethostbyname(host);"
+@@ -212,13 +190,6 @@
+     "addr->sin_addr = *((struct in_addr *)he->h_addr);"
+     "C_return(1);") )
+ 
+-(define (yield)
+-  (##sys#call-with-current-continuation
+-   (lambda (return)
+-     (let ((ct ##sys#current-thread))
+-       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+-       (##sys#schedule) ) ) ) )
+-
+ (define ##net#parse-host
+   (let ((substring substring))
+     (lambda (host proto)
+@@ -343,7 +314,9 @@
+ 	     (outbufsize (tbs))
+ 	     (outbuf (and outbufsize (fx> outbufsize 0) ""))
+ 	     (tmr (tcp-read-timeout))
++             (dlr (and tmr (+ (current-milliseconds) tmr)))
+ 	     (tmw (tcp-write-timeout))
++             (dlw (and tmw (+ (current-milliseconds) tmw)))
+ 	     (read-input
+ 	      (lambda ()
+ 		(let loop ()
+@@ -351,12 +324,11 @@
+ 		    (cond ((eq? -1 n)
+ 			   (cond ((or (eq? errno _ewouldblock) 
+ 				      (eq? errno _eagain))
+-				  (when tmr
+-				    (##sys#thread-block-for-timeout! 
+-				     ##sys#current-thread
+-				     (+ (current-milliseconds) tmr) ) )
++				  (when dlr
++				    (##sys#thread-block-for-timeout!
++                                     ##sys#current-thread dlr) )
+ 				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+-				  (yield)
++                                  (##sys#thread-yield!)
+ 				  (when (##sys#slot ##sys#current-thread 13)
+ 				    (##sys#signal-hook
+ 				     #:network-timeout-error
+@@ -386,7 +358,7 @@
+ 		       c) ) )
+ 	       (lambda ()
+ 		 (or (fx< bufindex buflen)
+-		     (let ((f (##net#select fd)))
++		     (let ((f (##net#check-fd-ready fd)))
+ 		       (when (eq? f -1)
+ 			 (##sys#update-errno)
+ 			 (##sys#signal-hook
+@@ -469,12 +441,11 @@
+ 		    (cond ((eq? -1 n)
+ 			   (cond ((or (eq? errno _ewouldblock)
+ 				      (eq? errno _eagain))
+-				  (when tmw
++				  (when dlw
+ 				    (##sys#thread-block-for-timeout! 
+-				     ##sys#current-thread
+-				     (+ (current-milliseconds) tmw) ) )
+-				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
+-				  (yield) 
++				     ##sys#current-thread dlw) )
++                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
++                                  (##sys#thread-yield!)
+ 				  (when (##sys#slot ##sys#current-thread 13)
+ 				    (##sys#signal-hook
+ 				     #:network-timeout-error
+@@ -528,38 +499,29 @@
+ 
+ (define (tcp-accept tcpl)
+   (##sys#check-structure tcpl 'tcp-listener)
+-  (let ((fd (##sys#slot tcpl 1))
+-	(tma (tcp-accept-timeout)))
++  (let* ((fd (##sys#slot tcpl 1))
++         (tma (tcp-accept-timeout))
++         (dla (and tma (+ tma (current-milliseconds)))))
+     (let loop ()
+-      (if (eq? 1 (##net#select fd))
+-	  (let ((fd (##net#accept fd #f #f)))
+-	    (cond ((not (eq? -1 fd)) (##net#io-ports fd))
+-		  ((eq? errno _eintr)
+-		   (##sys#dispatch-interrupt loop))
+-		  (else
+-		   (##sys#update-errno)
+-		   (##sys#signal-hook 
+-		    #:network-error
+-		    'tcp-accept
+-		    (##sys#string-append "could not accept from listener - " strerror)
+-		    tcpl))))
+-	  (begin
+-	    (when tma
+-	      (##sys#thread-block-for-timeout! 
+-	       ##sys#current-thread
+-	       (+ (current-milliseconds) tma) ) )
+-	    (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+-	    (yield)
+-	    (when (##sys#slot ##sys#current-thread 13)
+-	      (##sys#signal-hook
+-	       #:network-timeout-error
+-	       'tcp-accept
+-	       "accept operation timed out" tma fd) )
+-	    (loop) ) ) ) ) )
++      (when dla
++        (##sys#thread-block-for-timeout! ##sys#current-thread dla) )
++      (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
++      (##sys#thread-yield!)
++      (if (##sys#slot ##sys#current-thread 13)
++	  (##sys#signal-hook
++	   #:network-timeout-error
++	   'tcp-accept
++	   "accept operation timed out" tma fd) )
++      (let ((fd (##net#accept fd #f #f)))
++	(cond ((not (eq? -1 fd)) (##net#io-ports fd))
++	      ((eq? errno _eintr)
++	       (##sys#dispatch-interrupt loop))
++	      (else
++	       (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )
+ 
+ (define (tcp-accept-ready? tcpl)
+   (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
+-  (let ((f (##net#select (##sys#slot tcpl 1))))
++  (let ((f (##net#check-fd-ready (##sys#slot tcpl 1))))
+     (when (eq? -1 f)
+       (##sys#update-errno)
+       (##sys#signal-hook 
+@@ -578,8 +540,9 @@
+ (define general-strerror (foreign-lambda c-string "strerror" int))
+ 
+ (define (tcp-connect host . more)
+-  (let ((port (optional more #f))
+-	(tmc (tcp-connect-timeout)))
++  (let* ((port (optional more #f))
++         (tmc (tcp-connect-timeout))
++         (dlc (and tmc (+ (current-milliseconds) tmc))))
+     (##sys#check-string host)
+     (unless port
+       (set!-values (host port) (##net#parse-host host "tcp"))
+@@ -606,23 +569,9 @@
+       (let loop ()
+ 	(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
+ 	  (cond ((eq? errno _einprogress)
+-		 (let loop2 ()
+-		   (let ((f (##net#select-write s)))
+-		     (when (eq? f -1) (fail))
+-		     (unless (eq? f 1)
+-		       (when tmc
+-			 (##sys#thread-block-for-timeout!
+-			  ##sys#current-thread
+-			  (+ (current-milliseconds) tmc) ) )
+-		       (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
+-		       (yield)
+-		       (when (##sys#slot ##sys#current-thread 13)
+-			 (##net#close s)
+-			 (##sys#signal-hook
+-			  #:network-timeout-error
+-			  'tcp-connect
+-			  "connect operation timed out" tmc s) )
+-		       (loop2) ) ) ))
++		 (when dlc
++		   (##sys#thread-block-for-timeout! ##sys#current-thread dlc))
++		 (##sys#thread-block-for-i/o! ##sys#current-thread s #:all))
+ 		((eq? errno _eintr)
+ 		 (##sys#dispatch-interrupt loop))
+ 		(else (fail) ) )))