repl.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          repl.lisp
   6 ;;;; Purpose:       A repl server
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 (defconstant +default-repl-server-port+ 4000)
  22
  23 (defclass repl ()
  24   ((listener :initarg :listener :accessor listener
  25              :initform nil)))
  26
  27 (defun make-repl (&key (port +default-repl-server-port+)
  28                        announce user-checker remote-host-checker)
  29   (make-instance 'listener
  30     :port port
  31     :base-name "repl"
  32     :function 'repl-worker
  33     :function-args (list user-checker announce)
  34     :format :text
  35     :wait nil
  36     :remote-host-checker remote-host-checker
  37     :catch-errors nil))
  38
  39 (defun init/repl (repl state)
  40   (init/listener repl state))
  41
  42
  43 (defun repl-worker (conn user-checker announce)
  44   (when announce
  45     (format conn "~A~%" announce)
  46     (force-output conn))
  47   (when user-checker
  48     (let (login password)
  49       (format conn "login: ")
  50       (finish-output conn)
  51       (setq login (read-socket-line conn))
  52       (format conn "password: ")
  53       (finish-output conn)
  54       (setq password (read-socket-line conn))
  55       (unless (funcall user-checker login password)
  56         (format conn "Invalid login~%")
  57         (finish-output conn)
  58         (return-from repl-worker))))
  59   #+allegro
  60   (tpl::start-interactive-top-level
  61    conn
  62    #'tpl::top-level-read-eval-print-loop
  63    nil)
  64   #-allegro
  65   (repl-on-stream conn)
  66   )
  67
  68 (defun read-socket-line (stream)
  69   (string-right-trim-one-char #\return
  70                               (read-line stream nil nil)))
  71
  72 (defun print-prompt (stream)
  73   (format stream "~&~A> " (package-name *package*))
  74   (force-output stream))
  75
  76 (defun repl-on-stream (stream)
  77   (let ((*standard-input* stream)
  78         (*standard-output* stream)
  79         (*terminal-io* stream)
  80         (*debug-io* stream))
  81     #|
  82     #+sbcl
  83     (if (and (find-package 'sb-aclrepl)
  84              (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
  85         (sb-aclrepl::repl-fun)
  86         (%repl))
  87     #-sbcl
  88     |#
  89     (%repl)))
  90
  91 (defun %repl ()
  92   (loop
  93     (print-prompt *standard-output*)
  94     (let ((form (read *standard-input*)))
  95       (format *standard-output* "~&~S~%" (eval form)))))
  96