sbbs.el

Check-in [d3eb8c5431]
Login
Overview
Comment:Process recursive markup correctly
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | master | trunk
Files: files | file ages | folders
SHA3-256: d3eb8c5431942eb46b6b18267dc716c2379134715d82aa473a92f6f9b7acc2e7
User & Date: zge on 2021-05-28 11:56:22
Other Links: branch diff | manifest | tags
Context
2021-05-28
11:58
Add sbbs-open-at-last-post for compose buffers check-in: 651e7552b5 user: zge tags: master, trunk
11:56
Process recursive markup correctly check-in: d3eb8c5431 user: zge tags: master, trunk
10:53
Fix checkdoc complaints check-in: 6673da2ac4 user: zge tags: master, trunk
Changes

Modified sbbs.el from [8aac24173f] to [1d77173350].

266
267
268
269
270
271
272
273
274


275
276
277
278
279
280
281
266
267
268
269
270
271
272


273
274
275
276
277
278
279
280
281







-
-
+
+







        (sbbs--read-jump-to (apply #'min spec)))
      (let ((point (point)))
        (when sbbs-jump-to-link
          (forward-button 1)
          (when (invisible-p (point))
            (goto-char point)))))))

(defun sbbs--insert-link (text link)
  "Insert link to LINK as TEXT into buffer.
(defun sbbs--process-link (text link)
  "Process TEXT that refers to LINK.

If LINK is a (board, thread or site) local link, modify opening
behaviour accordingly."
  (save-match-data
    (let ((match (string-match sbbs--link-regexp link))
          range id other)
      (when match
300
301
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330














































331
332
333
334
335
336
337
300
301
302
303
304
305
306


307
308





















309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361







-
-
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







                              (sbbs-view-open id range)))
                           ;; other thread
                           ((/= id sbbs--thread-id)
                            (let ((sbbs--board board))
                              (sbbs-view-open id range)))
                           ;; this thread
                           (range (sbbs--limit-to-range range))))))
        (insert-button (propertize text  'face 'sbbs--variable-pitch)
                       'action func 'sbbs-ref range)))))
        (propertize text 'action func 'sbbs-ref range)))))

(defun sbbs--insert-sxml-par (sxml)
  "Insert paragraph contents SXML at point."
  (dolist (it sxml)
    (cond ((stringp it)
           (insert (propertize it 'face 'sbbs--variable-pitch)))
          ((eq (car it) 'br)
           (newline))
          ((eq (car it) 'b)
           (insert (propertize (cadr it) 'face '(bold sbbs--variable-pitch))))
          ((eq (car it) 'i)
           (insert (propertize (cadr it) 'face '(italic sbbs--variable-pitch))))
          ((eq (car it) 'code)
           (insert (propertize (cadr it) 'face 'fixed-pitch)))
          ((eq (car it) 'del)
           (insert (propertize (cadr it) 'face 'sbbs--spoiler-face)))
          ((eq (car it) 'a)
           (let* ((text (caddr it))
                  (link (plist-get (cadadr it) 'href)))
             (sbbs--insert-link text link)))
          (t (insert (prin1-to-string it)))))
  (insert ?\n))
(defun sbbs--process-sxml (sxml)
  "Process SXML into a formatted string."
  (message "%S" sxml)
  (let (processed)
    (dolist (it (if (listp sxml) sxml (list sxml)))
      (push (cond ((stringp it)
                   (propertize it 'face 'sbbs--variable-pitch))
                  ((eq (car it) 'br)
                   "\n")
                  ((eq (car it) 'b)
                   (propertize (sbbs--process-sxml (cdr it))
                               'face '(bold sbbs--variable-pitch)))
                  ((eq (car it) 'i)
                   (propertize (sbbs--process-sxml (cdr it))
                               'face '(italic sbbs--variable-pitch)))
                  ((eq (car it) 'code)
                   (propertize (sbbs--process-sxml (cdr it))
                               'face 'fixed-pitch))
                  ((eq (car it) 'del)
                   (propertize (sbbs--process-sxml (cdr it))
                               'face 'sbbs--spoiler-face))
                  ((eq (car it) 'a)
                   (let* ((text (sbbs--process-sxml (caddr it)))
                          (link (plist-get (cadadr it) 'href)))
                     (sbbs--process-link text link)))
                  (t (prin1-to-string it)))
            processed))
    (apply #'concat (nreverse processed))))

(defun sbbs--insert-sxml-par (sxml)
  "Insert paragraph contents SXML at point."
  (save-restriction
    (narrow-to-region (point) (point))
    (insert (sbbs--process-sxml sxml))
    (let (match)
      (goto-char (point-min))
      (while (setq match (text-property-search-forward 'action))
        ;; Buttons use overlays that cannot be passed in
        ;; strings. Therefore whenever a `activity' property was
        ;; inserted into the buffer, `make-button' has to be called
        ;; once more to add the actual overlay.
        (make-button (prop-match-beginning match)
                     (prop-match-end match)
                     'action (prop-match-value match)))
      (goto-char (point-max)))
    (newline)))

(defun sbbs--insert-sxml (sxml)
  "Insert top level SXML into buffer at point."
  (dolist (par sxml)
    (cond ((eq (car par) 'p)
           (sbbs--insert-sxml-par (cdr par)))
          ((eq (car par) 'blockquote)