mirror of https://codeberg.org/cage/tinmop/
- [GUI] added command to inline all images in a page.
This commit is contained in:
parent
b6bed17984
commit
b1440cd218
|
@ -1,46 +1,48 @@
|
||||||
(in-package :icons)
|
(in-package :icons)
|
||||||
|
|
||||||
(a:define-constant +icon-dir+ "/data/icons/" :test #'string=)
|
(a:define-constant +icon-dir+ "/data/icons/" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +search+ "fmw_search" :test #'string=)
|
(a:define-constant +search+ "fmw_search" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +back+ "fmw_back" :test #'string=)
|
(a:define-constant +back+ "fmw_back" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +go+ "fmw_go" :test #'string=)
|
(a:define-constant +go+ "fmw_go" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +open-tour+ "fmw_open_tour" :test #'string=)
|
(a:define-constant +open-tour+ "fmw_open_tour" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +refresh+ "fmw_refresh" :test #'string=)
|
(a:define-constant +refresh+ "fmw_refresh" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +up+ "fmw_uparrow" :test #'string=)
|
(a:define-constant +up+ "fmw_uparrow" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +document-delete+ "fmw_document-delete" :test #'string=)
|
(a:define-constant +document-delete+ "fmw_document-delete" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +document-add+ "fmw_document-add" :test #'string=)
|
(a:define-constant +document-add+ "fmw_document-add" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +document-accept+ "fmw_document-accept" :test #'string=)
|
(a:define-constant +document-accept+ "fmw_document-accept" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +document-edit+ "fmw_document-edit" :test #'string=)
|
(a:define-constant +document-edit+ "fmw_document-edit" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +folder+ "fmw_folder" :test #'string=)
|
(a:define-constant +folder+ "fmw_folder" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +star-yellow+ "fmw_star-yellow.png" :test #'string=)
|
(a:define-constant +star-yellow+ "fmw_star-yellow.png" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +star-blue+ "fmw_star-blue.png" :test #'string=)
|
(a:define-constant +star-blue+ "fmw_star-blue.png" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +arrow-up+ "fmw_arrow-up" :test #'string=)
|
(a:define-constant +arrow-up+ "fmw_arrow-up" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +arrow-down+ "fmw_arrow-down" :test #'string=)
|
(a:define-constant +arrow-down+ "fmw_arrow-down" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +cross+ "fmw_cross" :test #'string=)
|
(a:define-constant +cross+ "fmw_cross" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +bus-go+ "fmw_bus-go" :test #'string=)
|
(a:define-constant +bus-go+ "fmw_bus-go" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +dice+ "fmw_dice" :test #'string=)
|
(a:define-constant +dice+ "fmw_dice" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +gemlog-subscribe+ "fmw_rss-add.png" :test #'string=)
|
(a:define-constant +gemlog-subscribe+ "fmw_rss-add.png" :test #'string=)
|
||||||
|
|
||||||
(a:define-constant +gemlog-unsubscribe+ "fmw_rss-delete.png" :test #'string=)
|
(a:define-constant +gemlog-unsubscribe+ "fmw_rss-delete.png" :test #'string=)
|
||||||
|
|
||||||
|
(a:define-constant +inline-images+ "fmw_two-pictures.png" :test #'string=)
|
||||||
|
|
||||||
(defparameter *search* nil)
|
(defparameter *search* nil)
|
||||||
|
|
||||||
|
@ -82,6 +84,8 @@
|
||||||
|
|
||||||
(defparameter *gemlog-unsubscribe* nil)
|
(defparameter *gemlog-unsubscribe* nil)
|
||||||
|
|
||||||
|
(defparameter *inline-images* nil)
|
||||||
|
|
||||||
(defun load-icon (filename)
|
(defun load-icon (filename)
|
||||||
(let ((path (if (not (re:scan "(?i)png$" filename))
|
(let ((path (if (not (re:scan "(?i)png$" filename))
|
||||||
(res:get-data-file (fs:cat-parent-dir +icon-dir+
|
(res:get-data-file (fs:cat-parent-dir +icon-dir+
|
||||||
|
@ -111,4 +115,5 @@
|
||||||
(setf *bus-go* (load-icon +bus-go+))
|
(setf *bus-go* (load-icon +bus-go+))
|
||||||
(setf *dice* (load-icon +dice+))
|
(setf *dice* (load-icon +dice+))
|
||||||
(setf *gemlog-subscribe* (load-icon +gemlog-subscribe+))
|
(setf *gemlog-subscribe* (load-icon +gemlog-subscribe+))
|
||||||
(setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+)))
|
(setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+))
|
||||||
|
(setf *inline-images* (load-icon +inline-images+)))
|
||||||
|
|
|
@ -263,7 +263,11 @@
|
||||||
(subscribe-button
|
(subscribe-button
|
||||||
:initform nil
|
:initform nil
|
||||||
:initarg :subscribe-button
|
:initarg :subscribe-button
|
||||||
:accessor subscribe-button)))
|
:accessor subscribe-button)
|
||||||
|
(inline-images-button
|
||||||
|
:initform nil
|
||||||
|
:initarg :inline-images-button
|
||||||
|
:accessor inline-images-button)))
|
||||||
|
|
||||||
(defun autocomplete-iri-clsr (toolbar)
|
(defun autocomplete-iri-clsr (toolbar)
|
||||||
(declare (ignore toolbar))
|
(declare (ignore toolbar))
|
||||||
|
@ -368,6 +372,55 @@
|
||||||
(comm:make-request :gemini-save-url-db-history 1 iri))
|
(comm:make-request :gemini-save-url-db-history 1 iri))
|
||||||
(slurp-non-text-data main-window iri :try-to-open nil))))))
|
(slurp-non-text-data main-window iri :try-to-open nil))))))
|
||||||
|
|
||||||
|
(defun inline-image-p (link-value)
|
||||||
|
(or (re:scan "(?i)jpg$" link-value)
|
||||||
|
(re:scan "(?i)jpeg$" link-value)
|
||||||
|
(re:scan "(?i)png$" link-value)
|
||||||
|
(re:scan "(?i)gif$" link-value)
|
||||||
|
(re:scan "(?i)bmp$" link-value)
|
||||||
|
(re:scan "(?i)tga$" link-value)))
|
||||||
|
|
||||||
|
(defun inline-possible-p (link-value)
|
||||||
|
(inline-image-p link-value))
|
||||||
|
|
||||||
|
(defun inline-type (link-value)
|
||||||
|
(when (inline-image-p link-value)
|
||||||
|
:inline-image))
|
||||||
|
|
||||||
|
(defun inline-image (main-window link-value line-index)
|
||||||
|
(let* ((file-path (slurp-iri main-window link-value))
|
||||||
|
(image (gui:make-image file-path))
|
||||||
|
(coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
|
||||||
|
(gui:insert-image (gemtext-widget main-window) image coordinates)
|
||||||
|
(with-accessors ((ir-lines ir-lines)
|
||||||
|
(ir-rendered-lines ir-rendered-lines)) main-window
|
||||||
|
(let* ((parent-line (elt ir-lines (- line-index 1)))
|
||||||
|
(new-line (copy-list parent-line)))
|
||||||
|
(setf (getf new-line :type) (inline-type link-value))
|
||||||
|
(setf ir-lines
|
||||||
|
(fresh-vector-insert@ ir-lines
|
||||||
|
new-line
|
||||||
|
line-index))
|
||||||
|
(setf ir-rendered-lines
|
||||||
|
(fresh-vector-insert@ ir-lines
|
||||||
|
""
|
||||||
|
line-index))))))
|
||||||
|
|
||||||
|
(defun inline-all-images (main-window)
|
||||||
|
(gui-goodies:with-busy* (main-window)
|
||||||
|
(loop for line across (ir-lines main-window)
|
||||||
|
for line-number from 1
|
||||||
|
when (and (string= (getf line :type) "a")
|
||||||
|
(inline-image-p (getf line :href)))
|
||||||
|
do
|
||||||
|
(let ((link-value (absolutize-link (get-address-bar-text main-window)
|
||||||
|
(getf line :href))))
|
||||||
|
(inline-image main-window link-value line-number)))))
|
||||||
|
|
||||||
|
(defun inline-all-images-clsr (main-window)
|
||||||
|
(lambda ()
|
||||||
|
(inline-all-images main-window)))
|
||||||
|
|
||||||
(defun contextual-menu-link-clrs (link-name link-value main-window line-count)
|
(defun contextual-menu-link-clrs (link-name link-value main-window line-count)
|
||||||
(labels ((add-to-tour-callback ()
|
(labels ((add-to-tour-callback ()
|
||||||
(ev:with-enqueued-process-and-unblock ()
|
(ev:with-enqueued-process-and-unblock ()
|
||||||
|
@ -393,39 +446,10 @@
|
||||||
link-value)
|
link-value)
|
||||||
:bold t)
|
:bold t)
|
||||||
(client-bookmark-window:init-window main-window link-value))))
|
(client-bookmark-window:init-window main-window link-value))))
|
||||||
(inline-image-p (link-value)
|
|
||||||
(or (re:scan "(?i)jpg$" link-value)
|
|
||||||
(re:scan "(?i)jpeg$" link-value)
|
|
||||||
(re:scan "(?i)png$" link-value)
|
|
||||||
(re:scan "(?i)gif$" link-value)
|
|
||||||
(re:scan "(?i)bmp$" link-value)
|
|
||||||
(re:scan "(?i)tga$" link-value)))
|
|
||||||
(inline-possible-p (link-value)
|
|
||||||
(inline-image-p link-value))
|
|
||||||
(inline-type (link-value)
|
|
||||||
(when (inline-image-p link-value)
|
|
||||||
:inline-image))
|
|
||||||
(open-inline-callback ()
|
(open-inline-callback ()
|
||||||
(if (inline-possible-p link-value)
|
(if (inline-possible-p link-value)
|
||||||
(let ((file-path nil))
|
(gui-goodies:with-busy* (main-window)
|
||||||
(gui-goodies:with-busy* (main-window)
|
(inline-image main-window link-value line-count))
|
||||||
(setf file-path (slurp-iri main-window link-value)))
|
|
||||||
(let ((image (gui:make-image file-path))
|
|
||||||
(coordinates `(+ (:line ,line-count :char 0) 1 :lines)))
|
|
||||||
(gui:insert-image (gemtext-widget main-window) image coordinates)
|
|
||||||
(with-accessors ((ir-lines ir-lines)
|
|
||||||
(ir-rendered-lines ir-rendered-lines)) main-window
|
|
||||||
(let* ((parent-line (elt ir-lines (- line-count 1)))
|
|
||||||
(new-line (copy-list parent-line)))
|
|
||||||
(setf (getf new-line :type) (inline-type link-value))
|
|
||||||
(setf ir-lines
|
|
||||||
(fresh-vector-insert@ ir-lines
|
|
||||||
new-line
|
|
||||||
line-count))
|
|
||||||
(setf ir-rendered-lines
|
|
||||||
(fresh-vector-insert@ ir-lines
|
|
||||||
""
|
|
||||||
line-count))))))
|
|
||||||
(funcall (link-click-mouse-1-callback-clsr link-value main-window)))))
|
(funcall (link-click-mouse-1-callback-clsr link-value main-window)))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
||||||
|
@ -864,12 +888,11 @@
|
||||||
(line-index (1+ line-position)))
|
(line-index (1+ line-position)))
|
||||||
(gui:scroll-until-line-on-top gemtext-widget line-index))))))
|
(gui:scroll-until-line-on-top gemtext-widget line-index))))))
|
||||||
|
|
||||||
|
|
||||||
(defun reload-iri-clsr (main-window)
|
(defun reload-iri-clsr (main-window)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-accessors ((tool-bar tool-bar)) main-window
|
(with-accessors ((tool-bar tool-bar)) main-window
|
||||||
(with-accessors ((iri-entry iri-entry)) tool-bar
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
||||||
(let* ((iri (trim-blanks (gui:text iri-entry))))
|
(let ((iri (get-address-bar-text main-window)))
|
||||||
(open-iri iri main-window nil))))))
|
(open-iri iri main-window nil))))))
|
||||||
|
|
||||||
(defun up-iri-clsr (main-window)
|
(defun up-iri-clsr (main-window)
|
||||||
|
@ -964,14 +987,15 @@
|
||||||
(toc-frame toc-frame)
|
(toc-frame toc-frame)
|
||||||
(gemtext-widget gemtext-widget)
|
(gemtext-widget gemtext-widget)
|
||||||
(ir-lines ir-lines)) main-window
|
(ir-lines ir-lines)) main-window
|
||||||
(with-accessors ((iri-entry iri-entry)
|
(with-accessors ((iri-entry iri-entry)
|
||||||
(back-button back-button)
|
(back-button back-button)
|
||||||
(reload-button reload-button)
|
(reload-button reload-button)
|
||||||
(up-button up-button)
|
(up-button up-button)
|
||||||
(go-button go-button)
|
(go-button go-button)
|
||||||
(bookmark-button bookmark-button)
|
(bookmark-button bookmark-button)
|
||||||
(tour-button tour-button)
|
(tour-button tour-button)
|
||||||
(subscribe-button subscribe-button)) tool-bar
|
(subscribe-button subscribe-button)
|
||||||
|
(inline-images-button inline-images-button)) tool-bar
|
||||||
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))
|
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))
|
||||||
(toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
(toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
||||||
(gui:bind entry-autocomplete
|
(gui:bind entry-autocomplete
|
||||||
|
@ -983,23 +1007,25 @@
|
||||||
(gui:bind toc-listbox
|
(gui:bind toc-listbox
|
||||||
#$<<ListboxSelect>>$
|
#$<<ListboxSelect>>$
|
||||||
(toc-callback-clsr main-window))
|
(toc-callback-clsr main-window))
|
||||||
(setf (gui:command go-button) (open-iri-clsr main-window t))
|
(setf (gui:command go-button) (open-iri-clsr main-window t))
|
||||||
(setf (gui:command reload-button) (reload-iri-clsr main-window))
|
(setf (gui:command reload-button) (reload-iri-clsr main-window))
|
||||||
(setf (gui:command back-button) (back-iri-clsr main-window))
|
(setf (gui:command back-button) (back-iri-clsr main-window))
|
||||||
(setf (gui:command up-button) (up-iri-clsr main-window))
|
(setf (gui:command up-button) (up-iri-clsr main-window))
|
||||||
(setf (gui:command bookmark-button) (toggle-bookmark-iri-clsr main-window))
|
(setf (gui:command bookmark-button) (toggle-bookmark-iri-clsr main-window))
|
||||||
(setf (gui:command tour-button) (tour-visit-next-iri-clsr main-window))
|
(setf (gui:command tour-button) (tour-visit-next-iri-clsr main-window))
|
||||||
(setf (gui:command subscribe-button) (toggle-subscribtion-iri-clsr main-window))))))
|
(setf (gui:command subscribe-button) (toggle-subscribtion-iri-clsr main-window))
|
||||||
|
(setf (gui:command inline-images-button) (inline-all-images-clsr main-window))))))
|
||||||
|
|
||||||
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
||||||
(with-accessors ((iri-entry iri-entry)
|
(with-accessors ((iri-entry iri-entry)
|
||||||
(back-button back-button)
|
(back-button back-button)
|
||||||
(reload-button reload-button)
|
(reload-button reload-button)
|
||||||
(up-button up-button)
|
(up-button up-button)
|
||||||
(go-button go-button)
|
(go-button go-button)
|
||||||
(bookmark-button bookmark-button)
|
(bookmark-button bookmark-button)
|
||||||
(tour-button tour-button)
|
(tour-button tour-button)
|
||||||
(subscribe-button subscribe-button)) object
|
(subscribe-button subscribe-button)
|
||||||
|
(inline-images-button inline-images-button)) object
|
||||||
(gui:configure object :relief :raised)
|
(gui:configure object :relief :raised)
|
||||||
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
||||||
:master object
|
:master object
|
||||||
|
@ -1013,21 +1039,26 @@
|
||||||
(setf subscribe-button (make-instance 'gui:button
|
(setf subscribe-button (make-instance 'gui:button
|
||||||
:master object
|
:master object
|
||||||
:image icons:*gemlog-subscribe*))
|
:image icons:*gemlog-subscribe*))
|
||||||
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
(setf inline-images-button (make-instance 'gui:button
|
||||||
(reload-button (_ "reload address"))
|
:master object
|
||||||
(go-button (_ "go to address"))
|
:image icons:*inline-images*))
|
||||||
(up-button (_ "one level up"))
|
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
||||||
(bookmark-button (_ "add or remove bookmark"))
|
(reload-button (_ "reload address"))
|
||||||
(tour-button (_ "go to the next link in tour"))
|
(go-button (_ "go to address"))
|
||||||
(subscribe-button (_ "subscribe/unsubscribe to this gemlog")))
|
(up-button (_ "one level up"))
|
||||||
(gui:grid back-button 0 0 :sticky :nsw)
|
(bookmark-button (_ "add or remove bookmark"))
|
||||||
(gui:grid reload-button 0 1 :sticky :nsw)
|
(tour-button (_ "go to the next link in tour"))
|
||||||
(gui:grid up-button 0 2 :sticky :nsw)
|
(subscribe-button (_ "subscribe/unsubscribe to this gemlog"))
|
||||||
(gui:grid iri-entry 0 3 :sticky :nswe :padx +minimum-padding+)
|
(inline-images-button (_ "inline images")))
|
||||||
(gui:grid go-button 0 4 :sticky :nsw)
|
(gui:grid back-button 0 0 :sticky :nsw)
|
||||||
(gui:grid bookmark-button 0 5 :sticky :nsw)
|
(gui:grid reload-button 0 1 :sticky :nsw)
|
||||||
(gui:grid subscribe-button 0 6 :sticky :nsw)
|
(gui:grid up-button 0 2 :sticky :nsw)
|
||||||
(gui:grid tour-button 0 7 :sticky :nsw)
|
(gui:grid iri-entry 0 3 :sticky :nswe :padx +minimum-padding+)
|
||||||
|
(gui:grid go-button 0 4 :sticky :nsw)
|
||||||
|
(gui:grid bookmark-button 0 5 :sticky :nsw)
|
||||||
|
(gui:grid subscribe-button 0 6 :sticky :nsw)
|
||||||
|
(gui:grid tour-button 0 7 :sticky :nsw)
|
||||||
|
(gui:grid inline-images-button 0 8 :sticky :nsw)
|
||||||
(gui:grid-columnconfigure object 3 :weight 2)
|
(gui:grid-columnconfigure object 3 :weight 2)
|
||||||
object))
|
object))
|
||||||
|
|
||||||
|
@ -1182,6 +1213,9 @@
|
||||||
(defun set-address-bar-text (main-window text)
|
(defun set-address-bar-text (main-window text)
|
||||||
(setf (gui:text (iri-entry (tool-bar main-window))) text))
|
(setf (gui:text (iri-entry (tool-bar main-window))) text))
|
||||||
|
|
||||||
|
(defun get-address-bar-text (main-window)
|
||||||
|
(trim-blanks (gui:text (iri-entry (tool-bar main-window)))))
|
||||||
|
|
||||||
(defun init-main-window ()
|
(defun init-main-window ()
|
||||||
(let ((gui:*debug-tk* nil))
|
(let ((gui:*debug-tk* nil))
|
||||||
(gui:with-nodgui (:title +program-name+)
|
(gui:with-nodgui (:title +program-name+)
|
||||||
|
|
|
@ -3348,7 +3348,8 @@
|
||||||
:*bus-go*
|
:*bus-go*
|
||||||
:*dice*
|
:*dice*
|
||||||
:*gemlog-subscribe*
|
:*gemlog-subscribe*
|
||||||
:*gemlog-unsubscribe*))
|
:*gemlog-unsubscribe*
|
||||||
|
:*inline-images*))
|
||||||
|
|
||||||
(defpackage :validation
|
(defpackage :validation
|
||||||
(:use
|
(:use
|
||||||
|
|
Loading…
Reference in New Issue