;; Read a line from a stream, translating CR/LF to NL.
(defun read-line-nocr (stream)
  (let ((line (read-line stream nil nil)))
    (when (and line
               (>= (length line) 1)
               (eql (char line (1- (length line))) #\Return))
      (setq line (subseq line 0 (1- (length line))))
    )
    line
) )

;; Table for conversion to HTML encoding.
(defvar html-conversion-table
  (let ((v (make-array 256)))
    (dotimes (i 256) (setf (aref v i) (code-char i)))
    (setf (svref v (char-code #\")) """)
    (setf (svref v (char-code #\&)) "&")
    (setf (svref v (char-code #\<)) "&lt;")
    (setf (svref v (char-code #\>)) "&gt;")
    (setf (svref v (char-code #\ )) "&nbsp;")
    (setf (svref v (char-code #\¡)) "&iexcl;")
    (setf (svref v (char-code #\¢)) "&cent;")
    (setf (svref v (char-code #\£)) "&pound;")
    (setf (svref v (char-code #\¤)) "&curren;")
    (setf (svref v (char-code #\¥)) "&yen;")
    (setf (svref v (char-code #\¦)) "&brvbar;")
    (setf (svref v (char-code #\§)) "&sect;")
    (setf (svref v (char-code #\¨)) "&uml;")
    (setf (svref v (char-code #\©)) "&copy;")
    (setf (svref v (char-code #\ª)) "&ordf;")
    (setf (svref v (char-code #\«)) "&laquo;")
    (setf (svref v (char-code #\¬)) "&not;")
    (setf (svref v (char-code #\­)) "&shy;")
    (setf (svref v (char-code #\®)) "&reg;")
    (setf (svref v (char-code #\¯)) "&macr;")
    (setf (svref v (char-code #\°)) "&deg;")
    (setf (svref v (char-code #\±)) "&plusmn;")
    (setf (svref v (char-code #\²)) "&sup2;")
    (setf (svref v (char-code #\³)) "&sup3;")
    (setf (svref v (char-code #\´)) "&acute;")
    (setf (svref v (char-code #\µ)) "&micro;")
    (setf (svref v (char-code #\¶)) "&para;")
    (setf (svref v (char-code #\·)) "&middot;")
    (setf (svref v (char-code #\¸)) "&cedil;")
    (setf (svref v (char-code #\¹)) "&sup1;")
    (setf (svref v (char-code #\º)) "&ordm;")
    (setf (svref v (char-code #\»)) "&raquo;")
    (setf (svref v (char-code #\¼)) "&frac14;")
    (setf (svref v (char-code #\½)) "&frac12;")
    (setf (svref v (char-code #\¾)) "&frac34;")
    (setf (svref v (char-code #\¿)) "&iquest;")
    (setf (svref v (char-code #\À)) "&Agrave;")
    (setf (svref v (char-code #\Á)) "&Aacute;")
    (setf (svref v (char-code #\Â)) "&Acirc;")
    (setf (svref v (char-code #\Ã)) "&Atilde;")
    (setf (svref v (char-code #\Ä)) "&Auml;")
    (setf (svref v (char-code #\Å)) "&Aring;")
    (setf (svref v (char-code #\Æ)) "&AElig;")
    (setf (svref v (char-code #\Ç)) "&Ccedil;")
    (setf (svref v (char-code #\È)) "&Egrave;")
    (setf (svref v (char-code #\É)) "&Eacute;")
    (setf (svref v (char-code #\Ê)) "&Ecirc;")
    (setf (svref v (char-code #\Ë)) "&Euml;")
    (setf (svref v (char-code #\Ì)) "&Igrave;")
    (setf (svref v (char-code #\Í)) "&Iacute;")
    (setf (svref v (char-code #\Î)) "&Icirc;")
    (setf (svref v (char-code #\Ï)) "&Iuml;")
    (setf (svref v (char-code #\Ð)) "&ETH;")
    (setf (svref v (char-code #\Ñ)) "&Ntilde;")
    (setf (svref v (char-code #\Ò)) "&Ograve;")
    (setf (svref v (char-code #\Ó)) "&Oacute;")
    (setf (svref v (char-code #\Ô)) "&Ocirc;")
    (setf (svref v (char-code #\Õ)) "&Otilde;")
    (setf (svref v (char-code #\Ö)) "&Ouml;")
    (setf (svref v (char-code #\×)) "&times;")
    (setf (svref v (char-code #\Ø)) "&Oslash;")
    (setf (svref v (char-code #\Ù)) "&Ugrave;")
    (setf (svref v (char-code #\Ú)) "&Uacute;")
    (setf (svref v (char-code #\Û)) "&Ucirc;")
    (setf (svref v (char-code #\Ü)) "&Uuml;")
    (setf (svref v (char-code #\Ý)) "&Yacute;")
    (setf (svref v (char-code #\Þ)) "&THORN;")
    (setf (svref v (char-code #\ß)) "&szlig;")
    (setf (svref v (char-code #\à)) "&agrave;")
    (setf (svref v (char-code #\á)) "&aacute;")
    (setf (svref v (char-code #\â)) "&acirc;")
    (setf (svref v (char-code #\ã)) "&atilde;")
    (setf (svref v (char-code #\ä)) "&auml;")
    (setf (svref v (char-code #\å)) "&aring;")
    (setf (svref v (char-code #\æ)) "&aelig;")
    (setf (svref v (char-code #\ç)) "&ccedil;")
    (setf (svref v (char-code #\è)) "&egrave;")
    (setf (svref v (char-code #\é)) "&eacute;")
    (setf (svref v (char-code #\ê)) "&ecirc;")
    (setf (svref v (char-code #\ë)) "&euml;")
    (setf (svref v (char-code #\ì)) "&igrave;")
    (setf (svref v (char-code #\í)) "&iacute;")
    (setf (svref v (char-code #\î)) "&icirc;")
    (setf (svref v (char-code #\ï)) "&iuml;")
    (setf (svref v (char-code #\ð)) "&eth;")
    (setf (svref v (char-code #\ñ)) "&ntilde;")
    (setf (svref v (char-code #\ò)) "&ograve;")
    (setf (svref v (char-code #\ó)) "&oacute;")
    (setf (svref v (char-code #\ô)) "&ocirc;")
    (setf (svref v (char-code #\õ)) "&otilde;")
    (setf (svref v (char-code #\ö)) "&ouml;")
    (setf (svref v (char-code #\÷)) "&divide;")
    (setf (svref v (char-code #\ø)) "&oslash;")
    (setf (svref v (char-code #\ù)) "&ugrave;")
    (setf (svref v (char-code #\ú)) "&uacute;")
    (setf (svref v (char-code #\û)) "&ucirc;")
    (setf (svref v (char-code #\ü)) "&uuml;")
    (setf (svref v (char-code #\ý)) "&yacute;")
    (setf (svref v (char-code #\þ)) "&thorn;")
    (setf (svref v (char-code #\ÿ)) "&yuml;")
    v
) )

;; Writes a string to a stream, using HTML encoding.
;; Examples: (write-html "#<unbound>" browser)
;; but       (write-string "<P>text</P>" browser)
(defun write-html (string stream)
  (dotimes (i (length string))
    (let* ((c (char string i))
           (x (svref html-conversion-table (char-code c))))
      (if (characterp x)
        (write-char x stream)
        (write-string x stream)
  ) ) )
  string
)

;; Value of an empty slot.
(defun unbound ()
  (sys::%record-ref (clos::allocate-std-instance clos::<standard-object> 2) 1)
)

;; Signals an error if a slot does not exist any more.
(defun nonexistent-slot (index)
  (error (DEUTSCH "Slot ~D existiert nicht."
          ENGLISH "slot ~D does not exist."
          FRANCAIS "Le champ ~D n'existe pas.")
         index
) )

;; Functions to return the "virtual slots" of an object.
(defgeneric object-vslots (object))
(defgeneric object-vslot (object index))
(defgeneric object-vslot-label (object index))
;; Map through all the "virtual slots" of an object.
(defgeneric map-vslots (fn object))

;; Catch-all method for T.
(defmethod object-vslots ((object t))
  0
)
(defmethod object-vslot ((object t) index)
  (nonexistent-slot index)
)
(defmethod object-vslot-label ((object t) index)
  (sys::decimal-string index)
)

(defmethod map-vslots (fn (object t))
  (let ((n (object-vslots object)))
    (dotimes (index n)
      (funcall fn object index
                  (object-vslot-label object index)
                  (object-vslot object index)
    ) )
) )

;; Tricky method for CONS.
(labels ((circular-list-length (list period)
           ; mimimum n such that (nthcdr n list) already occurs in
           ; { (nthcdr 0 list), ..., (nthcdr n-1 list) }
           (do ((n 0 (1+ i))
                (l1 list (cdr l1))
                (l2 (nthcdr period list) (cdr l2)))
               ((eq l1 l2) (+ period n))
         ) )
         (list-length (list)  ; vgl. CLTL, S. 265
           (do ((n 0 (+ n 2))
                (fast list (cddr fast))
                (slow list (cdr slow))
               )
               (nil)
             (when (atom fast) (return n))
             (when (atom (cdr fast)) (return (1+ n)))
             (when (eq (cdr fast) slow)
               (return (circular-list-length list (1+ (/ n 2))))
        )) ) )
  (defmethod object-vslots ((object cons))
    (let ((len (list-length object)))
      (if (null (nthcdr len object)) len (+ len 1))
  ) )
  (defmethod object-vslot ((object cons) index)
    (let ((len (list-length object)))
      (cond ((< index len) (car (nthcdr index object)))
            ((= index len) (nthcdr index object))
            (t (nonexistent-slot index))
  ) ) )
  (defmethod object-vslot-label ((object cons) index)
    (if (= index (list-length object)) "tail" (sys::decimal-string index))
  )
  (defmethod map-vslots (fn (object cons)) ; only for efficiency on long lists
    (let ((len (list-length object)))
      (do ((i 0 (1+ i))
           (l object (cdr l)))
          ((= i len)
           (unless (null l)
             (funcall fn object i (object-vslot-label object i) l)
          ))
        (funcall fn object i (object-vslot-label object i) (car l))
  ) ) )
)

; Methods for SYMBOL.
(defmethod object-vslots ((object symbol))
  4
)
(defmethod object-vslot ((object symbol) index)
  (case index
    (0 (symbol-package object))
    (1 (if (boundp object) (symbol-value object) (unbound)))
    (2 (if (fboundp object) (symbol-function object) (unbound)))
    (3 (symbol-plist object))
    (t (nonexistent-slot index))
) )
(defmethod object-vslot-label ((object symbol) index)
  (svref '#("package" "value" "function" "plist") index)
)

; Methods for RATIO.
(defmethod object-vslots ((object ratio))
  2
)
(defmethod object-vslot ((object ratio) index)
  (case index
    (0 (numerator object))
    (1 (denominator object))
    (t (nonexistent-slot index))
) )
(defmethod object-vslot-label ((object ratio) index)
  (svref '#("numerator" "denominator") index)
)

; Methods for COMPLEX.
(defmethod object-vslots ((object complex))
  2
)
(defmethod object-vslot ((object complex) index)
  (case index
    (0 (realpart object))
    (1 (imagpart object))
    (t (nonexistent-slot index))
) )
(defmethod object-vslot-label ((object complex) index)
  (svref '#("realpart" "imagpart") index)
)

; Methods for STANDARD-OBJECT.
(defmethod object-vslots ((object standard-object))
  (length (clos::class-slots (class-of object)))
)
(defmethod object-vslot ((object standard-object) index)
  (slot-value object (clos::slotdef-name (nth index (clos::class-slots (class-of object)))))
)
(defmethod object-vslot-label ((object standard-object) index)
  (write-to-string (clos::slotdef-name (nth index (clos::class-slots (class-of object)))))
)

; Methods for CLOS::STRUCTURE-OBJECT.
(defmethod object-vslots ((object clos::structure-object))
  (length (clos::class-slots (class-of object)))
)
(defmethod object-vslot ((object clos::structure-object) index)
  (slot-value object (clos::slotdef-name (nth index (clos::class-slots (class-of object)))))
)
(defmethod object-vslot-label ((object clos::structure-object) index)
  (write-to-string (clos::slotdef-name (nth index (clos::class-slots (class-of object)))))
)


;; Functions for producing the WWW page describing an object.

; The page's URI, for example "/0/3/c/2/".
(defvar *URI*)

(defmacro write-link (uri stream &body body)
  `(progn
     (format ,stream "<A HREF=\"~A\">" ,uri)
     (progn ,@body)
     (write-string "</A>" ,stream)
   )
)

(defmacro write-relative-link (relative-uri stream &body body)
  `(progn
     (format ,stream "<A HREF=\"~A~A\">" *URI* ,relative-uri)
     (progn ,@body)
     (write-string "</A>" ,stream)
   )
)

(defgeneric write-object-vslots-description (object stream))
(defmethod write-object-vslots-description ((object t) stream)
  (map-vslots
     #'(lambda (object index label value)
         (declare (ignore object))
         (declare (compile)) ; because value can be unbound
         (write-html label stream)
         (write-html ": " stream)
         (write-relative-link (format nil "~D/" index) stream
           (write-html (sys::write-to-short-string value 60) stream)
         )
         (write-string "<BR>" stream)
         (terpri stream)
       )
     object
) )


(defgeneric write-object-description (object stream))
(defmethod write-object-description ((object t) stream)
  (write-string "<HEAD>" stream)
  (write-string "<TITLE>" stream)
  (write-html "Inspection of " stream)
  (write-html (sys::write-to-short-string object 30) stream)
  (write-string "</TITLE>" stream)
  (write-string "</HEAD>" stream)
  (terpri stream)
  (write-string "<BODY>" stream)
  (terpri stream)
  (write-string "<H1>" stream)
  (write-html "Inspection of " stream)
  (write-html (sys::write-to-short-string object 70) stream)
  (write-string "</H1>" stream)
  (write-string "<BR>" stream)
  (terpri stream)
  (write-html "Class: " stream)
  (write-relative-link "c/" stream
    (write-html (prin1-to-string (class-name (class-of object))) stream)
  )
  (write-string "<BR>" stream)
  (terpri stream)
  (write-html "Metaclass: " stream)
  (write-relative-link "c/c/" stream
    (write-html (prin1-to-string (class-name (class-of (class-of object)))) stream)
  )
  (write-string "<BR>" stream)
  (write-string "<BR>" stream)
  (terpri stream)
  (write-object-vslots-description object stream)
  (write-string "</BODY>" stream)
  (terpri stream)
)

(defvar *root-object*)
(defun object-from-URI (URI)
  ; Split the URI into slash separated pieces. Each piece is an index to
  ; be followed. Start at *root-object*.
  (let ((object *root-object*)
        (i 0))
    (loop
      (when (= i (length URI)) (return))
      (when (eql (char URI i) #\/) (incf i))
      (when (= i (length URI)) (return))
      (let* ((j (or (position #\/ URI :start i) (length URI)))
             (piece (subseq URI i j)))
        (cond ((string-equal piece "c") (setq object (class-of object)))
              (t (let ((index (parse-integer piece :radix 10)))
                   (setq object (object-vslot object index))
        )     )  )
        (setq i j)
    ) )
    object
) )

(defun handle-http-connection (stream)
  ;; We don't support the full HTTP protocol as specified in RFC1945, only
  ;; a small portion of it.
  (let ((tasks nil))
    (loop
      (when (and tasks (not (listen stream))) (return))
      (let ((line (read-line-nocr stream)))
        (unless line (return))
        (when (and (>= (length line) 4) (string-equal line "GET " :end1 4))
          (push line tasks)
        )
        (when (and (>= (length line) 12)
                   (string-equal line "User-Agent: " :end1 12)
                   (search "MSIE" line :test #'char=)
              )
          (write-html "Unsupported browser. Get Netscape Navigator®." stream)
          (terpri stream)
          (return-from handle-http-connection)
        )
    ) )
    (dolist (line (reverse tasks))
      (cond ((and (>= (length line) 4) (string-equal line "GET " :end1 4))
             (let* ((request (string-left-trim " " (subseq line 4)))
                    (URI (subseq request 0 (position #\Space request))))
               (when (and (>= (length URI) 1) (eql (char URI 0) #\/))
                 (unless (eql (char URI (1- (length URI))) #\/)
                   (setq URI (concatenate 'string URI "/"))
                 )
                 (multiple-value-bind (object error)
                     (ignore-errors (object-from-URI URI))
                   (write-line "<HTML>" stream)
                   (if error
                     (write-line "No object found at this address." stream)
                     (let ((*URI* URI))
                       (write-object-description object stream)
                   ) )
                   (write-line "</HTML>" stream)
                 )
            )) )
    ) )
) )

;; Set to the command which starts netscape, or to nil if you have netscape
;; but don't wish to use it.
(defvar *netscape* "netscape")

(defun launch-browser (url)
  #+UNIX
  (when (sys::getenv "DISPLAY")
    ; maybe also check
    ; (shell (format nil "type ~A > /dev/null 2>/dev/null" *netscape*))
    (when (eql (shell (format nil "~A -remote 'openURL(~A, new-window)'"
                                  *netscape* url))
               0)
      (return-from launch-browser)))
  ; By default the user has to launch the browser himself.
  (format *debug-io* "~&Please point your browser at ~A~%" url)
)

(defun inspect (*root-object*)
  (let* ((host-string (machine-instance))
         (host (subseq host-string 0 (position #\Space host-string)))
         (server
           (loop
             (multiple-value-bind (server error)
                 (ignore-errors (socket-server (+ 10000 (random 20000))))
               (unless error (return server))
         ) ) )
         (port (socket-server-port server))
         (url (format nil "http://~A:~D/" host port)))
    (launch-browser url)
    (loop
      (let ((stream (socket-accept server)))
        (unwind-protect
          (handle-http-connection stream)
          (close stream)
    ) ) )
    (socket-server-close server)
    (values)
) )