Overview
| Comment: | reworked link handling |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | master | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
9ba1b42fbc4dac2f762a881fbbf550d9 |
| User & Date: | philip@warpmail.net on 2020-03-07 20:02:43 |
| Other Links: | branch diff | manifest | tags |
Context
|
2020-03-07
| ||
| 20:52 | Add sbbs-recenter-to-top variable check-in: 0376b0426c user: philip@warpmail.net tags: master, trunk | |
| 20:02 | reworked link handling check-in: 9ba1b42fbc user: philip@warpmail.net tags: master, trunk | |
|
2020-02-29
| ||
| 09:52 | interpret server responses as utf-8 check-in: b95de752f7 user: philip@warpmail.net tags: master, trunk | |
Changes
Modified sbbs.el from [54b681e7c1] to [7633d1775c].
22 22 23 23 ;;; Code: 24 24 25 25 (require 'tabulated-list) 26 26 (require 'button) 27 27 (require 'url) 28 28 (require 'hl-line) 29 +(require 'rx) 29 30 30 31 ;; CUSTOMIZABLE DATA 31 32 32 33 (defgroup sbbs nil 33 34 "SchemeBBS client." 34 35 :group 'applications 35 36 :prefix "sbbs-") ................................................................................ 36 37 37 38 (defcustom sbbs-boards 38 39 '(("textboard.org" ("sol" "prog") nil)) 39 40 "List of SchemeBBS sites and boards." 40 41 :type '(repeat (list (string :tag "Board Domain") 41 42 (repeat (string :tag "Board Name")) 42 43 (boolean :tag "Use TLS?")))) 44 + 45 +(defcustom sbbs-jump-to-link t 46 + "Jump to first link after narrowing posts." 47 + :type 'boolean) 43 48 44 49 (defface sbbs--spoiler-face 45 50 '((((background light)) :background "black" :foreground "black") 46 51 (((background dark)) :background "white" :foreground "white")) 47 52 "Face for spoiler text in threads.") 48 53 49 54 (defface sbbs--code-face ................................................................................ 58 63 59 64 See `sbbs-make-board'.") 60 65 61 66 (defvar-local sbbs--thread-id nil 62 67 "Buffer local reference to current thread id. 63 68 64 69 Used in thread and reply buffers.") 70 + 71 +(defvar-local sbbs--limit-stack nil 72 + "Stack of last limit specs.") 65 73 66 74 ;; BOARD OBJECT AND FUNCTIONS 67 75 68 76 (defun sbbs-make-board (domain name &optional tls) 69 77 "Create board object, using DOMAIN, NAME and TLS flag." 70 78 (vector domain name tls)) 71 79 ................................................................................ 88 96 (let ((board (or board sbbs--board))) 89 97 (format "%s://%s/%s%s/%s" 90 98 (sbbs--board-protocol board) 91 99 (sbbs--board-domain board) 92 100 (if api-p "sexp/" "") 93 101 (sbbs--board-name board) 94 102 (or path "")))) 103 + 104 +(defun sbbs--list-boards () 105 + (let (boards) 106 + (dolist (ent sbbs-boards) 107 + (dolist (board (cadr ent)) 108 + (push (sbbs-make-board (car ent) board (caddr ent)) 109 + boards))) 110 + boards)) 95 111 96 112 (defun sbbs-read-board () 97 113 "Read in a board using `completing-read'. 98 114 99 115 The list will be generated using `sbbs-boards', and the result 100 116 will be a board object generated with `sbbs-make-board'." 101 117 (let (boards) 102 - (dolist (ent sbbs-boards) 103 - (dolist (board (cadr ent)) 104 - (push (cons (format "/%s/ (%s)" board (car ent)) 105 - (sbbs-make-board (car ent) board (caddr ent))) 106 - boards))) 118 + (dolist (b (sbbs--list-boards)) 119 + (push (cons (format "/%s/ (%s)" 120 + (sbbs--board-name b) 121 + (sbbs--board-domain b)) 122 + b) 123 + boards)) 107 124 (cdr (assoc (completing-read "Board: " boards nil t) boards)))) 108 125 109 126 ;; UTILITY FUNCTIONS 110 127 111 128 (defun sbbs--reload-thread (&optional _ignore-auto _noconfirm) 112 129 "Function to reload an opened thread." 113 130 (when sbbs--thread-id (sbbs-view-open sbbs--thread-id))) ................................................................................ 114 131 115 132 (defun sbbs--reload-board () 116 133 "Function to regenerate thread index. 117 134 118 135 Called by `tabulated-list-mode' hooks." 119 136 (when sbbs--board (sbbs-browse sbbs--board t))) 120 137 138 +(defun sbbs--parse-number-range (desc limit) 139 + "Generate list of numbers, as specified by DESC. 140 + 141 +To avoid memory overflows, limit number of entries to LIMIT." 142 + (save-match-data 143 + (apply #'nconc 144 + (mapcar 145 + (lambda (range) 146 + (cond ((string-match "\\`\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\'" range) 147 + (number-sequence (string-to-number (match-string 1 range)) 148 + (min limit (string-to-number (match-string 2 range))))) 149 + ((string-match "\\`\\([[:digit:]]+\\)\\'" range) 150 + (list (string-to-number (match-string 1 range)))) 151 + (t (error "invalid range")))) 152 + (split-string desc ","))))) 153 + 154 +(defun sbbs--read-jump-to (nr) 155 + "Set point to first character of post with number NR." 156 + (let ((up (point-min)) (down (point-max)) current) 157 + (while (progn 158 + (goto-char (+ up (/ (- down up) 2))) 159 + (setq current (get-text-property (point) 'sbbs-thread-nr)) 160 + (/= nr current)) 161 + (cond ((< nr current) (setq down (point))) 162 + ((> nr current) (setq up (point)))))) 163 + (unless (and (eq 'highlight (get-text-property (point) 'face)) 164 + (looking-at-p "\\`#[[:digit:]]+")) 165 + ;; in case we are on the first character of a post, we shouldn't 166 + ;; jump back, since that would mean setting to point to NR-1. 167 + (sbbs-read-previous 1))) 168 + 121 169 ;; UI GENERATOR 122 170 171 +(defconst sbbs--link-regexp 172 + (rx-to-string 173 + `(: bos 174 + (or (: "/" (group-n 2 (+ alnum)) 175 + "/" (group-n 3 (+ digit)) 176 + "/" (group-n 4 (: (+ digit) (? "-" (+ digit))) 177 + (* "," (+ digit) (? "-" (+ digit))))) 178 + (: "http" (? "s") "://" 179 + (group-n 1 (or ,@(mapcar #'sbbs--board-domain 180 + (sbbs--list-boards)))) 181 + "/" (group-n 2 (+ alnum)) 182 + "/" (group-n 3 (+ digit)) 183 + (? "#t" (backref 3) 184 + "p" (group-n 4 (+ digit))))) 185 + eos)) 186 + "Regular expression to destruct internal links.") 187 + 188 +(defun sbbs--limit-to-range (spec &optional no-push-p) 189 + "Hide all posts in the current thread, that aren't in SPEC. 190 + 191 +Unless NO-PUSH-P is non-nil, SPEC will be pushed onto 192 +`sbbs--limit-stack', as to be popped off again by 193 +`sbbs-show-pop'." 194 + (let ((inhibit-read-only t)) 195 + (remove-list-of-text-properties 196 + (point-min) (point-max) '(invisible intangible)) 197 + (when spec 198 + (unless no-push-p 199 + (push (cons (point) spec) sbbs--limit-stack)) 200 + (save-excursion 201 + (let ((last (point-max))) 202 + (goto-char last) 203 + (while (not (bobp)) 204 + (sbbs-read-previous 1) 205 + (unless (memq (get-text-property (point) 'sbbs-thread-nr) 206 + spec) 207 + (add-text-properties 208 + (point) last '(invisible t intangible t))) 209 + (setq last (point))))) 210 + (goto-char (point-min)) 211 + (when spec 212 + (sbbs--read-jump-to (car spec))) 213 + (let ((point (point))) 214 + (when sbbs-jump-to-link 215 + (forward-button 1) 216 + (when (invisible-p (point)) 217 + (goto-char point))))))) 218 + 123 219 (defun sbbs--insert-link (text link) 124 220 "Insert link to LINK as TEXT into buffer. 125 221 126 222 If LINK is a (board, thread or site) local link, modify opening 127 223 behaviour accordingly." 128 - (let ((domain (sbbs--board-domain sbbs--board)) 129 - (name (sbbs--board-name sbbs--board)) 130 - (id sbbs--thread-id) 131 - (local-re "\\`/%s/%d/\\([[:digit:]]+\\)") 132 - (thread-re "\\`/%s/\\([[:digit:]]+\\)") 133 - (board-re "\\`http\\(s?\\)://\\([-._[:alnum:]]+\\)/sexp/\\([[:alnum:]]+\\)/\\([[:digit:]]+\\)")) 134 - (save-match-data 135 - (cond ((string-match (format local-re name id) link) 136 - (insert-button 137 - text 138 - 'action (lambda (x) 139 - (goto-char (point-min)) 140 - (sbbs-read-next (1- (button-get x 'sbbs-post-id)))) 141 - 'sbbs-post-id (string-to-number (match-string 1 link)))) 142 - ((string-match (format thread-re name id) link) 143 - (insert-button 144 - text 145 - 'action (lambda (x) 146 - (sbbs-view-open (button-get x 'sbbs-link-id))) 147 - 'sbbs-link-id (string-to-number (match-string 1 link)))) 148 - ((string-match (format board-re domain name) link) 149 - (insert-button 150 - text 151 - 'action (lambda (x) 152 - (let ((sbbs--board (button-get x 'sbbs-board))) 153 - (sbbs-view-open (button-get x 'sbbs-link-id)))) 154 - 'sbbs-board (sbbs-make-board (match-string 2 link) 155 - (match-string 3 link) 156 - (string= (match-string 1 link) "s")) 157 - 'sbbs-link-id (string-to-number (match-string 3 link)))) 158 - (t (insert-button 159 - text 160 - 'action (lambda (x) (browse-url (button-get x 'url))) 161 - 'url link)))))) 224 + (save-match-data 225 + (let ((match (string-match sbbs--link-regexp link)) 226 + range id) 227 + (when match 228 + (when (match-string 4 link) 229 + (setq range (sbbs--parse-number-range (match-string 4 link) 300))) 230 + (setq id (string-to-number (match-string 3 link)))) 231 + (let* ((board sbbs--board) 232 + (domain (sbbs--board-domain board)) 233 + (name (sbbs--board-name board)) 234 + (other (sbbs-make-board (match-string 1 link) 235 + (match-string 2 link) 236 + (string-match-p "\\`https://" link))) 237 + (func (lambda (&optional _) 238 + (cond ((not match) (browse-url link)) 239 + ;; other supported board 240 + ((or (and (sbbs--board-domain other) 241 + (not (string= (sbbs--board-domain other) 242 + domain))) 243 + (not (string= name (sbbs--board-name other)))) 244 + (let ((sbbs--board other)) 245 + (sbbs-view-open id range))) 246 + ;; other thread 247 + ((/= id sbbs--thread-id) 248 + (let ((sbbs--board board)) 249 + (sbbs-view-open id range))) 250 + ;; this thread 251 + (range (sbbs--limit-to-range range)))))) 252 + (insert-button text 'action func))))) 162 253 163 254 (defun sbbs--insert-sxml-par (sxml) 164 255 "Insert paragraph contents SXML at point." 165 256 (dolist (it sxml) 166 257 (cond ((stringp it) 167 258 (insert (propertize it 'face 'variable-pitch))) 168 259 ((eq (car it) 'br) ................................................................................ 223 314 224 315 Load results into buffer BUF. STATUS is used to check for 225 316 errors." 226 317 (when (buffer-live-p buf) 227 318 (when (plist-get status :error) 228 319 (error "Error while loading: %s" 229 320 (cdr (plist-get status :error)))) 230 - (forward-paragraph) 231 321 (decode-coding-region (point-min) (point-max) 'utf-8) 322 + (forward-paragraph) 232 323 (let ((list (read (current-buffer)))) 233 324 (kill-buffer) 234 325 (with-current-buffer buf 235 326 (let (ent) 236 327 (dolist (thread list) 237 328 (push (list (car thread) 238 329 (vector (substring (cdr (assq 'date (cdr thread))) ................................................................................ 243 334 (cdr (assq 'headline (cdr thread))) 244 335 'face 'variable-pitch))) 245 336 ent)) 246 337 (setq-local tabulated-list-entries ent) 247 338 (tabulated-list-print t t) 248 339 (hl-line-highlight)))))) 249 340 250 -(defun sbbs--thread-loader (status id buf) 341 +(defun sbbs--thread-loader (status id buf range) 251 342 "Callback function for `url-retrieve' when loading thread. 252 343 253 344 The attribute ID determines what thread from board BOARD to 254 345 load. STATUS is used to check for errors." 255 346 (when (buffer-live-p buf) 256 347 (when (plist-get status :error) 257 348 (error "Error while loading: %s" ................................................................................ 276 367 (erase-buffer) 277 368 (setq header-line-format 278 369 (format "Thread %d: %s" id 279 370 (cdr (assq 'headline thread)))) 280 371 (dolist (post (cadr (assq 'posts thread))) 281 372 (sbbs--thread-insert-post post)) 282 373 (delete-blank-lines) 374 + (when range 375 + (sbbs--limit-to-range range)) 283 376 (goto-char (point-min))))))) 284 377 285 378 ;; INTERACTIVE FUNCTIONS 286 379 287 -(defun sbbs-view-open (id) 380 +(defun sbbs-show-all () 381 + "Show all hidden posts." 382 + (interactive) 383 + (sbbs-show-pop -1)) 384 + 385 +(defun sbbs-show-pop (&optional n) 386 + "Show all hidden posts. 387 + 388 +A prefix argument N, repeats this N times. If negative or zero, 389 +pop all the way up." 390 + (interactive "P") 391 + (let ((n (or n 1))) 392 + (dotimes (_ (if (> n 0) n (length sbbs--limit-stack))) 393 + (let ((point (car (pop sbbs--limit-stack)))) 394 + (sbbs--limit-to-range (cdar sbbs--limit-stack) t) 395 + (when point (goto-char point)))))) 396 + 397 +(defun sbbs-view-open (id &optional range) 288 398 "Open thread ID in new buffer." 289 399 (interactive (list (tabulated-list-get-id))) 290 400 (let ((url (sbbs--board-url (format "/%d" id) t)) 291 401 (headline (or (and (not (tabulated-list-get-entry)) 292 402 header-line-format) 293 403 (substring-no-properties 294 404 (aref (tabulated-list-get-entry) 2)))) ................................................................................ 299 409 id)))) 300 410 (with-current-buffer buf 301 411 (sbbs-read-mode) 302 412 (when headline 303 413 (setq header-line-format (format "Thread %d: %s" id headline))) 304 414 (setq sbbs--board board 305 415 sbbs--thread-id id)) 306 - (url-retrieve url #'sbbs--thread-loader (list id buf)) 416 + (url-retrieve url #'sbbs--thread-loader (list id buf range)) 307 417 (switch-to-buffer buf))) 308 418 309 419 (defun sbbs-view-compose () 310 420 "Create buffer to start a new thread." 311 421 (interactive) 312 422 (let ((board sbbs--board)) 313 423 (with-current-buffer (generate-new-buffer "*new thread*") ................................................................................ 363 473 (defun sbbs-read-next (arg) 364 474 "Move point ARG posts forward." 365 475 (interactive "p") 366 476 (dotimes (_ arg) 367 477 (end-of-line) 368 478 (catch 'found 369 479 (while (search-forward-regexp "^#" nil t) 370 - (when (eq 'highlight (get-text-property (point) 'face)) 480 + (when (and (eq 'highlight (get-text-property (point) 'face)) 481 + (not (get-text-property (point) 'invisible))) 371 482 (throw 'found t))))) 372 483 (beginning-of-line)) 373 484 374 485 (defun sbbs-read-previous (arg) 375 486 "Move point ARG posts backwards." 376 487 (interactive "p") 377 488 (dotimes (_ arg) 378 489 (catch 'found 379 490 (while (search-backward-regexp "^#" nil t) 380 - (when (eq 'highlight (get-text-property (point) 'face)) 491 + (when (and (eq 'highlight (get-text-property (point) 'face)) 492 + (not (get-text-property (point) 'invisible))) 381 493 (throw 'found t))))) 382 494 (beginning-of-line)) 383 495 384 496 ;;;###autoload 385 497 (defun sbbs-browse (board reload) 386 498 "Open thread overview for BOARD." 387 499 (interactive (list (sbbs-read-board) nil)) ................................................................................ 426 538 (let ((map (make-sparse-keymap))) 427 539 (suppress-keymap map) 428 540 (define-key map (kbd "<tab>") #'forward-button) 429 541 (define-key map (kbd "<backtab>") #'backward-button) 430 542 (define-key map (kbd "r") #'sbbs-read-reply) 431 543 (define-key map (kbd "n") #'sbbs-read-next) 432 544 (define-key map (kbd "p") #'sbbs-read-previous) 545 + (define-key map (kbd "a") #'sbbs-show-pop) 546 + (define-key map (kbd "A") #'sbbs-show-all) 433 547 map)) 434 548 435 549 (define-derived-mode sbbs-read-mode special-mode "SchemeBBS Read" 436 550 "Major mode for reading a thread." 437 551 (buffer-disable-undo) 438 552 (visual-line-mode t) 439 553 (setq-local revert-buffer-function #'sbbs--reload-thread))