mirror of https://codeberg.org/cage/tinmop/
- [GUI] started adding feature to inline bitmaps.
This commit is contained in:
cage
parent
786775f106
commit
b73c0856f2
|
|
@ -318,8 +318,56 @@
|
|||
path
|
||||
query))))
|
||||
|
||||
(defun slurp-iri (main-window iri)
|
||||
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri
|
||||
t)))
|
||||
(multiple-value-bind (status-code
|
||||
status-description
|
||||
meta
|
||||
cached
|
||||
original-iri)
|
||||
(displace-gemini-response connecting-response)
|
||||
(declare (ignore original-iri cached))
|
||||
(cond
|
||||
((gemini-client:header-input-p status-code)
|
||||
(let ((actual-iri (get-user-request-query iri meta main-window)))
|
||||
(slurp-iri main-window actual-iri)))
|
||||
((gemini-client:header-sensitive-input-p status-code)
|
||||
(let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
||||
(slurp-iri main-window actual-iri)))
|
||||
((= status-code comm:+tofu-error-status-code+)
|
||||
(when (gui:ask-yesno meta
|
||||
:title (_ "Server certificate error")
|
||||
:parent main-window)
|
||||
(cev:enqueue-request-and-wait-results :gemini-delete-certificate
|
||||
1
|
||||
ev:+maximum-event-priority+
|
||||
iri)
|
||||
(slurp-iri main-window iri)))
|
||||
((or (gemini-client:header-temporary-failure-p status-code)
|
||||
(gemini-client:header-permanent-failure-p status-code)
|
||||
(gemini-client:header-certificate-failure-p status-code))
|
||||
(notify-request-error (format nil
|
||||
"Error getting ~a (~a ~a)"
|
||||
iri
|
||||
status-code
|
||||
status-description)))
|
||||
((gemini-client:header-redirect-p status-code)
|
||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||
:title (_ "Redirection")
|
||||
:parent main-window)
|
||||
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
||||
meta
|
||||
(absolutize-link iri meta))))
|
||||
(slurp-iri redirect-iri main-window))))
|
||||
((gemini-client:header-success-p status-code)
|
||||
(slurp-non-text-data main-window iri :try-to-open nil))))))
|
||||
|
||||
(defun contextual-menu-link-clrs (link-name link-value main-window)
|
||||
(flet ((add-to-tour-callback ()
|
||||
(labels ((add-to-tour-callback ()
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(comm:make-request :tour-add-link
|
||||
1
|
||||
|
|
@ -342,16 +390,34 @@
|
|||
(_ "~s already bookmarked")
|
||||
link-value)
|
||||
:bold t)
|
||||
(client-bookmark-window:init-window main-window link-value)))))
|
||||
(client-bookmark-window:init-window main-window link-value))))
|
||||
(inline-possible-p ()
|
||||
(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)))
|
||||
(open-inline-clsr (x y)
|
||||
(lambda ()
|
||||
(let* ((popup-menu (gui:make-menu nil (_"link menu"))))
|
||||
(if (inline-possible-p)
|
||||
(let* ((file-path (slurp-iri main-window link-value))
|
||||
(image (gui:make-image file-path))
|
||||
(coordinates `(+ (:x ,x :y ,y) 1 :lines)))
|
||||
(gui:insert-image (gemtext-widget main-window) image coordinates))
|
||||
(funcall (link-click-mouse-1-callback-clsr link-value main-window))))))
|
||||
(lambda ()
|
||||
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
||||
(x (gui:screen-mouse-x))
|
||||
(y (gui:screen-mouse-y)))
|
||||
(gui:make-menubutton popup-menu (_ "Inline") (open-inline-clsr x y))
|
||||
(gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback)
|
||||
(gui:make-menubutton popup-menu (_ "Add link to tour") #'add-to-tour-callback)
|
||||
(gui:make-menubutton popup-menu (_ "Copy link to the clipboard") #'copy-link-callback)
|
||||
(gui:make-menubutton popup-menu
|
||||
(_ "Open link in background")
|
||||
#'download-background-callback)
|
||||
(gui:popup popup-menu (gui:screen-mouse-x) (gui:screen-mouse-y))))))
|
||||
(gui:popup popup-menu x y)))))
|
||||
|
||||
(defun collect-ir-lines (request-iri main-window lines)
|
||||
(with-accessors ((ir-lines ir-lines)
|
||||
|
|
@ -630,13 +696,15 @@
|
|||
(maybe-open-if-completed stream-info support-file))))
|
||||
(wait-enough-data)))
|
||||
|
||||
(defun slurp-non-text-data (main-window iri)
|
||||
(labels ((maybe-open-if-completed (stream-info support-file)
|
||||
(defun slurp-non-text-data (main-window iri &key (try-to-open t))
|
||||
(labels ((wait-until-download-complete (stream-info support-file)
|
||||
(if (string-equal (getf stream-info :stream-status)
|
||||
:completed)
|
||||
(if try-to-open
|
||||
(client-os-utils:open-resource-with-external-program main-window support-file)
|
||||
(getf stream-info :support-file))
|
||||
(wait-enough-data)))
|
||||
(buffer-filled-enough--to-open-p (buffer-size read-so-far)
|
||||
(buffer-filled-enough-to-open-p (buffer-size read-so-far)
|
||||
(let ((filled-configuration-threshold (and buffer-size
|
||||
(> read-so-far buffer-size))))
|
||||
(or filled-configuration-threshold
|
||||
|
|
@ -654,14 +722,15 @@
|
|||
(swconf:link-regex->program-to-use support-file)
|
||||
(declare (ignore y))
|
||||
(if program-exists
|
||||
(if wait-for-download
|
||||
(maybe-open-if-completed stream-info support-file)
|
||||
(if (or wait-for-download
|
||||
(not try-to-open))
|
||||
(wait-until-download-complete stream-info support-file)
|
||||
(let ((buffer-size (swconf:link-regex->program-to-use-buffer-size support-file)))
|
||||
(if (buffer-filled-enough--to-open-p buffer-size read-so-far)
|
||||
(if (buffer-filled-enough-to-open-p buffer-size read-so-far)
|
||||
(client-os-utils:open-resource-with-external-program main-window
|
||||
support-file)
|
||||
(wait-enough-data))))
|
||||
(maybe-open-if-completed stream-info support-file))))))
|
||||
(wait-until-download-complete stream-info support-file))))))
|
||||
(wait-enough-data)))
|
||||
|
||||
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))
|
||||
|
|
|
|||
Loading…
Reference in New Issue