~A - New Value or :q to quit?"
value)
@@ -2512,37 +2508,32 @@ 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 "~A
" (qb intro)))
- (n (length choices)) (i))
- (do ((c choices (cdr c)) (i 1 (+ i 1)))
- ((null c))
- (setf q (format nil "~A~&[~D] ~A~%
" q i (qb (car c)))))
- (do () ((typep i `(integer 1 ,n)))
- (let ((trc (make-array '(0) :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (with-output-to-string (s trc)
- (uiop:print-condition-backtrace intro :stream s))
- (when trc
- (format t "~%~A~%" trc)))
- (setf q (format nil "~A~&~A:" q prompt))
- (setq i (read-from-string (input-dialog obj q (lambda (result)
- (cond ((or (eq result nil)
- (equal result ""))
- (format nil "~A" n))
- (t
- result)))
- :title title
- :placeholder-value (format nil "~A" n)
- :time-out 999
- :modal nil
- :width 640
- :height 480))))
- (nth (- i 1) choices))))
+ (let ((q (format nil "
~A
" (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~%
" 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)))
+ (with-output-to-string (s trc)
+ (uiop:print-condition-backtrace intro :stream s))
+ (when trc
+ (format t "~%~A~%" trc)))
+ (setf q (format nil "~A~&~A:" q prompt))
+ (setq i (read-from-string (input-dialog obj q (lambda (result)
+ (cond ((or (eq result nil)
+ (equal result ""))
+ (format nil "~A" n))
+ (t
+ result)))
+ :title title
+ :placeholder-value (format nil "~A" n)
+ :time-out 999
+ :modal nil
+ :width 640
+ :height 480))))
+ (nth (- i 1) choices)))
(defparameter *default-icon*
"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAACAAAAAcCAYAAAAAwr0iAAAAAXNSR0IArs4c6QAAAKZlWElmTU0A
diff --git a/source/clog-utilities.lisp b/source/clog-utilities.lisp
index 4f6915a..7cbbe4b 100644
--- a/source/clog-utilities.lisp
+++ b/source/clog-utilities.lisp
@@ -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 ;;
;;;;;;;;;;;;;;;
diff --git a/source/clog.lisp b/source/clog.lisp
index fec98b6..c8d4b34 100644
--- a/source/clog.lisp
+++ b/source/clog.lisp
@@ -100,14 +100,15 @@ embedded in a native template application.)"
(random-hex-string function)
"CLOG JS utilities"
- (js-true-p function)
- (p-true-js function)
- (js-on-p function)
- (p-on-js function)
- (escape-string function)
- (lf-to-br function)
- (js-to-integer function)
- (js-to-float function)
+ (js-true-p function)
+ (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)
+ (js-to-float function)
"CLOG Color utilities"
(rgb function)
diff --git a/tools/clog-builder-scope.lisp b/tools/clog-builder-scope.lisp
index 75291a3..4cbf01e 100644
--- a/tools/clog-builder-scope.lisp
+++ b/tools/clog-builder-scope.lisp
@@ -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 "Class: ~A~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 "List" :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 "~A ~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 "~A ~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 "~A ~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))))))