X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lurk.git;a=blobdiff_plain;f=lurk.el;h=26eb8949d8a6adca12617bf90e1f303e2fda2331;hp=e76c5d1868de54852253164553af0bc617dfadc9;hb=8d3a7b25c3766e81cbbd0062b311c8bb6cf25abb;hpb=11f1a6e4cea738c506392608b2365e53957ca9eb diff --git a/lurk.el b/lurk.el index e76c5d1..26eb894 100644 --- a/lurk.el +++ b/lurk.el @@ -35,7 +35,7 @@ ;; (defgroup lurk nil - "Little Unified iRc Klient." + "Little Uni-buffer iRc Klient." :group 'network) (defcustom lurk-nick "plugd" @@ -77,22 +77,32 @@ '((t :inherit org-agenda-dimmed-todo-face)) "Face used for faded Lurk text.") +(defface lurk-timestamp + '((t :inherit org-agenda-dimmed-todo-face)) + "Face used for timestamps.") + (defface lurk-error '((t :inherit font-lock-regexp-grouping-construct)) "Face used for Lurk error text.") +(defface lurk-notice + '((t :inherit org-upcoming-deadline)) + "Face used for Lurk notice text.") + ;;; Global variables ;; -(defvar lurk-version "Lurk v0.1") +(defvar lurk-version "Lurk v0.1" + "Value of this string is used in response to CTCP version queries.") (defvar lurk-notice-prefix "-!-") (defvar lurk-error-prefix "!!!") -(defvar lurk-prompt-string - (propertize "> " 'face 'lurk-prompt)) +(defvar lurk-prompt-string ">") +(defvar lurk-debug nil + "If non-nil, enable debug mode.") ;;; Network process ;; @@ -157,6 +167,8 @@ (and proc (eq (process-status proc) 'open)))) (defun lurk-send-msg (msg) + (if lurk-debug + (lurk-display-string nil nil (lurk-msg->string msg))) (let ((proc (get-process "lurk"))) (if (and proc (eq (process-status proc) 'open)) (process-send-string proc (concat (lurk-msg->string msg) "\r\n")) @@ -301,7 +313,9 @@ portion of the source component of the message, as LURK doesn't use this.") (defun lurk-set-current-context (context) (setq lurk-current-context context) - (lurk-highlight-context context)) + (lurk-highlight-context context) + (if lurk-zoomed + (lurk-zoom-in lurk-current-context))) (defun lurk-cycle-contexts (&optional rev) (if lurk-current-context @@ -333,7 +347,7 @@ portion of the source component of the message, as LURK doesn't use this.") "") 'face 'lurk-context 'read-only t) - (propertize lurk-prompt-string + (propertize (concat lurk-prompt-string " ") 'face 'lurk-prompt 'read-only t 'rear-nonsticky t))) @@ -378,7 +392,7 @@ portion of the source component of the message, as LURK doesn't use this.") ;; and for different elements of the context-specific text to have ;; different styling. -;; Additionally, we can allow selective hiding of contexts via +;; Additionally, we allow selective hiding of contexts via ;; the buffer-invisibility-spec. (defvar lurk-context-facelists (make-hash-table :test 'equal) @@ -391,29 +405,43 @@ portion of the source component of the message, as LURK doesn't use this.") (puthash context facelist lurk-context-facelists)) facelist)) -(defun lurk-display-string (context &rest strings) +(defun lurk--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 lurk-display-string (context prefix &rest strings) (with-current-buffer (get-buffer-create "*lurk*") (save-excursion (goto-char lurk-prompt-marker) - (let ((inhibit-read-only t) - (old-pos (marker-position lurk-prompt-marker)) - (adaptive-fill-regexp (rx (= 6 anychar))) - (fill-column 80) - (context-atom (if context (intern context) nil))) + (let* ((inhibit-read-only t) + (old-pos (marker-position lurk-prompt-marker)) + (padded-timestamp (concat (format-time-string "%H:%M "))) + (padded-prefix (if prefix (concat prefix " ") "")) + (context-atom (if context (intern context) nil))) (insert-before-markers - (propertize (concat (format-time-string "%H:%M") " ") - 'face (lurk-get-context-facelist context) - 'read-only t - 'context context - 'invisible context-atom - 'help-echo (concat "Context: " (or context "none"))) - (propertize (concat (apply #'concat strings) "\n") - 'face (lurk-get-context-facelist context) - 'read-only t - 'context context - 'invisible context-atom - 'help-echo (concat "Context: " (or context "none")))) - (fill-region old-pos lurk-prompt-marker nil t))))) + (lurk--fill-strings + 80 + (+ (length padded-timestamp) + (length padded-prefix)) + (propertize padded-timestamp + 'face 'lurk-timestamp + 'read-only t + 'context context + 'invisible context-atom) + (propertize padded-prefix + 'read-only t + 'context context + 'invisible context-atom) + (propertize (concat (lurk-buttonify-urls (apply #'concat strings)) "\n") + 'face (lurk-get-context-facelist context) + 'read-only t + 'context context + 'invisible context-atom))))))) (defun lurk-display-message (from to text) (let ((context (if (eq 'channel (lurk-get-context-type to)) @@ -421,11 +449,13 @@ portion of the source component of the message, as LURK doesn't use this.") (if (equal to lurk-nick) from to)))) (lurk-display-string context - (pcase (lurk-get-context-type to) - ('channel (concat to " <" from "> ")) - ('nick (concat "[" from " -> " to "] ")) - (_ - (error "Unsupported context type"))) + (propertize + (pcase (lurk-get-context-type to) + ('channel (concat to " <" from ">")) + ('nick (concat "[" from " -> " to "]")) + (_ + (error "Unsupported context type"))) + 'face (lurk-get-context-facelist context)) text))) (defun lurk-display-action (from to action-text) @@ -434,19 +464,19 @@ portion of the source component of the message, as LURK doesn't use this.") (if (equal to lurk-nick) from to)))) (lurk-display-string context - "* " from " " action-text))) - + (concat "* " from) + action-text))) (defun lurk-display-notice (context &rest notices) (lurk-display-string context - lurk-notice-prefix " " + (propertize lurk-notice-prefix 'face 'lurk-notice) (apply #'concat notices))) (defun lurk-display-error (&rest messages) (lurk-display-string nil - lurk-error-prefix " " + (propertize lurk-error-prefix 'face 'lurk-error) (apply #'concat messages))) (defun lurk-highlight-context (context) @@ -479,20 +509,52 @@ portion of the source component of the message, as LURK doesn't use this.") lurk-context-facelists) (force-window-update "*lurk*"))) +(defconst lurk-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 lurk-click-url (button) + (browse-url (button-get button 'url))) + +(defun lurk-buttonify-urls (string) + "Turn substrings which look like urls in STRING into clickable buttons." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward lurk-url-regex nil t) + (let ((url (match-string 0))) + (make-text-button (match-beginning 0) + (match-end 0) + 'action #'lurk-click-url + 'url url + 'follow-link t + 'face 'button + 'help-echo "Open URL in browser."))) + (buffer-string))) + + ;;; Message evaluation ;; (defun lurk-eval-msg-string (string) - ;; (lurk-display-string nil string) + (if lurk-debug + (lurk-display-string nil nil string)) (let* ((msg (lurk-string->msg string))) (pcase (lurk-msg-cmd msg) ("PING" (lurk-send-msg (lurk-msg nil nil "PONG" (lurk-msg-params msg)))) - ;; (lurk-display-notice nil "ping-pong (server initiated)")) ("PONG") - ;; (lurk-display-notice nil "ping-pong (client initiated)")) ("001" (let* ((params (lurk-msg-params msg)) @@ -528,6 +590,8 @@ portion of the source component of the message, as LURK doesn't use this.") (topic (elt params 2))) (lurk-display-notice channel "Topic: " topic))) + ("333") ; Avoid displaying these + ((rx (= 3 (any digit))) (lurk-display-notice nil (mapconcat 'identity (cdr (lurk-msg-params msg)) " "))) @@ -562,6 +626,21 @@ portion of the source component of the message, as LURK doesn't use this.") (if lurk-show-joins (lurk-display-notice channel nick " left channel " channel)))) + ((and "KICK") + (let ((kicker-nick (lurk-msg-src msg)) + (channel (car (lurk-msg-params msg))) + (nick (cadr (lurk-msg-params msg))) + (reason (caddr (lurk-msg-params msg)))) + (if (equal nick lurk-nick) + (progn + (lurk-display-notice channel kicker-nick " kicked you from " channel ": " reason) + (lurk-del-context channel) + (if (equal channel lurk-current-context) + (lurk-set-current-context (lurk-get-next-context))) + (lurk-render-prompt)) + (lurk-del-context-user channel nick) + (lurk-display-notice channel kicker-nick " kicked " nick " from " channel ": " reason)))) + ("QUIT" (let ((nick (lurk-msg-src msg)) (reason (mapconcat 'identity (lurk-msg-params msg) " "))) @@ -617,10 +696,6 @@ portion of the source component of the message, as LURK doesn't use this.") (lurk-display-action from to action-text)) (_ - (if (and (equal from "BitBot") - (equal to "##moshpit") - (cl-search "\\_o< QUACK!" text)) - (lurk-send-msg (lurk-msg nil nil "PRIVMSG" to ",bef"))) (lurk-display-message from to text))))) (_ (lurk-display-notice nil (lurk-msg->string msg)))))) @@ -632,6 +707,10 @@ portion of the source component of the message, as LURK doesn't use this.") (defun lurk-enter-string (string) (if (string-prefix-p "/" string) (pcase (substring string 1) + ((rx "DEBUG") + (setq lurk-debug (not lurk-debug)) + (lurk-display-notice nil "Debug mode now " (if lurk-debug "on" "off") ".")) + ((rx (: "CONNECT " (let network (* not-newline)))) (lurk-display-notice nil "Attempting to connect to " network "...") (lurk-connect network)) @@ -670,6 +749,12 @@ portion of the source component of the message, as LURK doesn't use this.") (setq lurk-nick nick) (lurk-display-notice nil "Set default nick to '" nick "'"))) + ((rx "LIST") + (lurk-display-notice nil "This command can generate lots of output. Use `LIST -yes' if you're sure.")) + + ((rx (: "LIST" (+ whitespace) "-YES")) + (lurk-send-msg (lurk-msg nil nil "LIST"))) + ((rx "MSG " (let to (* (not whitespace))) " " @@ -693,18 +778,42 @@ portion of the source component of the message, as LURK doesn't use this.") (lurk-display-message lurk-nick lurk-current-context string)) (lurk-display-error "No current context."))))) +(defvar lurk-history nil + "Commands and messages sent in current session.") + + (defun lurk-enter () "Enter current contents of line after prompt." (interactive) (with-current-buffer "*lurk*" (let ((line (buffer-substring lurk-input-marker (point-max)))) + (push line lurk-history) + (setq lurk-history-index nil) (let ((inhibit-read-only t)) (delete-region lurk-input-marker (point-max))) (lurk-enter-string line)))) +(defvar lurk-history-index nil) + +(defun lurk-history-cycle (delta) + (when lurk-history + (with-current-buffer "*lurk*" + (if lurk-history-index + (setq lurk-history-index + (max 0 + (min (- (length lurk-history) 1) + (+ delta lurk-history-index)))) + (setq lurk-history-index 0)) + (delete-region lurk-input-marker (point-max)) + (insert (elt lurk-history lurk-history-index))))) + +(defun lurk-history-next () + (interactive) + (lurk-history-cycle -1)) -;;; Command completion -;; +(defun lurk-history-prev () + (interactive) + (lurk-history-cycle +1)) ;;; Interactive functions ;; @@ -727,18 +836,37 @@ portion of the source component of the message, as LURK doesn't use this.") (lurk-zoom-in lurk-current-context)) (setq lurk-zoomed (not lurk-zoomed))) +(defun lurk-complete-nick () + (interactive) + (when (and (>= (point) lurk-input-marker) lurk-current-context) + (let* ((end (max lurk-input-marker (point))) + (space-idx (save-excursion + (re-search-backward " " lurk-input-marker t))) + (start (if space-idx (+ 1 space-idx) lurk-input-marker))) + (unless (string-prefix-p "/" (buffer-substring start end)) + (completion-in-region start end (lurk-get-context-users lurk-current-context)))))) + + ;;; Mode ;; (defvar lurk-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'lurk-enter) - (define-key map (kbd "") 'lurk-complete) + (define-key map (kbd "") 'lurk-complete-nick) (define-key map (kbd "C-c C-z") 'lurk-toggle-zoom) (define-key map (kbd "") 'lurk-cycle-contexts-forward) (define-key map (kbd "") 'lurk-cycle-contexts-reverse) + (define-key map (kbd "") 'lurk-history-prev) + (define-key map (kbd "") 'lurk-history-next) + ;; (when (fboundp 'evil-define-key*) + ;; (evil-define-key* 'insert map + ;; (kbd "") 'lurk-history-prev + ;; (kbd "") 'lurk-history-next)) map)) +(defvar lurk-mode-map) + (define-derived-mode lurk-mode text-mode "lurk" "Major mode for LURK.") @@ -753,9 +881,9 @@ portion of the source component of the message, as LURK doesn't use this.") (interactive) (if (get-buffer "*lurk*") (switch-to-buffer "*lurk*") - (switch-to-buffer "*lurk*")) - (lurk-mode) - (lurk-setup-buffer) + (switch-to-buffer "*lurk*") + (lurk-mode) + (lurk-setup-buffer)) "Started LURK.")