X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lirc.el;h=a5a0500e578cafb21a10ffd34d8eb413b31ad23c;hb=6cee2fa822e2861b99872372a0c1cc234ca21383;hp=e6f47fb921f8b2153884f0b4f5cea719003d06a5;hpb=b37326a2c75f1296109c1a1574aac74eaaf419a4;p=lurk.git diff --git a/lirc.el b/lirc.el index e6f47fb..a5a0500 100644 --- a/lirc.el +++ b/lirc.el @@ -43,10 +43,12 @@ "Default full name.") (defcustom lirc-user-name "plugd" "Default user name.") -(defcustom lirc-host "localhost" - "Default server.") -(defcustom lirc-port 6667 - "Default port.") + +(defcustom lirc-networks + '(("libera" "irc.libera.chat" 6697) + ("freenode" "chat.freenode.net" 6697) + ("local" "localhost" 6697)) + "IRC networks.") (defcustom lirc-prompt-string "> " "Prompt.") @@ -70,11 +72,34 @@ '((t :inherit org-list-dt)) "Face used for the channel name in the prompt.") +(defface lirc-faded + '((t :inherit font-lock-preprocessor-face)) + "Face used for faded Lirc text.") + +(defface lirc-bold + '((t :inherit font-lock-function-name-face)) + "Face used for bold Lirc text.") + +(defface lirc-error + '((t :inherit font-lock-regexp-grouping-construct)) + "Face used for Lirc error text.") + ;;; Global variables ;; (defvar lirc-version "Lirc v0.1") +(defvar lirc-notice-prompt + (concat + (propertize + "-" 'face 'lirc-faded) + (propertize + "!" 'face 'lirc-bold) + (propertize + "-" 'face 'lirc-faded))) + +(defvar lirc-error-prompt + (propertize "!!!" 'face 'lirc-error)) ;;; Network process ;; @@ -87,16 +112,38 @@ (lirc-eval-msg-string (string-trim line)) (setq lirc-response line)))) -(defun lirc-get-process () +(defun lirc-sentinel (proc string) + (message string)) + +(defun lirc-start-process (network) + (let* ((row (assoc network lirc-networks)) + (host (elt row 1)) + (port (elt row 2))) + (make-network-process :name "lirc" + :host host + :service port + :filter #'lirc-filter + :nowait nil + :tls-parameters (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :hostname host)) + :buffer "*lirc*"))) + + +(defun lirc-connect (network) + (setq lirc-channel-list nil) + (setq lirc-current-channel nil) + (lirc-start-process network) + (lirc-send-msg (lirc-msg nil nil "USER" lirc-user-name 0 "*" lirc-full-name)) + (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick))) + +(defun lirc-send-msg (msg) (let ((proc (get-process "lirc"))) (if (and proc (eq (process-status proc) 'open)) - proc - (make-network-process :name "lirc" - :host lirc-host - :service lirc-port - :filter #'lirc-filter - :nowait t - :buffer "*lirc*")))) + (process-send-string proc (concat (lirc-msg->string msg) "\r\n")) + (lirc-display-error "No server connection established.") + (error "No server connection established")))) ;;; Messages ;; @@ -203,6 +250,18 @@ portion of the source component of the message, as LIRC doesn't use this.") (lirc-set-channel-users channel-name (cl-set-difference current-users users :test #'equal)))) +(defun lirc-del-users (&rest users) + (dolist (channel lirc-channel-list) + (apply #'lirc-del-channel-users (cons (car channel) users)))) + +(defun lirc-rename-user (old-nick new-nick) + (dolist (channel lirc-channel-list) + (let ((channel-name (car channel)) + (channel-users (cdr channel))) + (when (memq old-nick channel-users) + (lirc-del-channel-users old-nick) + (lirc-add-channel-users new-nick))))) + ;;; Buffer ;; @@ -211,27 +270,22 @@ portion of the source component of the message, as LIRC doesn't use this.") (with-current-buffer (get-buffer-create "*lirc*") (save-excursion (goto-char lirc-prompt-marker) - (let ((inhibit-read-only t)) + (let ((inhibit-read-only t) + (old-pos (marker-position lirc-prompt-marker)) + (adaptive-fill-regexp (rx (= 6 anychar)))) (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)) - (lirc-send-msg (lirc-msg nil nil "NICK" lirc-nick))) - -(defun lirc-send-msg (msg) - (let ((proc (lirc-get-process))) - (process-send-string proc (concat (lirc-msg->string msg) "\r\n")))) + 'read-only t)) + (fill-region old-pos lirc-prompt-marker))))) (defun lirc-render-prompt () (with-current-buffer "*lirc*" - (set-marker-insertion-type lirc-prompt-marker nil) - (set-marker-insertion-type lirc-input-marker t) (save-excursion + (set-marker-insertion-type lirc-prompt-marker nil) + (set-marker-insertion-type lirc-input-marker t) (let ((inhibit-read-only t)) (delete-region lirc-prompt-marker lirc-input-marker) (goto-char lirc-prompt-marker) @@ -244,8 +298,8 @@ portion of the source component of the message, as LIRC doesn't use this.") (propertize lirc-prompt-string 'face 'lirc-prompt 'read-only t - 'rear-nonsticky t))))) - (set-marker-insertion-type lirc-input-marker nil)) + 'rear-nonsticky t))) + (set-marker-insertion-type lirc-input-marker nil)))) (defvar lirc-prompt-marker nil "Marker for prompt position in LIRC buffer.") @@ -287,7 +341,12 @@ portion of the source component of the message, as LIRC doesn't use this.") (propertize message 'face 'lirc-text)))) (defun lirc-display-notice (&rest notices) - (lirc-display-string "*** " (apply #'concat notices))) + (lirc-display-string lirc-notice-prompt " " (apply #'concat notices))) + +(defun lirc-display-error (&rest messages) + (lirc-display-string lirc-error-prompt " " + (propertize (apply #'concat messages) + 'face 'lirc-error))) ;;; Message evaluation ;; @@ -298,7 +357,8 @@ portion of the source component of the message, as LIRC doesn't use this.") (pcase (lirc-msg-cmd msg) ("PING" (lirc-send-msg - (lirc-msg nil nil "PONG" (lirc-msg-params msg)))) + (lirc-msg nil nil "PONG" (lirc-msg-params msg))) + (lirc-display-notice "ping-pong")) ("353" ; NAMEREPLY (let* ((params (lirc-msg-params msg)) @@ -306,6 +366,11 @@ 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)))) + ("366" ; ENDOFNAMES + (lirc-display-notice + (lirc-as-string (length (lirc-get-channel-users lirc-current-channel))) + " users in " lirc-current-channel)) + ((rx (= 3 (any digit))) (lirc-display-notice (mapconcat 'identity (cdr (lirc-msg-params msg)) " "))) @@ -314,18 +379,23 @@ portion of the source component of the message, as LIRC doesn't use this.") (let ((channel (car (lirc-msg-params msg)))) (setq lirc-current-channel channel) (lirc-add-channel channel) + (lirc-display-notice "Joining channel " channel) (lirc-render-prompt))) ("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) + (lirc-display-notice nick " joined channel " channel))) ((and "PART" (guard (equal lirc-nick (lirc-msg-src msg)))) - (setq lirc-current-channel nil) - (lirc-del-channel (car (lirc-msg-params msg))) - (lirc-render-prompt)) + (let ((channel (car (lirc-msg-params msg)))) + (lirc-display-notice "Left channel " channel) + (lirc-del-channel (car (lirc-msg-params msg))) + (when (equal lirc-current-channel channel) + (setq lirc-current-channel nil) + (lirc-render-prompt)))) ("PART" (let ((channel (car (lirc-msg-params msg))) @@ -344,6 +414,12 @@ portion of the source component of the message, as LIRC doesn't use this.") (setq lirc-nick (car (lirc-msg-params msg))) (lirc-display-notice "Set nick to " lirc-nick)) + ("NICK" + (let ((old-nick (lirc-msg-src msg)) + (new-nick (car (lirc-msg-params msg)))) + (lirc-display-notice nick " is now known as " new-nick) + (lirc-rename-user nick new-nick))) + ("NOTICE" (let ((nick (lirc-msg-src msg)) (channel (car (lirc-msg-params msg))) @@ -352,7 +428,9 @@ portion of the source component of the message, as LIRC doesn't use this.") ((rx (: "\01VERSION " (let version (* (not "\01"))) "\01")) - (lirc-display-notice "CTCP version reply from " nick ": " version))))) + (lirc-display-notice "CTCP version reply from " nick ": " version)) + (_ + (lirc-display-notice text))))) ("PRIVMSG" (let ((nick (lirc-msg-src msg)) @@ -391,10 +469,14 @@ 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 (: "TOPIC" " " (let new-topic (* not-newline)))) + ((rx (: "CONNECT " (let network (* not-newline)))) + (lirc-display-notice "Connecting to " network "...") + (lirc-connect network)) + + ((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)))) + ((rx (: "ME " (let action (* not-newline)))) (lirc-send-msg (lirc-msg nil nil "PRIVMSG" (list lirc-current-channel (concat "\01ACTION " action "\01")))) @@ -405,8 +487,19 @@ portion of the source component of the message, as LIRC doesn't use this.") (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 "PART" (opt (: " " (let channel (* not-newline))))) + (if (or lirc-current-channel channel) + (lirc-send-msg (lirc-msg nil nil "PART" (if channel + channel + lirc-current-channel))) + (lirc-display-error "No current channel to leave."))) + + ((rx "MSG " + (let target (* (not whitespace))) + " " + (let text (* not-newline))) + (lirc-send-msg (lirc-msg nil nil "PRIVMSG" target text)) + (lirc-display-message target lirc-nick text)) ((rx (: (let cmd-str (+ (not whitespace))) (opt (: " " (let params-str (* not-newline)))))) @@ -416,8 +509,11 @@ portion of the source component of the message, as LIRC doesn't use this.") nil))))) (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)))) + (if lirc-current-channel + (progn + (lirc-send-msg (lirc-msg nil nil "PRIVMSG" lirc-current-channel string)) + (lirc-display-message lirc-current-channel lirc-nick string)) + (lirc-display-error "No current channel."))))) (defun lirc-enter () "Enter current contents of line after prompt." @@ -455,7 +551,6 @@ portion of the source component of the message, as LIRC doesn't use this.") (switch-to-buffer "*lirc*")) (lirc-mode) (lirc-setup-buffer) - (lirc-connect) "Started LIRC.")