Improved URL regex.

[lurk.git] / lurk.el

diff --git a/lurk.el b/lurk.el
index 1043775..05e7da3 100644 (file)
--- a/lurk.el
+++ b/lurk.el
@@ -1,4 +1,4 @@
-;;; lurk.el --- Little Uni-buffer iRc Klient -*- lexical-binding:t -*-
+;;; lurk.el --- Little Unibuffer iRc Klient -*- lexical-binding:t -*-
 
 ;; Copyright (C) 2021 Tim Vaughan
 
@@ -35,7 +35,7 @@
 ;;
 
 (defgroup lurk nil
-  "Little Uni-buffer iRc Klient."
+  "Little Unibuffer iRc Klient."
   :group 'network)
 
 (defcustom lurk-nick "plugd"
@@ -107,6 +107,19 @@
 (defvar lurk-debug nil
   "If non-nil, enable debug mode.")
 
+
+;;; Utility procedures
+;;
+
+(defun lurk--filtered-join (&rest args)
+  (string-join (seq-filter (lambda (el) el) args) " "))
+
+(defun lurk--as-string (obj)
+  (if obj
+      (with-output-to-string (princ obj))
+    nil))
+
+
 ;;; Network process
 ;;
 
@@ -182,11 +195,6 @@
 ;;; Server messages
 ;;
 
-(defun lurk--as-string (obj)
-  (if obj
-      (with-output-to-string (princ obj))
-    nil))
-
 (defun lurk-msg (tags src cmd &rest params)
   (list (lurk--as-string tags)
         (lurk--as-string src)
@@ -235,9 +243,6 @@ portion of the source component of the message, as LURK doesn't use this.")
         (apply #'lurk-msg (append (list tags src cmd) params)))
     (error "Failed to parse string " string)))
 
-(defun lurk--filtered-join (&rest args)
-  (string-join (seq-filter (lambda (el) el) args) " "))
-
 (defun lurk-msg->string (msg)
   (let ((tags (lurk-msg-tags msg))
         (src (lurk-msg-src msg))
@@ -368,22 +373,25 @@ portion of the source component of the message, as LURK doesn't use this.")
   "Marker for prompt position in LURK buffer.")
 
 (defun lurk-setup-header ()
-  (setq-local header-line-format
-              '(:eval
-                (let ((proc (get-process "lurk")))
-                  (if proc
-                      (concat
-                       "Host: " (car (process-contact proc))
-                       ", Context: "
-                       (if lurk-current-context
-                           (concat
-                            lurk-current-context
-                            " ("
-                            (number-to-string
-                             (length (lurk-get-context-users lurk-current-context)))
-                            " users)")
-                         "Server"))
-                    "No connection")))))
+  (with-current-buffer "*lurk*"
+    (setq-local header-line-format
+                '((:eval
+                   (let ((proc (get-process "lurk")))
+                     (if proc
+                         (concat
+                          "Host: " (car (process-contact proc))
+                          ", Context: "
+                          (if lurk-current-context
+                              (concat
+                               lurk-current-context
+                               " ("
+                               (number-to-string
+                                (length (lurk-get-context-users lurk-current-context)))
+                               " users)")
+                            "Server"))
+                       "No connection")))
+                  (:eval
+                   (if lurk-zoomed " [ZOOMED]" ""))))))
 
 (defun lurk-setup-buffer ()
   (with-current-buffer (get-buffer-create "*lurk*")
@@ -404,11 +412,11 @@ portion of the source component of the message, as LURK doesn't use this.")
 ;;; Output formatting and highlighting
 ;;
 
-;; Partially-implemented idea: the face text property can be
-;; a list of faces, applied in order.  By assigning each context
-;; a unique list and keeping track of these in a hash table, we can
-;; easily switch the face corresponding to a particular context
-;; by modifying the elements of this list.
+;; Idea: the face text property can be a list of faces, applied in
+;; order.  By assigning each context a unique list and keeping track
+;; of these in a hash table, we can easily switch the face
+;; corresponding to a particular context by modifying the elements of
+;; this list.
 ;;
 ;; More subtly, we make only the cdrs of this list shared among
 ;; all text of a given context, allowing the cars to be different
@@ -460,11 +468,12 @@ portion of the source component of the message, as LURK doesn't use this.")
                       'read-only t
                       'context context
                       'invisible context-atom)
-          (propertize (concat (lurk-buttonify-urls (apply #'concat strings)) "\n")
-                      'face (lurk-get-context-facelist context)
-                      'read-only t
-                      'context context
-                      'invisible context-atom)))))))
+          (lurk-add-formatting
+           (propertize (concat (apply #'lurk-buttonify-urls strings) "\n")
+                       'face (lurk-get-context-facelist context)
+                       'read-only t
+                       'context context
+                       'invisible context-atom))))))))
 
 (defun lurk-display-message (from to text)
   (let ((context (if (eq 'channel (lurk-get-context-type to))
@@ -543,17 +552,17 @@ portion of the source component of the message, as LURK doesn't use this.")
        (opt (group (: ":" (+ digit))))
        (opt (group (: "/"
                       (opt
-                       (* (any alnum "-/.,#:%=&_"))
-                       (any alnum "-/#:%=&_")))))))
+                       (* (any alnum "-/.,#:%=&_?~@+"))
+                       (any alnum "-/#:%=&_~@+")))))))
   "Imperfect regex used to find URLs in plain text.")
 
 (defun lurk-click-url (button)
   (browse-url (button-get button 'url)))
 
-(defun lurk-buttonify-urls (string)
+(defun lurk-buttonify-urls (&rest strings)
   "Turn substrings which look like urls in STRING into clickable buttons."
   (with-temp-buffer
-    (insert string)
+    (apply #'insert strings)
     (goto-char (point-min))
     (while (re-search-forward lurk-url-regex nil t)
       (let ((url (match-string 0)))
@@ -566,6 +575,34 @@ portion of the source component of the message, as LURK doesn't use this.")
                           'help-echo "Open URL in browser.")))
     (buffer-string)))
 
+(defun lurk-add-formatting (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (let ((bold nil)
+          (italics nil)
+          (underline nil)
+          (strikethrough nil)
+          (prev-point (point)))
+      (while (re-search-forward (rx (any "\x02\x1D\x1F\x1E")) nil t)
+        (let ((beg (+ (match-beginning 0) 1)))
+          (if bold
+              (add-face-text-property prev-point beg '(:weight bold)))
+          (if italics
+              (add-face-text-property prev-point beg '(:slant italic)))
+          (if underline
+              (add-face-text-property prev-point beg '(:underline t)))
+          (if strikethrough
+              (add-face-text-property prev-point beg '(:strike-through t)))
+          (pcase (match-string 0)
+            ("\x02" (setq bold (not bold)))
+            ("\x1D" (setq italics (not italics)))
+            ("\x1F" (setq underline (not underline)))
+            ("\x1E" (setq strikethrough (not strikethrough))))
+          (delete-region (match-beginning 0) (match-end 0))
+          (setq prev-point (point)))))
+    (buffer-string)))
+
 
 ;;; Message evaluation
 ;;