1 ;;; lurk.el --- Little Unibuffer iRc Klient -*- lexical-binding:t -*-
3 ;; Copyright (C) 2021 Tim Vaughan
5 ;; Author: Tim Vaughan <timv@ughan.xyz>
6 ;; Created: 14 June 2021
9 ;; Homepage: http://thelambdalab.xyz/lurk
10 ;; Package-Requires: ((emacs "26"))
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/>.
38 "Little Unibuffer iRc Klient."
41 (defcustom lurk-nick "plugd"
44 (defcustom lurk-default-quit-msg "Bye"
45 "Default quit message when none supplied.")
47 (defcustom lurk-networks
48 '(("libera" "irc.libera.chat" 6697))
51 (defcustom lurk-allow-ipv6 nil
52 "Set to non-nil to allow use of IPv6.")
54 (defcustom lurk-show-joins nil
55 "Set to non-nil to be notified of joins, parts and quits.")
57 (defcustom lurk-display-header t
58 "If non-nil, use buffer header to display information on current host and channel.")
64 '((t :inherit default))
65 "Face used for Lurk text.")
68 '((t :inherit font-lock-keyword-face))
69 "Face used for the prompt.")
72 '((t :inherit lurk-context))
73 "Face used for the context name in the prompt.")
76 '((t :inherit shadow))
77 "Face used for faded Lurk text.")
79 (defface lurk-timestamp
80 '((t :inherit shadow))
81 "Face used for timestamps.")
85 "Face used for Lurk error text.")
88 '((t :inherit warning))
89 "Face used for Lurk notice text.")
94 (defvar lurk-version "Lurk v0.1"
95 "Value of this string is used in response to CTCP version queries.")
97 (defvar lurk-notice-prefix "-!-")
99 (defvar lurk-error-prefix "!!!")
101 (defvar lurk-prompt-string ">")
103 (defvar lurk-debug nil
104 "If non-nil, enable debug mode.")
107 ;;; Utility procedures
110 (defun lurk--filtered-join (&rest args)
111 (string-join (seq-filter (lambda (el) el) args) " "))
113 (defun lurk--as-string (obj)
115 (with-output-to-string (princ obj))
122 (defvar lurk-response "")
124 (defun lurk-filter (proc string)
125 (dolist (line (split-string (concat lurk-response string) "\n"))
126 (if (string-suffix-p "\r" line)
127 (lurk-eval-msg-string (string-trim line))
128 (setq lurk-response line))))
130 (defun lurk-sentinel (proc string)
131 (unless (equal "open" (string-trim string))
132 (lurk-display-error "Disconnected from server.")
133 (clrhash lurk-contexts)
134 (lurk-set-current-context nil)
136 (cancel-timer lurk-ping-timer)))
138 (defun lurk-start-process (network)
139 (let* ((row (assoc network lurk-networks))
142 (flags (seq-drop row 3)))
143 (make-network-process :name "lurk"
146 :family (if lurk-allow-ipv6 nil 'ipv4)
147 :filter #'lurk-filter
148 :sentinel #'lurk-sentinel
150 :tls-parameters (if (memq :notls flags)
152 (cons 'gnutls-x509pki
153 (gnutls-boot-parameters
154 :type 'gnutls-x509pki
158 (defvar lurk-ping-timer nil)
159 (defvar lurk-ping-period 60)
161 (defun lurk-ping-function ()
162 (lurk-send-msg (lurk-msg nil nil "PING" (car (process-contact (get-process "lurk")))))
163 (setq lurk-ping-timer (run-with-timer lurk-ping-period nil #'lurk-ping-function)))
165 (defun lurk-connect (network)
166 (if (get-process "lurk")
167 (lurk-display-error "Already connected. Disconnect first.")
168 (if (not (assoc network lurk-networks))
169 (lurk-display-error "Network '" network "' is unknown.")
170 (clrhash lurk-contexts)
171 (lurk-set-current-context nil)
172 (lurk-start-process network)
173 (lurk-send-msg (lurk-msg nil nil "USER" lurk-nick 0 "*" lurk-nick))
174 (lurk-send-msg (lurk-msg nil nil "NICK" lurk-nick))
175 (setq lurk-ping-timer (run-with-timer lurk-ping-period nil #'lurk-ping-function)))))
177 (defun lurk-connected-p ()
178 (let ((proc (get-process "lurk")))
179 (and proc (eq (process-status proc) 'open))))
181 (defun lurk-send-msg (msg)
183 (lurk-display-string nil nil (lurk-msg->string msg)))
184 (let ((proc (get-process "lurk")))
185 (if (and proc (eq (process-status proc) 'open))
186 (process-send-string proc (concat (lurk-msg->string msg) "\r\n"))
187 (lurk-display-error "No server connection established.")
188 (error "No server connection established"))))
194 (defun lurk-msg (tags src cmd &rest params)
195 (list (lurk--as-string tags)
196 (lurk--as-string src)
197 (upcase (lurk--as-string cmd))
198 (mapcar #'lurk--as-string
199 (if (and params (listp (elt params 0)))
203 (defun lurk-msg-tags (msg) (elt msg 0))
204 (defun lurk-msg-src (msg) (elt msg 1))
205 (defun lurk-msg-cmd (msg) (elt msg 2))
206 (defun lurk-msg-params (msg) (elt msg 3))
207 (defun lurk-msg-trail (msg)
208 (let ((params (lurk-msg-params msg)))
210 (elt params (- (length params) 1)))))
212 (defvar lurk-msg-regex
214 (opt (: "@" (group (* (not (or "\n" "\r" ";" " ")))))
216 (opt (: ":" (: (group (* (not (any space "!" "@"))))
217 (* (not (any space)))))
219 (group (: (* (not whitespace))))
221 (opt (group (+ not-newline))))
222 "Regex used to parse IRC messages.
223 Note that this regex is incomplete. Noteably, we discard the non-nick
224 portion of the source component of the message, as LURK doesn't use this.")
226 (defun lurk-string->msg (string)
227 (if (string-match lurk-msg-regex string)
228 (let* ((tags (match-string 1 string))
229 (src (match-string 2 string))
230 (cmd (upcase (match-string 3 string)))
231 (params-str (match-string 4 string))
234 (let* ((idx (cl-search ":" params-str))
235 (l (split-string (string-trim (substring params-str 0 idx))))
236 (r (if idx (list (substring params-str (+ 1 idx))) nil)))
239 (apply #'lurk-msg (append (list tags src cmd) params)))
240 (error "Failed to parse string " string)))
242 (defun lurk-msg->string (msg)
243 (let ((tags (lurk-msg-tags msg))
244 (src (lurk-msg-src msg))
245 (cmd (lurk-msg-cmd msg))
246 (params (lurk-msg-params msg)))
248 (if tags (concat "@" tags) nil)
249 (if src (concat ":" src) nil)
251 (if (> (length params) 1)
252 (string-join (seq-take params (- (length params) 1)) " ")
254 (if (> (length params) 0)
255 (concat ":" (elt params (- (length params) 1)))
262 (defvar lurk-current-context nil)
263 (defvar lurk-contexts (make-hash-table :test #'equal))
265 (defun lurk-add-context (name)
266 (puthash name nil lurk-contexts))
268 (defun lurk-del-context (name)
269 (remhash name lurk-contexts))
271 (defun lurk-get-context-users (name)
272 (gethash name lurk-contexts))
274 (defun lurk-context-known-p (name)
275 (not (eq (gethash name lurk-contexts 0) 0)))
277 (defun lurk-add-context-users (context users)
280 (gethash context lurk-contexts))
283 (defun lurk-del-context-user (context user)
285 (remove user (gethash context lurk-contexts))
288 (defun lurk-del-user (user)
289 (dolist (context (lurk-get-context-list))
290 (lurk-del-context-user context user)))
292 (defun lurk-rename-user (old-nick new-nick)
293 (dolist (context (lurk-get-context-list))
294 (lurk-del-context-user context old-nick)
295 (lurk-add-context-users context (list new-nick))))
297 (defun lurk-get-context-type (name)
299 ((string-prefix-p "#" name) 'channel)
300 ((string-match-p (rx (or "." "localhost")) name) 'host)
303 (defun lurk-get-context-list ()
305 (maphash (lambda (key val)
306 (cl-pushnew key res))
310 (defun lurk-get-next-context (&optional prev)
311 (if lurk-current-context
312 (let* ((context-list (if prev
313 (reverse (lurk-get-context-list))
314 (lurk-get-context-list)))
315 (context-list* (member lurk-current-context context-list)))
316 (if (> (length context-list*) 1)
321 (defun lurk-set-current-context (context)
322 (setq lurk-current-context context)
323 (lurk-highlight-context context)
326 (lurk-zoom-in lurk-current-context)))
328 (defun lurk-cycle-contexts (&optional rev)
329 (if lurk-current-context
330 (lurk-set-current-context (lurk-get-next-context rev))
331 (lurk-display-error "No channels joined.")))
337 (defun lurk-render-prompt ()
338 (with-current-buffer "*lurk*"
339 (let ((update-point (= lurk-input-marker (point)))
340 (update-window-points (mapcar (lambda (w)
341 (list (= (window-point w) lurk-input-marker)
343 (get-buffer-window-list nil nil t))))
345 (set-marker-insertion-type lurk-prompt-marker nil)
346 (set-marker-insertion-type lurk-input-marker t)
347 (let ((inhibit-read-only t))
348 (delete-region lurk-prompt-marker lurk-input-marker)
349 (goto-char lurk-prompt-marker)
351 (propertize (if lurk-current-context
356 (propertize lurk-prompt-string
359 (propertize " " ; Need this to be separate to mark it as rear-nonsticky
362 (set-marker-insertion-type lurk-input-marker nil))
364 (goto-char lurk-input-marker))
365 (dolist (v update-window-points)
367 (set-window-point (cadr v) lurk-input-marker))))))
369 (defvar lurk-prompt-marker nil
370 "Marker for prompt position in LURK buffer.")
372 (defvar lurk-input-marker nil
373 "Marker for prompt position in LURK buffer.")
375 (defun lurk-setup-header ()
376 (with-current-buffer "*lurk*"
377 (setq-local header-line-format
379 (let ((proc (get-process "lurk")))
382 "Host: " (car (process-contact proc))
384 (if lurk-current-context
389 (length (lurk-get-context-users lurk-current-context)))
394 (if lurk-zoomed " [ZOOMED]" ""))))))
396 (defun lurk-setup-buffer ()
397 (with-current-buffer (get-buffer-create "*lurk*")
398 (setq-local scroll-conservatively 1)
399 (setq-local buffer-invisibility-spec nil)
400 (if (markerp lurk-prompt-marker)
401 (set-marker lurk-prompt-marker (point-max))
402 (setq lurk-prompt-marker (point-max-marker)))
403 (if (markerp lurk-input-marker)
404 (set-marker lurk-input-marker (point-max))
405 (setq lurk-input-marker (point-max-marker)))
406 (goto-char (point-max))
408 (if lurk-display-header
409 (lurk-setup-header))))
411 (defun lurk-clear-buffer ()
412 "Completely erase all non-prompt and non-input text from lurk buffer."
413 (with-current-buffer "*lurk*"
414 (let ((inhibit-read-only t))
415 (delete-region (point-min) lurk-prompt-marker))))
417 ;;; Output formatting and highlighting
420 ;; Idea: the face text property can be a list of faces, applied in
421 ;; order. By assigning each context a unique list and keeping track
422 ;; of these in a hash table, we can easily switch the face
423 ;; corresponding to a particular context by modifying the elements of
426 ;; More subtly, we make only the cdrs of this list shared among
427 ;; all text of a given context, allowing the cars to be different
428 ;; and for different elements of the context-specific text to have
429 ;; different styling.
431 ;; Additionally, we allow selective hiding of contexts via
432 ;; the buffer-invisibility-spec.
434 (defvar lurk-context-facelists (make-hash-table :test 'equal)
435 "List of seen contexts and associated face lists.")
437 (defun lurk-get-context-facelist (context)
438 (let ((facelist (gethash context lurk-context-facelists)))
440 (setq facelist (list 'lurk-text))
441 (puthash context facelist lurk-context-facelists))
444 (defun lurk--fill-strings (col indent &rest strings)
446 (setq buffer-invisibility-spec nil)
447 (let ((fill-column col)
448 (adaptive-fill-regexp (rx-to-string `(= ,indent anychar))))
449 (apply #'insert strings)
450 (fill-region (point-min) (point-max) nil t)
453 (defun lurk--start-of-final-line ()
454 (with-current-buffer "*lurk*"
456 (goto-char (point-max))
457 (line-beginning-position))))
459 (defun lurk-scroll-windows-to-last-line ()
460 (with-current-buffer "*lurk*"
461 (dolist (window (get-buffer-window-list))
462 (if (>= (window-point window) (lurk--start-of-final-line))
463 (with-selected-window window
466 (defun lurk-make-context-button (context &optional label)
468 (insert-text-button (or label context)
469 'action #'lurk--context-button-action
471 'help-echo "Switch context.")
474 (defun lurk--context-button-action (button)
475 (let ((context (button-get button 'context)))
476 (if (eq lurk-current-context context)
478 (lurk-set-current-context context))))
480 (defun lurk-display-string (context prefix &rest strings)
481 (with-current-buffer "*lurk*"
483 (goto-char lurk-prompt-marker)
484 (let* ((inhibit-read-only t)
485 (old-pos (marker-position lurk-prompt-marker))
486 (padded-timestamp (concat (format-time-string "%H:%M ")))
487 (padded-prefix (if prefix (concat prefix " ") ""))
488 (context-atom (if context (intern context) nil)))
489 (insert-before-markers
492 (+ (length padded-timestamp)
493 (length padded-prefix))
494 (propertize padded-timestamp
495 'face 'lurk-timestamp
498 'invisible context-atom)
499 (propertize padded-prefix
502 'invisible context-atom)
504 (propertize (concat (apply #'lurk-buttonify-urls strings) "\n")
505 'face (lurk-get-context-facelist context)
508 'invisible context-atom)))))))
509 (lurk-scroll-windows-to-last-line))
511 (defun lurk-display-message (from to text)
512 (let ((context (if (eq 'channel (lurk-get-context-type to))
514 (if (equal to lurk-nick) from to))))
518 (pcase (lurk-get-context-type to)
520 (lurk-make-context-button to)
522 ('nick (lurk-make-context-button context (concat "[" from " -> " to "]")))
524 (error "Unsupported context type")))
525 'face (lurk-get-context-facelist context))
528 (defun lurk-display-action (from to action-text)
529 (let ((context (if (eq 'channel (lurk-get-context-type to))
531 (if (equal to lurk-nick) from to))))
535 (concat (lurk-make-context-button context) " * " from)
536 'face (lurk-get-context-facelist context))
539 (defun lurk-display-notice (context &rest notices)
542 (propertize lurk-notice-prefix 'face 'lurk-notice)
543 (apply #'concat notices)))
545 (defun lurk-display-error (&rest messages)
548 (propertize lurk-error-prefix 'face 'lurk-error)
549 (apply #'concat messages)))
551 (defun lurk-highlight-context (context)
553 (lambda (this-context facelist)
554 (if (equal this-context context)
555 (setcar facelist 'lurk-text)
556 (setcar facelist 'lurk-faded)))
557 lurk-context-facelists)
558 (force-window-update "*lurk*"))
560 (defun lurk-zoom-in (context)
561 (with-current-buffer "*lurk*"
563 (lambda (this-context _)
565 (let ((this-context-atom (intern this-context)))
566 (if (equal this-context context)
567 (remove-from-invisibility-spec this-context-atom)
568 (add-to-invisibility-spec this-context-atom)))))
569 lurk-context-facelists)
570 (force-window-update "*lurk*"))
571 (lurk-scroll-windows-to-last-line))
573 (defun lurk-zoom-out ()
574 (with-current-buffer "*lurk*"
576 (lambda (this-context _)
577 (let ((this-context-atom (if this-context (intern this-context) nil)))
578 (remove-from-invisibility-spec this-context-atom)))
579 lurk-context-facelists)
580 (force-window-update "*lurk*"))
581 (lurk-scroll-windows-to-last-line))
583 (defun lurk-clear-context (context)
584 (with-current-buffer "*lurk*"
586 (goto-char (point-min))
587 (let ((inhibit-read-only t)
589 (while (setq match (text-property-search-forward 'context context t))
590 (delete-region (prop-match-beginning match)
591 (prop-match-end match)))))))
593 (defconst lurk-url-regex
597 (group (or (+ (any alnum "." "-"))
598 (+ (any alnum ":"))))
599 (opt (group (: ":" (+ digit))))
602 (* (any alnum "-/.,#:%=&_?~@+"))
603 (any alnum "-/#:%=&_~@+")))))))
604 "Imperfect regex used to find URLs in plain text.")
606 (defun lurk-click-url (button)
607 (browse-url (button-get button 'url)))
609 (defun lurk-buttonify-urls (&rest strings)
610 "Turn substrings which look like urls in STRING into clickable buttons."
612 (apply #'insert strings)
613 (goto-char (point-min))
614 (while (re-search-forward lurk-url-regex nil t)
615 (let ((url (match-string 0)))
616 (make-text-button (match-beginning 0)
618 'action #'lurk-click-url
622 'help-echo "Open URL in browser.")))
625 (defun lurk-add-formatting (string)
628 (goto-char (point-min))
633 (prev-point (point)))
634 (while (re-search-forward (rx (or (any "\x02\x1D\x1F\x1E\x0F")
635 (: "\x03" (+ digit) (opt "," (* digit)))))
637 (let ((beg (+ (match-beginning 0) 1)))
639 (add-face-text-property prev-point beg '(:weight bold)))
641 (add-face-text-property prev-point beg '(:slant italic)))
643 (add-face-text-property prev-point beg '(:underline t)))
645 (add-face-text-property prev-point beg '(:strike-through t)))
646 (pcase (match-string 0)
647 ("\x02" (setq bold (not bold)))
648 ("\x1D" (setq italics (not italics)))
649 ("\x1F" (setq underline (not underline)))
650 ("\x1E" (setq strikethrough (not strikethrough)))
655 (setq strikethrough nil))
657 (delete-region (match-beginning 0) (match-end 0))
658 (setq prev-point (point)))))
662 ;;; Message evaluation
665 (defun lurk-eval-msg-string (string)
667 (lurk-display-string nil nil string))
668 (let* ((msg (lurk-string->msg string)))
669 (lurk-process-autoreplies msg)
670 (pcase (lurk-msg-cmd msg)
673 (lurk-msg nil nil "PONG" (lurk-msg-params msg))))
678 (let* ((params (lurk-msg-params msg))
679 (nick (elt params 0))
680 (text (string-join (seq-drop params 1) " ")))
681 (setq lurk-nick nick)
682 (lurk-display-notice nil text)))
685 (let* ((params (lurk-msg-params msg))
686 (channel (elt params 2))
687 (names (split-string (elt params 3))))
688 (if (lurk-context-known-p channel)
689 (lurk-add-context-users channel names)
690 (lurk-display-notice nil "Users in " channel ": " (string-join names " ")))))
693 (let* ((params (lurk-msg-params msg))
694 (channel (elt params 1)))
695 (if (lurk-context-known-p channel)
698 (lurk--as-string (length (lurk-get-context-users channel)))
699 " users in " channel)
700 (lurk-display-notice nil "End of " channel " names list."))))
703 (let* ((params (lurk-msg-params msg))
704 (channel (elt params 1)))
710 (let* ((params (lurk-msg-params msg))
711 (channel (elt params 1))
712 (topic (elt params 2)))
713 (lurk-display-notice channel "Topic: " topic)))
715 ("333") ; Avoid displaying these
717 ((rx (= 3 (any digit)))
718 (lurk-display-notice nil (mapconcat 'identity (cdr (lurk-msg-params msg)) " ")))
721 (guard (equal lurk-nick (lurk-msg-src msg))))
722 (let ((channel (car (lurk-msg-params msg))))
723 (lurk-add-context channel)
724 (lurk-set-current-context channel)
725 (lurk-display-notice channel "Joining channel " channel)
726 (lurk-render-prompt)))
729 (let ((channel (car (lurk-msg-params msg)))
730 (nick (lurk-msg-src msg)))
731 (lurk-add-context-users channel (list nick))
733 (lurk-display-notice channel nick " joined channel " channel))))
736 (guard (equal lurk-nick (lurk-msg-src msg))))
737 (let ((channel (car (lurk-msg-params msg))))
738 (lurk-display-notice channel "Left channel " channel)
739 (lurk-del-context channel)
740 (if (equal channel lurk-current-context)
741 (lurk-set-current-context (lurk-get-next-context)))
742 (lurk-render-prompt)))
745 (let ((channel (car (lurk-msg-params msg)))
746 (nick (lurk-msg-src msg)))
747 (lurk-del-context-user channel nick)
749 (lurk-display-notice channel nick " left channel " channel))))
752 (let ((kicker-nick (lurk-msg-src msg))
753 (channel (car (lurk-msg-params msg)))
754 (nick (cadr (lurk-msg-params msg)))
755 (reason (caddr (lurk-msg-params msg))))
756 (if (equal nick lurk-nick)
758 (lurk-display-notice channel kicker-nick " kicked you from " channel ": " reason)
759 (lurk-del-context channel)
760 (if (equal channel lurk-current-context)
761 (lurk-set-current-context (lurk-get-next-context)))
762 (lurk-render-prompt))
763 (lurk-del-context-user channel nick)
764 (lurk-display-notice channel kicker-nick " kicked " nick " from " channel ": " reason))))
767 (let ((nick (lurk-msg-src msg))
768 (reason (mapconcat 'identity (lurk-msg-params msg) " ")))
771 (lurk-display-notice nil nick " quit: " reason))))
774 (guard (equal lurk-nick (lurk-msg-src msg))))
775 (setq lurk-nick (car (lurk-msg-params msg)))
776 (lurk-display-notice nil "Set nick to " lurk-nick))
779 (let ((old-nick (lurk-msg-src msg))
780 (new-nick (car (lurk-msg-params msg))))
781 (lurk-display-notice nil old-nick " is now known as " new-nick)
782 (lurk-rename-user old-nick new-nick)))
785 (let ((nick (lurk-msg-src msg))
786 (channel (car (lurk-msg-params msg)))
787 (text (cadr (lurk-msg-params msg))))
789 ((rx (: "\01VERSION "
790 (let version (* (not "\01")))
792 (lurk-display-notice nil "CTCP version reply from " nick ": " version))
794 (lurk-display-notice nil text)))))
797 (let* ((from (lurk-msg-src msg))
798 (params (lurk-msg-params msg))
800 (text (cadr params)))
803 (let ((version-string (concat lurk-version " - running on GNU Emacs " emacs-version)))
804 (lurk-send-msg (lurk-msg nil nil "NOTICE"
805 (list from (concat "\01VERSION "
808 (lurk-display-notice nil "CTCP version request received from " from))
810 ((rx (let ping (: "\01PING " (* (not "\01")) "\01")))
811 (lurk-send-msg (lurk-msg nil nil "NOTICE" (list from ping)))
812 (lurk-display-notice from "CTCP ping received from " from))
815 (lurk-display-notice from "CTCP userinfo request from " from " (no response sent)"))
817 ((rx (: "\01ACTION " (let action-text (* (not "\01"))) "\01"))
818 (lurk-display-action from to action-text))
821 (lurk-display-message from to text)))))
823 (lurk-display-notice nil (lurk-msg->string msg))))))
826 ;;; User-defined responses
829 (defvar lurk-autoreply-table nil
830 "Table of autoreply messages.
832 Each autoreply is a list of two elements: (matcher reply)
834 Here matcher is a list:
836 (network src cmd params ...)
838 and reply is another list:
842 Each entry in the matcher list is a regular expression tested against the
843 corresponding values in the incomming message. Entries can be nil,
844 in which case they match anything.")
846 (defun lurk--lists-equal (l1 l2)
848 (if (or (not (and (car l1) (car l2)))
849 (string-match (car l1) (car l2)))
850 (lurk--lists-equal (cdr l1) (cdr l2))
854 (defun lurk-process-autoreply (msg autoreply)
855 (let ((matcher (car autoreply))
856 (reply (cadr autoreply)))
857 (let ((network (car matcher)))
858 (when (and (or (not network)
859 (and (get-process "lurk")
860 (equal (car (process-contact (get-process "lurk")))
861 (cadr (assoc network lurk-networks)))))
862 (lurk--lists-equal (cdr matcher)
863 (append (list (lurk-msg-src msg)
865 (lurk-msg-params msg))))
867 (lurk-msg nil nil (car reply) (cdr reply)))))))
869 (defun lurk-process-autoreplies (msg)
872 (lurk-process-autoreply msg autoreply))
873 lurk-autoreply-table))
879 (defvar lurk-command-table
880 '(("DEBUG" "Toggle debug mode on/off." lurk-command-debug lurk-boolean-completions)
881 ("HEADER" "Toggle display of header." lurk-command-header lurk-boolean-completions)
882 ("CONNECT" "Connect to an IRC network." lurk-command-connect lurk-network-completions)
883 ("NETWORKS" "List known IRC networks." lurk-command-networks)
884 ("JOIN" "Join one or more channels." lurk-command-join)
885 ("TOPIC" "Set topic for current channel." lurk-command-topic)
886 ("ME" "Display action." lurk-command-me)
887 ("VERSION" "Request version of another user's client via CTCP." lurk-command-version lurk-nick-completions)
888 ("PART" "Leave channel." lurk-command-part lurk-context-completions)
889 ("QUIT" "Disconnect from current network." lurk-command-quit)
890 ("NICK" "Change nick." lurk-command-nick)
891 ("LIST" "Display details of one or more channels." lurk-command-list)
892 ("WHOIS" "Ask server for details of nick." nil lurk-nick-completions)
893 ("USERS" "List nicks of users in current context." lurk-command-users)
894 ("MSG" "Send private message to user." lurk-command-msg lurk-nick-completions)
895 ("CLEAR" "Clear buffer text." lurk-command-clear lurk-context-completions)
896 ("HELP" "Display help on client commands." lurk-command-help lurk-help-completions))
897 "Table of commands explicitly supported by Lurk.")
899 (defun lurk-boolean-completions ()
902 (defun lurk-network-completions ()
903 (mapcar (lambda (row) (car row)) lurk-networks))
905 (defun lurk-nick-completions ()
906 (lurk-get-context-users lurk-current-context))
908 (defun lurk-context-completions ()
909 (lurk-get-context-list))
911 (defun lurk-help-completions ()
912 (mapcar (lambda (row) (car row)) lurk-command-table))
914 (defun lurk-command-help (params)
916 (let* ((cmd-str (upcase (car params)))
917 (row (assoc cmd-str lurk-command-table #'equal)))
920 (lurk-display-notice nil "Help for \x02" cmd-str "\x02:")
921 (lurk-display-notice nil " " (elt row 1)))
922 (lurk-display-notice nil "No such (client-interpreted) command.")))
923 (lurk-display-notice nil "Client-interpreted commands:")
924 (dolist (row lurk-command-table)
925 (lurk-display-notice nil " \x02" (elt row 0) "\x02: " (elt row 1)))
926 (lurk-display-notice nil "Use /HELP COMMAND to display information about a specific command.")))
928 (defun lurk-command-debug (params)
931 (if (equal (upcase (car params)) "ON")
935 (lurk-display-notice nil "Debug mode now " (if lurk-debug "on" "off") "."))
937 (defun lurk-command-header (params)
940 (equal (upcase (car params)) "ON")
941 (not header-line-format))
944 (lurk-display-notice nil "Header enabled."))
945 (setq-local header-line-format nil)
946 (lurk-display-notice nil "Header disabled.")))
948 (defun lurk-command-connect (params)
950 (let ((network (car params)))
951 (lurk-display-notice nil "Attempting to connect to " network "...")
952 (lurk-connect network))
953 (lurk-display-notice nil "Usage: /connect <network>")))
955 (defun lurk-command-networks (params)
956 (lurk-display-notice nil "Currently-known networks:")
957 (dolist (row lurk-networks)
958 (seq-let (network server port &rest others) row
959 (lurk-display-notice nil "\t" network
961 " " (number-to-string port) "]")))
962 (lurk-display-notice nil "(Modify the `lurk-networks' variable to add more.)"))
964 (defun lurk-command-join (params)
966 (dolist (channel params)
967 (lurk-send-msg (lurk-msg nil nil "JOIN" channel)))
968 (lurk-display-notice nil "Usage: /join channel [channel2 ...]")))
970 (defun lurk-command-part (params)
971 (let ((channel (if params (car params) lurk-current-context)))
973 (lurk-send-msg (lurk-msg nil nil "PART" channel))
974 (lurk-display-error "No current channel to leave."))))
976 (defun lurk-command-version (params)
978 (let ((nick (car params)))
979 (lurk-send-msg (lurk-msg nil nil "PRIVMSG"
980 (list nick "\01VERSION\01")))
981 (lurk-display-notice nil "CTCP version request sent to " nick))
982 (lurk-display-notice nil "Usage: /version <nick>")))
984 (defun lurk-command-quit (params)
985 (let ((quit-msg (if params (string-join params " ") lurk-default-quit-msg)))
986 (lurk-send-msg (lurk-msg nil nil "QUIT" quit-msg))))
988 (defun lurk-command-nick (params)
989 (let ((new-nick (if params (string-join params " ") nil)))
991 (if (lurk-connected-p)
992 (lurk-send-msg (lurk-msg nil nil "NICK" new-nick))
993 (setq lurk-nick new-nick)
994 (lurk-display-notice nil "Set default nick to '" lurk-nick "'."))
995 (lurk-display-notice nil "Current nick: " lurk-nick))))
997 (defun lurk-command-me (params)
998 (if lurk-current-context
1000 (let* ((action (string-join params " "))
1001 (ctcp-text (concat "\01ACTION " action "\01")))
1002 (lurk-send-msg (lurk-msg nil nil "PRIVMSG"
1003 (list lurk-current-context ctcp-text)))
1004 (lurk-display-action lurk-nick lurk-current-context action))
1005 (lurk-display-notice nil "Usage: /me <action>"))
1006 (lurk-display-notice nil "No current channel.")))
1008 (defun lurk-command-list (params)
1010 (lurk-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.")
1011 (if (equal (upcase (car params)) "-YES")
1012 (lurk-send-msg (lurk-msg nil nil "LIST"))
1013 (lurk-send-msg (lurk-msg nil nil "LIST" (car params))))))
1015 (defun lurk-command-topic (params)
1016 (if lurk-current-context
1018 (lurk-send-msg (lurk-msg nil nil "TOPIC" lurk-current-context (string-join params " ")))
1019 (lurk-display-notice nil "Usage: /topic <new topic>"))
1020 (lurk-display-notice nil "No current channel.")))
1022 (defun lurk-command-msg (params)
1023 (if (and params (>= (length params) 2))
1024 (let ((to (car params))
1025 (text (string-join (cdr params) " ")))
1026 (lurk-send-msg (lurk-msg nil nil "PRIVMSG" to text))
1027 (lurk-display-message lurk-nick to text))
1028 (lurk-display-notice nil "Usage: /msg <nick> <message>")))
1030 (defun lurk-command-clear (params)
1033 (dolist (context params)
1034 (lurk-clear-context context))))
1036 (defun lurk-command-users (params)
1037 (if lurk-current-context
1039 (lurk-display-notice lurk-current-context "Users in " lurk-current-context ":")
1040 (lurk-display-notice
1041 lurk-current-context
1042 (string-join (lurk-get-context-users lurk-current-context) " ")))
1043 (lurk-display-notice nil "No current channel.")))
1045 ;;; Command entering
1048 (defun lurk-enter-string (string)
1049 (if (string-prefix-p "/" string)
1051 ((rx (: "/" (let cmd-str (+ (not whitespace)))
1053 (let params-str (+ anychar))
1055 (let ((command-row (assoc (upcase cmd-str) lurk-command-table #'equal))
1056 (params (if params-str
1057 (split-string params-str nil t)
1059 (if (and command-row (elt command-row 2))
1060 (funcall (elt command-row 2) params)
1061 (lurk-send-msg (lurk-msg nil nil (upcase cmd-str) params)))))
1063 (lurk-display-error "Badly formed command.")))
1064 (unless (string-empty-p string)
1065 (if lurk-current-context
1067 (lurk-send-msg (lurk-msg nil nil "PRIVMSG"
1068 lurk-current-context
1070 (lurk-display-message lurk-nick lurk-current-context string))
1071 (lurk-display-error "No current context.")))))
1077 (defvar lurk-history nil
1078 "Commands and messages sent in current session.")
1080 (defvar lurk-history-index nil)
1082 (defun lurk-history-cycle (delta)
1084 (with-current-buffer "*lurk*"
1085 (if lurk-history-index
1086 (setq lurk-history-index
1088 (min (- (length lurk-history) 1)
1089 (+ delta lurk-history-index))))
1090 (setq lurk-history-index 0))
1091 (delete-region lurk-input-marker (point-max))
1092 (insert (elt lurk-history lurk-history-index)))))
1095 ;;; Interactive functions
1098 (defun lurk-cycle-contexts-forward ()
1100 (lurk-cycle-contexts))
1102 (defun lurk-cycle-contexts-reverse ()
1104 (lurk-cycle-contexts t))
1106 (defvar lurk-zoomed nil
1107 "Keeps track of zoom status.")
1109 (defun lurk-toggle-zoom ()
1113 (lurk-zoom-in lurk-current-context))
1114 (setq lurk-zoomed (not lurk-zoomed)))
1116 (defun lurk-history-next ()
1118 (lurk-history-cycle -1))
1120 (defun lurk-history-prev ()
1122 (lurk-history-cycle +1))
1124 (defun lurk-complete-input ()
1126 (let ((completion-ignore-case t))
1127 (when (>= (point) lurk-input-marker)
1128 (pcase (buffer-substring lurk-input-marker (point))
1129 ((rx (: "/" (let cmd-str (+ (not whitespace))) (+ " ") (* (not whitespace)) string-end))
1130 (let ((space-idx (save-excursion
1131 (re-search-backward " " lurk-input-marker t)))
1132 (table-row (assoc (upcase cmd-str) lurk-command-table #'equal)))
1133 (if (and table-row (elt table-row 3))
1134 (let* ((completions-nospace (funcall (elt table-row 3)))
1135 (completions (mapcar (lambda (el) (concat el " ")) completions-nospace)))
1136 (completion-in-region (+ 1 space-idx) (point) completions)))))
1137 ((rx (: "/" (* (not whitespace)) string-end))
1138 (message (buffer-substring lurk-input-marker (point)))
1139 (completion-in-region lurk-input-marker (point)
1140 (mapcar (lambda (row) (concat "/" (car row) " "))
1141 lurk-command-table)))
1143 (let* ((end (max lurk-input-marker (point)))
1144 (space-idx (save-excursion
1145 (re-search-backward " " lurk-input-marker t)))
1146 (start (if space-idx (+ 1 space-idx) lurk-input-marker)))
1147 (unless (string-prefix-p "/" (buffer-substring start end))
1148 (let* ((users (lurk-get-context-users lurk-current-context))
1150 (lambda (u) (car (split-string u "@" t)))
1152 (completion-in-region start end users-no@)))))))))
1154 (defun lurk-enter ()
1155 "Enter current contents of line after prompt."
1157 (with-current-buffer "*lurk*"
1158 (let ((line (buffer-substring lurk-input-marker (point-max))))
1159 (push line lurk-history)
1160 (setq lurk-history-index nil)
1161 (let ((inhibit-read-only t))
1162 (delete-region lurk-input-marker (point-max)))
1163 (lurk-enter-string line))))
1169 (defvar lurk-mode-map
1170 (let ((map (make-sparse-keymap)))
1171 (define-key map (kbd "RET") 'lurk-enter)
1172 (define-key map (kbd "TAB") 'lurk-complete-input)
1173 (define-key map (kbd "C-c C-z") 'lurk-toggle-zoom)
1174 (define-key map (kbd "<C-tab>") 'lurk-cycle-contexts-forward)
1175 (define-key map (kbd "<C-S-tab>") 'lurk-cycle-contexts-reverse)
1176 (define-key map (kbd "<C-up>") 'lurk-history-prev)
1177 (define-key map (kbd "<C-down>") 'lurk-history-next)
1178 (when (fboundp 'evil-define-key*)
1179 (evil-define-key* 'motion map
1180 (kbd "TAB") 'lurk-complete-input))
1183 (define-derived-mode lurk-mode text-mode "lurk"
1184 "Major mode for LURK.")
1186 (when (fboundp 'evil-set-initial-state)
1187 (evil-set-initial-state 'lurk-mode 'insert))
1190 ;;; Main start procedure
1193 (defun lurk (&optional network)
1194 "Start lurk or just switch to the lurk buffer if one already exists.
1195 Also connect to NETWORK if non-nil."
1197 (if (get-buffer "*lurk*")
1198 (switch-to-buffer "*lurk*")
1199 (switch-to-buffer "*lurk*")
1203 (lurk-command-connect (list network))))
1207 ;;; lurk.el ends here