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

etc/default-theme.conf

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

etc/init.lisp

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

src/html-utils.lisp

@@ -104,7 +104,7 @@ Some convenience functions are provided to works with this structures.
                                         (_ "No address found")))
                             (descend-children node)
                             (when add-link-footnotes
-                              (format body-stream "[~a] " link-count))))
+                              (format body-stream " [~a] " link-count))))
                          ((tag= +tag-break+ node)
                           (format body-stream "~%")
                           (descend-children node))

src/keybindings.lisp

@@ -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:
 

src/line-oriented-window.lisp

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

src/open-attach-window.lisp

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

src/package.lisp

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

src/software-configuration.lisp

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

src/specials.lisp

@@ -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.")

src/text-utils.lisp

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

src/ui-goodies.lisp

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

tinmop.asd

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