From b37326a2c75f1296109c1a1574aac74eaaf419a4 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sun, 20 Jun 2021 23:57:10 +0200 Subject: [PATCH] Implemented CTCP version and ping. --- lirc.el | 133 ++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 115 insertions(+), 18 deletions(-) diff --git a/lirc.el b/lirc.el index 5301072..e6f47fb 100644 --- a/lirc.el +++ b/lirc.el @@ -54,6 +54,14 @@ ;;; Faces ;; +(defface lirc-text + '((t :inherit font-lock-preprocessor-face)) + "Face used for Lirc text.") + +(defface lirc-your-nick + '((t :inherit font-lock-constant-face)) + "Face used for highlighting your nick.") + (defface lirc-prompt '((t :inherit org-level-2)) "Face used for the prompt.") @@ -65,6 +73,8 @@ ;;; Global variables ;; +(defvar lirc-version "Lirc v0.1") + ;;; Network process ;; @@ -190,19 +200,24 @@ portion of the source component of the message, as LIRC doesn't use this.") (defun lirc-del-channel-users (channel-name &rest users) (let ((current-users (lirc-get-channel-users channel-name))) - (lirc-channel-set-users channel-name + (lirc-set-channel-users channel-name (cl-set-difference current-users users :test #'equal)))) ;;; Buffer ;; -(defun lirc-display-string (string) +(defun lirc-display-string (&rest strings) (with-current-buffer (get-buffer-create "*lirc*") (save-excursion (goto-char lirc-prompt-marker) (let ((inhibit-read-only t)) - (insert-before-markers (propertize (concat string "\n") 'read-only t)))))) + (insert-before-markers + (propertize (concat (format-time-string "%H:%M") " ") + 'face 'lirc-text + 'read-only t) + (propertize (concat (apply #'concat strings) "\n") + 'read-only t)))))) (defun lirc-connect () (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name)) @@ -250,18 +265,40 @@ portion of the source component of the message, as LIRC doesn't use this.") (goto-char (point-max)) (recenter -1))) + +;;; Output formatting +;; + +(defun lirc-display-action (channel nick action) + (lirc-display-string (concat " * " + (propertize (concat nick " " action) + 'face 'lirc-text)))) + +(defun lirc-display-message (channel nick message) + (lirc-display-string + (concat + (propertize (concat channel " ") + 'face 'lirc-text) + (propertize (concat "<" nick "> ") + 'face + (if (equal nick lirc-nick) + 'lirc-your-nick + 'lirc-text)) + (propertize message 'face 'lirc-text)))) + +(defun lirc-display-notice (&rest notices) + (lirc-display-string "*** " (apply #'concat notices))) + ;;; Message evaluation ;; (defun lirc-eval-msg-string (string) - (lirc-display-string string) + ;; (lirc-display-string string) (let* ((msg (lirc-string->msg string))) (pcase (lirc-msg-cmd msg) ("PING" (lirc-send-msg (lirc-msg nil nil "PONG" (lirc-msg-params msg)))) - ;; ((rx (= 3 digit)) - ;; (lirc-display-string (string-join (cdr (lirc-msg-params msg)) " "))) ("353" ; NAMEREPLY (let* ((params (lirc-msg-params msg)) @@ -269,6 +306,9 @@ portion of the source component of the message, as LIRC doesn't use this.") (names (split-string (elt params 3)))) (apply #'lirc-add-channel-users (cons channel names)))) + ((rx (= 3 (any digit))) + (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " "))) + ((and "JOIN" (guard (equal lirc-nick (lirc-msg-src msg)))) (let ((channel (car (lirc-msg-params msg)))) @@ -279,28 +319,68 @@ portion of the source component of the message, as LIRC doesn't use this.") ("JOIN" (let ((channel (car (lirc-msg-params msg))) (nick (lirc-msg-src msg))) - (lirc-add-channel-users channel nick))) + (lirc-add-channel-users channel nick))) ((and "PART" (guard (equal lirc-nick (lirc-msg-src msg)))) (setq lirc-current-channel nil) - (lirc-del-channel (car (lirc-msg-params msg)))) + (lirc-del-channel (car (lirc-msg-params msg))) + (lirc-render-prompt)) ("PART" (let ((channel (car (lirc-msg-params msg))) (nick (lirc-msg-src msg))) - (lirc-del-channel-users channel nick))) + (lirc-del-channel-users channel nick) + (lirc-display-notice nick " left channel " channel))) + + ("QUIT" + (let ((nick (lirc-msg-src msg)) + (reason (mapconcat 'identity (lirc-msg-params msg) " "))) + (lirc-del-users nick) + (lirc-display-notice nick " quit: " reason))) ((and "NICK" (guard (equal lirc-nick (lirc-msg-src msg)))) (setq lirc-nick (car (lirc-msg-params msg))) - (lirc-display-string (concat "*** Set nick to " lirc-nick))) + (lirc-display-notice "Set nick to " lirc-nick)) + + ("NOTICE" + (let ((nick (lirc-msg-src msg)) + (channel (car (lirc-msg-params msg))) + (text (cadr (lirc-msg-params msg)))) + (pcase text + ((rx (: "\01VERSION " + (let version (* (not "\01"))) + "\01")) + (lirc-display-notice "CTCP version reply from " nick ": " version))))) ("PRIVMSG" (let ((nick (lirc-msg-src msg)) (channel (car (lirc-msg-params msg))) (text (cadr (lirc-msg-params msg)))) - (lirc-display-string (concat channel " <" nick "> " text)))) + (pcase text + ((rx (: "\01ACTION " + (let action (* (not "\01"))) + "\01")) + (lirc-display-action nick action)) + + ("\01VERSION\01" + (let ((version-string (concat lirc-version " - running on GNU Emacs " emacs-version))) + (lirc-send-msg (lirc-msg nil nil "NOTICE" + (list nick (concat "\01VERSION " + version-string + "\01"))))) + (lirc-display-notice "CTCP version request received from " nick)) + + ((rx (let ping (: "\01PING " (* (not "\01")) "\01"))) + (lirc-send-msg (lirc-msg nil nil "NOTICE" (list nick ping))) + (lirc-display-notice "CTCP ping received from " nick)) + + ("\01USERINFO\01" + (lirc-display-notice "CTCP userinfo request from " nick " (no response sent)")) + + (_ + (lirc-display-message channel nick text))))) (_ (lirc-display-string (lirc-msg->string msg)))))) @@ -311,16 +391,33 @@ portion of the source component of the message, as LIRC doesn't use this.") (defun lirc-enter-string (string) (if (string-prefix-p "/" string) (pcase (substring string 1) - ((rx (: (let cmd-str (+ (not space)))) - (opt - (: (+ " ") - (let params-str (+ anything))))) - (lirc-send-msg (lirc-msg nil nil - cmd-str + ((rx (: "TOPIC" " " (let new-topic (* not-newline)))) + (lirc-send-msg (lirc-msg nil nil "TOPIC" lirc-current-channel new-topic))) + + ((rx (: "me" " " (let action (* not-newline)))) + (lirc-send-msg (lirc-msg nil nil "PRIVMSG" + (list lirc-current-channel + (concat "\01ACTION " action "\01")))) + (lirc-display-action lirc-nick action)) + + ((rx (: "VERSION" " " (let nick (* (not whitespace))))) + (lirc-send-msg (lirc-msg nil nil "PRIVMSG" + (list nick "\01VERSION\01"))) + (lirc-display-notice "CTCP version request sent to " nick)) + + ((rx "PART") + (lirc-send-msg (lirc-msg nil nil "PART" lirc-current-channel))) + + ((rx (: (let cmd-str (+ (not whitespace))) + (opt (: " " (let params-str (* not-newline)))))) + (lirc-send-msg (lirc-msg nil nil (upcase cmd-str) (if params-str (split-string params-str) nil))))) - (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string)))) + + (unless (string-empty-p string) + (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string)) + (lirc-display-message lirc-current-channel lirc-nick string)))) (defun lirc-enter () "Enter current contents of line after prompt." -- 2.20.1