r5265: *** empty log message ***

diff --git a/kmrcl.asd b/kmrcl.asd
index 29d0060ff555a91035427babb9575937e6627dd9..34bde481ff039a7075b01ac2ef74ff1edecd6562 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: kmrcl.asd,v 1.38 2003/07/08 16:11:19 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.39 2003/07/09 19:19:19 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -41,7 +41,6 @@
      (:file "console" :depends-on ("macros"))
      (:file "strings" :depends-on ("macros" "seqs"))
      (:file "buff-input" :depends-on ("macros"))
      (:file "console" :depends-on ("macros"))
      (:file "strings" :depends-on ("macros" "seqs"))
      (:file "buff-input" :depends-on ("macros"))

-     (:file "telnet-server" :depends-on ("macros"))

      (:file "random" :depends-on ("macros"))
      (:file "symbols" :depends-on ("macros"))
      (:file "datetime" :depends-on ("macros"))
      (:file "random" :depends-on ("macros"))
      (:file "symbols" :depends-on ("macros"))
      (:file "datetime" :depends-on ("macros"))


@@ -54,6 +53,7 @@
      (:file "sockets" :depends-on ("macros"))
      (:file "processes" :depends-on ("macros"))
      (:file "listener" :depends-on ("sockets" "processes"))
      (:file "sockets" :depends-on ("macros"))
      (:file "processes" :depends-on ("macros"))
      (:file "listener" :depends-on ("sockets" "processes"))

+     (:file "telnet-server" :depends-on ("listener"))

      ))
 
 
      ))
 
 

diff --git a/package.lisp b/package.lisp
index 60a96e7c1c0ded47b5aa9ea60037861a7b74e396..ff337e9678fec4612682250342457269ee537f8b 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: package.lisp,v 1.47 2003/07/08 16:11:19 kevin Exp $
+;;;; $Id: package.lisp,v 1.48 2003/07/09 19:19:19 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -59,7 +59,7 @@
    #:first-char
    #:last-char
    #:ensure-string
    #:first-char
    #:last-char
    #:ensure-string

-   #:string-left-trim-one-char
+   #:string-right-trim-one-char

    
    #:flatten
 
    
    #:flatten
 

diff --git a/strings.lisp b/strings.lisp
index 9c031164a11b1adede58e4811314baf0d46addc0..cadd1acc29c6891b8a36e269201b0957f947322d 100644 (file)
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: strings.lisp,v 1.46 2003/07/08 00:12:51 kevin Exp $
+;;;; $Id: strings.lisp,v 1.47 2003/07/09 19:19:19 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -493,7 +493,7 @@ for characters in a string"
     (symbol (symbol-name v))
     (otherwise (write-to-string v))))
 
     (symbol (symbol-name v))
     (otherwise (write-to-string v))))
 

