dickmao
/
nndiscourse
Protected
1
1
0
Fork 1
Code Issues 1 Pull Requests 1 Packages Projects Releases Wiki Activity

fix trivial issues #2

Merged
conao3 merged 3 commits from feature into master 2020-02-14 17:19:43 +00:00
Conversation 1 Commits 3 Files Changed 1
1 changed files with 155 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

310
nndiscourse.el
View File

@ -122,11 +122,11 @@ Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtab
Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables." Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables."
(declare (indent defun)) (declare (indent defun))
(unless (stringp string) (unless (stringp string)
(setq string (format "%s" string))) (setq string (prin1-to-string string)))
(let* ((capture (nndiscourse--gethash string hashtable)) (let* ((capture (nndiscourse--gethash string hashtable))
(replace-with (funcall func capture))) (replace-with (funcall func capture)))
(if (fboundp 'gnus-sethash) (if (fboundp 'gnus-sethash)
(set (intern string hashtable) replace-with) (set (intern string hashtable) replace-with)
(puthash string replace-with hashtable)))) (puthash string replace-with hashtable))))
(defmacro nndiscourse--sethash (string value hashtable) (defmacro nndiscourse--sethash (string value hashtable)
@ -287,9 +287,9 @@ Return response of METHOD ARGS of type `json-object-type' or nil if failure."
(proc (json-rpc-process connection))) (proc (json-rpc-process connection)))
(set-process-thread proc nil)) (set-process-thread proc nil))
(nndiscourse--with-mutex nndiscourse--mutex-rpc-request (nndiscourse--with-mutex nndiscourse--mutex-rpc-request
(gnus-message 7 "nndiscourse-rpc-request: send %s %s" method (gnus-message 7 "nndiscourse-rpc-request: send %s %s" method
(mapconcat (lambda (s) (format "%s" s)) args " ")) (mapconcat (lambda (s) (format "%s" s)) args " "))
(json-rpc connection method args))) (json-rpc connection method args)))
(error (prog1 nil (error (prog1 nil
(gnus-message 3 "nndiscourse-rpc-request: %s" (error-message-string err))))))) (gnus-message 3 "nndiscourse-rpc-request: %s" (error-message-string err)))))))
@ -374,31 +374,31 @@ I am counting on `gnus-check-server` in `gnus-read-active-file-1' in
(apply-partially 'nndiscourse--message-user server) (apply-partially 'nndiscourse--message-user server)
nil t)) nil t))
(nndiscourse-register-process (nndiscourse-register-process
free-port free-port
(let ((default-directory (let ((default-directory
(expand-file-name "nndiscourse" (expand-file-name "nndiscourse"
(file-name-directory (file-name-directory
(or (locate-library "nndiscourse") (or (locate-library "nndiscourse")
default-directory))))) default-directory)))))
(let ((new-proc (make-process :name server (let ((new-proc (make-process :name server
:buffer proc-buf :buffer proc-buf
:command ruby-command :command ruby-command
:noquery t :noquery t
:sentinel #'nndiscourse-sentinel :sentinel #'nndiscourse-sentinel
:stderr stderr-buffer))) :stderr stderr-buffer)))
(cl-loop repeat 10 (cl-loop repeat 10
until (condition-case nil until (condition-case nil
(prog1 t (prog1 t
(delete-process (delete-process
(make-network-process :name "test-port" (make-network-process :name "test-port"
:noquery t :noquery t
:host nndiscourse-localhost :host nndiscourse-localhost
:service free-port :service free-port
:buffer nil :buffer nil
:stop t))) :stop t)))
(file-error nil)) (file-error nil))
do (accept-process-output new-proc 0.3)) do (accept-process-output new-proc 0.3))
new-proc))))))) new-proc)))))))
(unless original-global-rbenv-mode (unless original-global-rbenv-mode
(global-rbenv-mode -1)))))) (global-rbenv-mode -1))))))
@ -430,17 +430,17 @@ Same argument meanings for KEY ALIST DEFAULT REMOVE and TESTFN."
,getter))))) ,getter)))))
`(progn `(progn
,(cond ,(cond
((null remove) set-exp) ((null remove) set-exp)
((or (eql v default) ((or (eql v default)
(and (eq (car-safe v) 'quote) (and (eq (car-safe v) 'quote)
(eq (car-safe default) 'quote) (eq (car-safe default) 'quote)
(eql (cadr v) (cadr default)))) (eql (cadr v) (cadr default))))
`(if ,p ,(funcall setter `(delq ,p ,getter)))) `(if ,p ,(funcall setter `(delq ,p ,getter))))
(t (t
`(cond `(cond
((not (eql ,default ,v)) ,set-exp) ((not (eql ,default ,v)) ,set-exp)
(,p ,(funcall setter (,p ,(funcall setter
`(delq ,p ,getter)))))) `(delq ,p ,getter))))))
,v)))))))))) ,v))))))))))
(defun nndiscourse-register-process (port proc) (defun nndiscourse-register-process (port proc)
@ -462,17 +462,17 @@ Return PROC if success, nil otherwise."
(defun nndiscourse-deregister-process (server) (defun nndiscourse-deregister-process (server)
"Disavow any knowledge of SERVER's process." "Disavow any knowledge of SERVER's process."
(aif (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal) (awhen (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal)
(let ((proc (nndiscourse-proc-info-process it))) (let ((proc (nndiscourse-proc-info-process it)))
(gnus-message 5 "`nndiscourse-deregister-process': deregistering %s %s pid=%s" (gnus-message 5 "`nndiscourse-deregister-process': deregistering %s %s pid=%s"
server (process-name proc) (process-id proc)) server (process-name proc) (process-id proc))
(delete-process proc))) (delete-process proc)))
(setf (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal) nil)) (setf (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal) nil))
(deffoo nndiscourse-close-server (&optional server _defs) (deffoo nndiscourse-close-server (&optional server _defs)
"Patterning after nnimap.el." "Patterning after nnimap.el."
(aif (nndiscourse--server-buffer server) (awhen (nndiscourse--server-buffer server)
(kill-buffer it)) (kill-buffer it))
(when (nnoo-change-server 'nndiscourse server nil) (when (nnoo-change-server 'nndiscourse server nil)
(nnoo-close-server 'nndiscourse server) (nnoo-close-server 'nndiscourse server)
t)) t))
@ -573,12 +573,12 @@ Originally written by Paul Issartel."
(deffoo nndiscourse-request-group-scan (group &optional server info) (deffoo nndiscourse-request-group-scan (group &optional server info)
"M-g from *Group* calls this." "M-g from *Group* calls this."
(nndiscourse--with-group server group (nndiscourse--with-group server group
(gnus-message 5 "nndiscourse-request-group-scan: scanning %s..." group) (gnus-message 5 "nndiscourse-request-group-scan: scanning %s..." group)
(nndiscourse-request-scan nil server) (nndiscourse-request-scan nil server)
(gnus-get-unread-articles-in-group (gnus-get-unread-articles-in-group
(or info (gnus-get-info gnus-newsgroup-name)) (or info (gnus-get-info gnus-newsgroup-name))
(gnus-active (gnus-info-group info))) (gnus-active (gnus-info-group info)))
(gnus-message 5 "nndiscourse-request-group-scan: scanning %s...done" group)) (gnus-message 5 "nndiscourse-request-group-scan: scanning %s...done" group))
t) t)
;; gnus-group-select-group ;; gnus-group-select-group
@ -592,14 +592,14 @@ Originally written by Paul Issartel."
;; nndiscourse-request-group ;; nndiscourse-request-group
(deffoo nndiscourse-request-group (group &optional server _fast _info) (deffoo nndiscourse-request-group (group &optional server _fast _info)
(nndiscourse--with-group server group (nndiscourse--with-group server group
(let* ((num-headers (length (nndiscourse-get-headers server group))) (let* ((num-headers (length (nndiscourse-get-headers server group)))
(status (format "211 %d %d %d %s" num-headers (status (format "211 %d %d %d %s" num-headers
(aif (nndiscourse--first-article-number server group) it 1) (aif (nndiscourse--first-article-number server group) it 1)
(aif (nndiscourse--last-article-number server group) it 0) (aif (nndiscourse--last-article-number server group) it 0)
group))) group)))
(gnus-message 7 "nndiscourse-request-group: %s" status) (gnus-message 7 "nndiscourse-request-group: %s" status)
(nnheader-insert "%s\n" status)) (nnheader-insert "%s\n" status))
t)) t))
(defun nndiscourse--request-item (id server) (defun nndiscourse--request-item (id server)
"Retrieve ID from SERVER as a property list." "Retrieve ID from SERVER as a property list."
@ -692,8 +692,8 @@ Originally written by Paul Issartel."
(nndiscourse-set-ref server (nndiscourse-set-ref server
(plist-get plst :id) (plist-get plst :id)
(plist-get (nndiscourse--number-to-header (plist-get (nndiscourse--number-to-header
server group (plist-get plst :topic_id) server group (plist-get plst :topic_id)
parent-number) parent-number)
:id))) :id)))
(nndiscourse--replace-hash type (lambda (x) (1+ (or x 0))) counts) (nndiscourse--replace-hash type (lambda (x) (1+ (or x 0))) counts)
(if-let ((info (gnus-get-info full-group))) (if-let ((info (gnus-get-info full-group)))
@ -712,7 +712,7 @@ Originally written by Paul Issartel."
(gnus-range-normalize gap)))))) (gnus-range-normalize gap))))))
(gnus-message 3 "nndiscourse--incoming: cannot update read for %s" group)) (gnus-message 3 "nndiscourse--incoming: cannot update read for %s" group))
(nndiscourse-set-headers server group (nndiscourse-set-headers server group
(nconc (nndiscourse-get-headers server group) (list plst))))) (nconc (nndiscourse-get-headers server group) (list plst)))))
(gnus-message (gnus-message
5 (concat "nndiscourse--incoming: " 5 (concat "nndiscourse--incoming: "
(format "last-id: %s, " nndiscourse--last-id) (format "last-id: %s, " nndiscourse--last-id)
@ -777,47 +777,47 @@ article header. Gnus manual does say the term `header` is oft conflated."
(deffoo nndiscourse-request-article (article-number &optional group server buffer) (deffoo nndiscourse-request-article (article-number &optional group server buffer)
(unless buffer (setq buffer nntp-server-buffer)) (unless buffer (setq buffer nntp-server-buffer))
(nndiscourse--with-group server group (nndiscourse--with-group server group
(with-current-buffer buffer (with-current-buffer buffer
(erase-buffer) (erase-buffer)
(let* ((header (nndiscourse--get-header server group article-number)) (let* ((header (nndiscourse--get-header server group article-number))
(mail-header (nndiscourse--make-header server group article-number)) (mail-header (nndiscourse--make-header server group article-number))
(score (cdr (assq 'X-Discourse-Score (mail-header-extra mail-header)))) (score (cdr (assq 'X-Discourse-Score (mail-header-extra mail-header))))
(permalink (cdr (assq 'X-Discourse-Permalink (mail-header-extra mail-header)))) (permalink (cdr (assq 'X-Discourse-Permalink (mail-header-extra mail-header))))
(body (nndiscourse--massage (plist-get header :cooked)))) (body (nndiscourse--massage (plist-get header :cooked))))
(when body (when body
(insert (insert
"Newsgroups: " group "\n" "Newsgroups: " group "\n"
"Subject: " (mail-header-subject mail-header) "\n" "Subject: " (mail-header-subject mail-header) "\n"
"From: " (or (mail-header-from mail-header) "nobody") "\n" "From: " (or (mail-header-from mail-header) "nobody") "\n"
"Date: " (mail-header-date mail-header) "\n" "Date: " (mail-header-date mail-header) "\n"
"Message-ID: " (mail-header-id mail-header) "\n" "Message-ID: " (mail-header-id mail-header) "\n"
"References: " (mail-header-references mail-header) "\n" "References: " (mail-header-references mail-header) "\n"
(format "Content-Type: text/html; charset=%s" nndiscourse-charset) "\n" (format "Content-Type: text/html; charset=%s" nndiscourse-charset) "\n"
"Archived-at: " permalink "\n" "Archived-at: " permalink "\n"
"Score: " score "\n" "Score: " score "\n"
"\n") "\n")
(-when-let* (-when-let*
((parent (plist-get header :parent)) ((parent (plist-get header :parent))
(parent-author (parent-author
(or (plist-get (nndiscourse--get-header server group parent) (or (plist-get (nndiscourse--get-header server group parent)
:username) :username)
"Someone")) "Someone"))
(parent-body (nndiscourse--massage (parent-body (nndiscourse--massage
(plist-get (plist-get
(nndiscourse--get-header server group parent) (nndiscourse--get-header server group parent)
:cooked)))) :cooked))))
(insert (nndiscourse--citation-wrap parent-author parent-body))) (insert (nndiscourse--citation-wrap parent-author parent-body)))
(insert body) (insert body)
(cons group article-number)))))) (cons group article-number))))))
(deffoo nndiscourse-retrieve-headers (article-numbers &optional group server _fetch-old) (deffoo nndiscourse-retrieve-headers (article-numbers &optional group server _fetch-old)
(with-current-buffer nntp-server-buffer (with-current-buffer nntp-server-buffer
(erase-buffer) (erase-buffer)
(nndiscourse--with-group server group (nndiscourse--with-group server group
(dolist (i article-numbers) (dolist (i article-numbers)
(when-let ((header (nndiscourse--make-header server group i))) (when-let ((header (nndiscourse--make-header server group i)))
(nnheader-insert-nov header))) (nnheader-insert-nov header)))
'nov))) 'nov)))
;; Primarily because `gnus-get-unread-articles' won't update unreads ;; Primarily because `gnus-get-unread-articles' won't update unreads
;; upon install (nndiscourse won't yet be in type-cache). ;; upon install (nndiscourse won't yet be in type-cache).
@ -899,9 +899,9 @@ article header. Gnus manual does say the term `header` is oft conflated."
"What happens when I click on discourse Subject." "What happens when I click on discourse Subject."
(-when-let* ((group-article gnus-article-current) (-when-let* ((group-article gnus-article-current)
(header (nndiscourse--get-header (header (nndiscourse--get-header
(nnoo-current-server 'nndiscourse) (nnoo-current-server 'nndiscourse)
(gnus-group-real-name (car group-article)) (gnus-group-real-name (car group-article))
(cdr group-article))) (cdr group-article)))
(url (format "%s://%s/t/%s/%s/%s" (url (format "%s://%s/t/%s/%s/%s"
nndiscourse-scheme nndiscourse-scheme
(nnoo-current-server 'nndiscourse) (nnoo-current-server 'nndiscourse)
@ -927,8 +927,8 @@ article header. Gnus manual does say the term `header` is oft conflated."
(defsubst nndiscourse--fallback-link () (defsubst nndiscourse--fallback-link ()
"Cannot render post." "Cannot render post."
(let* ((header (nndiscourse--get-header (nnoo-current-server 'nndiscourse) (let* ((header (nndiscourse--get-header (nnoo-current-server 'nndiscourse)
(gnus-group-real-name (car gnus-article-current)) (gnus-group-real-name (car gnus-article-current))
(cdr gnus-article-current))) (cdr gnus-article-current)))
(body (nndiscourse--massage (plist-get header :cooked)))) (body (nndiscourse--massage (plist-get header :cooked))))
(with-current-buffer gnus-original-article-buffer (with-current-buffer gnus-original-article-buffer
(article-goto-body) (article-goto-body)
@ -1110,75 +1110,75 @@ Written by John Wiegley (https://github.com/jwiegley/dot-emacs).")
"Override `mm-with-part' massaging message from HANDLE then executing FORMS." "Override `mm-with-part' massaging message from HANDLE then executing FORMS."
`(let* ((handle ,handle)) `(let* ((handle ,handle))
(when (and (mm-handle-buffer handle) (when (and (mm-handle-buffer handle)
(buffer-name (mm-handle-buffer handle))) (buffer-name (mm-handle-buffer handle)))
(with-temp-buffer (with-temp-buffer
(set-buffer-multibyte (buffer-local-value 'enable-multibyte-characters (set-buffer-multibyte (buffer-local-value 'enable-multibyte-characters
(mm-handle-buffer handle))) (mm-handle-buffer handle)))
(insert-buffer-substring (mm-handle-buffer handle)) (insert-buffer-substring (mm-handle-buffer handle))
(mm-decode-content-transfer-encoding (mm-decode-content-transfer-encoding
(mm-handle-encoding handle) (mm-handle-encoding handle)
(mm-handle-media-type handle)) (mm-handle-media-type handle))
,@forms)))) ,@forms))))
(defun nndiscourse-shr (handle) (defun nndiscourse-shr (handle)
"Override `mm-shr' for HANDLE." "Override `mm-shr' for HANDLE."
(require 'shr) (require 'shr)
(let ((shr-width (if shr-use-fonts (let ((shr-width (if shr-use-fonts
nil nil
fill-column)) fill-column))
(shr-content-function (lambda (id) (shr-content-function (lambda (id)
(let ((handle (mm-get-content-id id))) (let ((handle (mm-get-content-id id)))
(when handle (when handle
(nndiscourse-with-part handle (nndiscourse-with-part handle
(buffer-string)))))) (buffer-string))))))
(shr-inhibit-images mm-html-inhibit-images) (shr-inhibit-images mm-html-inhibit-images)
(shr-blocked-images mm-html-blocked-images) (shr-blocked-images mm-html-blocked-images)
charset coding char document) charset coding char document)
(nndiscourse-with-part (or handle (setq handle (mm-dissect-buffer t))) (nndiscourse-with-part (or handle (setq handle (mm-dissect-buffer t)))
(setq case-fold-search t) (setq case-fold-search t)
(or (setq charset (or (setq charset
(mail-content-type-get (mm-handle-type handle) 'charset)) (mail-content-type-get (mm-handle-type handle) 'charset))
(progn (progn
(goto-char (point-min)) (goto-char (point-min))
(and (re-search-forward "\ (and (re-search-forward "\
<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']?\ <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']?\
text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
(setq coding (mm-charset-to-coding-system (match-string 1) (setq coding (mm-charset-to-coding-system (match-string 1)
nil t)))) nil t))))
(setq charset mail-parse-charset)) (setq charset mail-parse-charset))
(when (and (or coding (when (and (or coding
(setq coding (mm-charset-to-coding-system charset nil t))) (setq coding (mm-charset-to-coding-system charset nil t)))
(not (eq coding 'ascii))) (not (eq coding 'ascii)))
(insert (prog1 (insert (prog1
(decode-coding-string (buffer-string) coding) (decode-coding-string (buffer-string) coding)
(erase-buffer) (erase-buffer)
(set-buffer-multibyte t)))) (set-buffer-multibyte t))))
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward (while (re-search-forward
"&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t)
(when (setq char (when (setq char
(cdr (assq (if (match-beginning 1) (cdr (assq (if (match-beginning 1)
(string-to-number (match-string 1) 16) (string-to-number (match-string 1) 16)
(string-to-number (match-string 2))) (string-to-number (match-string 2)))
mm-extra-numeric-entities))) mm-extra-numeric-entities)))
(replace-match (char-to-string char)))) (replace-match (char-to-string char))))
;; Remove "soft hyphens". ;; Remove "soft hyphens".
(goto-char (point-min)) (goto-char (point-min))
(while (search-forward "­" nil t) (while (search-forward "­" nil t)
(replace-match "" t t)) (replace-match "" t t))
(setq document (libxml-parse-html-region (point-min) (point-max)))) (setq document (libxml-parse-html-region (point-min) (point-max))))
(save-restriction (save-restriction
(narrow-to-region (point) (point)) (narrow-to-region (point) (point))
(shr-insert-document document) (shr-insert-document document)
(unless (bobp) (unless (bobp)
(insert "\n")) (insert "\n"))
(mm-handle-set-undisplayer (mm-handle-set-undisplayer
handle handle
(let ((min (point-min-marker)) (let ((min (point-min-marker))
(max (point-max-marker))) (max (point-max-marker)))
(lambda () (lambda ()
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(delete-region min max)))))))) (delete-region min max))))))))
(setf (alist-get 'shr mm-text-html-renderer-alist) 'nndiscourse-shr) (setf (alist-get 'shr mm-text-html-renderer-alist) 'nndiscourse-shr)