;;; -*- Mode:LISP; Package:TCP-APPLICATION; Base:10; Patch-File:T; Readtable:ZL -*-

;;; PATCH FOR RELEASE 2.0 FTP SERVER TO HANDLE BYTE SIZE 16 CORRECTLY.

(DEFUN FTP-SEND-DATA-FUNCTION (STATE INSTREAM OUTSTREAM DIRECTORY-P)
  (LET ((TRANSLATING-OUTSTREAM
	  (SELECTQ (FTPSTATE-TRANSFER-TYPE STATE)
	    (:ASCII
	     (FTP:MAKE-ASCII-TRANSLATING-OUTPUT-STREAM OUTSTREAM))
	    ((:IMAGE :LOGICAL-BYTE-SIZE)
	     (SELECTQ (FTPSTATE-BYTE-SIZE STATE)
	       (8 OUTSTREAM)
	       (16 (MAKE-16B-TO-8B-TRANSLATING-OUTPUT-STREAM OUTSTREAM))))
	    (T
	     NIL)))
	(FTP:*HASH* NIL)
	(COMPLETEDP NIL))
    (UNWIND-PROTECT
	(COND ((NOT TRANSLATING-OUTSTREAM)
	       (FTP-REPLY STATE 504 "Unimplemented type ~A." (FTPSTATE-TRANSFER-TYPE STATE)))
	      ('ELSE
	       (CONDITION-CASE-IF FTP-CATCH-ERRORS (ERR)
		   (PROGN (COND ((NOT DIRECTORY-P)
				 (STREAM-COPY-UNTIL-EOF INSTREAM TRANSLATING-OUTSTREAM)
				 (OR (EQ TRANSLATING-OUTSTREAM OUTSTREAM)
				     (SEND TRANSLATING-OUTSTREAM :FORCE-OUTPUT)))
				((EQ DIRECTORY-P T)
				 (DO ((ENTRY))
				     ((NULL (SETQ ENTRY (SEND INSTREAM :LINE-IN))))
				   (SEND TRANSLATING-OUTSTREAM :STRING-OUT ENTRY)
				   (TERPRI TRANSLATING-OUTSTREAM)))
				((EQ DIRECTORY-P :DIRECTORY-LIST)
				 (DO ((ENTRY))
				     ((NULL (SETQ ENTRY (SEND INSTREAM :ENTRY))))
				   (PRIN1 ENTRY TRANSLATING-OUTSTREAM)
				   (TERPRI TRANSLATING-OUTSTREAM)))
				((EQ DIRECTORY-P :NAME-LIST)
				 (SEND INSTREAM :ENTRY) ;; GET RID OF DISK-SPACE-DESCRIPTION
				 (DO ((ENTRY))
				     ((NULL (SETQ ENTRY (SEND INSTREAM :ENTRY))))
				   (SEND TRANSLATING-OUTSTREAM :STRING-OUT
					 (SEND (CAR ENTRY) :STRING-FOR-PRINTING))
				   (TERPRI TRANSLATING-OUTSTREAM))))
			  (SETQ COMPLETEDP T))
		 (FS:FILE-ERROR
		  (FTP-FILE-ERROR-REPLY STATE ERR))
		 (ERROR (FTP-REPLY STATE 451 '"Local error in processing.") NIL))))
      (CLOSE INSTREAM)
      (IF COMPLETEDP (SEND OUTSTREAM :FORCE-OUTPUT))
      (FTP-CLEANUP-DATA-CONNECTION STATE NIL)
      (SETF (FTPSTATE-DATA-TRANSFER-IN-PROGRESS STATE) NIL)
      (IF COMPLETEDP (FTP-REPLY STATE 226 '"Transfer complete")))))



(DEFUN FTP-RECEIVE-DATA-FUNCTION (STATE INSTREAM OUTSTREAM &AUX SUCCESS)
  "Transfer the contents of net instream to local outstream"
 (CONDITION-CASE-IF FTP-CATCH-ERRORS (ERR)
  (SELECTQ (FTPSTATE-TRANSFER-TYPE STATE)
    (:ASCII
     (LET ((FTP:*HASH* NIL)) 
       (DECLARE (SPECIAL FTP:*HASH*))
       (WITH-OPEN-STREAM (IS (FTP:MAKE-ASCII-TRANSLATING-INPUT-STREAM INSTREAM))
	 (STREAM-COPY-UNTIL-EOF IS OUTSTREAM)))
     (SETQ SUCCESS T))
    ((:IMAGE :LOGICAL-BYTE-SIZE)
     (SELECTQ (FTPSTATE-BYTE-SIZE STATE)
       (8
	(STREAM-COPY-UNTIL-EOF INSTREAM OUTSTREAM))
       (16
	(LET ((TRANS (MAKE-8B-TO-16B-TRANSLATING-OUTPUT-STREAM OUTSTREAM)))
	  (STREAM-COPY-UNTIL-EOF INSTREAM TRANS)
	  (SEND TRANS :FORCE-OUTPUT))))
     (SETQ SUCCESS T))
    (OTHERWISE (FERROR NIL '"Bad transfer type in FTPSTATE.")))
   (FS:FILE-ERROR (FTP-FILE-ERROR-REPLY STATE ERR) NIL)
   (ERROR (FTP-REPLY STATE 451 '"Local error in processing.") NIL))
 (CLOSE OUTSTREAM)
 (FTP-CLEANUP-DATA-CONNECTION STATE NIL)
 (SETF (FTPSTATE-DATA-TRANSFER-IN-PROGRESS STATE) NIL)
 (IF SUCCESS (FTP-REPLY STATE 226 '"Transfer complete.")))





(DEFFLAVOR 16B-TO-8B-TRANSLATING-OUTPUT-STREAM
	 (OUTPUT)
	 (SI:BUFFERED-OUTPUT-STREAM)
  (:INITABLE-INSTANCE-VARIABLES OUTPUT))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :NEW-OUTPUT-BUFFER) ()
  (DECLARE (VALUES ARRAY START END))
  (VALUES (allocate-resource 'FS:SIMPLE-ART-16B-BUFFER 1000)
	  0
	  1000))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :SEND-OUTPUT-BUFFER) (ARRAY END)
  (SEND OUTPUT
	:STRING-OUT
	(MAKE-ARRAY (* END 2) :TYPE 'ART-STRING :DISPLACED-TO ARRAY)
	0
	(* END 2))
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-ART-16B-BUFFER ARRAY))

(DEFMETHOD (16B-TO-8B-TRANSLATING-OUTPUT-STREAM :DISCARD-OUTPUT-BUFFER) (ARRAY)
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-ART-16B-BUFFER ARRAY))

(DEFFLAVOR 8B-TO-16B-TRANSLATING-OUTPUT-STREAM
	 (OUTPUT)
	 (SI:BUFFERED-OUTPUT-STREAM)
  (:INITABLE-INSTANCE-VARIABLES OUTPUT))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :NEW-OUTPUT-BUFFER) ()
  (DECLARE (VALUES ARRAY START END))
  (VALUES (allocate-resource 'FS:SIMPLE-STRING-BUFFER 2000)
	  0
	  2000))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :SEND-OUTPUT-BUFFER) (ARRAY END)
  (SEND OUTPUT :STRING-OUT (MAKE-ARRAY (FLOOR END 2)
				       :TYPE 'ART-16B
				       :DISPLACED-TO ARRAY))
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-STRING-BUFFER ARRAY))

(DEFMETHOD (8B-TO-16B-TRANSLATING-OUTPUT-STREAM :DISCARD-OUTPUT-BUFFER) (ARRAY)
  (DEALLOCATE-RESOURCE 'FS:SIMPLE-STRING-BUFFER ARRAY))

(COMPILE-FLAVOR-METHODS 16B-TO-8B-TRANSLATING-OUTPUT-STREAM 8B-TO-16B-TRANSLATING-OUTPUT-STREAM)


(DEFUN MAKE-16B-TO-8B-TRANSLATING-OUTPUT-STREAM (OUTPUT)
  (MAKE-INSTANCE '16B-TO-8B-TRANSLATING-OUTPUT-STREAM :OUTPUT OUTPUT))

(DEFUN MAKE-8B-TO-16B-TRANSLATING-OUTPUT-STREAM (OUTPUT)
  (MAKE-INSTANCE '8B-TO-16B-TRANSLATING-OUTPUT-STREAM :OUTPUT OUTPUT))