1 ;;; murk.el --- Multiserver Unibuffer iRc Klient -*- lexical-binding:t -*-
3 ;; Copyright (C) 2024 plugd
5 ;; Author: plugd <plugd@thelambdalab.xyz>
6 ;; Created: 11 May 2024
8 ;; Homepage: http://thelambdalab.xyz/murk
10 ;; Package-Requires: ((emacs "26.1"))
12 ;; This file is not part of GNU Emacs.
14 ;; This program is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this file. If not, see <http://www.gnu.org/licenses/>.
29 ;; A very simple IRC server which uses only a single buffer.
41 "Multiserver Unibuffer iRc Klient"
44 (defcustom murk-default-nick "plugd"
48 (defcustom murk-default-quit-msg "Bye"
49 "Default quit message when none supplied."
52 (defcustom murk-networks
53 '(("debug" "localhost" 6697)
54 ("libera" "irc.libera.chat" 6697)
55 ("tilde" "tilde.chat" 6697)
56 ("sdf" "irc.sdf.org" 6697)
57 ("freenode" "chat.freenode.net" 6697)
58 ("mbr" "mbrserver.com" 6667 :notls))
60 :type '(alist :key-type string))
62 (defcustom murk-show-joins nil
63 "Set to non-nil to be notified of joins, parts and quits.")
65 (defcustom murk-display-header t
66 "If non-nil, use buffer header to display current host and channel."
74 '((t :inherit default))
75 "Face used for murk text.")
78 '((t :inherit font-lock-keyword-face))
79 "Face used for the prompt.")
82 '((t :inherit murk-context))
83 "Face used for the context name in the prompt.")
86 '((t :inherit shadow))
87 "Face used for faded murk text.")
89 (defface murk-timestamp
90 '((t :inherit shadow))
91 "Face used for timestamps.")
95 "Face used for murk error text.")
98 '((t :inherit warning))
99 "Face used for murk notice text.")
105 (defvar murk-version "Murk v0.0"
106 "Value of this string is used in response to CTCP version queries.")
108 (defvar murk-notice-prefix "-!-")
109 (defvar murk-error-prefix "!!!")
110 (defvar murk-prompt-string ">")
112 (defvar murk-debug nil
113 "If non-nil, enable debug mode.")
116 ;;; Utility procedures
119 (defun murk--filtered-join (&rest args)
120 (string-join (seq-filter (lambda (el) el) args) " "))
122 (defun murk--as-string (obj)
124 (with-output-to-string (princ obj))
128 ;;; Network processes
131 (defvar murk-connection-table nil
132 "An alist associating servers to connection information.
133 This includes the process and the response string.")
135 (defun murk-connection-process (server)
136 (elt (assoc server murk-connection-table) 1))
138 (defun murk-connection-nick (server)
139 (elt (assoc server murk-connection-table) 2))
141 (defun murk-set-connection-nick (server nick)
142 (setf (elt (assoc server murk-connection-table) 2) nick))
144 (defun murk-connection-response (server)
145 (elt (assoc server murk-connection-table) 3))
147 (defun murk-set-connection-response (server string)
148 (setf (elt (assoc server murk-connection-table) 3) string))
150 (defun murk-connection-new (server process nick)
151 (add-to-list 'murk-connection-table
152 (list server process nick "")))
154 (defun murk-connection-remove (server)
155 (setq murk-connection-table
156 (seq-remove (lambda (row) (equal (car row) server))
157 murk-connection-table)))
159 (defun murk-make-server-filter (server)
160 (lambda (_proc string)
161 (dolist (line (split-string (concat (murk-connection-response server) string)
163 (if (string-suffix-p "\r" line)
164 (murk-eval-msg-string server (string-trim line))
165 (murk-set-connection-response server line)))))
167 (defun murk-make-server-sentinel (server)
168 (lambda (_proc string)
169 (unless (equal "open" (string-trim string))
170 (murk-display-error "Disconnected from server.")
171 (murk-connection-remove server)
172 (murk-remove-server-contexts server)
173 (murk-highlight-current-context)
174 (murk-render-prompt))))
176 (defun murk-start-process (server)
177 (let* ((row (assoc server murk-networks))
180 (flags (seq-drop row 3)))
181 (make-network-process :name (concat "murk-" server)
185 :filter (murk-make-server-filter server)
186 :sentinel (murk-make-server-sentinel server)
188 :tls-parameters (if (memq :notls flags)
190 (cons 'gnutls-x509pki
191 (gnutls-boot-parameters
192 :type 'gnutls-x509pki
196 (defvar murk-ping-period 60)
198 ;; IDEA: Have a single ping timer which pings all connected hosts
200 (defun murk-connect (server)
201 (if (assoc server murk-connection-table)
202 (murk-display-error "Already connected to this network")
203 (if (not (assoc server murk-networks))
204 (murk-display-error "Network '" server "' is unknown.")
205 (let ((proc (murk-start-process server)))
206 (murk-connection-new server proc murk-default-nick))
207 (murk-send-msg server (murk-msg nil nil "USER" murk-default-nick 0 "*" murk-default-nick))
208 (murk-send-msg server (murk-msg nil nil "NICK" murk-default-nick))
209 (murk-add-context (list server))
210 (murk-highlight-current-context)
211 (murk-render-prompt))))
213 (defun murk-send-msg (server msg)
215 (murk-display-string nil nil (murk-msg->string msg)))
216 (let ((proc (murk-connection-process server)))
217 (if (and proc (eq (process-status proc) 'open))
218 (process-send-string proc (concat (murk-msg->string msg) "\r\n"))
219 (murk-display-error "No server connection established"))))
225 (defun murk-msg (tags src cmd &rest params)
226 (list (murk--as-string tags)
227 (murk--as-string src)
228 (upcase (murk--as-string cmd))
229 (mapcar #'murk--as-string
230 (if (and params (listp (elt params 0)))
234 (defun murk-msg-tags (msg) (elt msg 0))
235 (defun murk-msg-src (msg) (elt msg 1))
236 (defun murk-msg-cmd (msg) (elt msg 2))
237 (defun murk-msg-params (msg) (elt msg 3))
238 (defun murk-msg-trail (msg)
239 (let ((params (murk-msg-params msg)))
241 (elt params (- (length params) 1)))))
243 (defvar murk-msg-regex
245 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
247 (opt (: ":" (: (group (* (not (any space "!" "@"))))
248 (* (not (any space)))))
250 (group (: (* (not whitespace))))
252 (opt (group (+ not-newline))))
253 "Regex used to parse IRC messages.
254 Note that this regex is incomplete. Noteably, we discard the non-nick
255 portion of the source component of the message, as mURK doesn't use this.")
257 (defun murk-string->msg (string)
258 (if (string-match murk-msg-regex string)
259 (let* ((tags (match-string 1 string))
260 (src (match-string 2 string))
261 (cmd (upcase (match-string 3 string)))
262 (params-str (match-string 4 string))
265 (let* ((idx (seq-position params-str ?:))
266 (l (split-string (string-trim (substring params-str 0 idx))))
267 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
270 (apply #'murk-msg (append (list tags src cmd) params)))
271 (error "Failed to parse string %s" string)))
273 (defun murk-msg->string (msg)
274 (let ((tags (murk-msg-tags msg))
275 (src (murk-msg-src msg))
276 (cmd (murk-msg-cmd msg))
277 (params (murk-msg-params msg)))
279 (if tags (concat "@" tags) nil)
280 (if src (concat ":" src) nil)
282 (if (> (length params) 1)
283 (string-join (seq-take params (- (length params) 1)) " ")
285 (if (> (length params) 0)
286 (concat ":" (elt params (- (length params) 1)))
293 ;; A context is a list (server channel users) identifying the server
294 ;; and channel. The tail of the list contains the nicks of users
295 ;; present in the channel.
297 ;; Each server has a special context (server) used for messages
298 ;; to/from the server itself.
300 (defvar murk-contexts nil
301 "List of currently-available contexts.
302 The head of this list is always the current context.")
304 (defun murk-current-context ()
305 "Return the current context."
310 (defun murk-contexts-equal (c1 c2)
311 (if (murk-server-context-p c1)
312 (and (murk-server-context-p c2)
313 (equal (murk-context-server c1)
314 (murk-context-server c2)))
315 (and (not (murk-server-context-p c2))
316 (equal (seq-take c1 2)
319 (defun murk-context-server (ctx)
322 (defun murk-context-channel (ctx)
325 (defun murk-context-users (ctx)
328 (defun murk-set-context-users (ctx users)
329 (setcar (cddr ctx) users))
331 (defun murk-server-context-p (ctx)
334 (defun murk-add-context (ctx)
335 (add-to-list 'murk-contexts ctx))
337 (defun murk-remove-context (ctx)
341 (murk-contexts-equal this-ctx ctx))
344 (defun murk-remove-server-contexts (server)
346 (seq-remove (lambda (row) (equal (car row) server))
349 (defun murk-context->string (ctx)
350 (if (murk-server-context-p ctx)
351 (concat "[" (murk-context-server ctx) "]")
352 (concat (murk-context-channel ctx) "@"
353 (murk-context-server ctx))))
355 (defun murk-string->context (string)
356 (if (not (string-prefix-p "#" string))
357 (murk-get-context string)
358 (let* ((parts (string-split string "@"))
359 (channel (elt parts 0))
360 (server (elt parts 1)))
361 (murk-get-context server channel))))
363 (defun murk-get-context (server &optional channel)
364 (if (and channel (string-prefix-p "#" channel))
365 (let ((test-ctx (list server channel)))
366 (seq-find (lambda (ctx)
367 (equal (seq-take ctx 2) test-ctx))
369 (car (member (list server) murk-contexts))))
371 (defun murk-cycle-contexts (&optional reverse)
374 (let ((nminus1 (- (length murk-contexts) 1)))
376 (elt murk-contexts nminus1)
377 (seq-take murk-contexts nminus1)))
378 (append (cdr murk-contexts) (list (car murk-contexts))))))
380 (defun murk-switch-to-context (ctx)
382 (let* ((new-head (memq ctx murk-contexts))
383 (new-tail (take (- (length murk-contexts)
384 (length new-head)))))
385 (append new-head new-tail))))
387 (defun murk-add-context-users (ctx users)
388 (murk-set-context-users
390 (cl-union users (murk-context-users ctx))))
392 (defun murk-del-context-user (ctx user)
393 (murk-set-context-users
395 (delete user (murk-context-users ctx))))
397 (defun murk-del-server-user (server user)
398 (dolist (ctx murk-contexts)
399 (if (and (equal (murk-context-server ctx) server)
400 (not (murk-server-context-p ctx)))
401 (murk-del-context-user ctx user))))
403 (defun murk-rename-server-user (server old-nick new-nick)
404 (dolist (ctx murk-contexts)
405 (when (and (equal (murk-context-server ctx) server)
406 (member old-nick (murk-context-users ctx)))
407 (murk-del-context-user ctx old-nick)
408 (murk-add-context-users ctx (list new-nick)))))
413 (defvar murk-prompt-marker nil
414 "Marker for prompt position in murk buffer.")
416 (defvar murk-input-marker nil
417 "Marker for prompt position in murk buffer.")
419 (defun murk-render-prompt ()
420 (with-current-buffer "*murk*"
421 (let ((update-point (= murk-input-marker (point)))
422 (update-window-points (mapcar (lambda (w)
423 (list (= (window-point w) murk-input-marker)
425 (get-buffer-window-list nil nil t))))
427 (set-marker-insertion-type murk-prompt-marker nil)
428 (set-marker-insertion-type murk-input-marker t)
429 (let ((inhibit-read-only t))
430 (delete-region murk-prompt-marker murk-input-marker)
431 (goto-char murk-prompt-marker)
433 (propertize (let ((ctx (murk-current-context)))
435 (murk-context->string ctx)
439 (propertize murk-prompt-string
442 (propertize " " ; Need this to be separate to mark it as rear-nonsticky
445 (set-marker-insertion-type murk-input-marker nil))
447 (goto-char murk-input-marker))
448 (dolist (v update-window-points)
450 (set-window-point (cadr v) murk-input-marker))))))
452 (defun murk-setup-header ()
453 (with-current-buffer "*murk*"
454 (setq-local header-line-format
456 (let* ((ctx (murk-current-context)))
458 (let ((server (murk-context-server ctx)))
460 "Network: " server ", "
461 (if (murk-server-context-p ctx)
465 (murk-context-channel ctx)
468 (length (murk-context-users ctx)))
470 "No connection")))))))
472 (defun murk-setup-buffer ()
473 (with-current-buffer (get-buffer-create "*murk*")
474 (setq-local scroll-conservatively 1)
475 (setq-local buffer-invisibility-spec nil)
476 (if (markerp murk-prompt-marker)
477 (set-marker murk-prompt-marker (point-max))
478 (setq murk-prompt-marker (point-max-marker)))
479 (if (markerp murk-input-marker)
480 (set-marker murk-input-marker (point-max))
481 (setq murk-input-marker (point-max-marker)))
482 (goto-char (point-max))
483 (murk-highlight-current-context)
485 (if murk-display-header
486 (murk-setup-header))))
488 (defun murk-clear-buffer ()
489 "Completely erase all non-prompt and non-input text from murk buffer."
490 (with-current-buffer "*murk*"
491 (let ((inhibit-read-only t))
492 (delete-region (point-min) murk-prompt-marker))))
495 ;;; Output formatting and highlighting
498 ;; Idea: the face text property can be a list of faces, applied in
499 ;; order. By assigning each context a unique list and keeping track
500 ;; of these in a hash table, we can easily switch the face
501 ;; corresponding to a particular context by modifying the elements of
504 ;; More subtly, we make only the cdrs of this list shared among
505 ;; all text of a given context, allowing the cars to be different
506 ;; and for different elements of the context-specific text to have
507 ;; different styling.
509 ;; Additionally, we allow selective hiding of contexts via
510 ;; the buffer-invisibility-spec.
512 (defvar murk-context-facelists (make-hash-table :test 'equal)
513 "List of seen contexts and associated face lists.")
515 (defun murk-get-context-facelist (context)
516 (let* ((short-ctx (take 2 context))
517 (facelist (gethash short-ctx murk-context-facelists)))
519 (setq facelist (list 'murk-text))
520 (puthash short-ctx facelist murk-context-facelists))
523 (defun murk--fill-strings (col indent &rest strings)
525 (setq buffer-invisibility-spec nil)
526 (let ((fill-column col)
527 (adaptive-fill-regexp (rx-to-string `(= ,indent anychar))))
528 (apply #'insert strings)
529 (fill-region (point-min) (point-max) nil t)
532 (defun murk-display-string (context prefix &rest strings)
533 (with-current-buffer "*murk*"
535 (goto-char murk-prompt-marker)
536 (let* ((inhibit-read-only t)
537 (old-pos (marker-position murk-prompt-marker))
538 (padded-timestamp (concat (format-time-string "%H:%M ")))
539 (padded-prefix (if prefix (concat prefix " ") ""))
540 (short-ctx (take 2 context))
541 (context-atom (if short-ctx
542 (intern (murk-context->string short-ctx))
544 (context-face (murk-get-context-facelist short-ctx)))
545 (insert-before-markers
548 (+ (length padded-timestamp)
549 (length padded-prefix))
550 (propertize padded-timestamp
551 'face 'murk-timestamp
554 'invisible context-atom)
555 (propertize padded-prefix
558 'invisible context-atom)
560 (propertize (concat (apply #'murk-buttonify-urls strings) "\n")
564 'invisible context-atom)))))))
565 (murk-scroll-windows-to-last-line))
567 (defun murk-display-message (server from to text)
568 (let ((context (if (string-prefix-p "#" to)
569 (murk-get-context server to)
570 (murk-get-context server))))
574 (if (murk-server-context-p context)
575 (concat "[" from "->" to "]")
576 (concat (murk-context->string context) " <" from ">"))
577 'face (murk-get-context-facelist context))
580 (defun murk-display-action (server from to action-text)
581 (let ((context (if (string-prefix-p "#" to)
582 (murk-get-context server to)
583 (murk-get-context server))))
586 (concat (murk-context->string context) " *")
587 from " " action-text)))
589 (defun murk-display-notice (context &rest notices)
592 (propertize murk-notice-prefix 'face 'murk-notice)
593 (apply #'concat notices)))
595 (defun murk-display-error (&rest messages)
598 (propertize murk-error-prefix 'face 'murk-error)
599 (apply #'concat messages)))
601 (defun murk-highlight-current-context ()
603 (lambda (this-context facelist)
604 (if (equal (take 2 this-context) (take 2 (murk-current-context)))
605 (setcar facelist 'murk-text)
606 (setcar facelist 'murk-faded)))
607 murk-context-facelists)
608 (force-window-update "*murk*"))
610 (defun murk-zoom-in (context)
611 (with-current-buffer "*murk*"
613 (lambda (this-context _)
615 (let ((this-context-atom
616 (intern (murk-context->string this-context))))
617 (if (equal this-context (take 2 context))
618 (remove-from-invisibility-spec this-context-atom)
619 (add-to-invisibility-spec this-context-atom)))))
620 murk-context-facelists)
621 (force-window-update "*murk*"))
622 (murk-scroll-windows-to-last-line))
624 (defun murk-zoom-out ()
625 (with-current-buffer "*murk*"
627 (lambda (this-context _)
628 (let ((this-context-atom
630 (intern (murk-context->string this-context))
632 (remove-from-invisibility-spec this-context-atom)))
633 murk-context-facelists)
634 (force-window-update "*murk*"))
635 (murk-scroll-windows-to-last-line))
637 (defun murk--start-of-final-line ()
638 (with-current-buffer "*murk*"
640 (goto-char (point-max))
641 (line-beginning-position))))
643 (defun murk-scroll-windows-to-last-line ()
644 (with-current-buffer "*murk*"
645 (dolist (window (get-buffer-window-list))
646 (if (>= (window-point window) (murk--start-of-final-line))
647 (with-selected-window window
650 (defconst murk-url-regex
654 (group (or (+ (any alnum "." "-"))
655 (+ (any alnum ":"))))
656 (opt (group (: ":" (+ digit))))
659 (* (any alnum "-/.,#:%=&_?~@+"))
660 (any alnum "-/#:%=&_~@+")))))))
661 "Imperfect regex used to find URLs in plain text.")
663 (defun murk-click-url (button)
664 (browse-url (button-get button 'url)))
666 (defun murk-buttonify-urls (&rest strings)
667 "Turn substrings which look like urls in STRING into clickable buttons."
669 (apply #'insert strings)
670 (goto-char (point-min))
671 (while (re-search-forward murk-url-regex nil t)
672 (let ((url (match-string 0)))
673 (make-text-button (match-beginning 0)
675 'action #'murk-click-url
679 'help-echo "Open URL in browser.")))
682 (defun murk-add-formatting (string)
685 (goto-char (point-min))
690 (prev-point (point)))
691 (while (re-search-forward (rx (or (any "\x02\x1D\x1F\x1E\x0F")
692 (: "\x03" (* digit) (opt "," (* digit)))))
694 (let ((beg (+ (match-beginning 0) 1)))
696 (add-face-text-property prev-point beg '(:weight bold)))
698 (add-face-text-property prev-point beg '(:slant italic)))
700 (add-face-text-property prev-point beg '(:underline t)))
702 (add-face-text-property prev-point beg '(:strike-through t)))
703 (pcase (match-string 0)
704 ("\x02" (setq bold (not bold)))
705 ("\x1D" (setq italics (not italics)))
706 ("\x1F" (setq underline (not underline)))
707 ("\x1E" (setq strikethrough (not strikethrough)))
712 (setq strikethrough nil))
714 (delete-region (match-beginning 0) (match-end 0))
715 (setq prev-point (point)))))
719 ;;; Message evaluation
722 (defun murk-eval-msg-string (server string)
724 (murk-display-string nil nil string))
725 (let* ((msg (murk-string->msg string)))
726 (pcase (murk-msg-cmd msg)
728 (murk-send-msg server
729 (murk-msg nil nil "PONG" (murk-msg-params msg))))
734 (let* ((params (murk-msg-params msg))
735 (nick (elt params 0))
736 (text (string-join (seq-drop params 1) " ")))
737 (murk-set-connection-nick server nick)
738 (murk-display-notice (murk-get-context server) text)))
741 (let* ((params (murk-msg-params msg))
742 (channel (elt params 2))
743 (names (split-string (elt params 3)))
744 (ctx (murk-get-context server channel)))
746 (murk-add-context-users ctx names)
747 (murk-display-notice nil "Users in " channel
748 ": " (string-join names " ")))))
751 (let* ((params (murk-msg-params msg))
752 (channel (elt params 1))
753 (ctx (murk-get-context server channel)))
757 (murk--as-string (length (murk-context-users ctx)))
758 " users in " channel)
759 (murk-display-notice nil "End of " channel " names list."))))
762 (let* ((params (murk-msg-params msg))
763 (channel (elt params 1))
764 (ctx (murk-get-context server channel)))
765 (murk-display-notice ctx "No topic set.")))
768 (let* ((params (murk-msg-params msg))
769 (channel (elt params 1))
770 (topic (elt params 2))
771 (ctx (murk-get-context server channel)))
772 (murk-display-notice ctx "Topic: " topic)))
774 ((rx (= 3 (any digit)))
775 (murk-display-notice (murk-get-context server)
776 (mapconcat 'identity (cdr (murk-msg-params msg)) " ")))
779 (guard (equal (murk-connection-nick server)
780 (murk-msg-src msg))))
781 (let ((channel (car (murk-msg-params msg))))
782 (murk-add-context (list server channel nil))
783 (murk-display-notice (murk-current-context)
784 "Joining channel " channel " on " server)
785 (murk-highlight-current-context)
786 (murk-render-prompt)))
789 (let* ((channel (car (murk-msg-params msg)))
790 (nick (murk-msg-src msg))
791 (ctx (murk-get-context server channel)))
792 (murk-add-context-users ctx (list nick))
794 (murk-display-notice ctx nick " joined channel " channel
798 (guard (equal (murk-connection-nick server)
799 (murk-msg-src msg))))
800 (let ((channel (car (murk-msg-params msg))))
801 (murk-display-notice (murk-current-context) "Left channel " channel)
802 (murk-remove-context (list server channel))
803 (murk-highlight-current-context)
804 (murk-render-prompt)))
807 (let* ((channel (car (murk-msg-params msg)))
808 (nick (murk-msg-src msg))
809 (ctx (murk-get-context server channel)))
810 (murk-del-context-user ctx nick)
812 (murk-display-notice ctx nick " left channel " channel
816 (guard (equal (murk-connection-nick server)
817 (murk-msg-src msg))))
818 (let ((new-nick (car (murk-msg-params msg)))
819 (old-nick (murk-connection-nick server)))
820 (murk-set-connection-nick server new-nick)
821 (murk-rename-server-user server old-nick new-nick)
822 (murk-display-notice (murk-get-context server)
823 "Nick set to " new-nick " on " server)))
826 (let ((old-nick (murk-msg-src msg))
827 (new-nick (car (murk-msg-params msg))))
828 (murk-display-notice nil old-nick " is now known as " new-nick
830 (murk-rename-server-user server old-nick new-nick)))
833 (let ((channel (car (murk-msg-params msg)))
834 (nick (murk-msg-src msg))
835 (topic (cadr (murk-msg-params msg))))
836 (murk-display-notice (murk-get-context server channel)
837 nick " set the topic: " topic)))
840 (let ((nick (murk-msg-src msg))
841 (reason (mapconcat 'identity (murk-msg-params msg) " ")))
842 (murk-del-server-user server nick)
844 (murk-display-notice (murk-get-context server)
845 nick " quit: " reason))))
848 (let ((nick (murk-msg-src msg))
849 (channel (car (murk-msg-params msg)))
850 (text (cadr (murk-msg-params msg))))
852 ((rx (: "\01VERSION "
853 (let version (* (not "\01")))
855 (murk-display-notice (murk-get-context server)
856 "CTCP version reply from " nick ": " version))
858 (murk-display-notice (murk-get-context server channel) text)))))
861 (let* ((from (murk-msg-src msg))
862 (params (murk-msg-params msg))
864 (text (cadr params)))
867 (let ((version-string (concat murk-version " - running on GNU Emacs " emacs-version)))
868 (murk-send-msg server
869 (murk-msg nil nil "NOTICE"
870 (list from (concat "\01VERSION "
873 (murk-display-notice (murk-get-context server)
874 "CTCP version request received from "
877 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
878 (murk-send-msg server (murk-msg nil nil "NOTICE" (list from ping)))
879 (murk-display-notice (murk-get-context server)
880 "CTCP ping received from " from " on " server))
883 (murk-display-notice (murk-get-context server)
884 "CTCP userinfo request from " from
885 " on " server " (no response sent)"))
888 (murk-display-notice (murk-get-context server)
889 "CTCP clientinfo request from " from
890 " on " server " (no response sent)"))
892 ((rx (: "\01ACTION " (let action-text (* (not "\01"))) "\01"))
893 (murk-display-action server from to action-text))
896 (murk-display-message server from to text)))))
899 (murk-display-notice (murk-get-context server)
900 (murk-msg->string msg))))))
905 (defvar murk-command-table
906 '(("DEBUG" "Toggle debug mode on/off." murk-command-debug murk-boolean-completions)
907 ("HEADER" "Toggle display of header." murk-command-header murk-boolean-completions)
908 ("SHOWJOINS" "Toggles display of joins/parts." murk-command-showjoins murk-boolean-completions)
909 ("NETWORKS" "List known IRC networks." murk-command-networks)
910 ("CONNECT" "Connect to an IRC network." murk-command-connect murk-network-completions)
911 ("QUIT" "Disconnect from current network." murk-command-quit)
912 ("JOIN" "Join one or more channels." murk-command-join)
913 ("PART" "Leave channel." murk-command-part murk-context-completions)
914 ("NICK" "Change nick." murk-command-nick)
915 ("LIST" "Display details of one or more channels." murk-command-list)
916 ("TOPIC" "Set/query topic for current channel." murk-command-topic)
917 ("USERS" "List nicks of users in current context." murk-command-users)
918 ("MSG" "Send private message to user." murk-command-msg murk-nick-completions)
919 ("ME" "Display action." murk-command-me)
920 ("VERSION" "Request version of another user's client via CTCP." murk-command-version murk-nick-completions)
921 ("CLEAR" "Clear buffer text." murk-command-clear murk-context-completions)
922 ("HELP" "Display help on client commands." murk-command-help murk-help-completions))
923 "Table of commands explicitly supported by murk.")
925 (defun murk-boolean-completions ()
928 (defun murk-network-completions ()
929 (mapcar (lambda (row) (car row)) murk-networks))
931 (defun murk-command-help (params)
933 (let* ((cmd-str (upcase (car params)))
934 (row (assoc cmd-str murk-command-table #'equal)))
937 (murk-display-notice nil "Help for \x02" cmd-str "\x02:")
938 (murk-display-notice nil " " (elt row 1)))
939 (murk-display-notice nil "No such (client-interpreted) command.")))
940 (murk-display-notice nil "Client-interpreted commands:")
941 (dolist (row murk-command-table)
942 (murk-display-notice nil " \x02" (elt row 0) "\x02: " (elt row 1)))
943 (murk-display-notice nil "Use /HELP COMMAND to display information about a specific command.")))
945 (defun murk-command-debug (params)
948 (if (equal (upcase (car params)) "ON")
952 (murk-display-notice nil "Debug mode now " (if murk-debug "on" "off") "."))
954 (defun murk-command-header (params)
957 (equal (upcase (car params)) "ON")
958 (not header-line-format))
961 (murk-display-notice nil "Header enabled."))
962 (setq-local header-line-format nil)
963 (murk-display-notice nil "Header disabled.")))
965 (defun murk-command-showjoins (params)
966 (setq murk-show-joins
968 (if (equal (upcase (car params)) "ON")
971 (not murk-show-joins)))
972 (murk-display-notice nil "Joins/parts will now be "
973 (if murk-show-joins "shown" "hidden") "."))
975 (defun murk-command-connect (params)
977 (let ((network (car params)))
978 (murk-display-notice nil "Attempting to connect to " network "...")
979 (murk-connect network))
980 (murk-display-notice nil "Usage: /connect <network>")))
982 (defun murk-command-networks (_params)
983 (murk-display-notice nil "Currently-known networks:")
984 (dolist (row murk-networks)
985 (seq-let (network server port &rest _others) row
986 (murk-display-notice nil "\t" network
988 " " (number-to-string port) "]")))
989 (murk-display-notice nil "(Modify the `murk-networks' variable to add more.)"))
991 (defun murk-command-quit (params)
992 (let ((ctx (murk-current-context)))
994 (murk-display-error "No current context")
995 (let ((quit-msg (if params (string-join params " ") murk-default-quit-msg)))
997 (murk-context-server ctx)
998 (murk-msg nil nil "QUIT" quit-msg))))))
1000 (defun murk-command-join (params)
1002 (let ((server (murk-context-server (murk-current-context))))
1003 (dolist (channel params)
1004 (murk-send-msg server (murk-msg nil nil "JOIN" channel))))
1005 (murk-display-notice nil "Usage: /join channel [channel2 ...]")))
1007 (defun murk-command-part (params)
1008 (let* ((server (murk-context-server (murk-current-context)))
1011 (murk-context-channel (murk-current-context)))))
1013 (murk-send-msg server (murk-msg nil nil "PART" channel))
1014 (murk-display-error "No current channel to leave"))))
1016 (defun murk-command-nick (params)
1018 (let ((new-nick (string-join params " "))
1019 (ctx (murk-current-context)))
1021 (murk-send-msg (murk-context-server ctx)
1022 (murk-msg nil nil "NICK" new-nick))
1023 (murk-display-error "No current connection")))
1024 (murk-display-notice nil "Usage: /nick <new-nick>")))
1026 (defun murk-command-list (params)
1027 (let ((ctx (murk-current-context)))
1030 (murk-display-notice nil "This command can generate lots of output. Use `/LIST -yes' if you really want this, or `/LIST <channel_regexp>' to reduce the output.")
1031 (let ((server (murk-context-server ctx)))
1032 (if (equal (upcase (car params)) "-YES")
1033 (murk-send-msg server (murk-msg nil nil "LIST"))
1034 (murk-send-msg server (murk-msg nil nil "LIST"
1036 (murk-display-error "No current connection"))))
1038 (defun murk-command-topic (params)
1039 (let ((ctx (murk-current-context)))
1040 (if (and ctx (not (murk-server-context-p ctx)))
1041 (let ((server (murk-context-server ctx))
1042 (channel (murk-context-channel ctx)))
1044 (murk-send-msg server
1045 (murk-msg nil nil "TOPIC" channel
1046 (string-join params " ")))
1047 (murk-send-msg server
1048 (murk-msg nil nil "TOPIC" channel))))
1049 (murk-display-notice nil "No current channel."))))
1051 (defun murk-command-msg (params)
1052 (let ((server (murk-context-server (murk-current-context))))
1053 (if (and params (>= (length params) 2))
1054 (let ((to (car params))
1055 (text (string-join (cdr params) " ")))
1056 (murk-send-msg server (murk-msg nil nil "PRIVMSG" to text))
1057 (murk-display-message server
1058 (murk-connection-nick server)
1060 (murk-display-notice nil "Usage: /msg <nick> <message>"))))
1062 (defun murk-command-me (params)
1063 (let* ((ctx (murk-current-context))
1064 (server (murk-context-server ctx)))
1065 (if (and ctx (not (murk-server-context-p ctx)))
1067 (let* ((channel (murk-context-channel ctx))
1068 (my-nick (murk-connection-nick server))
1069 (action (string-join params " "))
1070 (ctcp-text (concat "\01ACTION " action "\01")))
1071 (murk-send-msg server
1072 (murk-msg nil nil "PRIVMSG"
1073 (list channel ctcp-text)))
1074 (murk-display-action server my-nick channel action))
1075 (murk-display-notice nil "Usage: /me <action>"))
1076 (murk-display-notice nil "No current channel."))))
1078 (defun murk-command-version (params)
1079 (let ((ctx (murk-current-context)))
1082 (let ((server (murk-context-server ctx))
1083 (nick (car params)))
1084 (murk-send-msg server
1085 (lurk-msg nil nil "PRIVMSG"
1086 (list nick "\01VERSION\01")))
1087 (murk-display-notice ctx "CTCP version request sent to "
1088 nick " on " server))
1089 (murk-display-notice ctx "Usage: /version <nick>"))
1090 (murk-display-notice nil "No current channel."))))
1092 (defun murk-command-users (_params)
1093 (let ((ctx (murk-current-context)))
1094 (if (and ctx (not (murk-server-context-p ctx)))
1095 (let ((channel (murk-context-channel ctx))
1096 (server (murk-context-server ctx))
1097 (users (murk-context-users ctx)))
1098 (murk-display-notice ctx "Users in " channel " on " server ":")
1099 (murk-display-notice ctx (string-join users " ")))
1100 (murk-display-notice nil "No current channel."))))
1103 ;;; Command entering
1106 (defun murk-enter-string (string)
1107 (if (string-prefix-p "/" string)
1109 ((rx (: "/" (let cmd-str (+ (not whitespace)))
1111 (let params-str (+ anychar))
1113 (let ((command-row (assoc (upcase cmd-str) murk-command-table #'equal))
1114 (params (if params-str
1115 (split-string params-str nil t)
1117 (if (and command-row (elt command-row 2))
1118 (funcall (elt command-row 2) params)
1120 (murk-context-server (murk-current-context))
1121 (murk-msg nil nil (upcase cmd-str) params)))))
1123 (murk-display-error "Badly formed command")))
1124 (unless (string-empty-p string)
1125 (let ((ctx (murk-current-context)))
1127 (if (not (murk-server-context-p ctx))
1128 (let ((server (murk-context-server ctx))
1129 (channel (murk-context-channel ctx)))
1130 (murk-send-msg server
1131 (murk-msg nil nil "PRIVMSG" channel string))
1132 (murk-display-message server
1133 (murk-connection-nick server)
1135 (murk-display-error "No current channel"))
1136 (murk-display-error "No current context"))))))
1142 (defvar murk-history nil
1143 "Commands and messages sent in current session.")
1145 (defvar murk-history-index nil)
1147 (defun murk-history-cycle (delta)
1149 (with-current-buffer "*murk*"
1150 (if murk-history-index
1151 (setq murk-history-index
1153 (min (- (length murk-history) 1)
1154 (+ delta murk-history-index))))
1155 (setq murk-history-index 0))
1156 (delete-region murk-input-marker (point-max))
1157 (insert (elt murk-history murk-history-index)))))
1160 ;;; Interactive commands
1163 (defun murk-enter ()
1164 "Enter current contents of line after prompt."
1166 (with-current-buffer "*murk*"
1167 (let ((line (buffer-substring murk-input-marker (point-max))))
1168 (push line murk-history)
1169 (setq murk-history-index nil)
1170 (let ((inhibit-read-only t))
1171 (delete-region murk-input-marker (point-max)))
1172 (murk-enter-string line))))
1174 (defun murk-history-next ()
1176 (murk-history-cycle -1))
1178 (defun murk-history-prev ()
1180 (murk-history-cycle +1))
1182 (defun murk-cycle-contexts-forward ()
1184 (murk-cycle-contexts)
1185 (murk-highlight-current-context)
1186 (murk-render-prompt)
1188 (murk-zoom-in (murk-current-context))))
1190 (defun murk-cycle-contexts-reverse ()
1192 (murk-cycle-contexts t)
1193 (murk-highlight-current-context)
1194 (murk-render-prompt)
1196 (murk-zoom-in (murk-current-context))))
1198 (defvar murk-zoomed nil
1199 "Keeps track of zoom status.")
1201 (defun murk-toggle-zoom ()
1205 (murk-zoom-in (murk-current-context)))
1206 (setq murk-zoomed (not murk-zoomed)))
1209 (defun murk-complete-input ()
1211 (let ((completion-ignore-case t))
1212 (when (>= (point) murk-input-marker)
1213 (pcase (buffer-substring murk-input-marker (point))
1214 ((rx (: "/" (let cmd-str (+ (not whitespace))) (+ " ") (* (not whitespace)) string-end))
1215 (let ((space-idx (save-excursion
1216 (re-search-backward " " murk-input-marker t)))
1217 (table-row (assoc (upcase cmd-str) murk-command-table #'equal)))
1218 (if (and table-row (elt table-row 3))
1219 (let* ((completions-nospace (funcall (elt table-row 3)))
1220 (completions (mapcar (lambda (el) (concat el " ")) completions-nospace)))
1221 (completion-in-region (+ 1 space-idx) (point) completions)))))
1222 ((rx (: "/" (* (not whitespace)) string-end))
1223 (message (buffer-substring murk-input-marker (point)))
1224 (completion-in-region murk-input-marker (point)
1225 (mapcar (lambda (row) (concat "/" (car row) " "))
1226 murk-command-table)))
1228 (let* ((end (max murk-input-marker (point)))
1229 (space-idx (save-excursion
1230 (re-search-backward " " murk-input-marker t)))
1231 (start (if space-idx (+ 1 space-idx) murk-input-marker)))
1232 (unless (string-prefix-p "/" (buffer-substring start end))
1233 (let* ((users (murk-context-users (murk-current-context)))
1235 (lambda (u) (car (split-string u "@" t)))
1237 (completion-in-region start end users-no@)))))))))
1242 (defvar murk-mode-map
1243 (let ((map (make-sparse-keymap)))
1244 (define-key map (kbd "RET") 'murk-enter)
1245 (define-key map (kbd "TAB") 'murk-complete-input)
1246 (define-key map (kbd "C-c C-z") 'murk-toggle-zoom)
1247 (define-key map (kbd "<C-up>") 'murk-history-prev)
1248 (define-key map (kbd "<C-down>") 'murk-history-next)
1249 (define-key map (kbd "<C-tab>") 'murk-cycle-contexts-forward)
1250 (define-key map (kbd "<C-S-iso-lefttab>") 'murk-cycle-contexts-reverse)
1251 (define-key map (kbd "<C-S-tab>") 'murk-cycle-contexts-reverse)
1252 (when (fboundp 'evil-define-key*)
1253 (evil-define-key* 'motion map
1254 (kbd "TAB") 'murk-complete-input))
1257 (define-derived-mode murk-mode text-mode "murk"
1258 "Major mode for murk.")
1260 (when (fboundp 'evil-set-initial-state)
1261 (evil-set-initial-state 'murk-mode 'insert))
1263 ;;; Main start procedure
1267 "Start murk or just switch to the murk buffer if one already exists."
1269 (if (get-buffer "*murk*")
1270 (switch-to-buffer "*murk*")
1271 (switch-to-buffer "*murk*")
1273 (murk-setup-buffer))
1276 ;;; murk.el ends here