mirror of https://codeberg.org/cage/tinmop/
- changed all recursive lock with the non-recursive type;
- prevented opening another connection when deleting cache; - improved rendering of html blockquote.
This commit is contained in:
parent
8c6c69c667
commit
8f9d83fa0e
|
@ -23,7 +23,7 @@
|
||||||
"An istance of 'credentials' used to holds the intormation needed to
|
"An istance of 'credentials' used to holds the intormation needed to
|
||||||
access a mastodon instance")
|
access a mastodon instance")
|
||||||
|
|
||||||
(defparameter *client-lock* (bt:make-recursive-lock)
|
(defparameter *client-lock* (bt:make-lock)
|
||||||
"The Lock for prevent race conditions when accessing the mastodon server")
|
"The Lock for prevent race conditions when accessing the mastodon server")
|
||||||
|
|
||||||
(define-constant +credentials-filename+ "client" :test #'string=
|
(define-constant +credentials-filename+ "client" :test #'string=
|
||||||
|
@ -362,18 +362,18 @@ Returns nil if the user did not provided a server in the configuration file"
|
||||||
:folder folder)))
|
:folder folder)))
|
||||||
(program-events:push-event add-fetched-event))))
|
(program-events:push-event add-fetched-event))))
|
||||||
|
|
||||||
(defun-api-call update-timeline (timeline
|
(defun update-timeline (timeline
|
||||||
kind
|
kind
|
||||||
folder
|
folder
|
||||||
&key
|
&key
|
||||||
recover-from-skipped-statuses
|
recover-from-skipped-statuses
|
||||||
local
|
local
|
||||||
only-media
|
only-media
|
||||||
max-id
|
max-id
|
||||||
since-id
|
since-id
|
||||||
min-id
|
min-id
|
||||||
(recover-count 0)
|
(recover-count 0)
|
||||||
(limit 20))
|
(limit 20))
|
||||||
"Update a timeline, this function will fetch new messages and generate and event to
|
"Update a timeline, this function will fetch new messages and generate and event to
|
||||||
update the program reflectings the changes in the timeline (saves
|
update the program reflectings the changes in the timeline (saves
|
||||||
messages in the database etc.)"
|
messages in the database etc.)"
|
||||||
|
@ -385,8 +385,9 @@ Returns nil if the user did not provided a server in the configuration file"
|
||||||
:min-id min-id
|
:min-id min-id
|
||||||
:limit limit))
|
:limit limit))
|
||||||
(trees (if command-line:*update-timeline-climb-message-tree*
|
(trees (if command-line:*update-timeline-climb-message-tree*
|
||||||
(flatten (loop for node-status in timeline-statuses collect
|
(flatten (loop for node-status in timeline-statuses
|
||||||
(expand-status-tree node-status)))
|
collect
|
||||||
|
(expand-status-tree node-status)))
|
||||||
timeline-statuses))
|
timeline-statuses))
|
||||||
(event (make-instance 'program-events:save-timeline-in-db-event
|
(event (make-instance 'program-events:save-timeline-in-db-event
|
||||||
:payload trees
|
:payload trees
|
||||||
|
|
|
@ -17,7 +17,7 @@
|
||||||
|
|
||||||
(in-package :gemini-viewer)
|
(in-package :gemini-viewer)
|
||||||
|
|
||||||
(defparameter *gemini-db-streams-lock* (bt:make-recursive-lock))
|
(defparameter *gemini-db-streams-lock* (bt:make-lock))
|
||||||
|
|
||||||
(define-constant +read-buffer-size+ 2048 :test #'=
|
(define-constant +read-buffer-size+ 2048 :test #'=
|
||||||
:documentation "Chunk's size of the buffer when reading non gemini contents from stream")
|
:documentation "Chunk's size of the buffer when reading non gemini contents from stream")
|
||||||
|
@ -107,7 +107,7 @@
|
||||||
|
|
||||||
(defclass gemini-stream ()
|
(defclass gemini-stream ()
|
||||||
((download-thread-lock
|
((download-thread-lock
|
||||||
:initform (bt:make-recursive-lock "download-gemini")
|
:initform (bt:make-lock "download-gemini")
|
||||||
:initarg :download-thread-lock
|
:initarg :download-thread-lock
|
||||||
:accessor download-thread-lock)
|
:accessor download-thread-lock)
|
||||||
(download-thread-blocked
|
(download-thread-blocked
|
||||||
|
|
|
@ -21,7 +21,7 @@
|
||||||
|
|
||||||
(defparameter *list-detected* nil)
|
(defparameter *list-detected* nil)
|
||||||
|
|
||||||
(defparameter *parser-lock* (bt:make-recursive-lock))
|
(defparameter *parser-lock* (bt:make-lock))
|
||||||
|
|
||||||
(defparameter *pre-group-id* -1)
|
(defparameter *pre-group-id* -1)
|
||||||
|
|
||||||
|
|
|
@ -104,6 +104,8 @@
|
||||||
|
|
||||||
(defparameter *block-tag* nil)
|
(defparameter *block-tag* nil)
|
||||||
|
|
||||||
|
(defparameter *quote-level* 0)
|
||||||
|
|
||||||
(defun html->text (html &key
|
(defun html->text (html &key
|
||||||
(add-link-footnotes t) (body-footnotes-separator "")
|
(add-link-footnotes t) (body-footnotes-separator "")
|
||||||
(quote-prefix "> ") (list-item-prefix "* "))
|
(quote-prefix "> ") (list-item-prefix "* "))
|
||||||
|
@ -132,9 +134,7 @@ Some convenience functions are provided to works with these structures.
|
||||||
(when node
|
(when node
|
||||||
(cond
|
(cond
|
||||||
((stringp node)
|
((stringp node)
|
||||||
(if *block-tag*
|
(princ node body-stream))
|
||||||
(princ (strcat *prefix-text-line* node) body-stream)
|
|
||||||
(princ node body-stream)))
|
|
||||||
((consp (car node))
|
((consp (car node))
|
||||||
(descend (car node)))
|
(descend (car node)))
|
||||||
((tag= +tag-link+ node)
|
((tag= +tag-link+ node)
|
||||||
|
@ -161,6 +161,9 @@ Some convenience functions are provided to works with these structures.
|
||||||
(tag= +tag-div+ node))
|
(tag= +tag-div+ node))
|
||||||
(let ((*block-tag* t))
|
(let ((*block-tag* t))
|
||||||
(format body-stream "~%")
|
(format body-stream "~%")
|
||||||
|
(when *block-tag*
|
||||||
|
(loop for i from 0 below *quote-level* do
|
||||||
|
(princ *prefix-text-line* body-stream)))
|
||||||
(descend-children node)
|
(descend-children node)
|
||||||
(format body-stream "~%")))
|
(format body-stream "~%")))
|
||||||
((tag= +tag-list-item+ node)
|
((tag= +tag-list-item+ node)
|
||||||
|
@ -170,9 +173,9 @@ Some convenience functions are provided to works with these structures.
|
||||||
(format body-stream "~%")))
|
(format body-stream "~%")))
|
||||||
((tag= +tag-blockquote+ node)
|
((tag= +tag-blockquote+ node)
|
||||||
(let ((*prefix-text-line* quote-prefix)
|
(let ((*prefix-text-line* quote-prefix)
|
||||||
|
(*quote-level* (1+ *quote-level*))
|
||||||
(*block-tag* t))
|
(*block-tag* t))
|
||||||
(descend-children node)
|
(descend-children node)))
|
||||||
(format body-stream "~%")))
|
|
||||||
(t
|
(t
|
||||||
(descend-children node))))))
|
(descend-children node))))))
|
||||||
(descend root)
|
(descend root)
|
||||||
|
|
|
@ -991,7 +991,7 @@ to the array"
|
||||||
;; threads
|
;; threads
|
||||||
|
|
||||||
(defmacro with-lock ((lock) &body body)
|
(defmacro with-lock ((lock) &body body)
|
||||||
`(bt:with-recursive-lock-held (,lock)
|
`(bt:with-lock-held (,lock)
|
||||||
,@body))
|
,@body))
|
||||||
|
|
||||||
(defmacro defun-w-lock (name parameters lock &body body)
|
(defmacro defun-w-lock (name parameters lock &body body)
|
||||||
|
@ -1003,6 +1003,34 @@ to the array"
|
||||||
(with-lock (,lock)
|
(with-lock (,lock)
|
||||||
,@remaining-forms))))
|
,@remaining-forms))))
|
||||||
|
|
||||||
|
(defparameter *thread-default-special-bindings* bt:*default-special-bindings*)
|
||||||
|
|
||||||
|
(definline make-thread (function &key (name nil) (initial-bindings *thread-default-special-bindings*))
|
||||||
|
(bt:make-thread function :name name :initial-bindings initial-bindings))
|
||||||
|
|
||||||
|
(definline make-lock (&optional name)
|
||||||
|
(bt:make-lock name))
|
||||||
|
|
||||||
|
(defmacro with-lock-held ((lock) &body body)
|
||||||
|
`(bt:with-lock-held (,lock)
|
||||||
|
,@body))
|
||||||
|
|
||||||
|
(definline make-condition-variable (&key (name nil))
|
||||||
|
(bt:make-condition-variable :name name))
|
||||||
|
|
||||||
|
(definline condition-wait (condition-variable lock &key (timeout nil))
|
||||||
|
(bt:condition-wait condition-variable lock :timeout timeout))
|
||||||
|
|
||||||
|
(definline condition-notify (condition-variable)
|
||||||
|
(bt:condition-notify condition-variable))
|
||||||
|
|
||||||
|
(definline join-thread (thread)
|
||||||
|
(bt:join-thread thread))
|
||||||
|
|
||||||
|
(definline destroy-thread (thread)
|
||||||
|
(bt:destroy-thread thread))
|
||||||
|
|
||||||
|
|
||||||
;; http
|
;; http
|
||||||
|
|
||||||
(defun get-url-content (url)
|
(defun get-url-content (url)
|
||||||
|
|
|
@ -260,6 +260,15 @@
|
||||||
:binary-search
|
:binary-search
|
||||||
:defun-w-lock
|
:defun-w-lock
|
||||||
:with-lock
|
:with-lock
|
||||||
|
:*thread-default-special-bindings*
|
||||||
|
:make-thread
|
||||||
|
:make-lock
|
||||||
|
:with-lock-held
|
||||||
|
:make-condition-variable
|
||||||
|
:condition-wait
|
||||||
|
:condition-notify
|
||||||
|
:join-thread
|
||||||
|
:destroy-thread
|
||||||
:get-url-content
|
:get-url-content
|
||||||
:with-profile-time
|
:with-profile-time
|
||||||
:with-debug-print-profile-time
|
:with-debug-print-profile-time
|
||||||
|
|
|
@ -23,7 +23,7 @@
|
||||||
|
|
||||||
(define-constant +maximum-event-priority+ -2 :test #'=)
|
(define-constant +maximum-event-priority+ -2 :test #'=)
|
||||||
|
|
||||||
(defparameter *id-lock* (bt:make-recursive-lock))
|
(defparameter *id-lock* (bt:make-lock))
|
||||||
|
|
||||||
(defparameter *event-id* 0)
|
(defparameter *event-id* 0)
|
||||||
|
|
||||||
|
@ -100,7 +100,7 @@
|
||||||
|
|
||||||
(defclass events-queue (priority-queue)
|
(defclass events-queue (priority-queue)
|
||||||
((lock
|
((lock
|
||||||
:initform (bt:make-recursive-lock)
|
:initform (bt:make-lock)
|
||||||
:initarg :lock
|
:initarg :lock
|
||||||
:accessor lock)
|
:accessor lock)
|
||||||
(blocking-lock
|
(blocking-lock
|
||||||
|
@ -222,7 +222,7 @@
|
||||||
|
|
||||||
(defclass event-on-own-thread (program-event)
|
(defclass event-on-own-thread (program-event)
|
||||||
((lock
|
((lock
|
||||||
:initform (bt:make-recursive-lock)
|
:initform (bt:make-lock)
|
||||||
:initarg :lock
|
:initarg :lock
|
||||||
:accessor lock)
|
:accessor lock)
|
||||||
(condition-variable
|
(condition-variable
|
||||||
|
|
|
@ -3460,7 +3460,7 @@ gemini client certificates!)."
|
||||||
(with-valid-yes-at-prompt (input-text y-pressed-p)
|
(with-valid-yes-at-prompt (input-text y-pressed-p)
|
||||||
(when y-pressed-p
|
(when y-pressed-p
|
||||||
(with-enqueued-process ()
|
(with-enqueued-process ()
|
||||||
(db-utils:with-ready-database (:connect t)
|
(db-utils:with-ready-database (:connect nil)
|
||||||
(db:cache-delete-all)
|
(db:cache-delete-all)
|
||||||
(let ((children (remove-if (lambda (a)
|
(let ((children (remove-if (lambda (a)
|
||||||
(or (fs:backreference-dir-p a)
|
(or (fs:backreference-dir-p a)
|
||||||
|
|
Loading…
Reference in New Issue