From 04031f2520b0457d04abea86610f80ffc9800deb Mon Sep 17 00:00:00 2001 From: David Botton Date: Thu, 22 Aug 2024 05:49:35 -0400 Subject: [PATCH] added escape-for-html --- source/clog-gui.lisp | 65 +++++++++++++++-------------------- source/clog-utilities.lisp | 13 +++++++ source/clog.lisp | 17 ++++----- tools/clog-builder-scope.lisp | 52 +++++++++++++--------------- 4 files changed, 74 insertions(+), 73 deletions(-) diff --git a/source/clog-gui.lisp b/source/clog-gui.lisp index 0d0b317..2aa57ee 100644 --- a/source/clog-gui.lisp +++ b/source/clog-gui.lisp @@ -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 ~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))))))