From 64994dc2c5c36a9cdb125e6bd0ddc497e077fa25 Mon Sep 17 00:00:00 2001 From: plugd Date: Sat, 18 May 2024 17:03:12 +0200 Subject: [PATCH] Ported over more lurk code. --- murk.el | 291 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 283 insertions(+), 8 deletions(-) diff --git a/murk.el b/murk.el index af7fd0e..1cab898 100644 --- a/murk.el +++ b/murk.el @@ -6,7 +6,7 @@ ;; Created: 11 May 2024 ;; Version: 0.0 ;; Keywords: network -;; Homepage: http://thelambdalab.xyz/metalurk +;; Homepage: http://thelambdalab.xyz/murk ;; Package-Requires: ((emacs "26")) ;; This file is not part of GNU Emacs. @@ -48,6 +48,9 @@ ("tilde" "tilde.chat" 6697)) "IRC networks.") +(defcustom murk-display-header t + "If non-nil, use buffer header to display information on current host and channel.") + ;;; Faces ;; @@ -127,7 +130,7 @@ This includes the process and the response string.") (gnutls-boot-parameters :type 'gnutls-x509pki :hostname host))) - :buffer "*lurk*"))) + :buffer "*murk*"))) (defvar murk-ping-period 60) @@ -141,8 +144,85 @@ This includes the process and the response string.") (let ((proc (murk-start-process server))) (add-to-list murk-connection-table (list server proc ""))) - (murk-send-msg (murk-msg nil nil "USER" murk-nick 0 "*" murk-nick)) - (murk-send-msg (murk-msg nil nil "NICK" murk-nick))))) + (murk-send-msg server (murk-msg nil nil "USER" murk-nick 0 "*" murk-nick)) + (murk-send-msg server (murk-msg nil nil "NICK" murk-nick))))) + +(defun murk-send-msg (server msg) + (if murk-debug + (murk-display-string nil nil (murk-msg->string msg))) + (let ((proc (murk-connection-process server))) + (if (and proc (eq (process-status proc) 'open)) + (process-send-string proc (concat (murk-msg->string msg) "\r\n")) + (murk-display-error "No server connection established.") + (error "No server connection established")))) + +;;; Server messages +;; + +(defun murk-msg (tags src cmd &rest params) + (list (murk--as-string tags) + (murk--as-string src) + (upcase (murk--as-string cmd)) + (mapcar #'murk--as-string + (if (and params (listp (elt params 0))) + (elt params 0) + params)))) + +(defun murk-msg-tags (msg) (elt msg 0)) +(defun murk-msg-src (msg) (elt msg 1)) +(defun murk-msg-cmd (msg) (elt msg 2)) +(defun murk-msg-params (msg) (elt msg 3)) +(defun murk-msg-trail (msg) + (let ((params (murk-msg-params msg))) + (if params + (elt params (- (length params) 1))))) + +(defvar murk-msg-regex + (rx + (opt (: "@" (group (* (not (or "\n" "\r" ";" " "))))) + (* whitespace)) + (opt (: ":" (: (group (* (not (any space "!" "@")))) + (* (not (any space))))) + (* whitespace)) + (group (: (* (not whitespace)))) + (* whitespace) + (opt (group (+ not-newline)))) + "Regex used to parse IRC messages. +Note that this regex is incomplete. Noteably, we discard the non-nick +portion of the source component of the message, as mURK doesn't use this.") + +(defun murk-string->msg (string) + (if (string-match murk-msg-regex string) + (let* ((tags (match-string 1 string)) + (src (match-string 2 string)) + (cmd (upcase (match-string 3 string))) + (params-str (match-string 4 string)) + (params + (if params-str + (let* ((idx (cl-search ":" params-str)) + (l (split-string (string-trim (substring params-str 0 idx)))) + (r (if idx (list (substring params-str (+ 1 idx))) nil))) + (append l r)) + nil))) + (apply #'murk-msg (append (list tags src cmd) params))) + (error "Failed to parse string " string))) + +(defun murk-msg->string (msg) + (let ((tags (murk-msg-tags msg)) + (src (murk-msg-src msg)) + (cmd (murk-msg-cmd msg)) + (params (murk-msg-params msg))) + (murk--filtered-join + (if tags (concat "@" tags) nil) + (if src (concat ":" src) nil) + cmd + (if (> (length params) 1) + (string-join (seq-take params (- (length params) 1)) " ") + nil) + (if (> (length params) 0) + (concat ":" (elt params (- (length params) 1))) + nil)))) + ;;; Contexts and Servers ;; @@ -154,12 +234,207 @@ This includes the process and the response string.") ;; Each server has a special context (server) used for messages ;; to/from the server itself. -(defvar murk-current-context nil) -(defvar murk-context-members nil) +(defvar murk-contexts nil + "List of currently-available contexts. +The head of this list is always the current context.") + +(defun murk-current-context () + "Returns the current context." + (if murk-contexts + (car murk-contexts) + nil)) + +(defun murk-context-server (ctx) (elt ctx 0)) +(defun murk-context-name (ctx) (elt ctx 1)) + +;;; Buffer +;; + +(defun murk-render-prompt () + (with-current-buffer "*murk*" + (let ((update-point (= murk-input-marker (point))) + (update-window-points (mapcar (lambda (w) + (list (= (window-point w) murk-input-marker) + w)) + (get-buffer-window-list nil nil t)))) + (save-excursion + (set-marker-insertion-type murk-prompt-marker nil) + (set-marker-insertion-type murk-input-marker t) + (let ((inhibit-read-only t)) + (delete-region murk-prompt-marker murk-input-marker) + (goto-char murk-prompt-marker) + (insert + (propertize (let ((ctx (murk-current-context))) + (if ctx + (concat (murk-context-name) "@" (murk-context-server ctx)) + "")) + 'face 'murk-context + 'read-only t) + (propertize murk-prompt-string + 'face 'murk-prompt + 'read-only t) + (propertize " " ; Need this to be separate to mark it as rear-nonsticky + 'read-only t + 'rear-nonsticky t))) + (set-marker-insertion-type murk-input-marker nil)) + (if update-point + (goto-char murk-input-marker)) + (dolist (v update-window-points) + (if (car v) + (set-window-point (cadr v) murk-input-marker)))))) + +(defvar murk-prompt-marker nil + "Marker for prompt position in murk buffer.") + +(defvar murk-input-marker nil + "Marker for prompt position in murk buffer.") + +(defun murk-setup-header () + ;; To do + ) + +(defun murk-setup-buffer () + (with-current-buffer (get-buffer-create "*murk*") + (setq-local scroll-conservatively 1) + (setq-local buffer-invisibility-spec nil) + (if (markerp murk-prompt-marker) + (set-marker murk-prompt-marker (point-max)) + (setq murk-prompt-marker (point-max-marker))) + (if (markerp murk-input-marker) + (set-marker murk-input-marker (point-max)) + (setq murk-input-marker (point-max-marker))) + (goto-char (point-max)) + (murk-render-prompt) + (if murk-display-header + (murk-setup-header)))) + +(defun murk-clear-buffer () + "Completely erase all non-prompt and non-input text from murk buffer." + (with-current-buffer "*murk*" + (let ((inhibit-read-only t)) + (delete-region (point-min) murk-prompt-marker)))) + + +;;; Output formatting and highlighting +;; + +(defun murk--fill-strings (col indent &rest strings) + (with-temp-buffer + (setq buffer-invisibility-spec nil) + (let ((fill-column col) + (adaptive-fill-regexp (rx-to-string `(= ,indent anychar)))) + (apply #'insert strings) + (fill-region (point-min) (point-max) nil t) + (buffer-string)))) + +(defun murk-context->string (context) + (if context + (concat (murk-context-name) "@" (murk-context-server context)) + nil)) + + +(defun murk-display-string (context prefix &rest strings) + (with-current-buffer "*murk*" + (save-excursion + (goto-char murk-prompt-marker) + (let* ((inhibit-read-only t) + (old-pos (marker-position murk-prompt-marker)) + (padded-timestamp (concat (format-time-string "%H:%M "))) + (padded-prefix (if prefix (concat prefix " ") "")) + (context-atom (if context (intern (murk-context->string context)) nil))) + (insert-before-markers + (murk--fill-strings + 80 + (+ (length padded-timestamp) + (length padded-prefix)) + (propertize padded-timestamp + 'face 'murk-timestamp + 'read-only t + 'context context + 'invisible context-atom) + (propertize padded-prefix + 'read-only t + 'context context + 'invisible context-atom) + (concat (apply #'murk-buttonify-urls strings) "\n")))))) + (murk-scroll-windows-to-last-line)) + +(defun murk--start-of-final-line () + (with-current-buffer "*murk*" + (save-excursion + (goto-char (point-max)) + (line-beginning-position)))) + +(defun murk-scroll-windows-to-last-line () + (with-current-buffer "*murk*" + (dolist (window (get-buffer-window-list)) + (if (>= (window-point window) (murk--start-of-final-line)) + (with-selected-window window + (recenter -1)))))) + +(defconst murk-url-regex + (rx (: + (group (+ alpha)) + "://" + (group (or (+ (any alnum "." "-")) + (+ (any alnum ":")))) + (opt (group (: ":" (+ digit)))) + (opt (group (: "/" + (opt + (* (any alnum "-/.,#:%=&_?~@+")) + (any alnum "-/#:%=&_~@+"))))))) + "Imperfect regex used to find URLs in plain text.") + +(defun murk-click-url (button) + (browse-url (button-get button 'url))) + +(defun murk-buttonify-urls (&rest strings) + "Turn substrings which look like urls in STRING into clickable buttons." + (with-temp-buffer + (apply #'insert strings) + (goto-char (point-min)) + (while (re-search-forward murk-url-regex nil t) + (let ((url (match-string 0))) + (make-text-button (match-beginning 0) + (match-end 0) + 'action #'murk-click-url + 'url url + 'follow-link t + 'face 'button + 'help-echo "Open URL in browser."))) + (buffer-string))) + + +;;; Mode +;; + +(defvar murk-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'murk-enter) + (define-key map (kbd "TAB") 'murk-complete-input) + (when (fboundp 'evil-define-key*) + (evil-define-key* 'motion map + (kbd "TAB") 'murk-complete-input)) + map)) + +(define-derived-mode murk-mode text-mode "murk" + "Major mode for murk.") + +(when (fboundp 'evil-set-initial-state) + (evil-set-initial-state 'murk-mode 'insert)) ;;; Main start procedure ;; -(defun metalurk) +(defun murk () + "Start murk or just switch to the murk buffer if one already exists." + (interactive) + (if (get-buffer "*murk*") + (switch-to-buffer "*murk*") + (switch-to-buffer "*murk*") + (murk-mode) + (murk-setup-buffer)) + "Started murk.") + -;;; metalurk.el ends here +;;; murk.el ends here -- 2.20.1