X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lurk.el;h=fb8389225e6b26d4157f1c5d7adff5f24a088864;hb=f0d495cfd2f7b7bb1fb7743aa8b3996111a5b922;hp=82a43f2c043324d21c094812d1d410197a12ee51;hpb=b0fd29a0bc378d473ede724d8226ac988c3d5627;p=lurk.git diff --git a/lurk.el b/lurk.el index 82a43f2..fb83892 100644 --- a/lurk.el +++ b/lurk.el @@ -40,20 +40,24 @@ (defcustom lurk-nick "plugd" "Default nick.") -(defcustom lurk-full-name "plugd" - "Default full name.") -(defcustom lurk-user-name "plugd" - "Default user name.") + +(defcustom lurk-default-quit-msg "Bye" + "Default quit message when none supplied.") (defcustom lurk-networks '(("libera" "irc.libera.chat" 6697) ("freenode" "chat.freenode.net" 6697) + ("tilde" "tilde.chat" 6697) + ("mbr" "mbrserver.com" 6667 :notls) ("local" "localhost" 6697)) "IRC networks.") (defcustom lurk-allow-ipv6 nil "Set to non-nil to allow use of IPv6.") +(defcustom lurk-show-joins nil + "Set to non-nil to be notified of joins, parts and quits.") + ;;; Faces ;; @@ -102,7 +106,6 @@ (defvar lurk-error-prefix (propertize "!!!" 'face 'lurk-error)) - (defvar lurk-prompt-string (propertize "> " 'face 'lurk-prompt)) @@ -161,10 +164,13 @@ (clrhash lurk-contexts) (setq lurk-current-context nil) (lurk-start-process network) - (lurk-send-msg (lurk-msg nil nil "USER" lurk-user-name 0 "*" lurk-full-name)) + (lurk-send-msg (lurk-msg nil nil "USER" lurk-nick 0 "*" lurk-nick)) (lurk-send-msg (lurk-msg nil nil "NICK" lurk-nick)) (setq lurk-ping-timer (run-with-timer lurk-ping-period nil #'lurk-ping-function))))) +(defun lurk-connected-p () + (let ((proc (get-process "lurk"))) + (and proc (eq (process-status proc) 'open)))) (defun lurk-send-msg (msg) (let ((proc (get-process "lurk"))) @@ -280,6 +286,11 @@ portion of the source component of the message, as LURK doesn't use this.") (dolist (context (lurk-get-context-list)) (lurk-del-context-user context user))) +(defun lurk-rename-user (old-nick new-nick) + (dolist (context (lurk-get-context-list)) + (lurk-del-context-user context old-nick) + (lurk-add-context-users context (list new-nick)))) + (defun lurk-get-context-type (name) (cond ((string-prefix-p "#" name) 'channel) @@ -322,22 +333,6 @@ portion of the source component of the message, as LURK doesn't use this.") ;;; Buffer ;; - -(defun lurk-display-string (&rest strings) - (with-current-buffer (get-buffer-create "*lurk*") - (save-excursion - (goto-char lurk-prompt-marker) - (let ((inhibit-read-only t) - (old-pos (marker-position lurk-prompt-marker)) - (adaptive-fill-regexp (rx (= 6 anychar)))) - (insert-before-markers - (propertize (concat (format-time-string "%H:%M") " ") - 'face 'lurk-text - 'read-only t) - (propertize (concat (apply #'concat strings) "\n") - 'read-only t)) - (fill-region old-pos lurk-prompt-marker))))) - (defun lurk-render-prompt () (with-current-buffer "*lurk*" (let ((update-point (= lurk-input-marker (point))) @@ -390,8 +385,47 @@ portion of the source component of the message, as LURK doesn't use this.") ;;; Output formatting ;; +;; 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. +;; +;; More subtly, we make only the cdrs of this list shared among +;; all text of a given context, allowing the cars to be different +;; and for different elements of the context-specific text to have +;; different styling. + +(defvar lurk-context-facelists (make-hash-table :test 'equal) + "List of seen contexts and associated face lists.") + +(defun lurk-get-context-facelist (context) + (let ((facelist (gethash context lurk-context-facelists))) + (unless facelist + (setq facelist (list 'lurk-text)) + (puthash context facelist lurk-context-facelists)) + facelist)) + +(defun lurk-display-string (&rest strings) + (with-current-buffer (get-buffer-create "*lurk*") + (save-excursion + (goto-char lurk-prompt-marker) + (let ((inhibit-read-only t) + (old-pos (marker-position lurk-prompt-marker)) + (adaptive-fill-regexp (rx (= 6 anychar))) + (fill-column 80)) + (insert-before-markers + (propertize (concat (format-time-string "%H:%M") " ") + 'face 'lurk-text + 'read-only t) + (propertize (concat (apply #'concat strings) "\n") + 'read-only t)) + (fill-region old-pos lurk-prompt-marker nil t))))) + (defun lurk-display-message (from to text) - (let ((context (if (equal from lirc-nick) to from))) + (let ((context (if (eq 'channel (lurk-get-context-type to)) + to + (if (equal to lurk-nick) from to)))) (lurk-display-string (propertize (pcase (lurk-get-context-type to) @@ -399,14 +433,16 @@ portion of the source component of the message, as LURK doesn't use this.") ('nick (concat "[" from " -> " to "] " text)) (_ (error "Unsupported context type"))) - 'face 'lurk-text - 'help-echo (concat "Context: " to))))) + 'face (lurk-get-context-facelist context) + 'help-echo (concat "Context: " context) + 'context context)))) (defun lurk-display-notice (context &rest notices) (lurk-display-string (propertize (concat lurk-notice-prefix " " (apply #'concat notices)) - 'help-echo (concat "Context: " (or context "none"))))) + 'help-echo (concat "Context: " (or context "none")) + 'context context))) (defun lurk-display-error (&rest messages) (lurk-display-string @@ -414,12 +450,32 @@ portion of the source component of the message, as LURK doesn't use this.") (propertize (apply #'concat messages) 'face 'lurk-error)))) +(defun lurk-highlight-context (context) + (with-current-buffer "*lurk*" + (let* ((pos lurk-prompt-marker) + (nextpos (previous-single-property-change pos 'context)) + (inhibit-read-only t)) + (while (> pos nextpos) + (let ((thiscontext (get-text-property nextpos 'context))) + (if thiscontext + (if (equal context thiscontext) + (add-text-properties nextpos pos + '(face (foreground-color . "green"))) + (add-text-properties nextpos pos + '(face (foreground-color . "blue")))) + (add-text-properties nextpos pos + '(face lurk-text))) + thiscontext + (setq pos nextpos) + (setq nextpos (previous-single-property-change pos 'context nil 1))))))) + ;;; Message evaluation ;; (defun lurk-eval-msg-string (string) ;; (lurk-display-string string) (let* ((msg (lurk-string->msg string))) + ;; (message (pp msg)) (pcase (lurk-msg-cmd msg) ("PING" (lurk-send-msg @@ -429,6 +485,13 @@ portion of the source component of the message, as LURK doesn't use this.") ("PONG") ;; (lurk-display-notice nil "ping-pong (client initiated)")) + ("001" + (let* ((params (lurk-msg-params msg)) + (nick (elt params 0)) + (text (string-join (seq-drop params 1) " "))) + (setq lurk-nick nick) + (lurk-display-notice nil text))) + ("353" ; NAMEREPLY (let* ((params (lurk-msg-params msg)) (channel (elt params 2)) @@ -436,9 +499,12 @@ portion of the source component of the message, as LURK doesn't use this.") (lurk-add-context-users channel names))) ("366" ; ENDOFNAMES - (lurk-display-notice nil - (lurk--as-string (length (lurk-get-context-users lurk-current-context))) - " users in " lurk-current-context)) + (let* ((params (lurk-msg-params msg)) + (channel (elt params 1))) + (lurk-display-notice + channel + (lurk--as-string (length (lurk-get-context-users channel))) + " users in " channel))) ((rx (= 3 (any digit))) (lurk-display-notice nil (mapconcat 'identity (cdr (lurk-msg-params msg)) " "))) @@ -448,14 +514,15 @@ portion of the source component of the message, as LURK doesn't use this.") (let ((channel (car (lurk-msg-params msg)))) (lurk-add-context channel) (setq lurk-current-context channel) - (lurk-display-notice nil "Joining channel " channel) + (lurk-display-notice channel "Joining channel " channel) (lurk-render-prompt))) ("JOIN" (let ((channel (car (lurk-msg-params msg))) (nick (lurk-msg-src msg))) (lurk-add-context-users channel (list nick)) - (lurk-display-notice channel nick " joined channel " channel))) + (if lurk-show-joins + (lurk-display-notice channel nick " joined channel " channel)))) ((and "PART" (guard (equal lurk-nick (lurk-msg-src msg)))) @@ -470,13 +537,15 @@ portion of the source component of the message, as LURK doesn't use this.") (let ((channel (car (lurk-msg-params msg))) (nick (lurk-msg-src msg))) (lurk-del-context-user channel nick) - (lurk-display-notice channel nick " left channel " channel))) + (if lurk-show-joins + (lurk-display-notice channel nick " left channel " channel)))) ("QUIT" (let ((nick (lurk-msg-src msg)) (reason (mapconcat 'identity (lurk-msg-params msg) " "))) (lurk-del-user nick) - (lurk-display-notice nil nick " quit: " reason))) + (if lurk-show-joins + (lurk-display-notice nil nick " quit: " reason)))) ((and "NICK" (guard (equal lurk-nick (lurk-msg-src msg)))) @@ -486,8 +555,8 @@ portion of the source component of the message, as LURK doesn't use this.") ("NICK" (let ((old-nick (lurk-msg-src msg)) (new-nick (car (lurk-msg-params msg)))) - (lurk-display-notice nil nick " is now known as " new-nick) - (lurk-rename-user nick new-nick))) + (lurk-display-notice nil old-nick " is now known as " new-nick) + (lurk-rename-user old-nick new-nick))) ("NOTICE" (let ((nick (lurk-msg-src msg)) @@ -525,7 +594,7 @@ portion of the source component of the message, as LURK doesn't use this.") (_ (lurk-display-message from to text))))) (_ - (lurk-display-string (lurk-msg->string msg)))))) + (lurk-display-notice nil (lurk-msg->string msg)))))) ;;; Command entering @@ -547,7 +616,7 @@ portion of the source component of the message, as LURK doesn't use this.") (concat "\01ACTION " action "\01")))) (lurk-display-action lurk-nick action)) - ((rx (: "VERSION" " " (let nick (* (not whitespace))))) + ((rx (: "VERSION" " " (let nick (+ (not whitespace))))) (lurk-send-msg (lurk-msg nil nil "PRIVMSG" (list nick "\01VERSION\01"))) (lurk-display-notice nil "CTCP version request sent to " nick)) @@ -559,6 +628,19 @@ portion of the source component of the message, as LURK doesn't use this.") lurk-current-context))) (lurk-display-error "No current channel to leave."))) + ((rx "QUIT" (opt (: " " (let quit-msg (* not-newline))))) + (lurk-send-msg (lurk-msg nil nil "QUIT" + (or quit-msg lurk-default-quit-msg)))) + + ((rx (: "NICK" (* whitespace) string-end)) + (lurk-display-notice nil "Current nick: " lurk-nick)) + + ((rx (: "NICK" (+ whitespace) (let nick (+ (not whitespace))))) + (if (lurk-connected-p) + (lurk-send-msg (lurk-msg nil nil "NICK" nick)) + (setq lurk-nick nick) + (lurk-display-notice nil "Set default nick to '" nick "'"))) + ((rx "MSG " (let to (* (not whitespace))) " " @@ -586,10 +668,10 @@ portion of the source component of the message, as LURK doesn't use this.") "Enter current contents of line after prompt." (interactive) (with-current-buffer "*lurk*" - (lurk-enter-string - (buffer-substring lurk-input-marker (point-max))) - (let ((inhibit-read-only t)) - (delete-region lurk-input-marker (point-max))))) + (let ((line (buffer-substring lurk-input-marker (point-max)))) + (let ((inhibit-read-only t)) + (delete-region lurk-input-marker (point-max))) + (lurk-enter-string line)))) ;;; Mode