cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-08 07:08:39 +01:00
Code Issues

- [GUI] added command to inline all images in a page.

Browse Source
This commit is contained in:
cage 2023-05-13 14:45:45 +02:00
parent b6bed17984
commit b1440cd218
3 changed files with 135 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
src/gui/client/icons.lisp
View File

@ -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+)))

178
src/gui/client/main-window.lisp
View File

@ -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+)

3
src/package.lisp
View File

@ -3348,7 +3348,8 @@
:*bus-go*
:*dice*
:*gemlog-subscribe*
:*gemlog-unsubscribe*))
:*gemlog-unsubscribe*
:*inline-images*))
(defpackage :validation
(:use