[Prev][Next][Index][Thread]
Case problems in http:examples;documentation.lisp
If Lisp prints in lowercase this fails because it tries to lookup
symbols with lowercase names at various points. The attached patch (I
don't know how to make diffs on the symbolics...) fixes it by using
WITH-STANDARD-IO-SYNTAX but I'm not sure it's right. I'm running 60.57
so maybe this is fixed in later patches.
--tim
--cut--
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: user; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Reason: Function http::describe-symbol: fix case problem
;;; Function (clos:method http::respond-to-show-documentation (url:http-search t)): ditto
;;; Written by tfb, 21-Mar-1997 20:12:31
;;; while running on Ishmael from FEP0:>ishmael-cl-http.load.1
;;; with Genera 8.3, Logical Pathnames Translation Files NEWEST, UX Support 437.0,
;;; Experimental HTTP Server 60.57, Showable Procedures 36.3, Binary Tree 34.0,
;;; Experimental W3 Presentation System 2.2, microcode 3640-FPA-MIC 430, FEP 127,
;;; Fep0:>v127-lisp.flod(67), Fep0:>v127-loaders.flod(67), Fep0:>v127-info.flod(67),
;;; Fep0:>v127-rel7.flod(65), Fep0:>v127-debug.flod(66), 1067x748 B&W Screen,
;;; Machine serial number 5178,
;;; Tar tape patch (from SYS:SW;PATCHES;TAR-TAPE-PATCH.LISP.1),
;;; Misc hack: Add free words remaining to wholine display. (from SYS:SW;USEFUL-PATCHES;WHOLINE-FREE-WORDS),
;;; Patch TCP hang on close when client drops connection. (from HTTP:LISPM;SERVER;TCP-PATCH-HANG-ON-CLOSE.LISP.8).
(SCT:NOTE-PRIVATE-PATCH "Fix PRINT-CASE nasties in self documentation")
;========================
(SCT:BEGIN-PATCH-SECTION)
; From buffer documentation.lisp >tfb>work>cl-http>http>examples I: (1)
(SCT:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: http; BASE: 10; Syntax: ANSI-Common-Lisp; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*-")
(defun describe-symbol (sym &key reference documentation-p (stream html:*output-stream*)
&aux describe-handled-p)
(flet ((note-symbol (symbol reference)
(let* ((*package* (find-package :common-lisp)))
(html:break-line :stream stream)
(html:with-rendition (:bold :stream stream)
(if reference
(let* ((string (with-standard-io-syntax
(with-output-to-string (string)
(write symbol :stream string :readably t))))
(url-string (concatenate 'string reference string)))
(declare (dynamic-extent string url-string))
(html:note-anchor string :reference url-string :stream stream))
(write symbol :stream stream :readably t)))))
(note-documentation (symbol doc-type)
(let ((docs (documentation symbol doc-type)))
(html:break-line :stream stream)
(cond ((and docs (position #\newline docs :test #'eql))
(html:with-verbatim-text (:fresh-line nil :stream stream)
(html:write-string-quoting-specials docs stream)))
(docs
(html:write-string-quoting-specials docs stream))
(t (write-string "[Undocumented]" stream))))))
(declare (inline note-symbol note-documentation))
(macrolet ((%describe-symbol ((symbol reference doc-type lisp-type-string) &body body)
`(progn
(setq describe-handled-p t)
(note-symbol ,symbol ,reference)
(write-string ,lisp-type-string stream)
,@body
(when documentation-p
(note-documentation ,symbol ,doc-type)))))
(cond-every
((fboundp sym)
(%describe-symbol
(sym reference 'function
(cond ((macro-function sym) " [macro]: ")
((special-operator-p sym) " [special form]: ")
((functionp (symbol-function sym)) " [function]: ")
(t " [???]: ")))
(write (or (arglist sym) " ()") :stream stream :escape nil)))
((boundp sym)
(%describe-symbol
(sym reference 'variable
" [variable] : ")
(if (boundp sym)
(write-lisp-expression (symbol-value sym) stream)
(write-string "Unbound" stream))))
((find-class sym nil)
(%describe-symbol (sym reference 'type " [class] : ")))
;; handle more classes of lisp objects like methods....
((not describe-handled-p) (%describe-symbol (sym reference 'function " [random] : ")))))))
;========================
(SCT:BEGIN-PATCH-SECTION)
; From buffer documentation.lisp >tfb>work>cl-http>http>examples I: (1)
(SCT:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: http; BASE: 10; Syntax: ANSI-Common-Lisp; Default-Character-Style: (:FIX :ROMAN :NORMAL);-*-")
(PROGN
(defmethod respond-to-show-documentation ((url url:http-search) stream)
(with-slots (url:search-keys) url
(with-conditional-get-response (stream :html :expires (url:expiration-universal-time url)
:cache-control (url:response-cache-control-directives url)
:content-language (languages url))
(let ((title (with-standard-io-syntax
(format nil "Documentation for ~{~A~^~}" url:search-keys))))
(html:with-html-document (:stream stream)
(html:with-document-preamble (:stream stream)
(html:declare-base-reference url :stream stream)
(html:declare-title title :stream stream))
(html:with-document-body (:stream stream)
(html:with-section-heading (title :stream stream)
(image-line :stream stream)
(loop for item in url:search-keys
for sym = (get-symbol item)
do (describe-symbol sym :documentation-p t :stream stream))
(image-line :stream stream)
(cl-http-signature stream))))))))
(export-url #u"/cl-http/show-documentation?"
:search
:response-function #'respond-to-show-documentation
:expiration `(:interval ,(* 15. 60.))
:public t
:language :en
:keywords '(:cl-http :documentation)
:documentation "Shows the documentation for a Lisp symbol in CL-HTTP.
To use, provide a package-prefixed name of a symbol in uppercase (unless slashified versions are desired).")
;;;-------------------------------------------------------------------
;;;
;;;
;;;
)