-(defun string-left-trim-one-char (char str)
+(defun string-right-trim-one-char (char str)

   (declare (simple-string str))
   (let* ((len (length str))
         (last (1- len)))
   (declare (simple-string str))
   (let* ((len (length str))
         (last (1- len)))

diff --git a/telnet-server.lisp b/telnet-server.lisp
index 7520ea32c8538f0242640e1bc2d3b3e1c698cf66..cf95ad403896f2fc1895d547898100cc67ff414e 100644 (file)
--- a/telnet-server.lisp
+++ b/telnet-server.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: telnet-server.lisp,v 1.5 2002/10/16 03:45:34 kevin Exp $
+;;;; $Id: telnet-server.lisp,v 1.6 2003/07/09 19:19:19 kevin Exp $

 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -18,54 +18,58 @@
 
 (in-package :kmrcl)
 
 
 (in-package :kmrcl)
 

-(defvar *default-telnet-server-port* 4000)
+(defconstant +default-telnet-server-port+ 4000)

 
 

-#+allegro
-(defun start-telnet-server (&optional (port *default-telnet-server-port*))
-  (let ((passive (socket:make-socket :connect :passive
-                                    :local-host "127.1"
-                                    :local-port port
-                                    :reuse-address t)))
-    (mp:process-run-function
-     "telnet-listener"
-     #'(lambda (pass)
-        (let ((count 0))
-          (loop
-            (let ((con (socket:accept-connection pass)))
-              (mp:process-run-function
-               (format nil "tel~d" (incf count))
-               #'(lambda (con)
-                   (unwind-protect
-                       (tpl::start-interactive-top-level
-                        con
-                        #'tpl::top-level-read-eval-print-loop
-                        nil)
-                     (ignore-errors (close con :abort t))))
-               con)))))
-     passive)))
+(defclass telnetd ()
+  ((listener :initarg :listener :accessor listener
+            :initform nil)
+   (users :initarg :users :accessor users
+         :initform nil)
+   (announce :initarg :announce :accessor announce
+         :initform nil)))

 
 

-#+lispworks
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (require "comm"))
+(defun start-telnet-server (&key (port +default-telnet-server-port+)
+                           announce
+                           users)
+  (let ((telnetd
+        (make-instance 'telnetd
+                       :users users
+                       :listener
+                       (make-instance 'listener :port port
+                                :base-name "telnetd"                    
+                                :function 'telnet-worker
+                                :function-args (list users announce)
+                                :format :text
+                                :wait nil
+                                :catch-errors t))))
+    telnetd))

 
 

-#+lispworks
-(defun sts2  (&optional (port *default-telnet-server-port*))
-  (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))

 
 

-#+lispworks
-(defun make-telnet-stream (handle)
-  (let ((stream (make-instance 'comm:socket-stream
-                 :socket handle
-                 :direction :io
-                 :element-type
-                 'base-char))) 
-    (mp:process-run-function 
-     (format nil "telnet-session ~D" handle)
-     '()
-     'telnet-on-stream stream)))
+(defun telnet-worker (conn users announce)
+  (when announce
+    (format conn "~A~%" announce))
+  (when users
+    (let (user-name password)
+      (format conn "user: ")
+      (setq user-name (read-line conn))
+      (format conn "password: ")
+      (setq password (read-line conn))
+      (unless (and (string= user (car users))
+                  (string= password (cdr users)))
+       (format conn "Invalid login~%")
+       (return-from telnet-worker))))
+  #+allegro
+  (tpl::start-interactive-top-level
+   conn
+   #'tpl::top-level-read-eval-print-loop
+   nil)
+  #-allegro
+  (telnet-on-stream conn)
+  )

 
 (defun read-telnet-line (stream)
 
 (defun read-telnet-line (stream)

-  (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
+  (string-right-trim-one-char #\return
+                             (read-line stream nil nil)))

 
 (defun print-prompt (stream)
   (format stream "~&~A> " (package-name *package*))
 
 (defun print-prompt (stream)
   (format stream "~&~A> " (package-name *package*))


@@ -74,26 +78,11 @@
 (defvar *telnet-password* "")
 
 (defun telnet-on-stream (stream)
 (defvar *telnet-password* "")
 
 (defun telnet-on-stream (stream)

-  (unwind-protect
-      (progn
-       (let ((password (read-telnet-line stream))) 
-         (unless (and (stringp password)
-                      (string= password *telnet-password*))
-           (return-from telnet-on-stream)))
-       (print-prompt stream)
-       (loop for line = (read-telnet-line stream)
-           while line
-           do
-             (ignore-errors 
-              (format stream "~S" (eval (read-from-string line))))
-             (force-output stream)
-             (print-prompt stream)))
-    (close stream)))
-
-#+lispworks
-(defun start-telnet-server (&optional (port *default-telnet-server-port*))
-  (comm:start-up-server :service port
-                       :process-name (format nil "telnet-~d" port)
-                       :function 'kmrcl::make-telnet-stream))
-
-
+  (print-prompt stream)
+  (loop for line = (read-telnet-line stream)
+       while line
+       do
+       (ignore-errors 
+         (format stream "~S" (eval (read-from-string line))))
+       (force-output stream)
+       (print-prompt stream)))