cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- fixed extraction of URLs of the selected status in threads window if 

it is a reblogged one.
This commit is contained in:
cage 2023-10-05 18:42:37 +02:00
parent 507eed0412
commit 653ca72baa
6 changed files with 36 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/message-window.lisp
View File

@ -870,19 +870,9 @@ fragment matches- move the window to the line when matching occurred."
(row-move window (+ starting-match-row-pos line-matched))
(draw window)))))))
(defgeneric lines->uri (object))
(defmethod lines->uri ((object message-window))
(flatten (map-rows object
(lambda (row)
(when-let* ((text-line (line->text row))
(uri (lines->uri text-line)))
uri)))))
(defmethod lines->uri ((object string))
(when-let* ((words (split-words object)))
(remove-if (lambda (word)
(if (< (length word) 4)
t
(not (iri:absolute-url-p word))))
words)))

8
src/open-message-link-window.lisp
View File

@ -41,8 +41,12 @@
:selected-bg fg
:selected-fg bg))
links)))
(let* ((message (db:find-status-id status-id))
(links (reverse (text-utils:collect-links (db:row-message-rendered-text message)))))
(let* ((message (db:find-status-id status-id))
(reblogged-status-body (thread-window::reblogged-data message))
(body (db:row-message-rendered-text message))
(links (reverse (if (string-not-empty-p reblogged-status-body)
(collect-links reblogged-status-body)
(collect-links body)))))
(with-croatoan-window (croatoan-window object)
(when hooks:*before-displaying-links-hook*
(setf links

3
src/package.lisp
View File

@ -410,6 +410,7 @@
:cl
:config)
(:import-from :misc :definline)
(:local-nicknames (:a :alexandria))
(:export
:+float-regexp+
:+integer-regexp+
@ -450,6 +451,7 @@
:annotated-text-symbol
:annotated-text-value
:box-fit-multiple-column-annotated
:lines->uri
:collect-links
:percent-encode
:percent-decode
@ -2479,7 +2481,6 @@
:generate-gemini-toc
:gemini-toc-entry
:gemini-toc-group-id
:lines->uri
:init
:search-gemini-fragment))

42
src/text-utils.lisp
View File

@ -34,9 +34,9 @@
(in-package :text-utils)
(alexandria:define-constant +float-regexp+ "-?[0-9]+(\\.[0-9]+([eE]-?[0-9]+)?)?" :test 'string=)
(a:define-constant +float-regexp+ "-?[0-9]+(\\.[0-9]+([eE]-?[0-9]+)?)?" :test 'string=)
(alexandria:define-constant +integer-regexp+ "0|[1-9][0-9]+|[1-9]" :test 'string=)
(a:define-constant +integer-regexp+ "0|[1-9][0-9]+|[1-9]" :test 'string=)
(defun uchar-length (leading-byte)
(let ((ones (do* ((ct 7 (1- ct))
@ -123,9 +123,9 @@
(let* ((prefix-count 0)
(sorted-strings (num:shellsort strings #'(lambda (a b) (> (length a)
(length b)))))
(pivot-string (alexandria:first-elt sorted-strings))
(pivot-string (a:first-elt sorted-strings))
(actual-strings (rest sorted-strings))
(res (string (alexandria:first-elt pivot-string))))
(res (string (a:first-elt pivot-string))))
(labels ((advance-res ()
(incf prefix-count)
(setf res (strcat res (string (elt pivot-string prefix-count)))))
@ -625,9 +625,9 @@ printed in the box column by column; in the example above the results are:
(labels ((length-fitted (line)
(length (cat-annotated-values line)))
(cut-last (line)
(let ((shrinked (coerce (misc:safe-all-but-last-elt (cdr (alexandria:last-elt line)))
(let ((shrinked (coerce (misc:safe-all-but-last-elt (cdr (a:last-elt line)))
'string)))
(setf (cdr (alexandria:last-elt line))
(setf (cdr (a:last-elt line))
shrinked)
(remove-if (lambda (a)
(let((string (cdr a)))
@ -660,9 +660,9 @@ printed in the box column by column; in the example above the results are:
(let* ((raw-string (cat-annotated-values line))
(diff (- max-width
(length raw-string)))
(last-string (cdr (alexandria:last-elt line))))
(last-string (cdr (a:last-elt line))))
(when (> diff 0)
(setf (cdr (alexandria:last-elt line))
(setf (cdr (a:last-elt line))
(strcat last-string
(build-string diff))))
line))
@ -702,6 +702,16 @@ printed in the box column by column; in the example above the results are:
(list columns)))))
(fit)))
(defgeneric lines->uri (object))
(defmethod lines->uri ((object string))
(a:when-let ((words (split-words object)))
(remove-if (lambda (word)
(if (< (length word) 4)
t
(not (iri:absolute-url-p word))))
words)))
(defun collect-links (text &optional (schemes '("http" "https" "ftp" "gemini" "gopher")))
"Collect all hyperlinks in a text marked from a list of valid `schemes'"
(flet ((build-re-scheme ()
@ -711,15 +721,13 @@ printed in the box column by column; in the example above the results are:
(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)))
(a:when-let* ((all-uris (lines->uri text))
(re (strcat (build-re-scheme) "\\P{White_Space}+"))
(scanner (cl-ppcre:create-scanner re)))
(let ((results '()))
(loop for uri in all-uris when (cl-ppcre:scan scanner uri) do
(pushnew uri results :test #'string=))
results))))
(defun percent-encode (string)
(percent-encoding:encode string :encoding :utf-8))

4
src/thread-window.lisp
View File

@ -883,8 +883,8 @@ db:renumber-timeline-message-index."
(refresh-event (make-instance 'program-events:refresh-conversations-window-event))
(poll (db:find-poll-bound-to-status status-id))
(poll-text (poll->text (db:row-id poll)
(truncate (/ (win-width-no-border object)
2)))))
(truncate (/ (win-width-no-border object)
2)))))
(multiple-value-bind (reblogged-status-body reblogged-status-attachments)
(reblogged-data fields)
(let ((actual-body (if (string= body reblogged-status-body)

2
src/ui-goodies.lisp
View File

@ -394,7 +394,7 @@ Metadata includes:
:complete-fn #'complete:tags-complete)))
(defun message-extract-links ()
(when-let* ((all-iris (message-window:lines->uri *message-window*))
(when-let* ((all-iris (text-utils:lines->uri *message-window*))
(all-links (mapcar (lambda (a)
(make-instance 'gemini-parser:gemini-link
:target a))