mirror of https://codeberg.org/cage/tinmop/
173 lines
8.4 KiB
Common Lisp
173 lines
8.4 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © cage
|
|
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(in-package :open-attach-window)
|
|
|
|
(defclass open-attach-window (focus-marked-window
|
|
simple-line-navigation-window
|
|
title-window
|
|
border-window)
|
|
((status-id
|
|
:initform nil
|
|
:initarg :status-id
|
|
:accessor status-id)))
|
|
|
|
(defun refresh-view-links-window-config (window config-window-key &key (center-position nil))
|
|
(with-accessors ((croatoan-window croatoan-window)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)
|
|
(unselected-line-bg unselected-line-bg)
|
|
(unselected-line-fg unselected-line-fg)) window
|
|
(let* ((theme-style (swconf:form-style config-window-key))
|
|
(fg (swconf:foreground theme-style))
|
|
(bg (swconf:background theme-style))
|
|
(selected-fg (swconf:selected-foreground theme-style))
|
|
(selected-bg (swconf:selected-background theme-style))
|
|
(unselected-fg (swconf:unselected-foreground theme-style))
|
|
(unselected-bg (swconf:unselected-background theme-style))
|
|
(reference-window (if command-line:*gemini-full-screen-mode*
|
|
*gemini-toc-window*
|
|
*thread-window*))
|
|
(win-w (cond
|
|
(command-line:*gemini-full-screen-mode*
|
|
(- (win-width *main-window*)
|
|
(win-width reference-window)))
|
|
(center-position
|
|
(truncate (/ (win-width reference-window) 2)))
|
|
(t
|
|
(win-width reference-window))))
|
|
(win-h (cond
|
|
(command-line:*gemini-full-screen-mode*
|
|
(swconf:config-gemini-fullscreen-links-height))
|
|
(center-position
|
|
(truncate (/ (win-height reference-window) 2)))
|
|
(t
|
|
(win-height reference-window))))
|
|
(x (cond
|
|
(command-line:*gemini-full-screen-mode*
|
|
(win-width reference-window))
|
|
(center-position
|
|
(truncate (- (/ (win-width *main-window*) 2)
|
|
(/ win-w 2))))
|
|
(t
|
|
(win-x reference-window))))
|
|
(y (if center-position
|
|
(truncate (- (/ (win-height *main-window*) 2)
|
|
(/ win-h 2)))
|
|
0)))
|
|
(setf (c:background croatoan-window) (tui:make-win-background bg))
|
|
(setf (c:bgcolor croatoan-window) bg)
|
|
(setf (c:fgcolor croatoan-window) fg)
|
|
(setf selected-line-fg selected-fg)
|
|
(setf selected-line-bg selected-bg)
|
|
(setf unselected-line-fg unselected-fg)
|
|
(setf unselected-line-bg unselected-bg)
|
|
(win-resize window win-w win-h)
|
|
(win-move window x y)
|
|
window)))
|
|
|
|
(defmethod refresh-config :after ((object open-attach-window))
|
|
(refresh-view-links-window-config object swconf:+key-open-attach-window+))
|
|
|
|
(defmethod resync-rows-db ((object open-attach-window) &key
|
|
(redraw t)
|
|
(suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(status-id status-id)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(flet ((make-rows (attach-names bg fg)
|
|
(mapcar (lambda (name)
|
|
(make-instance 'line
|
|
:normal-text name
|
|
:selected-text name
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg))
|
|
attach-names)))
|
|
(let ((attach-names (db:all-attachments-urls-to-status status-id
|
|
:add-reblogged-urls t)))
|
|
(with-croatoan-window (croatoan-window object)
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows attach-names
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(draw object)))))))
|
|
|
|
(defun init (status-id)
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *open-attach-window*
|
|
(make-instance 'open-attach-window
|
|
:title (_ "Attachments")
|
|
:status-id status-id
|
|
:single-row-height 1
|
|
:uses-border-p t
|
|
:keybindings keybindings:*open-attach-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *open-attach-window*)
|
|
(resync-rows-db *open-attach-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *open-attach-window*))
|
|
(select-row *open-attach-window* 0))
|
|
(draw *open-attach-window*)
|
|
*open-attach-window*))
|
|
|
|
;; Note we can not use the function with the same name in
|
|
;; filesystem-utils as the latter doen not check for query string
|
|
(defun get-extension (file)
|
|
(multiple-value-bind (matchedp res)
|
|
(cl-ppcre:scan-to-strings "(?i)[a-z0-9]\(\\.[^./?]+)(\\?.+)?$" file)
|
|
(when matchedp
|
|
(first-elt res))))
|
|
|
|
(defun open-attachment (url &key (ignore-cache nil))
|
|
(labels ((add-extension (cached-value)
|
|
(strcat (to-s cached-value) (get-extension url)))
|
|
(fill-cache (url)
|
|
(let* ((cached-file-name (add-extension (db:cache-put url)))
|
|
(cached-output-file (os-utils:cached-file-path cached-file-name))
|
|
(stream (get-url-content url)))
|
|
(fs:create-file cached-output-file :skip-if-exists t)
|
|
(with-open-file (out-stream
|
|
cached-output-file
|
|
:element-type '(unsigned-byte 8)
|
|
:if-does-not-exist :error
|
|
:if-exists :supersede
|
|
:direction :output)
|
|
(loop for byte = (read-byte stream nil nil) while byte do
|
|
(write-byte byte out-stream))))))
|
|
(multiple-value-bind (program use-cache-p)
|
|
(swconf:link-regex->program-to-use url)
|
|
(let ((cached (db:cache-get-value url)))
|
|
(if (not cached)
|
|
(if (and program
|
|
(not use-cache-p))
|
|
(os-utils:open-link-with-program program url)
|
|
(progn
|
|
(fill-cache url)
|
|
(open-attachment url)))
|
|
(let ((cached-file (os-utils:cached-file-path (add-extension cached))))
|
|
(if (or (not (fs:file-exists-p cached-file))
|
|
(<= (fs:file-size cached-file) 0)
|
|
ignore-cache)
|
|
(progn
|
|
(db:cache-invalidate url)
|
|
(open-attachment url))
|
|
(os-utils:open-resource-with-external-program cached-file nil))))))))
|