mirror of
https://gitlab.com/eql/EQL5.git
synced 2025-12-25 03:11:44 -08:00
479 lines
17 KiB
Common Lisp
479 lines
17 KiB
Common Lisp
;;; Html utils (for easy WebKit GUIs)
|
|
;;;
|
|
;;; (depends on small plugin, see "lib/")
|
|
;;;
|
|
;;; Thread-safe utility functions, including convenience wrappers for all QWebElement methods
|
|
;;; (see also HGET, HSET, JS, TO-PIXMAP, ASSIGN-PIXMAP...).
|
|
|
|
#+win32 (si:trap-fpe 'floating-point-underflow nil) ; for QWebInspector
|
|
|
|
(qrequire :webkit)
|
|
|
|
(defpackage :h-utils
|
|
(:nicknames :h)
|
|
(:use :common-lisp :eql)
|
|
(:export
|
|
#:*web-view*
|
|
#:add-class
|
|
#:append-html
|
|
#:append-inside
|
|
#:append-outside
|
|
#:assign-pixmap
|
|
#:attribute-names
|
|
#:classes
|
|
#:clear-html
|
|
#:clear-pixmap
|
|
#:clone
|
|
#:document
|
|
#:document-element
|
|
#:element
|
|
#:enclose-contents-with
|
|
#:enclose-with
|
|
#:find-all-elements
|
|
#:find-first
|
|
#:find-first-element
|
|
#:first-child
|
|
#:frame
|
|
#:geometry
|
|
#:has-attribute
|
|
#:has-attributes
|
|
#:has-class
|
|
#:has-focus
|
|
#:hget
|
|
#:hset
|
|
#:inspector
|
|
#:is-null
|
|
#:iterate-child-elements
|
|
#:iterate-elements
|
|
#:lisp
|
|
#:lisp*
|
|
#:js
|
|
#:last-child
|
|
#:local-name
|
|
#:namespace-uri
|
|
#:next-sibling
|
|
#:parent
|
|
#:pause
|
|
#:prefix
|
|
#:prepend-inside
|
|
#:prepend-outside
|
|
#:previous-sibling
|
|
#:remove-all-children
|
|
#:remove-attribute
|
|
#:remove-class
|
|
#:remove-from-document
|
|
#:replace*
|
|
#:scroll-to-anchor
|
|
#:scroll-to-bottom
|
|
#:scroll-to-top
|
|
#:set-focus
|
|
#:set-style-property
|
|
#:style-property
|
|
#:tag-name
|
|
#:toggle-class
|
|
#:to-html
|
|
#:to-pixmap
|
|
#:web-frame))
|
|
|
|
(provide :h-utils)
|
|
|
|
(in-package :h-utils)
|
|
|
|
(defvar *web-view* (qnew "QWebView"))
|
|
(defvar *webkit-bridge* (qload-c++ "lib/webkit_bridge"))
|
|
(defvar *web-pixmap*)
|
|
|
|
(defun frame ()
|
|
(qrun* (! ("mainFrame" "page" *web-view*))))
|
|
|
|
;;; utils
|
|
|
|
(defmacro iterate-elements (selector &body body)
|
|
"Iterate over web elements of QWebFrame, binding H:ELEMENT to the current QWebElement."
|
|
(let ((i (gensym)))
|
|
`(let ((elements (qrun* (! "findAllElements" (frame) ,selector))))
|
|
(dotimes (,i (qrun* (! "count" elements)))
|
|
(let ((element (qrun* (! "at" elements ,i))))
|
|
,@body)))))
|
|
|
|
(defmacro iterate-child-elements (web-element selector &body body)
|
|
"Iterate over child elements of a QWebElement, binding H:ELEMENT to the current QWebElement."
|
|
(let ((i (gensym)))
|
|
`(let ((elements (qrun* (! "findAll" (ensure-web-element ,web-element) ,selector))))
|
|
(dotimes (,i (qrun* (! "count" elements)))
|
|
(let ((element (qrun* (! "at" elements ,i))))
|
|
,@body)))))
|
|
|
|
(defun >> (expression)
|
|
"Convert to string if needed."
|
|
(if (stringp expression)
|
|
expression
|
|
(princ-to-string expression)))
|
|
|
|
(defun << (expression)
|
|
"Convert from string if needed (to preserve strings, quote them in JavaScript)."
|
|
(cond ((stringp expression)
|
|
(read-from-string expression))
|
|
((listp expression)
|
|
(mapcar (lambda (x) (if (stringp x) (read-from-string x) x))
|
|
expression))
|
|
(t
|
|
expression)))
|
|
|
|
(defun assert-web-element (x)
|
|
(assert (= #.(qid "QWebElement") (qt-object-id x)) nil
|
|
"Wanted <QWebElement>, got: ~S." x)
|
|
x)
|
|
|
|
(defun ensure-web-element (x)
|
|
(if (stringp x)
|
|
(find-first-element x)
|
|
(assert-web-element x)))
|
|
|
|
(defun %input-text-p (web-element)
|
|
(and (string-equal "INPUT" (tag-name web-element))
|
|
(string-equal "text" (qrun* (! "attribute" web-element "type")))))
|
|
|
|
(defun js (javascript &optional web-element)
|
|
"Evaluate JavaScript in the context (as 'this') of either a QWebElement or the main QWebFrame."
|
|
(qrun* (! ("toString" ("evaluateJavaScript" javascript)
|
|
(or web-element (frame))))))
|
|
|
|
;;; Special functions HGET and HSET for :text :inner-xml :outer-xml and attributes like :value :src etc.;
|
|
;;; additionally, they can be used for any custom string property, e.g. :image-label "sunset"
|
|
|
|
(defun hget (selector/web-element attribute)
|
|
"Return (as multiple values) Html attribute of either all elements matching selector, or of the given web element."
|
|
(let (values)
|
|
(flet ((%do (element)
|
|
(push (cond ((eql :text attribute)
|
|
(qrun* (! "toPlainText" element)))
|
|
((eql :inner-xml attribute)
|
|
(qrun* (! "toInnerXml" element)))
|
|
((eql :outer-xml attribute)
|
|
(qrun* (! "toOuterXml" element)))
|
|
((and (%input-text-p element)
|
|
(member attribute '(:value :size)))
|
|
(js (format nil "this.~(~A~)" attribute) element))
|
|
(t
|
|
(let ((a (! "attribute" element (string-downcase attribute) "NIL")))
|
|
(unless (string= "NIL" a)
|
|
a))))
|
|
values)))
|
|
(if (stringp selector/web-element)
|
|
(iterate-elements selector/web-element
|
|
(%do element))
|
|
(progn
|
|
(assert-web-element selector/web-element)
|
|
(%do selector/web-element))))
|
|
(values-list (nreverse values))))
|
|
|
|
(defun hset (selector/web-element &rest attributes)
|
|
"Set Html attributes (any number of attribute/value pairs) of either all elements matching selector, or of the given web element."
|
|
(flet ((%do (element)
|
|
(do ((curr attributes (cddr curr)))
|
|
((null curr))
|
|
(let ((attribute (first curr))
|
|
(value (second curr)))
|
|
(cond ((eql :text attribute)
|
|
(qrun* (! "setPlainText" element value)))
|
|
((eql :inner-xml attribute)
|
|
(qrun* (! "setInnerXml" element value)))
|
|
((eql :outer-xml attribute)
|
|
(qrun* (! "setOuterXml" element value)))
|
|
((and (%input-text-p element)
|
|
(member attribute '(:value :size)))
|
|
(js (format nil "this.~(~A~) = ~S" attribute value) element))
|
|
(t
|
|
(qrun* (! "setAttribute" element (string-downcase attribute) value))))))))
|
|
(if (stringp selector/web-element)
|
|
(iterate-elements selector/web-element
|
|
(%do element))
|
|
(progn
|
|
(assert-web-element selector/web-element)
|
|
(%do selector/web-element)))))
|
|
|
|
;;; convenience wrappers for all QWebElement methods
|
|
|
|
(defmacro defun-web-element ((name qt-name &optional check-null))
|
|
`(defun ,name (x)
|
|
"QWebElement convenience function."
|
|
,(if check-null
|
|
`(qrun* (let ((el (! ,qt-name (ensure-web-element x))))
|
|
(unless (! "isNull" el)
|
|
el)))
|
|
`(qrun* (! ,qt-name (ensure-web-element x))))))
|
|
|
|
(defmacro defun-web-element-arg ((name qt-name &optional check-null))
|
|
`(defun ,name (x arg)
|
|
"QWebElement convenience function."
|
|
,(if check-null
|
|
`(qrun* (let ((el (! ,qt-name (ensure-web-element x) arg)))
|
|
(unless (! "isNull" el)
|
|
el)))
|
|
`(qrun* (! ,qt-name (ensure-web-element x) arg)))))
|
|
|
|
(defun attribute-names (web-element &optional namespace-uri)
|
|
"QWebElement convenience function."
|
|
(qrun* (! "attributeNames" (ensure-web-element web-element) namespace-uri)))
|
|
|
|
(defun append-inside (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "appendInside(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "appendInside(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun append-outside (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "appendOutside(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "appendOutside(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun enclose-contents-with (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "encloseContentsWith(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "encloseContentsWith(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun enclose-with (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "encloseWith(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "encloseWith(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun prepend-inside (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "prependInside(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "prependInside(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun prepend-outside (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "prependOutside(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "prependOutside(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun replace* (web-element x)
|
|
"QWebElement convenience function."
|
|
(if (stringp x)
|
|
(qrun* (! "replace(QString)" (ensure-web-element web-element) x))
|
|
(qrun* (! "replace(QWebElement)" (ensure-web-element web-element) (ensure-web-element x)))))
|
|
|
|
(defun set-style-property (selector/web-element property value)
|
|
"QWebElement convenience function."
|
|
(qrun* (! "setStyleProperty" (ensure-web-element selector/web-element)
|
|
(string-downcase property) value)))
|
|
|
|
(defun style-property (selector/web-element property &optional (resolve |QWebElement.ComputedStyle|))
|
|
"QWebElement convenience function."
|
|
(qrun* (! "styleProperty" (ensure-web-element selector/web-element)
|
|
(string-downcase property) resolve)))
|
|
|
|
(defun-web-element-arg (add-class "addClass"))
|
|
|
|
(defun-web-element (classes "classes"))
|
|
|
|
(defun-web-element (clone "clone"))
|
|
|
|
(defun-web-element (document "document"))
|
|
|
|
(defun-web-element-arg (find-first "findFirst" :check-null))
|
|
|
|
(defun-web-element (first-child "firstChild" :check-null))
|
|
|
|
(defun-web-element (geometry "geometry"))
|
|
|
|
(defun-web-element-arg (has-attribute "hasAttribute"))
|
|
|
|
(defun-web-element (has-attributes "hasAttributes"))
|
|
|
|
(defun-web-element-arg (has-class "hasClass"))
|
|
|
|
(defun-web-element (has-focus "hasFocus"))
|
|
|
|
(defun-web-element (is-null "isNull"))
|
|
|
|
(defun-web-element (last-child "lastChild" :check-null))
|
|
|
|
(defun-web-element (local-name "localName"))
|
|
|
|
(defun-web-element (namespace-uri "namespaceUri"))
|
|
|
|
(defun-web-element (next-sibling "nextSibling" :check-null))
|
|
|
|
(defun-web-element (parent "parent" :check-null))
|
|
|
|
(defun-web-element (prefix "prefix"))
|
|
|
|
(defun-web-element (previous-sibling "previousSibling" :check-null))
|
|
|
|
(defun-web-element-arg (remove-attribute "removeAttribute"))
|
|
|
|
(defun-web-element (remove-all-children "removeAllChildren"))
|
|
|
|
(defun-web-element-arg (remove-class "removeClass"))
|
|
|
|
(defun-web-element (remove-from-document "removeFromDocument"))
|
|
|
|
(defun-web-element (set-focus "setFocus"))
|
|
|
|
(defun-web-element (tag-name "tagName"))
|
|
|
|
(defun-web-element-arg (toggle-class "toggleClass"))
|
|
|
|
(defun-web-element (web-frame "webFrame"))
|
|
|
|
;;; macros for JavaScript callback code; the functions can be tested like this:
|
|
;;; (h:js (print (h:lisp (format nil (string "~R") 100))))
|
|
|
|
(defun %quote (arguments)
|
|
"Quote arguments, to prepare them for READ-FROM-STRING in Lisp. Strings are supposed to be JavaScript code, e.g. \"window.event.keyCode\". Literal strings can be passed using STRING, e.g. (string \"ok\")."
|
|
(mapcar (lambda (arg)
|
|
(cond ((consp arg)
|
|
(if (eql 'string (first arg))
|
|
(format nil "'~S'" (second arg))
|
|
(error "Only atom arguments allowed in JavaScript callback code: ~S" arg)))
|
|
((stringp arg)
|
|
arg)
|
|
(t
|
|
(format nil "'~A'" arg))))
|
|
arguments))
|
|
|
|
(defmacro lisp* (arguments)
|
|
"Generate JavaScript function call from a lispy definition. The first argument to the Lisp function is expected to be a QWebElement (see function WEB).
|
|
Example: (h:lisp* (foo :this 42 \"window.event.keyCode\" (string \"ok\")))"
|
|
(format nil "Lisp.fun2('~A::~A', ~A, [~{~A~^, ~}])"
|
|
(package-name (symbol-package (first arguments)))
|
|
(symbol-name (first arguments))
|
|
(if (eql :this (second arguments))
|
|
"this"
|
|
(second arguments))
|
|
(%quote (nthcdr 2 arguments))))
|
|
|
|
(defmacro lisp (arguments)
|
|
"Generate JavaScript function call from a lispy definition (see function FUN).
|
|
Example: (h:lisp (foo 42 \"window.event.keyCode\" (string \"ok\")))"
|
|
(if (eql :this (second arguments)) ; QWebElement argument
|
|
`(lisp* ,arguments)
|
|
(format nil "Lisp.fun('~A::~A', [~{~A~^, ~}])"
|
|
(package-name (symbol-package (first arguments)))
|
|
(symbol-name (first arguments))
|
|
(%quote (rest arguments)))))
|
|
|
|
;;; to be called from JavaScript
|
|
|
|
(defun fun (function arguments)
|
|
"Qt: QString fun(QString, QVariantList = 0)
|
|
Use this variant for ordinary function calls, e.g. Lisp.fun('+', ['1/2', '1/3'])"
|
|
(if arguments
|
|
(>> (apply (<< function) (<< arguments)))
|
|
(>> (funcall (<< function)))))
|
|
|
|
(defun fun* (function web-element arguments)
|
|
"Qt: QString fun2(QString, QWebElement, QVariantList = 0)
|
|
Use this variant if you need to pass a QWebElement, e.g. Lisp.fun2('move', this)"
|
|
(flet ((not-null (el)
|
|
(if (qrun* (! "isNull" el)) nil el)))
|
|
(if arguments
|
|
(>> (apply (<< function) (not-null web-element) (<< arguments)))
|
|
(>> (funcall (<< function) (not-null web-element))))))
|
|
|
|
(defun %web-pixmap ()
|
|
"Qt: QPixmap pixmap()" ; see "Lisp.pixmap()" in ASSIGN-PIXMAP
|
|
*web-pixmap*)
|
|
|
|
;;; pixmap utilities
|
|
|
|
(defun assign-pixmap (web-element pixmap)
|
|
"Directly assign a QPixmap to a <img> web element."
|
|
(let ((*web-pixmap* pixmap)
|
|
(element (ensure-web-element web-element)))
|
|
(assert (string= "IMG" (tag-name element)) nil
|
|
"Wanted <img>, got <~(~A~)>." (tag-name element))
|
|
(js "Lisp.pixmap().assignToHTMLImageElement(this)" element)))
|
|
|
|
(defun to-pixmap (web-element &optional scale-factor)
|
|
"Render web element into a pixmap, optionally scaling it."
|
|
(qrun* (let* ((element (ensure-web-element web-element))
|
|
(size (nthcdr 2 (! "geometry" element)))
|
|
(pixmap (qnew "QPixmap(QSize)" size)))
|
|
(if (find 0 size)
|
|
pixmap
|
|
(progn
|
|
(! "fill" pixmap "transparent")
|
|
(qlet ((painter "QPainter(QPixmap*)" pixmap))
|
|
(x:do-with (! "setRenderHint" painter)
|
|
(|QPainter.Antialiasing| t)
|
|
(|QPainter.TextAntialiasing| t)
|
|
(|QPainter.SmoothPixmapTransform| t))
|
|
(! "render" element painter))
|
|
(if scale-factor
|
|
(! "scaled(QSize,Qt::AspectRatioMode,Qt::TransformationMode)" pixmap
|
|
(mapcar (lambda (x) (truncate (+ 0.5 (* scale-factor x))))
|
|
size)
|
|
|Qt.IgnoreAspectRatio| |Qt.SmoothTransformation|)
|
|
pixmap))))))
|
|
|
|
(let (dummy)
|
|
(defun clear-pixmap (web-element)
|
|
(unless dummy
|
|
(qrun* (setf dummy (qnew "QPixmap(int,int)" 1 1))
|
|
(! "fill" dummy "transparent")))
|
|
(assign-pixmap web-element dummy)))
|
|
|
|
;;; generic utilities
|
|
|
|
(defun inspector ()
|
|
(when (probe-file "inspector.lisp")
|
|
(load "inspector")
|
|
(inspector) ; redefined function
|
|
t))
|
|
|
|
(defun clear-html ()
|
|
(qrun* (! "setHtml" *web-view* "")))
|
|
|
|
(defun append-html (text/html &optional scroll-to-bottom)
|
|
(append-inside "BODY" text/html)
|
|
(when scroll-to-bottom
|
|
(qrun* (qlater 'scroll-to-bottom))))
|
|
|
|
(defun pause (seconds)
|
|
(qrun* (qsleep seconds)))
|
|
|
|
;;; wrappers for some QFrame methods
|
|
|
|
(defun to-html ()
|
|
(qrun* (! "toHtml" (frame))))
|
|
|
|
(defun document-element ()
|
|
(qrun* (! "documentElement" (frame))))
|
|
|
|
(defun find-all-elements (selector)
|
|
"Return all matching web elements for given selector."
|
|
(let ((els (qrun* (! "findAllElements" (frame) selector))))
|
|
(unless (qrun* (zerop (! "count" els)))
|
|
els)))
|
|
|
|
(defun find-first-element (selector)
|
|
"Return first matching web element for given selector."
|
|
(let ((el (qrun* (! "findFirstElement" (frame) selector))))
|
|
(unless (qrun* (! "isNull" el))
|
|
el)))
|
|
|
|
(defun scroll-to-top ()
|
|
(qrun* (! "setScrollPosition" (frame) '(0 0))))
|
|
|
|
(defun scroll-to-bottom ()
|
|
(qrun* (! "setScrollPosition" (frame) '(0 #.(expt 2 15)))))
|
|
|
|
(defun scroll-to-anchor (anchor)
|
|
(qrun* (! "scrollToAnchor" (frame) anchor)))
|
|
|
|
;;; ini
|
|
|
|
(qconnect (frame) "javaScriptWindowObjectCleared()"
|
|
(lambda ()
|
|
(! "addToJavaScriptWindowObject" (frame) "Lisp" *webkit-bridge*)
|
|
(! "addToJavaScriptWindowObject" (frame) "WebView" *web-view*)
|
|
(js "function string (x) { return '\"' + x + '\"'; }"))) ; global JS function for H:LISP
|
|
|