From 76a9a3aafffa759a16534baff571710a4156a51a Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 10 Sep 2022 13:21:20 +0200 Subject: [PATCH] - added command "status-tree->text". --- etc/init.lisp | 4 ++- src/html-utils.lisp | 4 +-- src/mtree-utils.lisp | 1 - src/package.lisp | 1 + src/ui-goodies.lisp | 68 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 74 insertions(+), 4 deletions(-) diff --git a/etc/init.lisp b/etc/init.lisp index dae716a..7cb3d3b 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -262,7 +262,9 @@ (status-id (db:row-message-status-id selected-row))) (ui:info-message (format nil "ID: ~a" status-id)))) -(define-key "I" #'print-post-id *thread-keymap*) +(define-key "I" #'print-post-id *thread-keymap*) + +(define-key "s d" #'status-tree->text *thread-keymap*) (define-key "up" #'thread-go-up *thread-keymap*) diff --git a/src/html-utils.lisp b/src/html-utils.lisp index f93da25..d6a6841 100644 --- a/src/html-utils.lisp +++ b/src/html-utils.lisp @@ -96,7 +96,7 @@ (defun node->link (node) (html-utils:attribute-value (html-utils:find-attribute :href node))) -(defun html->text (html &key (add-link-footnotes t)) +(defun html->text (html &key (add-link-footnotes t) (body-footnotes-separator "")) "Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message This function uses a library that transform html5 text into s-expressions um the form @@ -152,7 +152,7 @@ Some convenience functions are provided to works with these structures. (descend-children node)))))) (descend root) (if add-link-footnotes - (strcat body footnotes) + (strcat body body-footnotes-separator footnotes) body))))))) (defun extract-shotcodes (file) diff --git a/src/mtree-utils.lisp b/src/mtree-utils.lisp index f8957c2..f1351f6 100644 --- a/src/mtree-utils.lisp +++ b/src/mtree-utils.lisp @@ -514,7 +514,6 @@ (child-char (string #\├)) (spacer-child (string #\─)) (arrow-char (format nil "~c " +tree-arrow-char+)) - (print-data nil) (print-data-fn #'to-s)) (let ((res ()) diff --git a/src/package.lisp b/src/package.lisp index 433f5b9..5608b5d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -2769,6 +2769,7 @@ :refresh-thread :refresh-thread-totally :refresh-tags + :status-tree->text :favourite-selected-status :unfavourite-selected-status :boost-selected-status diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index e750a0d..e0a764d 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -939,6 +939,74 @@ Expand the post until all the reply and parents are downloaded. If some posts was deleted before, download them again." (expand-status-tree t)) +(defun status-tree->text () + (let* ((thread "") + (message-max-width (truncate (/ (win-width-no-border *message-window*) 3))) + (padding-step (truncate (/ message-max-width 4)))) + (labels ((print-node-data (node padding) + (let* ((row (mtree:data node)) + (content (html-utils:html->text (db:row-message-content row) + :body-footnotes-separator + (format nil (_ "───── links ───── ~%")))) + (author (format nil "~a (~a)" + (db:row-message-username row) + (db:row-message-user-display-name row))) + (creation-time (db:row-message-creation-time row)) + (encoded-date (format-time (db-utils:encode-datetime-string creation-time) + (swconf:date-fmt swconf:+key-message-window+))) + (visibility (message-rendering-utils::visibility->mark + (db:row-message-visibility row))) + (from-label (_ "From: ")) + (visibility-label (_ "Visibility: ")) + (date-label (_ "Date: ")) + (lines (flatten (mapcar (lambda (a) + (flush-left-mono-text (split-words a) + message-max-width)) + (split-lines content)))) + (padding-spaces (make-string padding :initial-element #\space)) + (text-lines (mapcar (lambda (a) (strcat padding-spaces + a + (format nil "~%"))) + lines)) + (text (format nil + "~2%~a~a~a~%~a~a~a~%~a~a~a~2%~a" + padding-spaces from-label author + padding-spaces date-label encoded-date + padding-spaces visibility-label visibility + (join-with-strings text-lines "")))) + text)) + (print-tree (tree &optional (padding 0)) + (let ((children-padding (+ padding padding-step))) + (setf thread (strcat thread (print-node-data tree padding))) + (loop + for node across (children tree) do + (print-tree node children-padding)))) + (save-file (file) + (when-let* ((selected-message (line-oriented-window:selected-row-fields *thread-window*)) + (timeline (thread-window:timeline-type *thread-window*)) + (folder (thread-window:timeline-folder *thread-window*)) + (status-id (actual-author-message-id selected-message))) + (with-enqueued-process () + (db-utils:with-ready-database (:connect t) + (let* ((tree (db:message-id->tree timeline folder status-id))) + (print-tree tree) + (when (string-not-empty-p file) + (if (fs:file-exists-p file) + (error-message (format nil + (_ "I refuse to overwrite an existing file ~s.") + file)) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :if-does-not-exist :error) + (write-sequence thread stream)))) + (message-window:prepare-for-rendering *message-window* thread) + (windows:draw *message-window*) + (focus-to-message-window))))))) + (ask-string-input #'save-file + :prompt (_ "Save thread to file: ") + :complete-fn #'complete:directory-complete)))) + (defun refresh-tags () "Update messages for subscribed tags" (let* ((all-tags (db:all-subscribed-tags-name))