X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=murk.el;h=0766b7d020a9c81ee4e2ea6d0ed6f0863c89cbe4;hb=2d5b239d6b1b43beec02e7b0b2612772e2d1e316;hp=1903a33d171e1d7aeed639efee25a8720e636a04;hpb=050c1fe2eeffe1d815c5c84db4e783711b3298ee;p=lurk.git diff --git a/murk.el b/murk.el index 1903a33..0766b7d 100644 --- a/murk.el +++ b/murk.el @@ -53,7 +53,9 @@ '(("debug" "localhost" 6697) ("libera" "irc.libera.chat" 6697) ("tilde" "tilde.chat" 6697) - ("freenode" "chat.freenode.net" 6697)) + ("sdf" "irc.sdf.org" 6697) + ("freenode" "chat.freenode.net" 6697) + ("mbr" "mbrserver.com" 6667 :notls)) "IRC networks." :type '(alist :key-type string)) @@ -64,6 +66,24 @@ "If non-nil, use buffer header to display current host and channel." :type '(boolean)) +(defcustom murk-autoreply-table nil + "Table of autoreply messages. + +Each autoreply is a list of two elements: (matcher reply) + +Here matcher is a list: + +(network src cmd params ...) + +and reply is another list: + + (cmd params ...) + +Each entry in the matcher list is a regular expression tested against the +corresponding values in the incomming message. Entries can be nil, +in which case they match anything." + :type '(list (list) (list))) + ;;; Faces ;; @@ -168,6 +188,7 @@ This includes the process and the response string.") (murk-display-error "Disconnected from server.") (murk-connection-remove server) (murk-remove-server-contexts server) + (murk-highlight-current-context) (murk-render-prompt)))) (defun murk-start-process (server) @@ -204,6 +225,7 @@ This includes the process and the response string.") (murk-send-msg server (murk-msg nil nil "USER" murk-default-nick 0 "*" murk-default-nick)) (murk-send-msg server (murk-msg nil nil "NICK" murk-default-nick)) (murk-add-context (list server)) + (murk-highlight-current-context) (murk-render-prompt)))) (defun murk-send-msg (server msg) @@ -312,12 +334,20 @@ The head of this list is always the current context.") (equal (seq-take c1 2) (seq-take c2 2))))) -(defun murk-context-server (ctx) (elt ctx 0)) -(defun murk-context-channel (ctx) (elt ctx 1)) -(defun murk-context-users (ctx) (elt ctx 2)) +(defun murk-context-server (ctx) + (elt ctx 0)) + +(defun murk-context-channel (ctx) + (elt ctx 1)) + +(defun murk-context-users (ctx) + (elt ctx 2)) + (defun murk-set-context-users (ctx users) (setcar (cddr ctx) users)) -(defun murk-server-context-p (ctx) (not (cdr ctx))) + +(defun murk-server-context-p (ctx) + (not (cdr ctx))) (defun murk-add-context (ctx) (add-to-list 'murk-contexts ctx)) @@ -340,13 +370,21 @@ The head of this list is always the current context.") (concat (murk-context-channel ctx) "@" (murk-context-server ctx)))) -(defun murk-get-context (server &optional name) - (if name - (let ((test-ctx (list server name))) +(defun murk-string->context (string) + (if (not (string-prefix-p "#" string)) + (murk-get-context string) + (let* ((parts (string-split string "@")) + (channel (elt parts 0)) + (server (elt parts 1))) + (murk-get-context server channel)))) + +(defun murk-get-context (server &optional channel) + (if (and channel (string-prefix-p "#" channel)) + (let ((test-ctx (list server channel))) (seq-find (lambda (ctx) (equal (seq-take ctx 2) test-ctx)) murk-contexts)) - (assoc server murk-contexts))) + (car (member (list server) murk-contexts)))) (defun murk-cycle-contexts (&optional reverse) (setq murk-contexts @@ -357,6 +395,13 @@ The head of this list is always the current context.") (seq-take murk-contexts nminus1))) (append (cdr murk-contexts) (list (car murk-contexts)))))) +(defun murk-switch-to-context (ctx) + (setq murk-contexts + (let* ((new-head (memq ctx murk-contexts)) + (new-tail (take (- (length murk-contexts) + (length new-head))))) + (append new-head new-tail)))) + (defun murk-add-context-users (ctx users) (murk-set-context-users ctx @@ -369,7 +414,8 @@ The head of this list is always the current context.") (defun murk-del-server-user (server user) (dolist (ctx murk-contexts) - (if (equal (murk-context-server ctx) server) + (if (and (equal (murk-context-server ctx) server) + (not (murk-server-context-p ctx))) (murk-del-context-user ctx user)))) (defun murk-rename-server-user (server old-nick new-nick) @@ -452,6 +498,7 @@ The head of this list is always the current context.") (set-marker murk-input-marker (point-max)) (setq murk-input-marker (point-max-marker))) (goto-char (point-max)) + (murk-highlight-current-context) (murk-render-prompt) (if murk-display-header (murk-setup-header)))) @@ -466,6 +513,31 @@ The head of this list is always the current context.") ;;; Output formatting and highlighting ;; +;; 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. + +;; Additionally, we allow selective hiding of contexts via +;; the buffer-invisibility-spec. + +(defvar murk-context-facelists (make-hash-table :test 'equal) + "List of seen contexts and associated face lists.") + +(defun murk-get-context-facelist (context) + (let* ((short-ctx (take 2 context)) + (facelist (gethash short-ctx murk-context-facelists))) + (unless facelist + (setq facelist (list 'murk-text)) + (puthash short-ctx facelist murk-context-facelists)) + facelist)) + (defun murk--fill-strings (col indent &rest strings) (with-temp-buffer (setq buffer-invisibility-spec nil) @@ -483,7 +555,11 @@ The head of this list is always the current context.") (old-pos (marker-position murk-prompt-marker)) (padded-timestamp (concat (format-time-string "%H:%M "))) (padded-prefix (if prefix (concat prefix " ") "")) - (context-atom (if context (intern (murk-context->string context)) nil))) + (short-ctx (take 2 context)) + (context-atom (if short-ctx + (intern (murk-context->string short-ctx)) + nil)) + (context-face (murk-get-context-facelist short-ctx))) (insert-before-markers (murk--fill-strings 80 @@ -492,16 +568,17 @@ The head of this list is always the current context.") (propertize padded-timestamp 'face 'murk-timestamp 'read-only t - 'context context + 'context short-ctx 'invisible context-atom) (propertize padded-prefix 'read-only t - 'context context + 'context short-ctx 'invisible context-atom) (murk-add-formatting (propertize (concat (apply #'murk-buttonify-urls strings) "\n") + 'face context-face 'read-only t - 'context context + 'context short-ctx 'invisible context-atom))))))) (murk-scroll-windows-to-last-line)) @@ -511,11 +588,24 @@ The head of this list is always the current context.") (murk-get-context server)))) (murk-display-string context - (if (murk-server-context-p context) - (concat "[" from " -> " to "]") - (concat (murk-context->string context) " <" from ">")) + (propertize + (if (murk-server-context-p context) + (concat "[" from "->" to "]") + (concat (murk-context->string context) " <" from ">")) + 'face (murk-get-context-facelist context)) text))) +(defun murk-display-action (server from to action-text) + (let ((context (if (string-prefix-p "#" to) + (murk-get-context server to) + (murk-get-context server)))) + (murk-display-string + context + (propertize + (concat (murk-context->string context) " *") + 'face (murk-get-context-facelist context)) + from " " action-text))) + (defun murk-display-notice (context &rest notices) (murk-display-string context @@ -528,6 +618,42 @@ The head of this list is always the current context.") (propertize murk-error-prefix 'face 'murk-error) (apply #'concat messages))) +(defun murk-highlight-current-context () + (maphash + (lambda (this-context facelist) + (if (equal (take 2 this-context) (take 2 (murk-current-context))) + (setcar facelist 'murk-text) + (setcar facelist 'murk-faded))) + murk-context-facelists) + (force-window-update "*murk*")) + +(defun murk-zoom-in (context) + (with-current-buffer "*murk*" + (maphash + (lambda (this-context _) + (when this-context + (let ((this-context-atom + (intern (murk-context->string this-context)))) + (if (equal this-context (take 2 context)) + (remove-from-invisibility-spec this-context-atom) + (add-to-invisibility-spec this-context-atom))))) + murk-context-facelists) + (force-window-update "*murk*")) + (murk-scroll-windows-to-last-line)) + +(defun murk-zoom-out () + (with-current-buffer "*murk*" + (maphash + (lambda (this-context _) + (let ((this-context-atom + (if this-context + (intern (murk-context->string this-context)) + nil))) + (remove-from-invisibility-spec this-context-atom))) + murk-context-facelists) + (force-window-update "*murk*")) + (murk-scroll-windows-to-last-line)) + (defun murk--start-of-final-line () (with-current-buffer "*murk*" (save-excursion @@ -583,7 +709,7 @@ The head of this list is always the current context.") (strikethrough nil) (prev-point (point))) (while (re-search-forward (rx (or (any "\x02\x1D\x1F\x1E\x0F") - (: "\x03" (+ digit) (opt "," (* digit))))) + (: "\x03" (* digit) (opt "," (* digit))))) nil t) (let ((beg (+ (match-beginning 0) 1))) (if bold @@ -617,6 +743,7 @@ The head of this list is always the current context.") (if murk-debug (murk-display-string nil nil string)) (let* ((msg (murk-string->msg string))) + (murk-process-autoreplies server msg) (pcase (murk-msg-cmd msg) ("PING" (murk-send-msg server @@ -629,7 +756,7 @@ The head of this list is always the current context.") (nick (elt params 0)) (text (string-join (seq-drop params 1) " "))) (murk-set-connection-nick server nick) - (murk-display-notice nil text))) + (murk-display-notice (murk-get-context server) text))) ("353" ; NAMEREPLY (let* ((params (murk-msg-params msg)) @@ -666,7 +793,8 @@ The head of this list is always the current context.") (murk-display-notice ctx "Topic: " topic))) ((rx (= 3 (any digit))) - (murk-display-notice nil (mapconcat 'identity (cdr (murk-msg-params msg)) " "))) + (murk-display-notice (murk-get-context server) + (mapconcat 'identity (cdr (murk-msg-params msg)) " "))) ((and "JOIN" (guard (equal (murk-connection-nick server) @@ -675,6 +803,7 @@ The head of this list is always the current context.") (murk-add-context (list server channel nil)) (murk-display-notice (murk-current-context) "Joining channel " channel " on " server) + (murk-highlight-current-context) (murk-render-prompt))) ("JOIN" @@ -692,6 +821,7 @@ The head of this list is always the current context.") (let ((channel (car (murk-msg-params msg)))) (murk-display-notice (murk-current-context) "Left channel " channel) (murk-remove-context (list server channel)) + (murk-highlight-current-context) (murk-render-prompt))) ("PART" @@ -710,7 +840,8 @@ The head of this list is always the current context.") (old-nick (murk-connection-nick server))) (murk-set-connection-nick server new-nick) (murk-rename-server-user server old-nick new-nick) - (murk-display-notice nil "Nick set to " new-nick " on " server))) + (murk-display-notice (murk-get-context server) + "Nick set to " new-nick " on " server))) ("NICK" (let ((old-nick (murk-msg-src msg)) @@ -731,7 +862,21 @@ The head of this list is always the current context.") (reason (mapconcat 'identity (murk-msg-params msg) " "))) (murk-del-server-user server nick) (if murk-show-joins - (murk-display-notice nil nick " quit: " reason)))) + (murk-display-notice (murk-get-context server) + nick " quit: " reason)))) + + ("NOTICE" + (let ((nick (murk-msg-src msg)) + (channel (car (murk-msg-params msg))) + (text (cadr (murk-msg-params msg)))) + (pcase text + ((rx (: "\01VERSION " + (let version (* (not "\01"))) + "\01")) + (murk-display-notice (murk-get-context server) + "CTCP version reply from " nick ": " version)) + (_ + (murk-display-notice (murk-get-context server channel) text))))) ("PRIVMSG" (let* ((from (murk-msg-src msg)) @@ -746,29 +891,66 @@ The head of this list is always the current context.") (list from (concat "\01VERSION " version-string "\01"))))) - (murk-display-notice nil "CTCP version request received from " + (murk-display-notice (murk-get-context server) + "CTCP version request received from " from " on " server)) ((rx (let ping (: "\01PING " (* (not "\01")) "\01"))) (murk-send-msg server (murk-msg nil nil "NOTICE" (list from ping))) - (murk-display-notice nil "CTCP ping received from " from " on " server)) + (murk-display-notice (murk-get-context server) + "CTCP ping received from " from " on " server)) ("\01USERINFO\01" - (murk-display-notice nil "CTCP userinfo request from " from + (murk-display-notice (murk-get-context server) + "CTCP userinfo request from " from " on " server " (no response sent)")) ("\01CLIENTINFO\01" - (murk-display-notice nil "CTCP clientinfo request from " from + (murk-display-notice (murk-get-context server) + "CTCP clientinfo request from " from " on " server " (no response sent)")) ((rx (: "\01ACTION " (let action-text (* (not "\01"))) "\01")) - (murk-display-action from to action-text)) + (murk-display-action server from to action-text)) (_ (murk-display-message server from to text))))) (_ - (murk-display-notice nil (murk-msg->string msg)))))) + (murk-display-notice (murk-get-context server) + (murk-msg->string msg)))))) + + +;;; User-defined responses +;; + +(defun murk--lists-equal (l1 l2) + (if (and l1 l2) + (if (or (not (and (car l1) (car l2))) + (string-match (car l1) (car l2))) + (murk--lists-equal (cdr l1) (cdr l2)) + nil) + t)) + +(defun murk-process-autoreply (server msg autoreply) + (let ((matcher (car autoreply)) + (reply (cadr autoreply))) + (let ((target-server (car matcher))) + (when (and (or (not target-server) + (and (equal server target-server))) + (murk--lists-equal (cdr matcher) + (append (list (lurk-msg-src msg) + (lurk-msg-cmd msg)) + (murk-msg-params msg)))) + (murk-send-msg server + (murk-msg nil nil (car reply) (cdr reply))))))) + +(defun murk-process-autoreplies (server msg) + (mapc + (lambda (autoreply) + (murk-process-autoreply server msg autoreply)) + murk-autoreply-table)) + ;;; Commands ;; @@ -787,6 +969,8 @@ The head of this list is always the current context.") ("TOPIC" "Set/query topic for current channel." murk-command-topic) ("USERS" "List nicks of users in current context." murk-command-users) ("MSG" "Send private message to user." murk-command-msg murk-nick-completions) + ("ME" "Display action." murk-command-me) + ("VERSION" "Request version of another user's client via CTCP." murk-command-version murk-nick-completions) ("CLEAR" "Clear buffer text." murk-command-clear murk-context-completions) ("HELP" "Display help on client commands." murk-command-help murk-help-completions)) "Table of commands explicitly supported by murk.") @@ -860,7 +1044,7 @@ The head of this list is always the current context.") (defun murk-command-quit (params) (let ((ctx (murk-current-context))) (if (not ctx) - (murk-display-error "No current context") + (murk-display-error "No current server") (let ((quit-msg (if params (string-join params " ") murk-default-quit-msg))) (murk-send-msg (murk-context-server ctx) @@ -928,6 +1112,36 @@ The head of this list is always the current context.") to text)) (murk-display-notice nil "Usage: /msg ")))) +(defun murk-command-me (params) + (let* ((ctx (murk-current-context)) + (server (murk-context-server ctx))) + (if (and ctx (not (murk-server-context-p ctx))) + (if params + (let* ((channel (murk-context-channel ctx)) + (my-nick (murk-connection-nick server)) + (action (string-join params " ")) + (ctcp-text (concat "\01ACTION " action "\01"))) + (murk-send-msg server + (murk-msg nil nil "PRIVMSG" + (list channel ctcp-text))) + (murk-display-action server my-nick channel action)) + (murk-display-notice nil "Usage: /me ")) + (murk-display-notice nil "No current channel.")))) + +(defun murk-command-version (params) + (let ((ctx (murk-current-context))) + (if ctx + (if params + (let ((server (murk-context-server ctx)) + (nick (car params))) + (murk-send-msg server + (lurk-msg nil nil "PRIVMSG" + (list nick "\01VERSION\01"))) + (murk-display-notice ctx "CTCP version request sent to " + nick " on " server)) + (murk-display-notice ctx "Usage: /version ")) + (murk-display-notice nil "No current channel.")))) + (defun murk-command-users (_params) (let ((ctx (murk-current-context))) (if (and ctx (not (murk-server-context-p ctx))) @@ -1021,12 +1235,29 @@ The head of this list is always the current context.") (defun murk-cycle-contexts-forward () (interactive) (murk-cycle-contexts) - (murk-render-prompt)) + (murk-highlight-current-context) + (murk-render-prompt) + (if murk-zoomed + (murk-zoom-in (murk-current-context)))) (defun murk-cycle-contexts-reverse () (interactive) (murk-cycle-contexts t) - (murk-render-prompt)) + (murk-highlight-current-context) + (murk-render-prompt) + (if murk-zoomed + (murk-zoom-in (murk-current-context)))) + +(defvar murk-zoomed nil + "Keeps track of zoom status.") + +(defun murk-toggle-zoom () + (interactive) + (if murk-zoomed + (murk-zoom-out) + (murk-zoom-in (murk-current-context))) + (setq murk-zoomed (not murk-zoomed))) + (defun murk-complete-input () (interactive) @@ -1065,6 +1296,7 @@ The head of this list is always the current context.") (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'murk-enter) (define-key map (kbd "TAB") 'murk-complete-input) + (define-key map (kbd "C-c C-z") 'murk-toggle-zoom) (define-key map (kbd "") 'murk-history-prev) (define-key map (kbd "") 'murk-history-next) (define-key map (kbd "") 'murk-cycle-contexts-forward)