cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-01-30 04:14:47 +01:00
Code Issues

- added a window to browse the links that a message contains.

Browse Source
This commit is contained in:
cage 2020-05-17 17:47:33 +02:00
parent 9f6adf02c4
commit 07b13b40d2
12 changed files with 297 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
etc/default-theme.conf
View File

@ -411,8 +411,20 @@ open-attach-window.background = black
open-attach-window.foreground = #67998B
# the colors of selected attachments
# the colors of selected attachment
open-attach-window.input.selected.background = black
open-attach-window.input.selected.foreground = #71AF8C
# this is the window that allow to browse the links of a message
open-message-link-window.background = black
open-message-link-window.foreground = #FEB200
# the colors of selected link
open-message-link-window.input.selected.background = black
open-message-link-window.input.selected.foreground = #FFB200

52
etc/init.lisp
View File

@ -203,6 +203,14 @@
(define-key "v" #'open-message-attach *thread-keymap*)
(define-key "V" #'open-message-link *thread-keymap*)
(define-key "C-c u" #'update-conversations *thread-keymap*)
(define-key "C-c o" #'open-conversation *thread-keymap*)
(define-key "C-c c" #'change-conversation-name *thread-keymap*)
(define-key "C-f c" #'change-folder *thread-keymap*)
(define-key "C-t c" #'change-timeline *thread-keymap*)
@ -215,20 +223,6 @@
(define-key "C-t h r" #'refresh-tags *thread-keymap*)
(define-key "C-X m t" #'move-message-tree *thread-keymap*)
(define-key "C-X m f" #'favourite-selected-status *thread-keymap*)
(define-key "C-X m r f" #'unfavourite-selected-status *thread-keymap*)
(define-key "C-X m b" #'boost-selected-status *thread-keymap*)
(define-key "C-X m r b" #'unboost-selected-status *thread-keymap*)
(define-key "C-X m s" #'subscribe-to-hash *thread-keymap*)
(define-key "C-X m u" #'unsubscribe-to-hash *thread-keymap*)
(define-key "C-u i" #'ignore-user *thread-keymap*)
(define-key "C-u x" #'unignore-user *thread-keymap*)
@ -247,11 +241,19 @@
(define-key "C-u c k g" #'crypto-generate-key *thread-keymap*)
(define-key "C-c u" #'update-conversations *thread-keymap*)
(define-key "C-X m t" #'move-message-tree *thread-keymap*)
(define-key "C-c o" #'open-conversation *thread-keymap*)
(define-key "C-X m f" #'favourite-selected-status *thread-keymap*)
(define-key "C-c c" #'change-conversation-name *thread-keymap*)
(define-key "C-X m r f" #'unfavourite-selected-status *thread-keymap*)
(define-key "C-X m b" #'boost-selected-status *thread-keymap*)
(define-key "C-X m r b" #'unboost-selected-status *thread-keymap*)
(define-key "C-X m s" #'subscribe-to-hash *thread-keymap*)
(define-key "C-X m u" #'unsubscribe-to-hash *thread-keymap*)
;; message window keymap
@ -303,4 +305,18 @@
(define-key "down" #'open-message-attach-go-down *open-attach-keymap*)
(define-key "q" #'close-open-message-window *open-attach-keymap*)
(define-key "q" #'close-open-attach-window *open-attach-keymap*)
;; message links keymap
(define-key "C-J" #'open-message-link-perform-opening
*open-message-link-keymap*)
(define-key "up" #'open-message-link-go-up
*open-message-link-keymap*)
(define-key "down" #'open-message-link-go-down
*open-message-link-keymap*)
(define-key "q" #'close-open-message-link-window
*open-message-link-keymap*)

3
src/keybindings.lisp
View File

@ -243,6 +243,9 @@ produces a tree and graft the latter on `existing-tree'"
(defparameter *open-attach-keymap* (make-starting-comand-tree)
"The keymap for window to open message's attachments.")
(defparameter *open-message-link-keymap* (make-starting-comand-tree)
"The keymap for window to open message's links.")
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
"Define a key sequence that trigger a function:

2
src/line-oriented-window.lisp
View File

@ -220,10 +220,12 @@ this exact quantity wold go beyond the length or fows or zero."
(defclass simple-line-navigation-window (wrapper-window row-oriented-widget border-window)
((selected-line-bg
:initform :blue
:initarg :selected-line-bg
:accessor selected-line-bg
:documentation "The background color for a selected line")
(selected-line-fg
:initform :red
:initarg :selected-line-fg
:accessor selected-line-fg
:documentation "The foreground color for a selected line"))

15
src/open-attach-window.lisp
View File

@ -25,11 +25,11 @@
:initarg :status-id
:accessor status-id)))
(defmethod refresh-config :after ((object open-attach-window))
(defun refresh-view-links-window-config (window config-window-key)
(with-accessors ((croatoan-window croatoan-window)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(let* ((theme-style (swconf:form-style swconf:+key-open-attach-window+))
(selected-line-fg selected-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))
@ -46,9 +46,12 @@
(setf (fgcolor croatoan-window) fg)
(setf selected-line-fg selected-fg)
(setf selected-line-bg selected-bg)
(win-resize object win-w win-h)
(win-move object x y)
object)))
(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)

39
src/package.lisp
View File

@ -351,7 +351,8 @@
:box-fit-multiple-column
:annotated-text-symbol
:annotated-text-value
:box-fit-multiple-column-annotated))
:box-fit-multiple-column-annotated
:collect-links))
(defpackage :html-utils
(:use
@ -927,6 +928,7 @@
:+key-boosted+
:+key-tags-window+
:+key-open-attach-window+
:+key-open-message-link-window+
:+key-conversations-window+
:+key-keybindings-window+
:+key-suggestions-window+
@ -1027,6 +1029,7 @@
:*send-message-keymap*
:*follow-requests-keymap*
:*open-attach-keymap*
:*open-message-link-keymap*
:define-key
:init-keyboard-mapping
:find-keymap-node
@ -1051,7 +1054,8 @@
:*follow-requests-window*
:*tags-window*
:*conversations-window*
:*open-attach-window*))
:*open-attach-window*
:*open-message-link-window*))
(defpackage :program-events
(:use
@ -1613,10 +1617,34 @@
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:open-attach-window
:status-id
:refresh-view-links-window-config
:resync-rows-db
:open-attachment
:init))
(defpackage :open-message-link-window
(:use
:cl
:alexandria
:cl-ppcre
:access
:croatoan
:config
:constants
:text-utils
:misc
:mtree
:specials
:windows
:line-oriented-window
:tui-utils)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:open-message-link-window
:open-message-link
:init))
(defpackage :command-window
(:use
:cl
@ -1855,7 +1883,12 @@
:open-message-attach-go-up
:open-message-attach-go-down
:open-message-attach-perform-opening
:close-open-message-window
:close-open-attach-window
:open-message-link
:open-message-link-go-up
:open-message-link-go-down
:open-message-link-perform-opening
:close-open-message-link-window
:attach-go-up
:attach-go-down
:attach-delete

1
src/software-configuration.lisp
View File

@ -353,6 +353,7 @@
keybindings-window
suggestions-window
open-attach-window
open-message-link-window
command-window
command-separator
tree

3
src/specials.lisp
View File

@ -48,3 +48,6 @@
(defparameter *open-attach-window* nil
"The window that shows attachments for a message.")
(defparameter *open-message-link-window* nil
"The window that shows links in a message.")

19
src/text-utils.lisp
View File

@ -631,3 +631,22 @@ printed in the box column by column; in the example above the results are:
box-height))
(list columns)))))
(fit)))
(defun collect-links (text &optional (schemes '("http" "https" "ftp")))
"Collect all hyperlinks in a text marked from a list of valid `schemes'"
(flet ((build-re-scheme ()
(let ((res ""))
(loop for (scheme . rest) on schemes do
(if rest
(setf res (strcat res "(" scheme ")|"))
(setf res (strcat res "(" scheme ")://"))))
(strcat "(" res ")"))))
(let* ((results ())
(re (strcat (build-re-scheme) "\\P{White_Space}+"))
(words (split-words text))
(scanner (cl-ppcre:create-scanner re)))
(loop for word in words when (cl-ppcre:scan scanner word) do
(pushnew (cl-ppcre:scan-to-strings scanner word)
results
:test #'string=))
results)))

66
src/ui-goodies.lisp
View File

@ -342,7 +342,9 @@ Metadata includes:
specials:*thread-window*
:documentation "Move focus on thread window"
:info-change-focus-message (_ "Focus passed on threads window")
:windows-lose-focus (specials:*conversations-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*conversations-window*
specials:*tags-window*
specials:*send-message-window*
specials:*message-window*
@ -352,7 +354,9 @@ Metadata includes:
specials:*message-window*
:documentation "Move focus on message window"
:info-change-focus-message (_ "Focus passed on message window")
:windows-lose-focus (specials:*conversations-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*conversations-window*
specials:*tags-window*
specials:*thread-window*
specials:*send-message-window*
@ -363,7 +367,8 @@ Metadata includes:
specials:*send-message-window*
:documentation "Move focus on send message window"
:info-change-focus-message (_ "Focus passed on send message window")
:windows-lose-focus (specials:*open-attach-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*conversations-window*
specials:*tags-window*
specials:*thread-window*
@ -374,7 +379,8 @@ Metadata includes:
specials:*follow-requests-window*
:documentation "Move focus on follow requests window"
:info-change-focus-message (_ "Focus passed on follow requests window")
:windows-lose-focus (specials:*open-attach-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*conversations-window*
specials:*tags-window*
specials:*thread-window*
@ -385,7 +391,8 @@ Metadata includes:
specials:*tags-window*
:documentation "Move focus on tags window"
:info-change-focus-message (_ "Focus passed on tags window")
:windows-lose-focus (specials:*open-attach-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*conversations-window*
specials:*follow-requests-window*
specials:*thread-window*
@ -395,7 +402,8 @@ Metadata includes:
specials:*conversations-window*
:documentation "Move focus on conversations window"
:info-change-focus-message (_ "Focus passed on conversation window")
:windows-lose-focus (specials:*open-attach-window*
:windows-lose-focus (specials:*open-message-link-window*
specials:*open-attach-window*
specials:*tags-window*
specials:*follow-requests-window*
specials:*thread-window*
@ -406,7 +414,20 @@ Metadata includes:
specials:*open-attach-window*
:documentation "Move focus on open-attach window"
:info-change-focus-message (_ "Focus passed on attach window")
:windows-lose-focus (specials:*open-message-link-window*
specials:*conversations-window*
specials:*tags-window*
specials:*follow-requests-window*
specials:*thread-window*
specials:*message-window*
specials:*send-message-window*))
(gen-focus-to-window open-message-link-window
specials:*open-message-link-window*
:documentation "Move focus on open-link window"
:info-change-focus-message (_ "Focus passed on link window")
:windows-lose-focus (specials:*conversations-window*
specials:*open-attach-window*
specials:*tags-window*
specials:*follow-requests-window*
specials:*thread-window*
@ -822,7 +843,9 @@ Starting from the oldest toot and going back."
(push-event event)))))))
(defun open-message-attach ()
"Open message attachments window"
"Open message links window
Browse and optionally open the links the messages contains."
(when-let* ((win specials:*thread-window*)
(selected-message (line-oriented-window:selected-row-fields win)))
(open-attach-window:init (db:row-message-status-id selected-message))
@ -845,9 +868,36 @@ Starting from the oldest toot and going back."
(url (line-oriented-window:normal-text selected-line)))
(open-attach-window:open-attachment url)))
(defun close-open-message-window ()
(defun close-open-attach-window ()
(close-window-and-return-to-threads specials:*open-attach-window*))
(defun open-message-link ()
"Open message attachments window"
(when-let* ((win specials:*thread-window*)
(selected-message (line-oriented-window:selected-row-fields win)))
(open-message-link-window:init (db:row-message-status-id selected-message))
(focus-to-open-message-link-window)))
(defun open-message-link-move (amount)
(ignore-errors
(line-oriented-window:unselect-all specials:*open-message-link-window*)
(line-oriented-window:row-move specials:*open-message-link-window* amount)
(draw specials:*open-message-link-window*)))
(defun open-message-link-go-down ()
(open-message-link-move 1))
(defun open-message-link-go-up ()
(open-message-link-move -1))
(defun open-message-link-perform-opening ()
(when-let* ((selected-line (line-oriented-window:selected-row specials:*open-message-link-window*))
(url (line-oriented-window:normal-text selected-line)))
(open-message-link-window:open-message-link url)))
(defun close-open-message-link-window ()
(close-window-and-return-to-threads specials:*open-message-link-window*))
(defun prompt-for-username (prompt complete-function event
notify-starting-message
notify-ending-message)

1
tinmop.asd
View File

@ -92,6 +92,7 @@
(:file "thread-window")
(:file "message-window")
(:file "open-attach-window")
(:file "open-message-link-window")
(:file "command-window")
(:file "sending-message")
(:file "follow-requests")