From 4850ffaef859a3f33f03c5500602881e30b1039c Mon Sep 17 00:00:00 2001
From: ckonstanski <ckonstanski@pippiandcarlos.com>
Date: Tue, 22 Dec 2020 20:57:44 -0700
Subject: Moved core to its own library

---
 core/html.lisp | 324 ---------------------------------------------------------
 1 file changed, 324 deletions(-)
 delete mode 100644 core/html.lisp

(limited to 'core/html.lisp')

diff --git a/core/html.lisp b/core/html.lisp
deleted file mode 100644
index c76e9cb..0000000
--- a/core/html.lisp
+++ /dev/null
@@ -1,324 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-(declaim (optimize (speed 0) (safety 3) (debug 3)))
-
-;; Lifted directly from araneida.
-
-(in-package :ldapadmin)
-
-;;; XXX fix this, it's not correct
-(defun html-reserved-p (c)
-  (member c '(#\< #\"  #\> #\&)))
-
-(defun html-escape (html-string)
-  (apply #'concatenate 'string
-         (loop for c across html-string
-            if (html-reserved-p c)
-            collect (format nil "&#~A;" (char-code c))
-            else if (eql c #\Newline) collect "<br>"
-            else collect (string c))))
-
-(defun s. (&rest args)
-  "Concatenate ARGS as strings"
-  (declare (optimize (speed 3)))
-  (let ((*print-pretty* nil))
-    (with-output-to-string (out)
-      (dolist (arg args)
-        (princ arg out)))))
-
-(defun html-escape-tag (tag attrs content)
-  (declare (ignore tag attrs))
-  (s. (mapcar #'html-escape content)))
-
-(setf (get 'escape 'html-converter) #'html-escape-tag)
-(setf (get 'null 'html-converter) #'princ-to-string)
-
-(macrolet ((html-attr-body ()
-             `(with-output-to-string (o)
-                (loop for (att val . rest) on attr by #'cddr do
-                     (cond
-                       #+parenscript((and (symbolp att) (equal (symbol-name 'css) (symbol-name att)))
-                                     (progn
-                                       (princ " " o)
-                                       (princ "style=\"" o)
-                                       (princ (val-printer (parenscript::css-inline-func val)) o)
-                                       (princ "\"" o)))
-                       ((symbolp att)
-                        (progn
-                          (princ " " o)
-                          (princ (symbol-name att) o)
-                          (princ "=\"" o)
-                          (princ (val-printer val) o)
-                          (princ "\"" o)))
-                       (t
-                        (error "attribute ~S is not a symbol in attribute list ~S" att attr)))))))
-  (defun html-attr (attr)
-    (macrolet ((val-printer (val)
-                 val))
-      (html-attr-body)))
-  (defun html-attr-escaped (attr)
-    (macrolet ((val-printer (val)
-                 `(html-escape ,val)))
-      (html-attr-body))))
-
-(defun empty-element-p (tag)
-  (member (intern (symbol-name tag) #.*package*) '()))
-
-(defmacro defhtmltag (tag (attributes-var content-var) &body body)
-  "Define a custom HTML tag
-Useful for custom phrases, or even special constructs.
-
-Example:
-(defhtmltag coffee (attr content)
-  (declare (ignore attr content))
-  \"c|_|\")
-
-So, saying
-(span \"Nice hot \" (coffee))
-
-Would produce:
-<span>Nice hot c|_|</span>
-
-More in-depth use would be something such as:
-(even-odd-list
- (li \"one\")
- (li \"two\")
- (li \"three\"))
-
-Turning into:
-(ul
- ((li :class \"odd\") \"one\")
- ((li :class \"even\") \"two\")
- ((li :class \"odd\") \"odd\"))
-
-Your custom tag is expected to return either a string or
-an html construct like you'd pass to HTML-STREAM."
-  (with-gensyms (throw-away)
-    `(setf (get ',tag :html-converter)
-      (lambda (,throw-away ,attributes-var ,content-var)
-	(declare (ignore ,throw-away))
-	(funcall 
-         (lambda (,attributes-var ,content-var)
-	   ,@body)
-	 ,attributes-var ,content-var)))))
-
-(defun htmlp (html)
-  "Returns t if html is a legal HTML list.
-NB: HTML and friends print out a superset of legal html lists.
-
-'(ul (li \"yes\") (li \"no\")) is legal
-3 is not
-
-But HTML will print both of them"
-  (and (consp html)
-       (not (stringp (car html)))))
-
-(defmacro destructure-html ((tag-sym attrs-sym content-sym) html &body body)
-  "Destructure an HTML construct.
-(destructure-html (tag attrs content) '((span :class \"strange\") \"A strange span!\")
-  (format t \"<~A ~{~A~}>~{~A~}</~A>\" tag attrs content tag))
-If the construct is invalid, it will cause an error"
-  (once-only (html)
-    `(if (htmlp ,html)
-      (let ((,tag-sym (if (consp (car ,html))
-			  (caar ,html)
-			  (car ,html)))
-	    (,attrs-sym (if (consp (car ,html))
-			    (cdar ,html)
-			    nil))
-	    (,content-sym (cdr ,html)))
-	,@body))))
-
-; I admit, this is a rather goofy way to write this. There's just so much code they have in common
-; and this lets me modify them rather easily.
-(macrolet ((html-body ()
-             `(ret-block
-               (cond ((htmlp things)
-                      (destructure-html (tag attrs content) things
-                        (let ((special-effect (get tag :html-converter)))
-                          (if special-effect
-                              (if (not (functionp special-effect))
-                                  (error "Tag ~A has :html-converter set, but NOT as a function." tag)
-                                  (call-self stream (funcall special-effect tag attrs content) inline-elements))
-                              (cond ((equal (symbol-name 'comment) (symbol-name tag))
-                                     (printing
-                                      (format-out "<!-- ~{~A ~}~%" attrs)
-                                      (iter-list (c content)
-                                                 (call-self stream c inline-elements))
-                                      (format-out " -->~%")))
-                                    #+parenscript
-                                    ((equal (symbol-name 'css) (symbol-name tag))
-                                     (printing
-                                      (format-out "<style type=\"text/css\">~%")
-                                      (format-out "<!--~%")
-                                      (iter-list (c content)
-                                                 (format-out (parenscript::css-rule-to-string (parenscript::make-css-rule (car c) (cdr c)))))
-                                      (format-out "~%-->")
-                                      (format-out "</style>")))
-                                    #+parenscript
-                                    ((equal (symbol-name 'js-script) (symbol-name tag))
-                                     (printing
-                                      (format-out "<script type=\"text/javascript\">~%")
-                                      (format-out "// <![CDATA[~%")
-                                      (format-out (parenscript:js* (cons 'progn content)))
-                                      (format-out "~%// ]]>~%")))
-                                    ((not (empty-element-p tag))
-                                     (printing
-                                      (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs))
-                                      (iter-list (c content)
-                                                 (call-self stream c inline-elements))
-                                      (format-out "</~A>~:[~;~%~]"
-                                                  (symbol-name tag)
-                                                  (not (member tag inline-elements)))))
-                                    (t
-                                     (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs))))))))
-                     ((consp things)
-                      (iter-list (thing things) (format-out "~A" thing)))
-                     ((functionp things)
-                      (call-function things stream))
-                     ((keywordp things)
-                      (format-out "<~A>" (symbol-name things)))
-                     (t
-                      (format-out "~A" (thing-printer things)))))))
-
-  ;; stream forms first
-  (macrolet ((ret-block (output-block)
-               `(progn
-                  ,output-block
-                  t))
-             (iter-list ((item list) func)
-               `(dolist (,item ,list)
-                  ,func))
-             (printing (&body list)
-               `(progn
-                  ,@list))
-             (format-out (&rest args)
-               `(format stream ,@args))
-             (call-function (things stream)
-               `(funcall ,things ,stream)))
-    
-    (defun html-stream (stream things &optional inline-elements)
-      "Format supplied argument as HTML.  Argument may be a string
-\(returned unchanged\) or a list of \(tag content\) where tag may be
-\(tagname attrs\).  \(\(a :href \"/ \"\) \"home\"\) is formatted as
-you'd expect it to be.  INLINE-ELEMENTS is a list of elements not to
-print a newline after.  Returns T unless broken, so can be the last
-form in a handler For special effects, set the HTML-CONVERTER property
-of a symbol for a tag to a function.  It will be called with arguments
-\(TAG ATTRS CONTENT\) and should return a string to be interpolated at
-that point."
-      (declare (optimize (speed 3))
-               (type stream stream))
-      (macrolet ((attr-printer (attrs)
-                   `(html-attr ,attrs))
-                 (call-self (stream things &optional inline-elements)
-                   `(html-stream ,stream ,things ,inline-elements))
-                 (thing-printer (things)
-                   `(princ-to-string things)))
-        (html-body)))
-
-    (defun html-escaped-stream (stream things &optional inline-elements)
-      "Format supplied argument as HTML, escaping properly.
-Just like html-stream except certain things are now html-escaped.
-Content - in '\(p \"foo\"\) \"foo\" is the content - is escaped, as
-well as the values of attributes. Please note that this CAN result in
-double escaping if calling code also escapes.  For special effects,
-set the HTML-CONVERTER property of a symbol for a tag to a function.
-It will be called with arguments \(TAG ATTRS CONTENT\) and should
-return a string to be interpolated at that point. NB that the attrs
-and content will be passed in *unescaped*"
-      (declare (optimize (speed 3))
-               (type stream stream))
-      (macrolet ((attr-printer (attrs)
-                   `(html-attr-escaped ,attrs))
-                 (call-self (stream things &optional inline-elements)
-                   `(html-escaped-stream ,stream ,things ,inline-elements))
-                 (thing-printer (things)
-                   `(html-escape (princ-to-string ,things))))
-        (html-body))))
-
-  ;; now for the string forms
-  (macrolet ((ret-block (output-block)
-               output-block)
-             (iter-list ((item list) func)
-               `(apply #'concatenate 'string (mapcar (lambda (,item) ,func) ,list)))
-             (printing (&body list)
-               `(concatenate 'string
-                             ,@list))
-             (format-out (&rest args)
-               `(format nil ,@args))
-             (call-function (things stream)
-               (declare (ignore stream))
-               `(funcall ,things)))
-    
-    (defun html (things &optional inline-elements)
-      "Format supplied argument as HTML.  Argument may be a string
-\(returned unchanged\) or a list of \(tag content\) where tag may be
-\(tagname attrs\).  \(\(a :href \"/\"\) \"home\"\) is formatted as
-you'd expect it to be.  For special effects, set the HTML-CONVERTER
-property of a symbol for a tag to a function.  It will be called with
-arguments \(TAG ATTRS CONTENT\) and should return a string to be
-interpolated at that point."
-      (declare (optimize (speed 3)))
-      (macrolet ((attr-printer (attrs)
-                   `(html-attr ,attrs))
-                 (call-self (stream things &optional inline-elements)
-                   `(html ,things ,inline-elements))
-                 (thing-printer (things)
-                   `(princ-to-string ,things)))
-        (html-body)))))
-
-(defun html5 (things &optional inline-elements)
-  (format nil "<!DOCTYPE html>~%~a" (html things inline-elements)))
-
-#||
-(search-html-tree '((string> ht :element) t (= p :element)) '((html) ((body) ((p) "foo") ((p) "bar") ((div :title "titl") "blah"))))
-||#
-
-(defun search-html-tree (search-terms tree)
-  (labels ((node-matches (term tree)
-             (or (eql term t)
-                 (destructuring-bind (op content name) term
-                   (let ((r-op (if (eql op '=) 'equal op)))
-                     (if (eql name :element)
-                         (funcall r-op content (caar tree))
-                         (funcall r-op content (getf (cdar tree) name))))))))
-    (cond ((eql (cdr search-terms) nil)
-           (and (node-matches (car search-terms) tree) tree))
-          ((null tree) nil)
-          ((node-matches (car search-terms) tree)
-           (remove-if #'null
-                      (mapcar (lambda (tr)
-                                (search-html-tree (cdr search-terms) tr))
-                              (cdr tree)))))))
-
-
-#+parenscript
-(defmacro css-file (request &rest rules)
-  "Sends CSS as a file in response to request, as specified by rules.
-  For example:
-  (defmethod handle-request-response ((handler my-handler) method request)
-    (css-file request
-	      (* :border \"1px solid black\")
-	      (div.bl0rg :font-family \"serif\")
-	      ((\"a:active\" \"a:hoover\") :color \"black\" :size \"200%\")))
-  See the documentation for Parenscript for more info on the CSS rules themselves."
-  `(progn
-     (request-send-headers ,request :content-type "text/css")
-     ,@(mapcar (lambda (rule)
-                 `(princ (parenscript::css-rule-to-string (parenscript::css-rule ,@rule)) (request-stream ,request)))
-               rules)
-     t))
-
-#+parenscript
-(defmacro js-file (request &rest body)
-  "Sends Javascript as a file in response to request, as specified by the javascript body.
-  For example:
-  (defmethod handle-request-response ((handler my-handler) method request)
-    (js-file request
-      (defun hello ()
-	     (alert \"Hello, World!\"))))
-  See the documentation for Parenscript for more info on how to do Javascript."
-  `(progn
-     (request-send-headers ,request :content-type "text/javascript")
-     (princ (parenscript:js ,@body) (request-stream ,request))
-     t))
-- 
cgit v1.3