1 ;;; lurk.el --- Little Unibuffer iRc Klient -*- lexical-binding:t -*-
3 ;; Copyright (C) 2021--2024 plugd
5 ;; Author: plugd <plugd@thelambdalab.xyz>
6 ;; Created: 14 June 2021
8 ;; Homepage: http://thelambdalab.xyz/lurk
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 client which uses only a single buffer.
41 "Multinetwork Unibuffer iRc Klient"
44 (defcustom lurk-default-nick "plugd"
48 (defcustom lurk-default-quit-msg "Bye"
49 "Default quit message when none supplied."
52 (defcustom lurk-networks
53 '(("libera" "irc.libera.chat" 6697)
54 ("tilde" "tilde.chat" 6697)
55 ("sdf" "irc.sdf.org" 6697))
57 :type '(alist :key-type string))
59 (defcustom lurk-show-joins nil
60 "Set to non-nil to be notified of joins, parts and quits.")
62 (defcustom lurk-display-header t
63 "If non-nil, use buffer header to display current host and channel."
66 (defcustom lurk-autoreply-table nil
67 "Table of autoreply messages.
69 Each autoreply is a list of two elements: (matcher reply)
71 Here matcher is a list:
73 (network src cmd params ...)
75 and reply is another list:
79 Each entry in the matcher list is a regular expression tested against the
80 corresponding values in the incomming message. Entries can be nil,
81 in which case they match anything."
82 :type '(list (list) (list)))
89 '((t :inherit default))
90 "Face used for lurk text.")
93 '((t :inherit font-lock-keyword-face))
94 "Face used for the prompt.")
97 '((t :inherit lurk-context))
98 "Face used for the context name in the prompt.")
101 '((t :inherit shadow))
102 "Face used for faded lurk text.")
104 (defface lurk-timestamp
105 '((t :inherit shadow))
106 "Face used for timestamps.")
109 '((t :inherit error))
110 "Face used for lurk error text.")
113 '((t :inherit warning))
114 "Face used for lurk notice text.")
120 (defvar lurk-version "Lurk v0.0"
121 "Value of this string is used in response to CTCP version queries.")
123 (defvar lurk-notice-prefix "-!-")
124 (defvar lurk-error-prefix "!!!")
125 (defvar lurk-prompt-string ">")
127 (defvar lurk-debug nil
128 "If non-nil, enable debug mode.")
131 ;;; Utility procedures
134 (defun lurk--filtered-join (&rest args)
135 (string-join (seq-filter (lambda (el) el) args) " "))
137 (defun lurk--as-string (obj)
139 (with-output-to-string (princ obj))
143 ;;; Network processes
146 (defvar lurk-connection-table nil
147 "An alist associating networks to connection information.
148 This includes the process and the response string.")
150 (defun lurk-connection-process (network)
151 (elt (assoc network lurk-connection-table) 1))
153 (defun lurk-connection-nick (network)
154 (elt (assoc network lurk-connection-table) 2))
156 (defun lurk-set-connection-nick (network nick)
157 (setf (elt (assoc network lurk-connection-table) 2) nick))
159 (defun lurk-connection-response (network)
160 (elt (assoc network lurk-connection-table) 3))
162 (defun lurk-set-connection-response (network string)
163 (setf (elt (assoc network lurk-connection-table) 3) string))
165 (defun lurk-connection-new (network process nick)
166 (add-to-list 'lurk-connection-table
167 (list network process nick "")))
169 (defun lurk-connection-remove (network)
170 (setq lurk-connection-table
171 (seq-remove (lambda (row) (equal (car row) network))
172 lurk-connection-table)))
174 (defun lurk-make-network-filter (network)
175 (lambda (_proc string)
176 (dolist (line (split-string (concat (lurk-connection-response network) string)
178 (if (string-suffix-p "\r" line)
179 (lurk-eval-msg-string network (string-trim line))
180 (lurk-set-connection-response network line)))))
182 (defun lurk-make-network-sentinel (network)
183 (lambda (_proc string)
184 (unless (equal "open" (string-trim string))
185 (lurk-display-error "Disconnected from network.")
186 (lurk-connection-remove network)
187 (lurk-remove-network-contexts network)
188 (lurk-highlight-current-context)
189 (lurk-render-prompt))))
191 (defun lurk-start-process (network)
192 (let* ((row (assoc network lurk-networks))
195 (flags (seq-drop row 3)))
196 (make-network-process :name (concat "lurk-" network)
200 :filter (lurk-make-network-filter network)
201 :sentinel (lurk-make-network-sentinel network)
203 :tls-parameters (if (memq :notls flags)
205 (cons 'gnutls-x509pki
206 (gnutls-boot-parameters
207 :type 'gnutls-x509pki
211 (defvar lurk-ping-period 60)
213 ;; IDEA: Have a single ping timer which pings all connected hosts
215 (defun lurk-connect (network)
216 (if (assoc network lurk-connection-table)
217 (lurk-display-error "Already connected to this network")
218 (if (not (assoc network lurk-networks))
219 (lurk-display-error "Network '" network "' is unknown.")
220 (let ((proc (lurk-start-process network)))
221 (lurk-connection-new network proc lurk-default-nick))
222 (lurk-send-msg network (lurk-msg nil nil "USER" lurk-default-nick 0 "*" lurk-default-nick))
223 (lurk-send-msg network (lurk-msg nil nil "NICK" lurk-default-nick))
224 (lurk-add-context (list network))
225 (lurk-highlight-current-context)
226 (lurk-render-prompt))))
228 (defun lurk-send-msg (network msg)
230 (lurk-display-string nil nil (lurk-msg->string msg)))
231 (let ((proc (lurk-connection-process network)))
232 (if (and proc (eq (process-status proc) 'open))
233 (process-send-string proc (concat (lurk-msg->string msg) "\r\n"))
234 (lurk-display-error "No network connection established"))))
240 (defun lurk-msg (tags src cmd &rest params)
241 (list (lurk--as-string tags)
242 (lurk--as-string src)
243 (upcase (lurk--as-string cmd))
244 (mapcar #'lurk--as-string
245 (if (and params (listp (elt params 0)))
249 (defun lurk-msg-tags (msg) (elt msg 0))
250 (defun lurk-msg-src (msg) (elt msg 1))
251 (defun lurk-msg-cmd (msg) (elt msg 2))
252 (defun lurk-msg-params (msg) (elt msg 3))
253 (defun lurk-msg-trail (msg)
254 (let ((params (lurk-msg-params msg)))
256 (elt params (- (length params) 1)))))
258 (defvar lurk-msg-regex
260 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
262 (opt (: ":" (: (group (* (not (any space "!" "@"))))
263 (* (not (any space)))))
265 (group (: (* (not whitespace))))
267 (opt (group (+ not-newline))))
268 "Regex used to parse IRC messages.
269 Note that this regex is incomplete. Noteably, we discard the non-nick
270 portion of the source component of the message, as lurk doesn't use this.")
272 (defun lurk-string->msg (string)
273 (if (string-match lurk-msg-regex string)
274 (let* ((tags (match-string 1 string))
275 (src (match-string 2 string))
276 (cmd (upcase (match-string 3 string)))
277 (params-str (match-string 4 string))
280 (let* ((idx (seq-position params-str ?:))
281 (l (split-string (string-trim (substring params-str 0 idx))))
282 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
285 (apply #'lurk-msg (append (list tags src cmd) params)))
286 (error "Failed to parse string %s" string)))
288 (defun lurk-msg->string (msg)
289 (let ((tags (lurk-msg-tags msg))
290 (src (lurk-msg-src msg))
291 (cmd (lurk-msg-cmd msg))
292 (params (lurk-msg-params msg)))
294 (if tags (concat "@" tags) nil)
295 (if src (concat ":" src) nil)
297 (if (> (length params) 1)
298 (string-join (seq-take params (- (length params) 1)) " ")
300 (if (> (length params) 0)
301 (concat ":" (elt params (- (length params) 1)))
308 ;; A context is a list (network channel) identifying the network
309 ;; and channel. The tail of the list contains the nicks of users
310 ;; present in the channel.
312 ;; Each network has a special context (network) used for messages
313 ;; to/from the network itself.
315 (defvar lurk-contexts nil
316 "List of currently-available contexts.
317 The head of this list is always the current context.")
319 (defun lurk-current-context ()
320 "Return the current context."
325 (defun lurk-contexts-equal (c1 c2)
326 (if (lurk-network-context-p c1)
327 (and (lurk-network-context-p c2)
328 (equal (lurk-context-network c1)
329 (lurk-context-network c2)))
330 (and (not (lurk-network-context-p c2))
331 (equal (seq-take c1 2)
334 (defun lurk-context-network (ctx)
337 (defun lurk-context-channel (ctx)
340 (defun lurk-network-context-p (ctx)
343 (defun lurk-add-context (ctx)
344 (add-to-list 'lurk-contexts ctx))
346 (defun lurk-remove-context (ctx)
350 (lurk-contexts-equal this-ctx ctx))
353 (defun lurk-remove-network-contexts (network)
355 (seq-remove (lambda (row) (equal (car row) network))
358 (defun lurk-context->string (ctx)
360 (if (lurk-network-context-p ctx)
362 (concat (lurk-context-channel ctx) "@"))
363 (lurk-context-network ctx)))
365 (defun lurk-string->context (string)
366 (if (not (string-prefix-p "#" string))
367 (lurk-get-context string)
368 (let* ((parts (string-split string "@"))
369 (channel (elt parts 0))
370 (network (elt parts 1)))
371 (lurk-get-context network channel))))
373 (defun lurk-get-context (network &optional channel)
374 (if (and channel (string-prefix-p "#" channel))
375 (let ((test-ctx (list network channel)))
376 (seq-find (lambda (ctx)
377 (equal (seq-take ctx 2) test-ctx))
379 (car (member (list network) lurk-contexts))))
381 (defun lurk-cycle-contexts (&optional reverse)
384 (let ((nminus1 (- (length lurk-contexts) 1)))
386 (elt lurk-contexts nminus1)
387 (seq-take lurk-contexts nminus1)))
388 (append (cdr lurk-contexts) (list (car lurk-contexts))))))
390 (defun lurk-switch-to-context (ctx)
392 (let* ((new-head (memq ctx lurk-contexts))
393 (new-tail (take (- (length lurk-contexts)
396 (append new-head new-tail))))
402 (defvar lurk-context-users nil
403 "Association list between channel contexts and users.")
405 (defun lurk-get-context-users (ctx)
406 (cdr (assoc ctx lurk-context-users)))
408 (defun lurk-set-context-users (ctx users)
409 (setq lurk-context-users
410 (cons (cons ctx users) (assoc-delete-all ctx lurk-context-users))))
412 (defun lurk-add-context-users (ctx users)
413 (lurk-set-context-users
415 (cl-union users (lurk-get-context-users ctx))))
417 (defun lurk-del-context-user (ctx user)
418 (lurk-set-context-users
420 (delete user (lurk-get-context-users ctx))))
422 (defun lurk-del-all-context-users (ctx)
423 (lurk-set-context-users ctx nil))
425 (defun lurk-del-network-user (network user)
426 (dolist (ctx lurk-contexts)
427 (if (and (equal (lurk-context-network ctx) network)
428 (not (lurk-network-context-p ctx)))
429 (lurk-del-context-user ctx user))))
431 (defun lurk-del-all-network-users (network)
432 (dolist (ctx lurk-contexts)
433 (if (and (equal (lurk-context-network ctx) network)
434 (not (lurk-network-context-p ctx)))
435 (lurk-del-all-context-users ctx))))
437 (defun lurk-rename-network-user (network old-nick new-nick)
438 (dolist (ctx lurk-contexts)
439 (when (and (equal (lurk-context-network ctx) network)
440 (member old-nick (lurk-get-context-users ctx)))
441 (lurk-del-context-user ctx old-nick)
442 (lurk-add-context-users ctx (list new-nick)))))
448 (defvar lurk-prompt-marker nil
449 "Marker for prompt position in lurk buffer.")
451 (defvar lurk-input-marker nil
452 "Marker for prompt position in lurk buffer.")
454 (defun lurk-render-prompt ()
455 (with-current-buffer "*lurk*"
456 (let ((update-point (= lurk-input-marker (point)))
457 (update-window-points (mapcar (lambda (w)
458 (list (= (window-point w) lurk-input-marker)
460 (get-buffer-window-list nil nil t))))
462 (set-marker-insertion-type lurk-prompt-marker nil)
463 (set-marker-insertion-type lurk-input-marker t)
464 (let ((inhibit-read-only t))
465 (delete-region lurk-prompt-marker lurk-input-marker)
466 (goto-char lurk-prompt-marker)
468 (propertize (let ((ctx (lurk-current-context)))
470 (lurk-context->string ctx)
474 (propertize lurk-prompt-string
477 (propertize " " ; Need this to be separate to mark it as rear-nonsticky
480 (set-marker-insertion-type lurk-input-marker nil))
482 (goto-char lurk-input-marker))
483 (dolist (v update-window-points)
485 (set-window-point (cadr v) lurk-input-marker))))))
487 (defun lurk-setup-header ()
488 (with-current-buffer "*lurk*"
489 (setq-local header-line-format
491 (let* ((ctx (lurk-current-context)))
493 (let ((network (lurk-context-network ctx)))
495 "Network: " network ", "
496 (if (lurk-network-context-p ctx)
500 (lurk-context-channel ctx)
503 (length (lurk-get-context-users ctx)))
505 "No connection")))))))
507 (defun lurk-setup-buffer ()
508 (with-current-buffer (get-buffer-create "*lurk*")
509 (setq-local scroll-conservatively 1)
510 (setq-local buffer-invisibility-spec nil)
511 (if (markerp lurk-prompt-marker)
512 (set-marker lurk-prompt-marker (point-max))
513 (setq lurk-prompt-marker (point-max-marker)))
514 (if (markerp lurk-input-marker)
515 (set-marker lurk-input-marker (point-max))
516 (setq lurk-input-marker (point-max-marker)))
517 (goto-char (point-max))
518 (lurk-highlight-current-context)
520 (if lurk-display-header
521 (lurk-setup-header))))
523 (defun lurk-clear-buffer ()
524 "Completely erase all non-prompt and non-input text from lurk buffer."
525 (with-current-buffer "*lurk*"
526 (let ((inhibit-read-only t))
527 (delete-region (point-min) lurk-prompt-marker))))
530 ;;; Output formatting and highlighting
533 ;; Idea: the face text property can be a list of faces, applied in
534 ;; order. By assigning each context a unique list and keeping track
535 ;; of these in a hash table, we can easily switch the face
536 ;; corresponding to a particular context by modifying the elements of
539 ;; More subtly, we make only the cdrs of this list shared among
540 ;; all text of a given context, allowing the cars to be different
541 ;; and for different elements of the context-specific text to have
542 ;; different styling.
544 ;; Additionally, we allow selective hiding of contexts via
545 ;; the buffer-invisibility-spec.
547 (defvar lurk-context-facelists (make-hash-table :test 'equal)
548 "List of seen contexts and associated face lists.")
550 (defun lurk-get-context-facelist (context)
551 (let* ((facelist (gethash context lurk-context-facelists)))
553 (setq facelist (list 'lurk-text))
554 (puthash context facelist lurk-context-facelists))
557 (defun lurk--fill-strings (col indent &rest strings)
559 (setq buffer-invisibility-spec nil)
560 (let ((fill-column col)
561 (adaptive-fill-regexp (rx-to-string `(= ,indent anychar))))
562 (apply #'insert strings)
563 (fill-region (point-min) (point-max) nil t)
566 (defun lurk-display-string (context prefix &rest strings)
567 (with-current-buffer "*lurk*"
569 (goto-char lurk-prompt-marker)
570 (let* ((inhibit-read-only t)
571 (old-pos (marker-position lurk-prompt-marker))
572 (padded-timestamp (concat (format-time-string "%H:%M ")))
573 (padded-prefix (if prefix (concat prefix " ") ""))
574 (context-atom (if context
575 (intern (lurk-context->string context))
577 (context-face (lurk-get-context-facelist context)))
578 (insert-before-markers
581 (+ (length padded-timestamp)
582 (length padded-prefix))
583 (propertize padded-timestamp
584 'face 'lurk-timestamp
587 'invisible context-atom)
588 (propertize padded-prefix
591 'invisible context-atom)
593 (propertize (concat (apply #'lurk-buttonify-urls strings) "\n")
597 'invisible context-atom)))))))
598 (lurk-scroll-windows-to-last-line))
600 (defun lurk-click-context (button)
601 (lurk-switch-to-context (button-get button 'context))
602 (lurk-highlight-current-context)
605 (lurk-zoom-in (lurk-current-context))))
607 (defun lurk-make-context-button (context &optional string)
609 (let ((label (or string (lurk-context->string context))))
610 (insert-text-button label
611 'action #'lurk-click-context
614 'help-echo "Switch context"))
617 (defun lurk-display-message (network from to text)
618 (let ((context (if (string-prefix-p "#" to)
619 (lurk-get-context network to)
620 (lurk-get-context network))))
624 (if (lurk-network-context-p context)
625 (concat "[" from "->" to "]")
627 (lurk-make-context-button context)
629 'face (lurk-get-context-facelist context))
632 (defun lurk-display-action (network from to action-text)
633 (let ((context (if (string-prefix-p "#" to)
634 (lurk-get-context network to)
635 (lurk-get-context network))))
639 (concat (lurk-context->string context) " *")
640 'face (lurk-get-context-facelist context))
641 from " " action-text)))
643 (defun lurk-display-notice (context &rest notices)
646 (propertize lurk-notice-prefix 'face 'lurk-notice)
647 (apply #'concat notices)))
649 (defun lurk-display-error (&rest messages)
652 (propertize lurk-error-prefix 'face 'lurk-error)
653 (apply #'concat messages)))
655 (defun lurk-highlight-current-context ()
656 (with-current-buffer "*lurk*"
658 (lambda (this-context facelist)
659 (if (equal this-context (lurk-current-context))
660 (setcar facelist 'lurk-text)
661 (setcar facelist 'lurk-faded)))
662 lurk-context-facelists))
663 (force-window-update "*lurk*"))
665 (defun lurk-zoom-in (context)
666 (with-current-buffer "*lurk*"
668 (lambda (this-context _)
670 (let ((this-context-atom
671 (intern (lurk-context->string this-context))))
672 (if (equal this-context context)
673 (remove-from-invisibility-spec this-context-atom)
674 (add-to-invisibility-spec this-context-atom)))))
675 lurk-context-facelists)
676 (force-window-update "*lurk*"))
677 (lurk-scroll-windows-to-last-line))
679 (defun lurk-zoom-out ()
680 (with-current-buffer "*lurk*"
682 (lambda (this-context _)
683 (let ((this-context-atom
685 (intern (lurk-context->string this-context))
687 (remove-from-invisibility-spec this-context-atom)))
688 lurk-context-facelists)
689 (force-window-update "*lurk*"))
690 (lurk-scroll-windows-to-last-line))
692 (defun lurk--start-of-final-line ()
693 (with-current-buffer "*lurk*"
695 (goto-char (point-max))
696 (line-beginning-position))))
698 (defun lurk-scroll-windows-to-last-line ()
699 (with-current-buffer "*lurk*"
700 (dolist (window (get-buffer-window-list))
701 (if (>= (window-point window) (lurk--start-of-final-line))
702 (with-selected-window window
705 (defconst lurk-url-regex
709 (group (or (+ (any alnum "." "-"))
710 (+ (any alnum ":"))))
711 (opt (group (: ":" (+ digit))))
714 (* (any alnum "-/.,#:%=&_?~@+"))
715 (any alnum "-/#:%=&_~@+")))))))
716 "Imperfect regex used to find URLs in plain text.")
718 (defun lurk-click-url (button)
719 (browse-url (button-get button 'url)))
721 (defun lurk-buttonify-urls (&rest strings)
722 "Turn substrings which look like urls in STRING into clickable buttons."
724 (apply #'insert strings)
725 (goto-char (point-min))
726 (while (re-search-forward lurk-url-regex nil t)
727 (let ((url (match-string 0)))
728 (make-text-button (match-beginning 0)
730 'action #'lurk-click-url
734 'help-echo "Open URL in browser.")))
737 (defun lurk-add-formatting (string)
740 (goto-char (point-min))
745 (prev-point (point)))
746 (while (re-search-forward (rx (or (any "\x02\x1D\x1F\x1E\x0F")
747 (: "\x03" (* digit) (opt "," (* digit)))))
749 (let ((beg (+ (match-beginning 0) 1)))
751 (add-face-text-property prev-point beg '(:weight bold)))
753 (add-face-text-property prev-point beg '(:slant italic)))
755 (add-face-text-property prev-point beg '(:underline t)))
757 (add-face-text-property prev-point beg '(:strike-through t)))
758 (pcase (match-string 0)
759 ("\x02" (setq bold (not bold)))
760 ("\x1D" (setq italics (not italics)))
761 ("\x1F" (setq underline (not underline)))
762 ("\x1E" (setq strikethrough (not strikethrough)))
767 (setq strikethrough nil))
769 (delete-region (match-beginning 0) (match-end 0))
770 (setq prev-point (point)))))
774 ;;; Message evaluation
777 (defun lurk-eval-msg-string (network string)
779 (lurk-display-string nil nil string))
780 (let* ((msg (lurk-string->msg string)))
781 (lurk-process-autoreplies network msg)
782 (pcase (lurk-msg-cmd msg)
784 (lurk-send-msg network
785 (lurk-msg nil nil "PONG" (lurk-msg-params msg))))
790 (let* ((params (lurk-msg-params msg))
791 (nick (elt params 0))
792 (text (string-join (seq-drop params 1) " ")))
793 (lurk-set-connection-nick network nick)
794 (lurk-display-notice (lurk-get-context network) text))
795 (let* ((row (assoc network lurk-networks))
796 (channels (if (memq :channels row)
797 (cdr (memq :channels row))
799 (dolist (channel channels)
800 (lurk-command-join (list channel)))))
803 (let* ((params (lurk-msg-params msg))
804 (channel (elt params 2))
805 (names (split-string (elt params 3)))
806 (ctx (lurk-get-context network channel)))
808 (lurk-add-context-users ctx names)
809 (lurk-display-notice ctx "Users in " channel
810 ": " (string-join names " ")))))
813 (let* ((params (lurk-msg-params msg))
814 (channel (elt params 1))
815 (ctx (lurk-get-context network channel)))
819 (lurk--as-string (length (lurk-get-context-users ctx)))
820 " users in " channel)
821 (lurk-display-notice (lurk-get-context network)
822 "End of " channel " names list."))))
825 (let* ((params (lurk-msg-params msg))
826 (channel (elt params 1))
827 (ctx (lurk-get-context network channel)))
828 (lurk-display-notice ctx "No topic set.")))
831 (let* ((params (lurk-msg-params msg))
832 (channel (elt params 1))
833 (topic (elt params 2))
834 (ctx (lurk-get-context network channel)))
835 (lurk-display-notice ctx "Topic: " topic)))
837 ((rx (= 3 (any digit)))
838 (lurk-display-notice (lurk-get-context network)
839 (mapconcat 'identity (cdr (lurk-msg-params msg)) " ")))
842 (guard (equal (lurk-connection-nick network)
843 (lurk-msg-src msg))))
844 (let* ((channel (car (lurk-msg-params msg)))
845 (context (list network channel)))
846 (lurk-add-context context)
847 (lurk-del-all-context-users context)
848 (lurk-display-notice (lurk-current-context)
849 "Joining channel " channel " on " network)
850 (lurk-highlight-current-context)
851 (lurk-render-prompt)))
854 (let* ((channel (car (lurk-msg-params msg)))
855 (nick (lurk-msg-src msg))
856 (ctx (lurk-get-context network channel)))
857 (lurk-add-context-users ctx (list nick))
859 (lurk-display-notice ctx nick " joined channel " channel
863 (guard (equal (lurk-connection-nick network)
864 (lurk-msg-src msg))))
865 (let* ((channel (car (lurk-msg-params msg)))
866 (context (list network channel)))
867 (lurk-display-notice context "Left channel " channel)
868 (lurk-remove-context context)
869 (lurk-del-all-context-users context)
870 (lurk-highlight-current-context)
871 (lurk-render-prompt)))
874 (let* ((channel (car (lurk-msg-params msg)))
875 (nick (lurk-msg-src msg))
876 (ctx (lurk-get-context network channel)))
877 (lurk-del-context-user ctx nick)
879 (lurk-display-notice ctx nick " left channel " channel
883 (guard (equal (lurk-connection-nick network)
884 (lurk-msg-src msg))))
885 (let ((new-nick (car (lurk-msg-params msg)))
886 (old-nick (lurk-connection-nick network)))
887 (lurk-set-connection-nick network new-nick)
888 (lurk-rename-network-user network old-nick new-nick)
889 (lurk-display-notice (lurk-get-context network)
890 "Nick set to " new-nick " on " network)))
893 (let ((old-nick (lurk-msg-src msg))
894 (new-nick (car (lurk-msg-params msg))))
895 (lurk-display-notice (lurk-get-context network)
896 old-nick " is now known as " new-nick
898 (lurk-rename-network-user network old-nick new-nick)))
901 (let ((channel (car (lurk-msg-params msg)))
902 (nick (lurk-msg-src msg))
903 (topic (cadr (lurk-msg-params msg))))
904 (lurk-display-notice (lurk-get-context network channel)
905 nick " set the topic: " topic)))
908 (let ((nick (lurk-msg-src msg))
909 (reason (mapconcat 'identity (lurk-msg-params msg) " ")))
910 (lurk-del-network-user network nick)
912 (lurk-display-notice (lurk-get-context network)
913 nick " on " network " has quit: " reason))))
916 (let ((nick (lurk-msg-src msg))
917 (channel (car (lurk-msg-params msg)))
918 (text (cadr (lurk-msg-params msg))))
920 ((rx (: "\01VERSION "
921 (let version (* (not "\01")))
923 (lurk-display-notice (lurk-get-context network)
924 "CTCP version reply from " nick ": " version))
926 (lurk-display-notice (lurk-get-context network channel) text)))))
929 (let* ((from (lurk-msg-src msg))
930 (params (lurk-msg-params msg))
932 (text (cadr params)))
935 (let ((version-string (concat lurk-version " - running on GNU Emacs " emacs-version)))
936 (lurk-send-msg network
937 (lurk-msg nil nil "NOTICE"
938 (list from (concat "\01VERSION "
941 (lurk-display-notice (lurk-get-context network)
942 "CTCP version request received from "
943 from " on " network))
945 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
946 (lurk-send-msg network (lurk-msg nil nil "NOTICE" (list from ping)))
947 (lurk-display-notice (lurk-get-context network)
948 "CTCP ping received from " from " on " network))
951 (lurk-display-notice (lurk-get-context network)
952 "CTCP userinfo request from " from
953 " on " network " (no response sent)"))
956 (lurk-display-notice (lurk-get-context network)
957 "CTCP clientinfo request from " from
958 " on " network " (no response sent)"))
960 ((rx (: "\01ACTION " (let action-text (* (not "\01"))) "\01"))
961 (lurk-display-action network from to action-text))
964 (lurk-display-message network from to text)))))
967 (lurk-display-notice (lurk-get-context network)
968 (lurk-msg->string msg))))))
971 ;;; User-defined responses
974 (defun lurk--lists-equal (l1 l2)
976 (if (or (not (and (car l1) (car l2)))
977 (string-match (car l1) (car l2)))
978 (lurk--lists-equal (cdr l1) (cdr l2))
982 (defun lurk-process-autoreply (network msg autoreply)
983 (let ((matcher (car autoreply))
984 (reply (cadr autoreply)))
985 (let ((target-network (car matcher)))
986 (when (and (or (not target-network)
987 (and (equal network target-network)))
988 (lurk--lists-equal (cdr matcher)
989 (append (list (lurk-msg-src msg)
991 (lurk-msg-params msg))))
992 (lurk-send-msg network
993 (lurk-msg nil nil (car reply) (cdr reply)))))))
995 (defun lurk-process-autoreplies (network msg)
998 (lurk-process-autoreply network msg autoreply))
999 lurk-autoreply-table))
1005 (defvar lurk-command-table
1006 '(("DEBUG" "Toggle debug mode on/off." lurk-command-debug lurk-boolean-completions)
1007 ("HEADER" "Toggle display of header." lurk-command-header lurk-boolean-completions)
1008 ("SHOWJOINS" "Toggles display of joins/parts." lurk-command-showjoins lurk-boolean-completions)
1009 ("NETWORKS" "List known IRC networks." lurk-command-networks)
1010 ("CONNECT" "Connect to an IRC network." lurk-command-connect lurk-network-completions)
1011 ("QUIT" "Disconnect from current network." lurk-command-quit)
1012 ("JOIN" "Join one or more channels." lurk-command-join)
1013 ("PART" "Leave channel." lurk-command-part lurk-channel-completions)
1014 ("SWITCHCONTEXT" "Switch current context" lurk-command-switch-context lurk-context-completions)
1015 ("NICK" "Change nick." lurk-command-nick)
1016 ("LIST" "Display details of one or more channels." lurk-command-list)
1017 ("TOPIC" "Set/query topic for current channel." lurk-command-topic)
1018 ("USERS" "List nicks of users in current channel." lurk-command-users)
1019 ("MSG" "Send private message to user." lurk-command-msg lurk-nick-completions)
1020 ("ME" "Display action." lurk-command-me)
1021 ("VERSION" "Request version of another user's client via CTCP." lurk-command-version lurk-nick-completions)
1022 ("CLEAR" "Clear buffer text." lurk-command-clear lurk-context-completions)
1023 ("HELP" "Display help on client commands." lurk-command-help lurk-help-completions))
1024 "Table of commands explicitly supported by lurk.")
1026 (defun lurk-boolean-completions ()
1029 (defun lurk-network-completions ()
1030 (mapcar (lambda (row) (car row)) lurk-networks))
1032 (defun lurk-help-completions ()
1033 (mapcar (lambda (row) (car row)) lurk-command-table))
1035 (defun lurk-channel-completions ()
1036 (mapcar (lambda (ctx)
1037 (lurk-context->string ctx))
1038 (seq-filter (lambda (ctx)
1039 (not (lurk-network-context-p ctx)))
1042 (defun lurk-context-completions ()
1043 (mapcar (lambda (ctx) (lurk-context->string ctx)) lurk-contexts))
1045 (defun lurk-command-help (params)
1047 (let* ((cmd-str (upcase (car params)))
1048 (row (assoc cmd-str lurk-command-table #'equal)))
1051 (lurk-display-notice nil "Help for \x02" cmd-str "\x02:")
1052 (lurk-display-notice nil " " (elt row 1)))
1053 (lurk-display-notice nil "No such (client-interpreted) command.")))
1054 (lurk-display-notice nil "Client-interpreted commands:")
1055 (dolist (row lurk-command-table)
1056 (lurk-display-notice nil " \x02" (elt row 0) "\x02: " (elt row 1)))
1057 (lurk-display-notice nil "Use /HELP COMMAND to display information about a specific command.")))
1059 (defun lurk-command-debug (params)
1062 (if (equal (upcase (car params)) "ON")
1066 (lurk-display-notice nil "Debug mode now " (if lurk-debug "on" "off") "."))
1068 (defun lurk-command-header (params)
1071 (equal (upcase (car params)) "ON")
1072 (not header-line-format))
1075 (lurk-display-notice nil "Header enabled."))
1076 (setq-local header-line-format nil)
1077 (lurk-display-notice nil "Header disabled.")))
1079 (defun lurk-command-showjoins (params)
1080 (setq lurk-show-joins
1082 (if (equal (upcase (car params)) "ON")
1085 (not lurk-show-joins)))
1086 (lurk-display-notice nil "Joins/parts will now be "
1087 (if lurk-show-joins "shown" "hidden") "."))
1089 (defun lurk-command-connect (params)
1091 (let ((network (car params)))
1092 (lurk-display-notice nil "Attempting to connect to " network "...")
1093 (lurk-connect network))
1094 (lurk-display-notice nil "Usage: /connect <network>")))
1096 (defun lurk-command-networks (_params)
1097 (lurk-display-notice nil "Currently-known networks:")
1098 (dolist (row lurk-networks)
1099 (seq-let (network network port &rest _others) row
1100 (lurk-display-notice nil "\t" network
1102 " " (number-to-string port) "]")))
1103 (lurk-display-notice nil "(Modify the `lurk-networks' variable to add more.)"))
1105 (defun lurk-command-quit (params)
1106 (let ((ctx (lurk-current-context)))
1108 (lurk-display-error "No current network")
1109 (let ((quit-msg (if params (string-join params " ") lurk-default-quit-msg)))
1111 (lurk-context-network ctx)
1112 (lurk-msg nil nil "QUIT" quit-msg))))))
1114 (defun lurk-command-join (params)
1116 (let ((network (lurk-context-network (lurk-current-context))))
1117 (dolist (channel params)
1118 (lurk-send-msg network (lurk-msg nil nil "JOIN" channel))))
1119 (lurk-display-notice nil "Usage: /join channel [channel2 ...]")))
1121 (defun lurk-command-part (params)
1123 ((not params) (lurk-current-context))
1124 ((seq-contains (car params) "@") (lurk-string->context (car params)))
1125 (t (list (lurk-context-network (lurk-current-context)) (car params))))))
1126 (let ((network (lurk-context-network ctx))
1127 (channel (lurk-context-channel ctx)))
1129 (lurk-send-msg network (lurk-msg nil nil "PART" channel))
1130 (lurk-display-error "Specify which channel to leave")))))
1132 (defun lurk-command-switch-context (params)
1134 (lurk-display-notice nil "Usage: /switchcontext #channel@network")
1135 (let ((ctx (lurk-string->context (car params))))
1136 (lurk-switch-to-context ctx)
1137 (lurk-highlight-current-context)
1138 (lurk-render-prompt)
1140 (lurk-zoom-in (lurk-current-context))))))
1142 (defun lurk-command-nick (params)
1144 (let ((new-nick (string-join params " "))
1145 (ctx (lurk-current-context)))
1147 (lurk-send-msg (lurk-context-network ctx)
1148 (lurk-msg nil nil "NICK" new-nick))
1149 (lurk-display-error "No current connection")))
1150 (lurk-display-notice nil "Usage: /nick <new-nick>")))
1152 (defun lurk-command-list (params)
1153 (let ((ctx (lurk-current-context)))
1156 (lurk-display-notice nil "This command can generate lots of output."
1157 " Use `/LIST -yes' if you really want this,"
1158 " or `/LIST <channel_regexp>' to reduce the output.")
1159 (let ((network (lurk-context-network ctx)))
1160 (if (equal (upcase (car params)) "-YES")
1161 (lurk-send-msg network (lurk-msg nil nil "LIST"))
1162 (lurk-send-msg network (lurk-msg nil nil "LIST"
1164 (lurk-display-error "No current connection"))))
1166 (defun lurk-command-topic (params)
1167 (let ((ctx (lurk-current-context)))
1168 (if (and ctx (not (lurk-network-context-p ctx)))
1169 (let ((network (lurk-context-network ctx))
1170 (channel (lurk-context-channel ctx)))
1172 (lurk-send-msg network
1173 (lurk-msg nil nil "TOPIC" channel
1174 (string-join params " ")))
1175 (lurk-send-msg network
1176 (lurk-msg nil nil "TOPIC" channel))))
1177 (lurk-display-notice nil "No current channel."))))
1179 (defun lurk-command-msg (params)
1180 (let ((network (lurk-context-network (lurk-current-context))))
1181 (if (and params (>= (length params) 2))
1182 (let ((to (car params))
1183 (text (string-join (cdr params) " ")))
1184 (lurk-send-msg network (lurk-msg nil nil "PRIVMSG" to text))
1185 (lurk-display-message network
1186 (lurk-connection-nick network)
1188 (lurk-display-notice nil "Usage: /msg <nick> <message>"))))
1190 (defun lurk-command-me (params)
1191 (let* ((ctx (lurk-current-context))
1192 (network (lurk-context-network ctx)))
1193 (if (and ctx (not (lurk-network-context-p ctx)))
1195 (let* ((channel (lurk-context-channel ctx))
1196 (my-nick (lurk-connection-nick network))
1197 (action (string-join params " "))
1198 (ctcp-text (concat "\01ACTION " action "\01")))
1199 (lurk-send-msg network
1200 (lurk-msg nil nil "PRIVMSG"
1201 (list channel ctcp-text)))
1202 (lurk-display-action network my-nick channel action))
1203 (lurk-display-notice nil "Usage: /me <action>"))
1204 (lurk-display-notice nil "No current channel."))))
1206 (defun lurk-command-version (params)
1207 (let ((ctx (lurk-current-context)))
1210 (let ((network (lurk-context-network ctx))
1211 (nick (car params)))
1212 (lurk-send-msg network
1213 (lurk-msg nil nil "PRIVMSG"
1214 (list nick "\01VERSION\01")))
1215 (lurk-display-notice ctx "CTCP version request sent to "
1216 nick " on " network))
1217 (lurk-display-notice ctx "Usage: /version <nick>"))
1218 (lurk-display-notice nil "No current channel."))))
1220 (defun lurk-command-users (_params)
1221 (let ((ctx (lurk-current-context)))
1222 (if (and ctx (not (lurk-network-context-p ctx)))
1223 (let ((channel (lurk-context-channel ctx))
1224 (network (lurk-context-network ctx))
1225 (users (lurk-get-context-users ctx)))
1226 (lurk-display-notice ctx "Users in " channel " on " network ":")
1227 (lurk-display-notice ctx (string-join users " ")))
1228 (lurk-display-notice nil "No current channel."))))
1231 ;;; Command entering
1234 (defun lurk-enter-string (string)
1235 (if (string-prefix-p "/" string)
1237 ((rx (: "/" (let cmd-str (+ (not whitespace)))
1239 (let params-str (+ anychar))
1241 (let ((command-row (assoc (upcase cmd-str) lurk-command-table #'equal))
1242 (params (if params-str
1243 (split-string params-str nil t)
1245 (if (and command-row (elt command-row 2))
1246 (funcall (elt command-row 2) params)
1248 (lurk-context-network (lurk-current-context))
1249 (lurk-msg nil nil (upcase cmd-str) params)))))
1251 (lurk-display-error "Badly formed command")))
1252 (unless (string-empty-p string)
1253 (let ((ctx (lurk-current-context)))
1255 (if (not (lurk-network-context-p ctx))
1256 (let ((network (lurk-context-network ctx))
1257 (channel (lurk-context-channel ctx)))
1258 (lurk-send-msg network
1259 (lurk-msg nil nil "PRIVMSG" channel string))
1260 (lurk-display-message network
1261 (lurk-connection-nick network)
1263 (lurk-display-error "No current channel"))
1264 (lurk-display-error "No current context"))))))
1270 (defvar lurk-history nil
1271 "Commands and messages sent in current session.")
1273 (defvar lurk-history-index nil)
1275 (defun lurk-history-cycle (delta)
1277 (with-current-buffer "*lurk*"
1278 (if lurk-history-index
1279 (setq lurk-history-index
1281 (min (- (length lurk-history) 1)
1282 (+ delta lurk-history-index))))
1283 (setq lurk-history-index 0))
1284 (delete-region lurk-input-marker (point-max))
1285 (insert (elt lurk-history lurk-history-index)))))
1288 ;;; Interactive commands
1291 (defun lurk-enter ()
1292 "Enter current contents of line after prompt."
1294 (with-current-buffer "*lurk*"
1295 (let ((line (buffer-substring lurk-input-marker (point-max))))
1296 (push line lurk-history)
1297 (setq lurk-history-index nil)
1298 (let ((inhibit-read-only t))
1299 (delete-region lurk-input-marker (point-max)))
1300 (lurk-enter-string line))))
1302 (defun lurk-history-next ()
1304 (lurk-history-cycle -1))
1306 (defun lurk-history-prev ()
1308 (lurk-history-cycle +1))
1310 (defun lurk-cycle-contexts-forward ()
1312 (lurk-cycle-contexts)
1313 (lurk-highlight-current-context)
1314 (lurk-render-prompt)
1316 (lurk-zoom-in (lurk-current-context))))
1318 (defun lurk-cycle-contexts-reverse ()
1320 (lurk-cycle-contexts t)
1321 (lurk-highlight-current-context)
1322 (lurk-render-prompt)
1324 (lurk-zoom-in (lurk-current-context))))
1326 (defvar lurk-zoomed nil
1327 "Keeps track of zoom status.")
1329 (defun lurk-toggle-zoom ()
1333 (lurk-zoom-in (lurk-current-context)))
1334 (setq lurk-zoomed (not lurk-zoomed)))
1337 (defun lurk-complete-input ()
1339 (let ((completion-ignore-case t))
1340 (when (>= (point) lurk-input-marker)
1341 (pcase (buffer-substring lurk-input-marker (point))
1342 ((rx (: "/" (let cmd-str (+ (not whitespace))) (+ " ") (* (not whitespace)) string-end))
1343 (let ((space-idx (save-excursion
1344 (re-search-backward " " lurk-input-marker t)))
1345 (table-row (assoc (upcase cmd-str) lurk-command-table #'equal)))
1346 (if (and table-row (elt table-row 3))
1347 (let* ((completions-nospace (funcall (elt table-row 3)))
1348 (completions (mapcar (lambda (el) (concat el " ")) completions-nospace)))
1349 (completion-in-region (+ 1 space-idx) (point) completions)))))
1350 ((rx (: "/" (* (not whitespace)) string-end))
1351 (message (buffer-substring lurk-input-marker (point)))
1352 (completion-in-region lurk-input-marker (point)
1353 (mapcar (lambda (row) (concat "/" (car row) " "))
1354 lurk-command-table)))
1356 (let* ((end (max lurk-input-marker (point)))
1357 (space-idx (save-excursion
1358 (re-search-backward " " lurk-input-marker t)))
1359 (start (if space-idx (+ 1 space-idx) lurk-input-marker)))
1360 (unless (string-prefix-p "/" (buffer-substring start end))
1361 (let* ((users (lurk-get-context-users (lurk-current-context)))
1363 (lambda (u) (car (split-string u "@" t)))
1365 (completion-in-region start end users-no@)))))))))
1370 (defvar lurk-mode-map
1371 (let ((map (make-sparse-keymap)))
1372 (define-key map (kbd "RET") 'lurk-enter)
1373 (define-key map (kbd "TAB") 'lurk-complete-input)
1374 (define-key map (kbd "C-c C-z") 'lurk-toggle-zoom)
1375 (define-key map (kbd "<C-up>") 'lurk-history-prev)
1376 (define-key map (kbd "<C-down>") 'lurk-history-next)
1377 (define-key map (kbd "<C-tab>") 'lurk-cycle-contexts-forward)
1378 (define-key map (kbd "<C-S-iso-lefttab>") 'lurk-cycle-contexts-reverse)
1379 (define-key map (kbd "<C-S-tab>") 'lurk-cycle-contexts-reverse)
1380 (when (fboundp 'evil-define-key*)
1381 (evil-define-key* 'motion map
1382 (kbd "TAB") 'lurk-complete-input))
1385 (define-derived-mode lurk-mode text-mode "lurk"
1386 "Major mode for lurk.")
1388 (when (fboundp 'evil-set-initial-state)
1389 (evil-set-initial-state 'lurk-mode 'insert))
1391 ;;; Main start procedure
1396 "Start lurk or just switch to the lurk buffer if one already exists."
1398 (if (get-buffer "*lurk*")
1399 (switch-to-buffer "*lurk*")
1400 (switch-to-buffer "*lurk*")
1402 (lurk-setup-buffer))
1405 ;;; lurk.el ends here