cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [GUI] added command for the 'go up iri' button.

This commit is contained in:
cage 2023-04-06 15:06:31 +02:00
parent f9afbd64e0
commit 2778372317
6 changed files with 55 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -669,6 +669,38 @@
(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))))
(open-iri iri main-window nil))))))
(defun back-iri-clsr (main-window)
(lambda ()
(with-accessors ((tool-bar tool-bar)) main-window
(with-accessors ((iri-entry iri-entry)) tool-bar
(let ((to-parent-iri (cev:enqueue-request-and-wait-results :iri-to-parent-path
(gui:text iri-entry)
1
ev:+standard-event-priority+)))
(when (string-not-empty-p to-parent-iri)
(setf (gui:text iri-entry) to-parent-iri)
(open-iri to-parent-iri main-window t)))))))
(defun up-iri-clsr (main-window)
(lambda ()
(with-accessors ((tool-bar tool-bar)) main-window
(with-accessors ((iri-entry iri-entry)) tool-bar
(let ((iri-visited (cev:enqueue-request-and-wait-results :iri-to-parent-path
1
ev:+standard-event-priority+
(gui:text iri-entry))))
(when (string-not-empty-p iri-visited)
(setf (gui:text iri-entry) iri-visited)
(open-iri iri-visited main-window t)))))))
(defun setup-main-window-events (main-window)
(with-accessors ((tool-bar tool-bar)
(toc-frame toc-frame)
@ -692,25 +724,8 @@
(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))))))
(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))))
(open-iri iri main-window nil))))))
(defun back-iri-clsr (main-window)
(lambda ()
(with-accessors ((tool-bar tool-bar)) main-window
(with-accessors ((iri-entry iri-entry)) tool-bar
(let ((iri-visited (cev:enqueue-request-and-wait-results :gemini-pop-url-from-history
1
ev:+standard-event-priority+)))
(when (string-not-empty-p iri-visited)
(setf (gui:text iri-entry) iri-visited)
(open-iri iri-visited main-window t)))))))
(setf (gui:command back-button) (back-iri-clsr main-window))
(setf (gui:command up-button) (up-iri-clsr main-window))))))
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
(with-accessors ((iri-entry iri-entry)

3
src/gui/server/main-window-server-side.lisp
View File

@ -76,3 +76,6 @@
(defun gemini-pop-url-from-history ()
(gw:pop-url-from-history *gemini-window*))
(defun iri-to-parent-path (iri)
(iri:iri-to-parent-path iri))

3
src/gui/server/public-api.lisp
View File

@ -104,7 +104,8 @@
(gen-rpc "tour-pop-link" 'tour-pop-link)
(gen-rpc "tour-delete-link"
'tour-delete-link
"url" 0)
"iri" 0)
(gen-rpc "clear-tour" 'clear-tour)
(gen-rpc "iri-to-parent-path" 'iri-to-parent-path "iri" 0)
(gen-rpc "quit-program" 'quit-program)
,@body))

11
src/iri-parser.lisp
View File

@ -367,3 +367,14 @@
(defun ipv6-address-p (string)
(cl-ppcre:scan ":" string))
(defun iri-to-parent-path (iri)
(let* ((parsed-iri (iri:iri-parse iri))
(parent-path (fs:parent-dir-path (uri:path parsed-iri)))
(new-iri (to-s (make-instance 'iri:iri
:scheme (uri:scheme parsed-iri)
:host (uri:host parsed-iri)
:user-info (uri:user-info parsed-iri)
:port (uri:port parsed-iri)
:path parent-path))))
new-iri))

3
src/package.lisp
View File

@ -754,7 +754,8 @@
:normalize-path
:absolute-url-p
:ipv4-address-p
:ipv6-address-p))
:ipv6-address-p
:iri-to-parent-path))
(defpackage :tour-mode-parser
(:use

15
src/ui-goodies.lisp
View File

@ -2401,18 +2401,9 @@ Currently the only recognized protocols are gemini and kami."
(push-event (make-instance 'gemini-back-event)))
(defun address-go-back-in-path ()
(when-let ((current-url (gemini-viewer:current-gemini-url)))
(multiple-value-bind (actual-iri host path query port fragment scheme user-info)
(gemini-client:displace-iri (iri:iri-parse current-url))
(declare (ignore fragment query actual-iri))
(let* ((parent-path (fs:parent-dir-path path))
(new-iri (to-s (make-instance 'iri:iri
:scheme scheme
:host host
:user-info user-info
:port port
:path parent-path))))
(open-net-address new-iri)))))
(when-let* ((current-url (gemini-viewer:current-gemini-url))
(new-iri (ignore-errors (iri:iri-to-parent-path current-url))))
(open-net-address new-iri)))
(defun address-go-root-path ()
(when-let ((current-url (gemini-viewer:current-gemini-url)))