mirror of https://codeberg.org/cage/tinmop/
- [GUI] added command to inline all images in a page.
This commit is contained in:
cage
parent
b6bed17984
commit
b1440cd218
|
|
@ -1,46 +1,48 @@
|
|||
(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)
|
||||
|
||||
|
|
@ -82,6 +84,8 @@
|
|||
|
||||
(defparameter *gemlog-unsubscribe* nil)
|
||||
|
||||
(defparameter *inline-images* nil)
|
||||
|
||||
(defun load-icon (filename)
|
||||
(let ((path (if (not (re:scan "(?i)png$" filename))
|
||||
(res:get-data-file (fs:cat-parent-dir +icon-dir+
|
||||
|
|
@ -111,4 +115,5 @@
|
|||
(setf *bus-go* (load-icon +bus-go+))
|
||||
(setf *dice* (load-icon +dice+))
|
||||
(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
|
||||
:initform nil
|
||||
: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)
|
||||
(declare (ignore toolbar))
|
||||
|
|
@ -368,6 +372,55 @@
|
|||
(comm:make-request :gemini-save-url-db-history 1 iri))
|
||||
(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)
|
||||
(labels ((add-to-tour-callback ()
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
|
|
@ -393,39 +446,10 @@
|
|||
link-value)
|
||||
:bold t)
|
||||
(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 ()
|
||||
(if (inline-possible-p link-value)
|
||||
(let ((file-path nil))
|
||||
(gui-goodies:with-busy* (main-window)
|
||||
(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))))))
|
||||
(gui-goodies:with-busy* (main-window)
|
||||
(inline-image main-window link-value line-count))
|
||||
(funcall (link-click-mouse-1-callback-clsr link-value main-window)))))
|
||||
(lambda ()
|
||||
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
||||
|
|
@ -864,12 +888,11 @@
|
|||
(line-index (1+ line-position)))
|
||||
(gui:scroll-until-line-on-top gemtext-widget line-index))))))
|
||||
|
||||
|
||||
(defun reload-iri-clsr (main-window)
|
||||
(lambda ()
|
||||
(with-accessors ((tool-bar tool-bar)) main-window
|
||||
(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))))))
|
||||
|
||||
(defun up-iri-clsr (main-window)
|
||||
|
|
@ -964,14 +987,15 @@
|
|||
(toc-frame toc-frame)
|
||||
(gemtext-widget gemtext-widget)
|
||||
(ir-lines ir-lines)) main-window
|
||||
(with-accessors ((iri-entry iri-entry)
|
||||
(back-button back-button)
|
||||
(reload-button reload-button)
|
||||
(up-button up-button)
|
||||
(go-button go-button)
|
||||
(bookmark-button bookmark-button)
|
||||
(tour-button tour-button)
|
||||
(subscribe-button subscribe-button)) tool-bar
|
||||
(with-accessors ((iri-entry iri-entry)
|
||||
(back-button back-button)
|
||||
(reload-button reload-button)
|
||||
(up-button up-button)
|
||||
(go-button go-button)
|
||||
(bookmark-button bookmark-button)
|
||||
(tour-button tour-button)
|
||||
(subscribe-button subscribe-button)
|
||||
(inline-images-button inline-images-button)) tool-bar
|
||||
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))
|
||||
(toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
||||
(gui:bind entry-autocomplete
|
||||
|
|
@ -983,23 +1007,25 @@
|
|||
(gui:bind toc-listbox
|
||||
#$<<ListboxSelect>>$
|
||||
(toc-callback-clsr main-window))
|
||||
(setf (gui:command go-button) (open-iri-clsr main-window t))
|
||||
(setf (gui:command reload-button) (reload-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 bookmark-button) (toggle-bookmark-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 go-button) (open-iri-clsr main-window t))
|
||||
(setf (gui:command reload-button) (reload-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 bookmark-button) (toggle-bookmark-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 inline-images-button) (inline-all-images-clsr main-window))))))
|
||||
|
||||
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
||||
(with-accessors ((iri-entry iri-entry)
|
||||
(back-button back-button)
|
||||
(reload-button reload-button)
|
||||
(up-button up-button)
|
||||
(go-button go-button)
|
||||
(bookmark-button bookmark-button)
|
||||
(tour-button tour-button)
|
||||
(subscribe-button subscribe-button)) object
|
||||
(with-accessors ((iri-entry iri-entry)
|
||||
(back-button back-button)
|
||||
(reload-button reload-button)
|
||||
(up-button up-button)
|
||||
(go-button go-button)
|
||||
(bookmark-button bookmark-button)
|
||||
(tour-button tour-button)
|
||||
(subscribe-button subscribe-button)
|
||||
(inline-images-button inline-images-button)) object
|
||||
(gui:configure object :relief :raised)
|
||||
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
||||
:master object
|
||||
|
|
@ -1013,21 +1039,26 @@
|
|||
(setf subscribe-button (make-instance 'gui:button
|
||||
:master object
|
||||
:image icons:*gemlog-subscribe*))
|
||||
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
||||
(reload-button (_ "reload address"))
|
||||
(go-button (_ "go to address"))
|
||||
(up-button (_ "one level up"))
|
||||
(bookmark-button (_ "add or remove bookmark"))
|
||||
(tour-button (_ "go to the next link in tour"))
|
||||
(subscribe-button (_ "subscribe/unsubscribe to this gemlog")))
|
||||
(gui:grid back-button 0 0 :sticky :nsw)
|
||||
(gui:grid reload-button 0 1 :sticky :nsw)
|
||||
(gui:grid up-button 0 2 :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)
|
||||
(setf inline-images-button (make-instance 'gui:button
|
||||
:master object
|
||||
:image icons:*inline-images*))
|
||||
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
||||
(reload-button (_ "reload address"))
|
||||
(go-button (_ "go to address"))
|
||||
(up-button (_ "one level up"))
|
||||
(bookmark-button (_ "add or remove bookmark"))
|
||||
(tour-button (_ "go to the next link in tour"))
|
||||
(subscribe-button (_ "subscribe/unsubscribe to this gemlog"))
|
||||
(inline-images-button (_ "inline images")))
|
||||
(gui:grid back-button 0 0 :sticky :nsw)
|
||||
(gui:grid reload-button 0 1 :sticky :nsw)
|
||||
(gui:grid up-button 0 2 :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)
|
||||
object))
|
||||
|
||||
|
|
@ -1182,6 +1213,9 @@
|
|||
(defun set-address-bar-text (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 ()
|
||||
(let ((gui:*debug-tk* nil))
|
||||
(gui:with-nodgui (:title +program-name+)
|
||||
|
|
|
|||
|
|
@ -3348,7 +3348,8 @@
|
|||
:*bus-go*
|
||||
:*dice*
|
||||
:*gemlog-subscribe*
|
||||
:*gemlog-unsubscribe*))
|
||||
:*gemlog-unsubscribe*
|
||||
:*inline-images*))
|
||||
|
||||
(defpackage :validation
|
||||
(:use
|
||||
|
|
|
|||
Loading…
Reference in New Issue