;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/nrdl/RCS/nrdl.lisp,v 395.1 2008/04/20 17:25:50 gene Exp $
;;;
;;; Copyright (c) 2006 Gene Michael Stover.  All rights reserved.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;; 
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;; 
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL GENE MICHAEL STOVER BE LIABLE FOR
;;; ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
;;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;; 
;;; Except as contained in this notice, the name of Gene Michael Stover
;;; shall not be used in advertising or otherwise to promote the sale, use
;;; or other dealings in this Software without prior written authorization
;;; from Gene Michael Stover.
;;;

(defpackage "COM.CYBERTIGGYR.NRDL"
  (:use "COMMON-LISP")
  (:import-from "CYBERTIGGYR-TEST" check deftest)
  (:import-from "COM.CYBERTIGGYR.PRM" make-permutator maperm))
(in-package "COM.CYBERTIGGYR.NRDL")

;;;
;;; To use INTERNET-READLINE in another program, you could load
;;; this whole file, "nrdl.lisp", or you could copy the following
;;; LABELS form into your program.  The LABELS form is the self-
;;; contained INTERNET-READLINE function, though the DEFUN form
;;; which actually creates INTERNET-READLINE isn't.
;;;

(labels
    ((nrdl (read-code to-char &key (is-strict nil) (max 1024))
       (declare (type function read-code to-char) (type integer max))
       (assert (plusp max))
       (labels ((xread-code () (funcall read-code))
		(xto-char (code)
                  (declare (type integer code))
                  (funcall to-char code))
		(is-end (string code)
		  (declare (type string string))
                  (or (>= (length string) max)
		      (member code '(#x0D #x0A nil))))
		(is-good-terminator (code)
		  (or
		   (and (not is-strict) (member code '(nil #x0A)))
		   (and (eql code #x0D) (eql (xread-code) #x0A)))))
	 (let ((first-code (xread-code)))
	   (and first-code
		(do ((x (make-array max :element-type 'character
				    :adjustable nil :fill-pointer 0))
		     (code first-code (xread-code)))
		    ((is-end x code)
		     (and (is-good-terminator code) x))
		    (vector-push (xto-char code) x))))))
     (ascii-char (ascii)
       ;; If the ASCII value can't be converted to a native
       ;; character, return that value unchanged. Otherwise,
       ;; return a character which corresonds to the ASCII value.
       ;; This is analogous to CODE-CHAR."
       (case ascii
	 ;; (0 #\Nul) 
	 ;; (1 #\Soh) 
	 ;; (2 #\Stx) 
	 ;; (3 #\Etx) 
	 ;; (4 #\Eot) 
	 ;; (5 #\Enq) 
	 ;; (6 #\Ack) 
	 ;; (7 #\Bel) 
	 (8 #\Backspace) 
	 (9 #\Tab) 
	 ;; (10 #\Newline) 
	 ;; (11 #\Vt) 
	 ;; (12 #\Page) 
	 ;; (13 #\Return) 
	 ;; (14 #\So) 
	 ;; (15 #\Si) 
	 ;; (16 #\Dle) 
	 ;; (17 #\Dc1) 
	 ;; (18 #\Dc2) 
	 ;; (19 #\Dc3) 
	 ;; (20 #\Dc4) 
	 ;; (21 #\Nak) 
	 ;; (22 #\Syn) 
	 ;; (23 #\Etb) 
	 ;; (24 #\Can) 
	 ;; (25 #\Em) 
	 ;; (26 #\Sub) 
	 ;; (27 #\Esc) 
	 ;; (28 #\Fs) 
	 ;; (29 #\Gs) 
	 ;; (30 #\Rs) 
	 ;; (31 #\Us) 
	 (32 #\Space) 
	 (33 #\!) 
	 (34 #\") 
	 (35 #\#) 
	 (36 #\$) 
	 (37 #\%) 
	 (38 #\&) 
	 (39 #\') 
	 (40 #\() 
	 (41 #\)) 
	 (42 #\*) 
	 (43 #\+) 
	 (44 #\,) 
	 (45 #\-) 
	 (46 #\.) 
	 (47 #\/) 
	 (48 #\0) 
	 (49 #\1) 
	 (50 #\2) 
	 (51 #\3) 
	 (52 #\4) 
	 (53 #\5) 
	 (54 #\6) 
	 (55 #\7) 
	 (56 #\8) 
	 (57 #\9) 
	 (58 #\:) 
	 (59 #\;) 
	 (60 #\<) 
	 (61 #\=) 
	 (62 #\>) 
	 (63 #\?) 
	 (64 #\@) 
	 (65 #\A) 
	 (66 #\B) 
	 (67 #\C) 
	 (68 #\D) 
	 (69 #\E) 
	 (70 #\F) 
	 (71 #\G) 
	 (72 #\H) 
	 (73 #\I) 
	 (74 #\J) 
	 (75 #\K) 
	 (76 #\L) 
	 (77 #\M) 
	 (78 #\N) 
	 (79 #\O) 
	 (80 #\P) 
	 (81 #\Q) 
	 (82 #\R) 
	 (83 #\S) 
	 (84 #\T) 
	 (85 #\U) 
	 (86 #\V) 
	 (87 #\W) 
	 (88 #\X) 
	 (89 #\Y) 
	 (90 #\Z) 
	 (91 #\[) 
	 (92 #\\) 
	 (93 #\]) 
	 (94 #\^) 
	 (95 #\_) 
	 (96 #\`) 
	 (97 #\a) 
	 (98 #\b) 
	 (99 #\c) 
	 (100 #\d) 
	 (101 #\e) 
	 (102 #\f) 
	 (103 #\g) 
	 (104 #\h) 
	 (105 #\i) 
	 (106 #\j) 
	 (107 #\k) 
	 (108 #\l) 
	 (109 #\m) 
	 (110 #\n) 
	 (111 #\o) 
	 (112 #\p) 
	 (113 #\q) 
	 (114 #\r) 
	 (115 #\s) 
	 (116 #\t) 
	 (117 #\u) 
	 (118 #\v) 
	 (119 #\w) 
	 (120 #\x) 
	 (121 #\y) 
	 (122 #\z) 
	 (123 #\{) 
	 (124 #\|) 
	 (125 #\}) 
	 (126 #\~) 
	 ;; (127 #\Rubout) 
	 ;; Finally, make a valiant attempt to convert to a native
	 ;; character.  If that doesn't work, return ASCII (which
	 ;; is almost sure to cause problems because it is not a
	 ;; character).
	 (otherwise (or (ignore-errors (code-char ascii))
			ascii)))))

  (defun internet-readline (strm &key (is-strict nil) (max 1024))
    (case (stream-element-type strm)
      (character (nrdl #'(lambda ()
			   (let ((x (read-char strm nil)))
			     (and x (char-code x))))
		       #'code-char
		       :is-strict is-strict
		       :max max))
      (otherwise (nrdl #'(lambda () (read-byte strm nil))
		       #'ascii-char
		       :is-strict is-strict
		       :max max))))

  (defun internet-readall (pn &key (is-strict nil) (max 1024)
			      (element-type 'character))
    (with-open-file (strm pn :element-type element-type)
      (labels
	  ((next () (internet-readline strm :is-strict is-strict :max max)))
	(do ((lst nil (cons line lst))
	     (line (next) (next)))
	    ((null line) (nreverse lst)))))))

;;;
;;; TESTS
;;;

(deftest test0000 ()
  "Null test.  Always succeeds."
  'test0000)

;;;
;;; These tests require support functions.
;;; Support functions for the rest of the tests.
;;; Normally, I believe tests are best if they are
;;; simple & self-contained because it makes them
;;; less succeptable to bugs.  (Tests are for
;;; detecting bugs in another program.  If the
;;; possibility of bugs in the tests themselves is
;;; high...)  I'm breaking that rule this time.
;;;

(defun basic-test (is-strict max element-type octets expected)
  (let ((pn (make-pathname :directory '(:relative)
			   :name "test" :type "txt")))
    ;; Create the input file
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename-and-delete)
      (dolist (ascii octets) (write-byte ascii strm)))
    ;; Read from the input file.
    (let ((x (internet-readall pn :is-strict is-strict :max max
			       :element-type element-type)))
      (if (equal x expected)
	  (delete-file pn)
	;; Else, Retain the file for the programmer to inspect
	;; later.  Also, print an error message.
	(progn
	  (format t "~&~A returned ~S." 'internet-readall x)
	  (format t "~&Expected ~S." expected)))
      (equal x expected))))
    
(deftest test0100 ()
  "Read a single, short line terminated with CR LF.  Strict.
Element type is character."
  (basic-test t 3 'character '(#x42 #x0D #x0A) '("B")))

(deftest test0103 ()
  "Read a single, long (but legal) line terminated with CR LF.  Strict.
Element type is character."
  (basic-test t 3 'character '(#x41 #x42 #x43 #x0D #x0A) '("ABC")))

(deftest test0106 ()
  "Read a three lines, each terminated with CR LF.  Strict.
Element type is character."
  (basic-test t 3 'character
	      '(#x41 #x0D #x0A          ; "A" CR LF
                #x42 #x43 #x0D #x0A     ; "BC" CR LF
		#x44 #x45 #x46 #x0D #x0A) ; "DEF" CR LF
	      '("A" "BC" "DEF")))

(deftest test0110 ()
  "Read a single, short line terminated with CR LF.  Strict.
Element type is octet."
  (basic-test t 3 '(unsigned-byte 8) '(#x42 #x0D #x0A) '("B")))

(deftest test0113 ()
  "Read a single, long (but legal) line terminated with CR LF.  Strict.
Element type is octet."
  (basic-test t 3 '(unsigned-byte 8) '(#x41 #x42 #x43 #x0D #x0A) '("ABC")))

(deftest test0116 ()
  "Read a three lines, each terminated with CR LF.  Strict.
Element type is octet."
  (basic-test t 3 '(unsigned-byte 8)
	      '(#x41 #x0D #x0A          ; "A" CR LF
                #x42 #x43 #x0D #x0A     ; "BC" CR LF
		#x44 #x45 #x46 #x0D #x0A) ; "DEF" CR LF
	      '("A" "BC" "DEF")))

(defun make-lisp-test (eol len is-strict element-type)
  (let ((testname (read-from-string
		   (remove #\: (format nil "test-~A-~A-~A-~A"
				       eol len
				       (if is-strict 'strict 'lenient)
				       (if (eq element-type 'character)
					   'character 'octet))))))
    `(deftest ,testname ()
       (basic-test ,is-strict
		   3                    ; max
		   ',element-type
		   ',(append (ecase len
			       (:len-zero nil)
			       (:len-short '(#x41))
			       (:len-max '(#x41 #x42 #x43))
			       (:len-longer '(#x41 #x42 #x43 #x44)))
			     (ecase eol
			       (:eol-nil nil)
			       (:eol-cr '(#x0D))
			       (:eol-lf '(#x0A))
			       (:eol-crlf '(#x0D #x0A))))
		   ',(cond ((and is-strict (not (eq eol :eol-crlf))) nil)
			   ((eq eol :eol-cr) nil)
			   ((eq len :len-longer) nil)
			   ((and (eq eol :eol-nil) (eq len :len-zero)) nil)
			   (t
			    (ecase len
			      (:len-zero '(""))
			      (:len-short '("A"))
			      (:len-max '("ABC"))
			      (:len-longer nil))))))))

(defmacro def-lisp-tests ()
  (cons
   'progn
   (let ((prm (make-permutator '(:eol-crlf :eol-nil :eol-lf :eol-cr)
			      '(:len-zero :len-short :len-max :len-longer)
			      '(t nil)
			      '(character (unsigned-byte 8)))))
     (declare (type function prm))
     (do ((x (funcall prm) (funcall prm))
	  (lst nil (cons (apply #'make-lisp-test x) lst)))
	 ((null x) (nreverse lst))))))


;;; --- end of file ---