mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
added escape-for-html
This commit is contained in:
David Botton
parent
a34e516325
commit
04031f2520
4 changed files with 74 additions and 73 deletions
|
|
@ -310,9 +310,7 @@ symbol before any change is made by dialog."
|
|||
(when (validp body)
|
||||
(if (and ,time-out (not ,auto-probe))
|
||||
(let* ((ovalue ,symbol)
|
||||
(value (format nil "~A" ovalue)))
|
||||
(setf value (ppcre:regex-replace-all "<" value "<"))
|
||||
(setf value (ppcre:regex-replace-all ">" value ">"))
|
||||
(value (escape-for-html ovalue)))
|
||||
(when ,save-value
|
||||
(setf clog-gui:*probe* ovalue))
|
||||
(input-dialog body
|
||||
|
|
@ -334,9 +332,7 @@ symbol before any change is made by dialog."
|
|||
(lambda ()
|
||||
(loop
|
||||
(let* ((ovalue ,symbol)
|
||||
(value (format nil "~A" ovalue)))
|
||||
(setf value (ppcre:regex-replace-all "<" value "<"))
|
||||
(setf value (ppcre:regex-replace-all ">" value ">"))
|
||||
(value (escape-for-html ovalue)))
|
||||
(when (eq (input-dialog body
|
||||
(format nil "Probe result <code>~A</code> - New Value or :q to quit?"
|
||||
value)
|
||||
|
|
@ -2512,16 +2508,11 @@ make-two-way-stream to provide a *query-io* using a clog-gui instead of console)
|
|||
|
||||
(defun one-of-dialog (obj intro choices &key (title "Please choose one") (prompt "Choice"))
|
||||
"Prompt a dialog box with TITLE and INTRO using list of CHOICES and PROMPT"
|
||||
(flet ((qb (q)
|
||||
(setf q (format nil "~A" q))
|
||||
(setf q (ppcre:regex-replace-all "<" q "<"))
|
||||
(setf q (ppcre:regex-replace-all ">" q ">"))
|
||||
q))
|
||||
(let ((q (format nil "<pre>~A</pre><p style='text-align:left'>" (qb intro)))
|
||||
(let ((q (format nil "<pre>~A</pre><p style='text-align:left'>" (escape-for-html intro)))
|
||||
(n (length choices)) (i))
|
||||
(do ((c choices (cdr c)) (i 1 (+ i 1)))
|
||||
((null c))
|
||||
(setf q (format nil "~A~&[~D] ~A~%<br>" q i (qb (car c)))))
|
||||
(setf q (format nil "~A~&[~D] ~A~%<br>" q i (escape-for-html (car c)))))
|
||||
(do () ((typep i `(integer 1 ,n)))
|
||||
(let ((trc (make-array '(0) :element-type 'base-char
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
|
|
@ -2542,7 +2533,7 @@ make-two-way-stream to provide a *query-io* using a clog-gui instead of console)
|
|||
:modal nil
|
||||
:width 640
|
||||
:height 480))))
|
||||
(nth (- i 1) choices))))
|
||||
(nth (- i 1) choices)))
|
||||
|
||||
(defparameter *default-icon*
|
||||
"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAACAAAAAcCAYAAAAAwr0iAAAAAXNSR0IArs4c6QAAAKZlWElmTU0A
|
||||
|
|
|
|||
|
|
@ -58,6 +58,19 @@ package."
|
|||
;; Implementation - JS Utilities
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;
|
||||
;; escape-for-html ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun escape-for-html (value)
|
||||
"Returns a string where < and > are replaced with html entities. This is
|
||||
particularly useful as #<> is used for unprintable objects in Lisp. Value is
|
||||
converted with format to a string first."
|
||||
(setf value (format nil "~A" value))
|
||||
(setf value (ppcre:regex-replace-all "<" value "<"))
|
||||
(setf value (ppcre:regex-replace-all ">" value ">"))
|
||||
value)
|
||||
|
||||
;;;;;;;;;;;;;;;
|
||||
;; js-true-p ;;
|
||||
;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@ embedded in a native template application.)"
|
|||
(p-true-js function)
|
||||
(js-on-p function)
|
||||
(p-on-js function)
|
||||
(escape-for-html function)
|
||||
(escape-string function)
|
||||
(lf-to-br function)
|
||||
(js-to-integer function)
|
||||
|
|
|
|||
|
|
@ -51,15 +51,11 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
(setf (positioning pac-line) :absolute)
|
||||
(set-geometry root-obj :height 27 :width "100%" :top 0 :left 0 :right 0)
|
||||
(set-geometry pac-line :height 27 :width "100%" :top 27 :left 0 :right 0)
|
||||
(labels ((escape-lisp (object)
|
||||
(let ((value (format nil "~A" object)))
|
||||
(setf value (ppcre:regex-replace-all "<" value "<"))
|
||||
(setf value (ppcre:regex-replace-all ">" value ">"))))
|
||||
(get-package (sym)
|
||||
(labels ((get-package (sym)
|
||||
(handler-case
|
||||
(escape-lisp (package-name (symbol-package sym)))
|
||||
(escape-for-html (package-name (symbol-package sym)))
|
||||
(error ()
|
||||
(escape-lisp sym))))
|
||||
(escape-for-html sym))))
|
||||
(add-list (node lst)
|
||||
(mapcar (lambda (object)
|
||||
(add-class node (class-of object) object))
|
||||
|
|
@ -86,7 +82,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
:content (format nil "<b>Class: ~A</b>~A"
|
||||
(get-name (class-name class))
|
||||
(if (typep object class)
|
||||
(format nil " : Object Value ~A" (escape-lisp object))
|
||||
(format nil " : Object Value ~A" (escape-for-html object))
|
||||
"")))))
|
||||
(when (consp object)
|
||||
(create-clog-tree-item (tree-root class-tree) :content "<u>List</u>" :node-html "")
|
||||
|
|
@ -152,7 +148,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
:fill-function (lambda (obj)
|
||||
(on-calc-methods obj class))))))
|
||||
(get-name (sym)
|
||||
(escape-lisp (if (typep sym 'cons)
|
||||
(escape-for-html (if (typep sym 'cons)
|
||||
(format nil "(~A ~A:~A)"
|
||||
(first sym)
|
||||
(get-package (second sym))
|
||||
|
|
@ -183,7 +179,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
:content (handler-case
|
||||
(format nil "<b>~A</b> ~A"
|
||||
(get-name (closer-mop:generic-function-name item))
|
||||
(escape-lisp (closer-mop:generic-function-lambda-list item)))
|
||||
(escape-for-html (closer-mop:generic-function-lambda-list item)))
|
||||
(error ()
|
||||
""))))
|
||||
(closer-mop:specializer-direct-generic-functions class)))
|
||||
|
|
@ -208,7 +204,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
:package (second sys))))
|
||||
:content (format nil "<b>~A</b> ~A"
|
||||
(get-name (closer-mop:generic-function-name (closer-mop:method-generic-function item)))
|
||||
(escape-lisp (closer-mop:method-lambda-list item)))))
|
||||
(escape-for-html (closer-mop:method-lambda-list item)))))
|
||||
(closer-mop:specializer-direct-methods dclass))))
|
||||
(on-method (obj class)
|
||||
(mapcar (lambda (item)
|
||||
|
|
@ -225,7 +221,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
:package (second sys))))
|
||||
:content (format nil "<b>~A</b> ~A"
|
||||
(get-name (closer-mop:generic-function-name (closer-mop:method-generic-function item)))
|
||||
(escape-lisp (closer-mop:method-lambda-list item)))))
|
||||
(escape-for-html (closer-mop:method-lambda-list item)))))
|
||||
(closer-mop:specializer-direct-methods class)))
|
||||
(on-precedences (obj class object)
|
||||
(mapcar (lambda (item)
|
||||
|
|
@ -256,7 +252,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
(if (typep object class)
|
||||
(handler-case
|
||||
(format nil " Object Value = ~A"
|
||||
(escape-lisp (slot-value object (closer-mop:slot-definition-name slot))))
|
||||
(escape-for-html (slot-value object (closer-mop:slot-definition-name slot))))
|
||||
(error () " Unbound"))
|
||||
"")))))
|
||||
(when (typep object class)
|
||||
|
|
@ -267,25 +263,25 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
(error () nil)))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initargs = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initargs slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initargs slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initform = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initform slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initform slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initfunction = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initfunction slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initfunction slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-readers = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-readers slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-readers slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-writers = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-writers slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-writers slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-type = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-type slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-type slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-allocation = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-allocation slot))))))
|
||||
(escape-for-html (closer-mop:slot-definition-allocation slot))))))
|
||||
(closer-mop:class-direct-slots class)))
|
||||
(on-calc-slots (obj class object)
|
||||
(dolist (dclass (closer-mop:class-precedence-list class))
|
||||
|
|
@ -310,7 +306,7 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
(if (typep object class)
|
||||
(handler-case
|
||||
(format nil " Object Value = ~A"
|
||||
(escape-lisp (slot-value object (closer-mop:slot-definition-name slot))))
|
||||
(escape-for-html (slot-value object (closer-mop:slot-definition-name slot))))
|
||||
(error () " Unbound"))
|
||||
"")))))
|
||||
(when (typep object class)
|
||||
|
|
@ -321,25 +317,25 @@ name. If CLOG-BODY not set use *clog-debug-instance*"
|
|||
(error () nil)))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initargs = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initargs slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initargs slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initform = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initform slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initform slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-initfunction = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-initfunction slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-initfunction slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-readers = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-readers slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-readers slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-writers = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-writers slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-writers slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-type = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-type slot))))
|
||||
(escape-for-html (closer-mop:slot-definition-type slot))))
|
||||
(create-clog-tree-item (tree-root sltt)
|
||||
:content (format nil "slot-definition-allocation = ~A"
|
||||
(escape-lisp (closer-mop:slot-definition-allocation slot))))))
|
||||
(escape-for-html (closer-mop:slot-definition-allocation slot))))))
|
||||
(closer-mop:class-direct-slots dclass))
|
||||
(error ()
|
||||
(return))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue