;;; $Id: kc-mud.el,v 3.69 2002/05/25 21:28:35 quarl Exp $ ;;; kc-mud.el --- KC's mud module. ;;; originally modified from Waider's mud.el 2.6 ;; Copyright (C) 2001-2002 Karl Chen. ;; You may distribute under the GNU General Public License. ;;; NEW MAJOR FEATURES: ;; - color ;; - both single- and dual- window mode ;; - hugely better regexp hook support ;; - automatic map extraction to separate buffer ;; - local aliases (eg "/ R3en\n" becomes ;; "recall\neast\neast\neast\nnorth\n") ;;; NO LONGER SUPPORTED: ;; - Emacs 18, if it really ever was. Emacs 19 probably not supported ;; either now. ;; - single-input-mode (replaced by new single-window mode) ;; - firewall gateway support. It was pretty shoddy anyway, and if anyone ;; wants it, it's still easy to add back. ;;; TODO: ;; - BS at bol doesn't erase to prev line - disable hungry mode? (s/w mode) ;; - aliases!!! (multiline) ;; - page up/down bounces (s/w mode) ; - prevent killing windows without quitting mud ;;; MUD YOUR EMACS! ;; original: $ Id: mud.el,v 2.6 1999/03/03 10:25:48 waider Exp $ ;; Waider, Started April '96 ;; ;; Easy Mud Access Client System??? ;; ;; The current version of mud.el is available at ;; this ;; location, unless I've changed jobs. If all else fails, try mail to ;; address@hidden ;; (defvar mud-debug-p t) (defvar mud-debug-pause-p nil) ;; ;;; ;;; Firewall handler ;;; ;;; Very minimal. Works for the type of firewall where you telnet to a ;;; gateway machine and then telnet out from there; if anyone requires ;;; more firewall support I may hack it in. Maybe. Set the two ;;; variables below to activate firewall climbing. ;;; ;;; This hasn't been expanded since we installed masquerading instead ;;; of fwtk stuff. If you really need something changed here, mail ;;; me at ;;; address@hidden ;;; ;;; gw-host is a quoted string, either the FQDN or the IP ;;; gw-port is a number. I dunno what happens if you quote it :) ;;; ;;(defvar gw-host nil "*Name of your firewall host") ;;(defvar gw-port nil "*Port to connect to on the firewall host") ;;(defvar gw-prompt nil "*Firewall's prompt string.") ;;; kc: ansi-color from emacs 21.1 has problems. ;;(require 'ansi-color) (load "kc-el/ansi-color.el") (eval-when-compile (require 'ansi-color)) ;; change black to darkgray so we can see it (since black background). (defvar mud--ansi-color-map (let ((ansi-color-names-vector ["gray45" "red" "green" "yellow" "blue" "magenta" "cyan" "white"])) (ansi-color-make-color-map)) "ansi-color-map to use in mud mode.") ;; (default): ;;(defcustom ansi-color-names-vector ;; ["black" "red" "green" "yellow" "blue" "magenta" "cyan" "white"]) ;;; ;;; Version of open-network-stream that firewalls if the gw-host and ;;; gw-port variables are set. ;;; ;;(defun mud-open-network-stream (name buffer host port) ;; ;; Do clever host stuff here to automagically determine firewall ;; ;; requirements? ;; (let (proc) ;; (if (and gw-host gw-port) ;; (progn ;; (message "Using firewall to connect.") ;; (setq proc (open-network-stream name buffer gw-host gw-port)) ;; (if proc ;; ;; Prod the gateway, if necessary. ;; (save-excursion ;; (message "Connected to firewall.") ;; ;;(process-send-string proc magic-string) ;; (message (concat "Connecting to " host ", port " port)) ;; (process-send-string ;; proc (concat "telnet " host " " port "\r\n")) ;; ;; Wait for Connected to... here ;; ;;(process-send-string proc "") ;; ;;(process-send-string proc "set mode char\r\n") ;; ))) ;; ;;; ELSE no firewalling required ;; (message (format "Connecting to %s port %d" host port)) ;; (setq proc (open-network-stream name buffer host port)) ;; (message "Connected to host.")) ;; proc)) (defun mud--open-network-stream (name buffer host port) (prog2 (message (format "Connecting to %s port %d" host port)) (open-network-stream name buffer host port) (message "Connected to host."))) ;;; ;;; mud.el proper ;;; ;;; Name Host Port Login (defvar mud-list '( (Necromium ("necromium.com" 4000)) ;;(Nerdsholm ("boutell.com" 4096 t)) ;;(NewtMUD ("tapaboy.ma.ultranet.com" 4096)) ) "*List of lists, containing Mud name, then (\"host\" port login pass). Login and pass can be omitted; if login is t, mud-default-user and mud-default-pass will be used. Once you've defined a Mud here, you can set various features for that mud by doing (put 'MUDNAME 'feature value). The Properties menu will give you a list of currently-set properties and their values, excluding properties for buffers, windows and the mud process.") (defmacro mud--setq-local (var val) `(progn (eval-when-compile (defvar ,var nil "Internal, yo")) (make-local-variable ',var) (setq ,var ,val))) (defmacro mud--defvar-local (var &optional initial-value doc-string) `(progn (defvar ,var ,initial-value ,doc-string) (make-variable-buffer-local ',var))) (defvar mud-default 'Necromium "*default mud to log in to.") ;;; Auto-Login support (mud--defvar-local mud-user nil "*default username to connect with.") (mud--defvar-local mud-pass nil "*default password for mud-default-user.") (mud--defvar-local mud-separate-input-window nil "*true if the input window should be separate from the main output buffer.") (mud--defvar-local mud-separate-map-frame nil "*true if the map window should be in a separate frame.") (mud--defvar-local mud-map-window-width 22 "*width of mud map window.") (mud--defvar-local mud-single-window-input-prompt "> " "*Mud prompt single window mode.") (mud--defvar-local mud-log-filename-format "~/mud-%s.log" "*default format to generate log filename. A string where '%s' is replaced by the mud name. Default is \"mud-%s.log\".") (mud--defvar-local mud-logging nil "*Should we log mud output in a file?") (mud--defvar-local mud-page-beep t "*Should the mud make noise about pages?") (mud--defvar-local mud-max-buffer 100000 "*Maximum size of a mud buffer.") (mud--defvar-local mud-trim-buffer-delta 10000 "*Number of extra characters to trim when buffer size exceeds `mud-max-buffer'.") (mud--defvar-local mud-pong nil "*Should we react to pings from other users?") (mud--defvar-local mud-keep-visible t "*Should the output buffer pop up on receiving mud text?") (mud--defvar-local mud-quote-string ": quotes: " "*String to precede file quotes with") (mud--defvar-local mud-idle-chat 0 "*Should the client generate messages if you're idle? Non-nil says to generate idle messages. If set to 't', actual text will be sent (see mud-idle-messages); if set to '0', mud-default-idle-noop will be sent.") (mud--defvar-local mud-idle-time "10 min" "*Default idle timeout") (mud--defvar-local mud-idle-messages '( "rolls over and snorts quietly." "scritches." "beables softly." "snores gently." "coughs." "sneezes." "downs a beer.";; About the only sensible one! "idles." ) "*List of messages used by idle timer.") (mud--defvar-local mud-idle-noop "\n" "*Do-nothing string for idle timer.") (mud--defvar-local mud-extract-map nil "*Whether to automagically extract map, room descriptions, exits.") (mud--defvar-local mud-extract-map-face '((foreground-color . "yellow"))) (mud--defvar-local mud-extract-map-header ",---------------\$------------\$?\\.\n") (mud--defvar-local mud-extract-map-footer "`---------------\$------------\$?'\n") (defvar mud-load-hook nil "Hook to run when kc-mud is loaded.") (defvar mud-init-hook nil "Hook to run when `mud' is run.") (defvar mud-backspace-function (or (key-binding [ (backspace) ]) 'backward-delete-char-untabify) "*Function called by `kc-electric-backspace' when deleting backwards.") (defvar mud-delete-function (or (key-binding [ (delete) ]) 'delete-char) "*Function called by `kc-electric-backspace' when deleting forwards.") (defun mud-backspace (arg) "Delete backward, unless already at bol. Calls `mud-backspace-function'." (interactive "*P") (if (bolp) (beep) (funcall mud-backspace-function 1))) (defun mud-delete (arg) "Delete forward, unless already at eol. Calls `mud-delete-function'." (interactive "*P") (if (eolp) (beep) (funcall mud-delete-function 1))) ;;; Mud hook stuff (defvar mud-processing-hooks nil "*List of functions to run when the mud generates output. The hooks should take the form (lambda (output start end &rest ignored)). Where OUTPUT is colored text, START and END are the region where text is inserted, and the rest is for future expansion. Note that END is not neccessarily the end of the buffer, esp. in combined input window mode. Most of the fun things you can do should probably be done with the regexp matcher - see mud-default-regexps-list. To add a local hook use (add-hook 'mud-processing-hooks HOOK t t). ") ;;; Add the new hooks in. (add-hook 'mud-processing-hooks 'mud-check-for-regexps t) (add-hook 'mud-processing-hooks 'mud-extract-map t) (mud--defvar-local mud-regexps-list nil "List of vectors, [regexp func last-matched], to run on the mud buffer. Performs arbitrary regexp hacking. Each element is a vector whose elements are [regexp function]. You should use `mud-add-trigger' or `mud-add-trigger-function' to add to this. To set it only for a certain mud, do it in a pre-connect hook. ") (defmacro mud-add-trigger-function (name regexp) "Add a trigger with regexp REGEXP and function name NAME." `(add-to-list 'mud-regexps-list (vector ,regexp ',name) t )) (defmacro mud-add-trigger (name regexp &rest body) "Define a mud trigger function NAME with body BODY, and add a trigger with regexp REGEXP that calls this function. Example: (mud-add-trigger mud-open-whatever \"The \\\$\\\\S-+\\\$ seems to be closed\\\\.\" (mud-send-string-with-echo (format \"open %s\\n\" (setq mud--last-door (match-string 1))))) " `(progn (defun ,name (&rest ignored) (interactive) (when (mud-goto-output-buffer) ,@body)) (mud-add-trigger-function ,name ,regexp))) (defun mud-add-gag (regexp) "Gag any occurance of REGEXP." (mud-add-trigger-function mud-gag-line regexp)) (defun mud-gag-line (&rest ignored) (message (format "gagged: %s" (match-string 0))) (replace-match "") (if (eq (char-after) 10) (delete-char 1))) ;;; Mud hilighting faces ;;; ;;; FEATURE: some sort of convenience font thing would be nice. ;;; FEATURE: Menu to tweak faces? ;;; (defmacro mud-def-face (face base help &optional fg bg) `(progn (defvar ,face ',face ,help) (copy-face ',base ',face) ,(if fg `(set-face-foreground ',face ,fg)) ,(if bg `(set-face-background ',face ,bg)))) ;; set background to black, foreground to white. (mud-def-face mud-default-face default "*default text face for mud." "white" "black") ;; derive other faces from mud-default-face (mud-def-face mud-page-face mud-default-face "*Face to highlight pages with." "blue") (mud-def-face mud-url-face mud-default-face "*Face to highlight urls with." "red") (mud-def-face mud-whisper-face mud-default-face "*Face to highlight whispers with." "brown") (defvar mud-default-topic-color-array [ "medium slate blue" "dark green" "purple" "DarkGoldenRod4" "IndianRed4" "OliveDrab4" "medium blue" "yellow4" ] "An array of colors to be used for topics.") ;;; Mud highlighting regexps (defvar mud-whisper-regexp "^\$You whisper\\|\\S-+ whispers,\$ .*\$[\r\n] .*\$*" "Regular expression that matches 'whisper traffic'.") (defvar mud-page-regexp "^\$You paged\\|\\(\\S-+\$ pages:\\|\$\\S-+\$ is looking for you in\\) \$[^\r\n]*\$.*$" "Regular expression that matches 'page traffic'.") (defvar mud-url-regexp "\n]+\\)>\\|\$\\(file\\|ftp\\|gopher\\|http\\|https\\|s?news\\|wais\\|www\$://[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)\\|\$mailto:[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\$" "Regular expression that matches an absolute URL.");; found in vm :) (defvar mud-ping-regexp "^\$\\S-+\$ \$say\\|whisper\\|page\$s\$ to \\S-+\$?[,:] \"?[Pp][Ii][Nn][Gg].*$" "Regular expression that matches a ping request.") (defvar mud-topic-regexp "^\\S-+ .*\$[\r\n] .*\$* <\$\\S-+\$>\r$") (defvar mud-version-regexp "^\$\\S-+\$ whispers, \"version\"" "Regular expression that matches a version request.") (defvar mud-output-map nil "Keymap for mud output buffers.") (defvar mud-input-map nil "Keymap for mud input buffer.") (defvar mud-shared-map nil "Keymap shared between input and output.") (defvar mud-current-list nil "List of muds we're currently connected to.") (defvar mud-history-list nil "History list for minibuffer.") (defvar mud-frame nil "Frame containing mud window(s).") (defvar mud-map-frame nil "Frame containing mud map window(s).") (defvar mud-number-keypad-as-directions 1 "Positive if (un-num-locked) number keypad should be used as cardinal direction commands.") (defsubst function-name-add-1 (symbol) (intern (concat (symbol-name symbol) "-1"))) (defun mud-define-key-1 (key function) (mud--DEBUG-expect-to-be-in-bin) (define-key mud-input-map key function) (define-key mud-output-map key function) ) (defmacro mud-define-key (function key &rest body) `(progn ;;(defun ,(function-name-add-1 `',function) () (interactive) ,@body) (defun ,function () (interactive) (when (mud-goto-input-buffer)) ,@body) (mud-define-key-1 ,key ',function))) (defmacro mud-define-key-reply (function key string) `(mud-define-key ,function ,key (mud-send-string-with-echo ,string))) ;;; keypad directions a la SimpleMu (everything is natural except 5=down, 0=up) (defun mud-number-keypad (&optional arg) "Toggle mud-number-keypad-as-directions mode. If arg, then directly set iff > 0." (interactive "P") (when (mud-goto-input-buffer) (if (setq mud-number-keypad-as-directions (if arg (> (prefix-numeric-value arg) 0) (not mud-number-keypad-as-directions))) (progn (mud-define-key-1 [ (kp-1) ] 'mud-keypad-southwest) (mud-define-key-1 [ (kp-2) ] 'mud-keypad-south) (mud-define-key-1 [ (kp-3) ] 'mud-keypad-southeast) (mud-define-key-1 [ (kp-4) ] 'mud-keypad-west) (mud-define-key-1 [ (kp-5) ] 'mud-keypad-down) (mud-define-key-1 [ (kp-6) ] 'mud-keypad-east) (mud-define-key-1 [ (kp-7) ] 'mud-keypad-northwest) (mud-define-key-1 [ (kp-8) ] 'mud-keypad-north) (mud-define-key-1 [ (kp-9) ] 'mud-keypad-northeast) (mud-define-key-1 [ (kp-0) ] 'mud-keypad-up) ;;(mud-define-key-1 [ (kp-delete) ] 'mud-keypad-dot) (message "Number keypad enabled.") ) (mud-define-key-1 [ (kp-1) ] 'nil) (mud-define-key-1 [ (kp-2) ] 'nil) (mud-define-key-1 [ (kp-3) ] 'nil) (mud-define-key-1 [ (kp-4) ] 'nil) (mud-define-key-1 [ (kp-5) ] 'nil) (mud-define-key-1 [ (kp-6) ] 'nil) (mud-define-key-1 [ (kp-7) ] 'nil) (mud-define-key-1 [ (kp-8) ] 'nil) (mud-define-key-1 [ (kp-9) ] 'nil) (mud-define-key-1 [ (kp-0) ] 'nil) (mud-define-key-1 [ (kp-delete) ] 'nil) (message "Number keypad disabled.") ))) ;; from menu-bar.el. (defmacro kc--menu-bar-make-toggle (name variable doc message help &rest body) `(progn (defun ,name () ,(concat "Toggle whether to " (downcase (substring help 0 1)) (substring help 1) ".") (interactive) (if ,(if body `(progn . ,body) `(setq ,variable (not ,variable))) (message ,message "enabled") (message ,message "disabled"))) '(menu-item ,doc ,name :help ,help :button (:toggle . (and (boundp ',variable) ,variable))))) (defun mud--create-menu () (let ((map (make-sparse-keymap "Mud"))) (define-key map [send-ping] '("Send a ping" . mud-send-ping)) (define-key map [toggle-page] (kc--menu-bar-make-toggle mud-toggle-page mud-page-beep "Beeping on page" "Beep on Page %s" "Toggle beeping on page")) (define-key map [toggle-log] (kc--menu-bar-make-toggle mud-toggle-log mud-logging "Logging" "Logging %s" "Toggle logging" (if (setq mud-logging (not mud-logging)) (mud-enable-logging)))) (define-key map [toggle-idle] (kc--menu-bar-make-toggle mud-toggle-idle mud-idle-chat "Anti-idle messages" "Anti-Idle Messages %s" "Toggle anti-idle messaging")) (define-key map [toggle-pong] (kc--menu-bar-make-toggle mud-toggle-pong mud-pong "Pong messages" "Pong Replies to Pings %s" "Toggle pong replies to pings")) (define-key map [insert-file] '("Quote a file" . mud-insert-file)))) (defun mud--define-common-keys (keymap) (define-key keymap "\C-cp" 'mud-toggle-page) (define-key keymap "\C-c\C-p" 'mud-send-ping) (define-key keymap "\C-cl" 'mud-toggle-log) (define-key keymap "\M-n" 'mud-grab-next-line) (define-key keymap "\M-p" 'mud-grab-prev-line) (define-key keymap "\C-ci" 'mud-insert-file) (define-key keymap [ (meta m) ] 'mud-toggle-map-window) (define-key keymap [ (meta z) ] 'mud-repeat-previous-command) (define-key keymap [ (meta kp-multiply) ] 'mud-number-keypad) (define-key keymap [ (meta kp-add) ] 'mud-repeat-previous-command-1+) (define-key keymap [ (meta kp-subtract) ] 'mud-repeat-previous-command-1-) (define-key keymap [ (pause) ] 'mud-toggle-pause-output) ) ;; Define keys for the input buffer (defun mud--make-input-keymap () (let ((mud-input-map (make-keymap))) (define-key mud-input-map "\r" 'mud-send-input) (define-key mud-input-map "\C-r" 'mud-bout-isearch-backward) (define-key mud-input-map [ (backspace) ] 'mud-backspace) (define-key mud-input-map [ (delete) ] 'mud-delete) (define-key mud-input-map [menu-bar] (make-sparse-keymap)) (define-key mud-input-map [menu-bar mud] (cons "Mud" (mud--create-menu))) (mud--define-common-keys mud-input-map) mud-input-map )) ;; Define keys for the output buffer (defun mud--make-output-keymap () (let ((mud-output-map (make-keymap))) (substitute-key-definition 'self-insert-command 'mud-bounce-input mud-output-map global-map) ;; All these keys will open the input window but not do anything else. (define-key mud-output-map "\r" 'mud-goto-input) (define-key mud-output-map "\t" 'mud-goto-input) (define-key mud-output-map [ (backspace) ] 'mud-goto-input) (define-key mud-output-map [ (delete) ] 'mud-goto-input) (substitute-key-definition 'copy-region-as-kill 'mud-copy-region-no-properties-as-kill mud-output-map global-map) (define-key mud-output-map [ (control insert) ] 'mud-copy-region-no-properties-as-kill) (substitute-key-definition 'yank 'mud-paste-to-input-region mud-output-map global-map) (define-key mud-output-map [ (shift insert) ] 'mud-paste-to-input-region) ;; Add a hook for browse-url if it's loaded. (if (fboundp 'browse-url-at-mouse) (define-key mud-output-map [mouse-2] 'mud-browse-url-at-mouse)) (mud--define-common-keys mud-output-map) mud-output-map )) (unless mud-input-map (setq mud-input-map (mud--make-input-keymap))) (unless mud-output-map (setq mud-output-map (mud--make-output-keymap))) (defun mud--setup-input-buffer-1 () (mud--setq-local mud--is-bin t) (mud--setq-local mud--idle-timer nil) (make-local-variable 'mud-input-map) (make-local-variable 'mud-output-map) (use-local-map mud-input-map) ) (defun mud--setup-output-buffer-1 () (mud--setq-local mud--is-bout t) ;; TODO: need a more elegant & customizable way of doing this. (setq fill-column 80) (mud--setq-local mud--regexps-data nil) (mud--setq-local mud--last-output (copy-marker (point-marker) t)) (mud--setq-local mud--last-fill (point-marker)) (mud--setq-local mud--last-log (point-marker)) ;;(mud--setq-local mud--extract-map-point (point-marker)) (mud--setq-local mud--logged-in nil) ) (defun mud--setup-common-buffer-1 (x-mud x-mud-name x-mud--bin x-mud--bout) (mud--setq-local mud-current x-mud) (mud--setq-local mud--bin x-mud--bin) (mud--setq-local mud--bout x-mud--bout) (mud--setq-local mud--bmap nil) (mud--setq-local mud-name x-mud-name) (mud--setq-local ansi-color-map mud--ansi-color-map) (setq major-mode 'mud-mode) ) (defun mud-make-buffer-name (new-mud-name type) (format (cond ((eq type 'in) "%s [input]") ((eq type 'out) "%s [output]") ((eq type 'map) "%s [map]") ((eq type 'single) "%s") (t (error "invalid buffer type"))) new-mud-name)) (defun mud--setup-buffers-separate (x-mud x-mud-name) (let ((x-mud--bin (get-buffer-create (mud-make-buffer-name x-mud-name 'in))) (x-mud--bout (get-buffer-create (mud-make-buffer-name x-mud-name 'out)))) ;; setup MUD--BIN (put x-mud 'mud--bin x-mud--bin) (set-buffer x-mud--bin) (goto-char (point-max)) (mud--setup-common-buffer-1 x-mud x-mud-name x-mud--bin x-mud--bin) (mud--setup-input-buffer-1) (setq mode-name "Mud-Input") (setq mud-separate-input-window t) ; make sure this is remembered locally ;; setup MUD--BOUT (let ((map mud-output-map)) (set-buffer x-mud--bout) (goto-char (point-max)) (mud--setup-common-buffer-1 x-mud x-mud-name x-mud--bin x-mud--bin) (mud--setup-output-buffer-1) (setq mode-name "Mud-Output") (use-local-map map) (setq buffer-read-only t) (setq mud-separate-input-window t) ; make sure this is remembered locally ) (set-buffer x-mud--bin) )) (defun mud--setup-buffers-single (x-mud x-mud-name) (let ((x-mud--bin (get-buffer-create x-mud-name))) (set-buffer x-mud--bin) (goto-char (point-max)) (insert " ") (mud--setup-common-buffer-1 x-mud x-mud-name x-mud--bin x-mud--bin) (mud--setup-input-buffer-1) (setq mud-separate-input-window nil) ; make sure this is remembered locally (let ((inhibit-read-only t) (start (point))) (insert mud-single-window-input-prompt) (add-text-properties start (point) (list 'field 'mud-prompt 'intangible t 'read-only t 'rear-nonsticky t 'local-map mud-output-map ;;'front-sticky '(read-only local-map) )) (put-text-property (1- (point)) (point) 'local-map nil) (set-buffer-modified-p nil) (mud--setq-local mud-input-marker (point-marker)) (goto-char start) ) (mud--setup-output-buffer-1) (setq mode-name "Mud") (goto-char mud-input-marker) )) (cond (mud-debug-p (defun mud--DEBUG-expect-to-be-in-bin () (unless (and (boundp 'mud--is-bin) mud--is-bin) (error "Not in mud--bin"))) (defun mud--DEBUG-expect-to-be-in-bout () (unless (and (boundp 'mud--is-bout) mud--is-bout) (error "Not in mud--bout"))) (defun mud--DEBUG-pause-output () (when mud-debug-pause-p (mud-pause-output))) (defun mud--DEBUG-unpause-output () (when mud-debug-pause-p (mud-unpause-output))) ) (t (defun mud--DEBUG-expect-to-be-in-bin ()) (defun mud--DEBUG-expect-to-be-in-bout ()) (defun mud--DEBUG-pause-output ()) (defun mud--DEBUG-unpause-output ()) )) (defun mud-mode () "Mud mode. Doc TODO." ) (defun mud--regexps-list-initiliaze (veclist) (mud--DEBUG-expect-to-be-in-bout) (mapcar (lambda (vec) (if (> (length vec) 2) (aset vec 2 (copy-marker mud--last-output)) (vconcat vec (vector (copy-marker mud--last-output))))) veclist)) (defun mud-reset-regexps () "Re-initialize mud's regexp pointers to end-of-buffer." (interactive) (when (mud-goto-input-buffer) (mud-reset-regexps-1))) (defun mud-reset-regexps-1 () (let ((regexps mud-regexps-list)) (mud--DEBUG-expect-to-be-in-bin) (mud-goto-output-buffer-from-input) (setq mud--regexps-data (mud--regexps-list-initiliaze regexps)))) ;;; STRATEGY for per-mud settings ;;; The old strategy was to use GET and PUT to keep track of all mud user ;;; variables and settings. Any access to these variables required figuring ;;; out what object to use and then a call to GET. Instead, now we will use ;;; buffer-local variables so we can simply use them directly. We will ;;; concentrate most variables to the input buffer since that is where the ;;; user mostly interacts. Some variables specifically used only from the ;;; output buffer will be set there. Other buffers (output, map, etc) will ;;; have a local variable that points to the input buffer so that we can get ;;; to it when neccessary. (defun mud--failed-to-find-buffer () "message and return nil." (message "Not in any mud buffer!") nil) (defun mud-goto-input () "Show and switch to the mud input window. In single-window mode, also go to the end of buffer if not currently in the input region. Intended to be called before echoing input. Returns true if switched successfully." (interactive) (or (mud-goto-input-1) (mud--failed-to-find-buffer))) (defun mud-goto-input-buffer () (or (mud-goto-input-buffer-1) (mud--failed-to-find-buffer))) (defun mud-goto-input-1 () (mud-goto-input-buffer-1) (unless mud-separate-input-window ;; should already be in the correct buffer. go to the input "region" if ;; neccessary - basically end of buffer! (if (< (point) mud-input-marker) (goto-char (point-max))) t) ;; may need to change window/frame. (if (frame-live-p mud-frame) (select-frame mud-frame)) (unless (window-live-p mud--win) (mud--setup-windows)) (select-window mud--win) ) (defun mud-goto-input-buffer-1 () "Go to the mud input buffer from input, output, or map buffers. Returns true if we may still need to position within the buffer." (and (boundp 'mud-current) mud-current (boundp 'mud--bin) (buffer-live-p mud--bin) (set-buffer mud--bin))) (defun mud-goto-output-buffer-from-input () "Go to output buffer, from input buffer." (mud--DEBUG-expect-to-be-in-bin) (when mud-separate-input-window (set-buffer mud--bout))) (defun mud-goto-output-buffer () "Go to output buffer, from any mud buffer." (or (and (boundp 'mud--is-bout) mud--is-bout) (and (mud-goto-input-buffer) (mud-goto-output-buffer-from-input)))) (defun mud--select-frame-create () "Create the mud frame if neccessary, and switch to it." (unless (frame-live-p mud-frame) (setq mud-frame (make-frame '((name . "MUD") ;;; TODO: use color vars instead of hardcoding (background-color . "black") (foreground-color . "white"))))) (select-frame mud-frame)) ;;; ;;; Start here! ;;; (defun mud (&optional new-mud-name) "Connect to a mud" (interactive) ;; Find out what mud to log into, if it's not specified. FEATURE: ;; allow user to connect to an arbitrary mud by prompting for ;; details. (or new-mud-name (setq new-mud-name (car (mud-pick-from-list mud-list mud-default)))) (and (equal new-mud-name "") (setq new-mud-name (prin1-to-string mud-default))) (let ((mud (intern new-mud-name))) (mud-1 mud new-mud-name (cadr (assoc mud mud-list))))) (defun mud-1 (x-mud x-mud-name mud-connect-info) (mud--select-frame-create) (if mud-separate-input-window (mud--setup-buffers-separate x-mud x-mud-name) (mud--setup-buffers-single x-mud x-mud-name)) (mud--DEBUG-expect-to-be-in-bin) (mud--setq-local mud--win nil) (mud--setq-local mud--wout nil) (mud--setq-local mud--wmap nil) ;;(mud--setq-local mud-fin nil) (mud--setup-windows) ;; numpad directions (mud-number-keypad mud-number-keypad-as-directions) ;; Autologon stuff (mud--setq-local mud-host (nth 0 mud-connect-info)) (mud--setq-local mud-port (nth 1 mud-connect-info)) (mud--setq-local mud-user (nth 2 mud-connect-info)) (mud--setq-local mud-pass (nth 3 mud-connect-info)) (mud--setq-local mud-pre-connect-hooks (nth 4 mud-connect-info)) (mud--setq-local mud-post-connect-hooks (nth 5 mud-connect-info)) ;; history stuff (mud--setq-local mud--command-history nil) (mud--setq-local mud--command-to-yank -1) ;; Initialise properties ;; Topic coloring ;;(mud--setq-local mud-num-colored-topics 0) ;;(mud--setq-local mud-topic-color-alist nil) ;; Log to file (mud--setq-local mud-log-file (mud-make-log-filename)) ;; Set up the idle-timer (mud--idle-timer-reset) ;; (message "Building props list...") ;; (mud-list-props mud-new) ;; (message "Building props list...done") (run-hooks 'mud-pre-connect-hooks) (mud-reset-regexps) ;; connect now, after everything is set up. (mud--setq-local mud-process nil) (mud--stream-setup) ;; Add to 'live' list (setq mud-current-list (cons mud-current mud-current-list)) (mud-whine (concat "Connected to host at " (current-time-string) ".")) (run-hooks 'mud-post-connect-hooks) (run-hooks 'mud-init-hook) ) ;;; ;;; Notify user that the URL has been sent ;;; This is mainly to reassure me that I clicked on the url, since I ;;; have a slow machine. ;;; (defun mud-browse-url-at-mouse () (interactive) (when (fboundp 'browse-url-at-mouse) (message "Sending URL to browse-url...") (call-interactively 'browse-url-at-mouse) (message "Sending URL to browse-url...done."))) (defun kc-symbol-to-string (symbol) (if (and symbol (symbolp symbol)) (symbol-name symbol) "")) ;;; ;;; Choose a mud from a list, with optional default. ;;; (defun mud-pick-from-list (mud-list &optional mud-default) "Select a mud from LIST and return the string & symbol." (let ((mud-completion-list (mapcar (lambda (x) (let ((x (if (consp x) (car x) x))) (cons (prin1-to-string x) x))) mud-list))) (assoc (completing-read "Mud: " mud-completion-list nil 0 (kc-symbol-to-string mud-default) mud-history-list) mud-completion-list))) (defun mud-bounce-input () "Bounce input to the correct buffer." (interactive) (when (mud-goto-input) ;;(let ((inhibit-read-only t)) (self-insert-command 1) ;;) )) (defmacro nspaces (n) `(make-string ,n ? )) (defun kc-ansi-cursor-movements (begin end) ;; for now, only do ^[C (cursor forward)'s since their the easiest - we'll ;; assume that it is only used at ends of lines for stupid asses that think ;; they are saving spaces with them. (let ((end-marker (copy-marker end))) (save-excursion (goto-char begin) (while (re-search-forward "\033\\[\$[0-9]*\$C" nil t) (replace-match (nspaces (string-to-int (match-string 1)))))))) (defun call-functions-with-error-control (hooks args) (while hooks (save-excursion (condition-case nil (apply (car hooks) args) (error (message "Error in hook function '%s'!" (car hooks)) (mud-whine (format "Error in hook function '%s'!" (car hooks))) ))) (setq hooks (cdr hooks)))) (defun mud--stream-run-hooks (&rest args) "Process output from the mud - run hooks." (mud--DEBUG-expect-to-be-in-bout) (call-functions-with-error-control mud-processing-hooks args)) ;;; ;;; Gather any output the mud has to offer ;;; (defun mud-pause-output-1 () (mud--DEBUG-expect-to-be-in-bout) (mud--setq-local mud--saved-output "") (unless (assq 'mud--saved-output minor-mode-alist) (setq minor-mode-alist (cons '(mud--saved-output " PAUSED") minor-mode-alist))) (set-process-filter mud-process 'mud--stream-save-output) (message "Mud output paused.") ) (defun mud-unpause-output-1 () (mud--DEBUG-expect-to-be-in-bout) (let ((output mud--saved-output)) (setq mud--saved-output nil) (mud--stream-output output) (set-process-filter mud-process 'mud--stream-output-filter-function) (message "Mud output unpaused.") )) (defun mud--is-output-paused () (mud--DEBUG-expect-to-be-in-bout) (and (boundp 'mud--saved-output) mud--saved-output)) (defun mud-pause-output () (interactive) (save-excursion (when (mud-goto-output-buffer) (when (not (mud--is-output-paused)) (mud-pause-output-1))))) (defun mud-unpause-output () (interactive) (save-excursion (when (mud-goto-output-buffer) (when (mud--is-output-paused) (mud-unpause-output-1))))) (defun mud-toggle-pause-output () (interactive) (save-excursion (when (mud-goto-output-buffer) (if (mud--is-output-paused) (mud-unpause-output-1) (mud-pause-output-1))))) (defun mud--save-paused-output-1 (string) (mud--DEBUG-expect-to-be-in-bout) (setq mud--saved-output (concat mud--saved-output string))) (defun mud--stream-save-output (process string) (save-excursion-to-buffer (process-buffer process) (mud--save-paused-output-1 string))) ;;; TODO: can we use accept-process-output to get all input when there is some ;;; more waiting? (defun mud--stream-output-filter-function (process output) (save-excursion-to-buffer (process-buffer process) (mud--stream-output output))) (defun mud--stream-output (output) (mud--DEBUG-expect-to-be-in-bin) (let ((colored-output (ansi-color-apply (mud--ansi-filter-misc output)))) (unless (string= colored-output "") (mud-goto-output-buffer-from-input) (mud--DEBUG-pause-output) (mud--stream-output-1 colored-output) (mud--DEBUG-unpause-output) ))) (defun mud--ansi-filter-misc (string) "Filter non-SGR ANSI sequences." (let ((start 0)) (while (setq start (string-match "\033\\[\\??[0-9;]*[KCDh]" string start)) (setq string (replace-match "" t t string))) string)) (defun mud--display-bout-if-neccessary () "Display mud--bout if we want to keep it visible and it's not. Update mud--wout and return it. If not visible and not keeping visible, return nil." (setq mud--wout (or (get-buffer-window mud--bout t) (and mud-keep-visible (display-buffer mud--bout))))) (defun mud--recenter-output-window () (let ((cur-win (selected-window))) (when (mud--display-bout-if-neccessary) (select-window mud--wout) (recenter -1) (select-window cur-win)))) (defun mud--stream-output-1 (colored-output) "Process colored output into buffer." (mud--DEBUG-expect-to-be-in-bout) (let ((start (copy-marker mud--last-output)) ;; copy to get rid of insert-before-ness (do-recenter (mud-append-output-1 colored-output))) (save-excursion (let ((inhibit-read-only t)) (mud--remove-carriage-returns start mud--last-output) (goto-char mud--last-output) (mud--stream-run-hooks start mud--last-output) ;; Special hooks. These are always called, where as stuff on the hooks ;; list is optional and can be removed if desired. ;; Auto Login (mud--check-logon) ;; NB This should be the last thing called as it destroys essential ;; information about the way the line arrived. (mud--fill-lines) ;; However, we do like to log /after/ the buffer has been pretty-printed (mud--log-to-file) ;; And then resize the thing. This is REALLY the last thing to be called. (mud--check-buffer-size) )) ;; Pretend we didn't modify the buffer (set-buffer-modified-p nil) ;; recenter if neccessary (if do-recenter (mud--recenter-output-window)) )) (defmacro mud-get-bin-var (v) `(if mud-separate-input-window (prog2 (set-buffer mud--bin) ,v (set-buffer mud--bout)) ,v)) ;; Log the mud output to a file (defun mud--log-to-file () "Log mud output to the mud's logfile." (when (mud-get-bin-var mud-logging) (write-region mud--last-log mud--last-output mud-log-file t 'silent) (setq mud--last-log mud--last-output))) (defsubst string-nonempty-p (string) (and (stringp string) (not (string-equal string "")))) (defun mud--check-logon-1 () (mud--DEBUG-expect-to-be-in-bout) (cond ((re-search-forward "Do you wish to use ANSI colors?" mud--last-output t) (mud-send-string-with-echo "y\n") ;; pretend to be logged in if we don't have username or password. (not (and (string-nonempty-p mud-user) (string-nonempty-p mud-pass))) ) ((re-search-forward "By what name do you wish to be known " mud--last-output t) (mud-send-string-with-echo (concat mud-user "\n")) (mud-send-string (concat mud-pass "\n")) t) ((re-search-forward "connect " mud--last-output t) (mud-send-string (concat "connect " mud-user " " mud-pass "\n")) ;; FIXME should check if we've actually logged in! t) )) ;;; ;;; Try logging onto the mud once we get a prompt ;;; (defun mud--check-logon () "Try to log onto the mud automatically." (mud--DEBUG-expect-to-be-in-bout) (unless mud--logged-in ;;(goto-char mud--last-output) ;; search current line only, not whole buffer. ;;(goto-char (point-min)) (beginning-of-line) (if (mud--check-logon-1) (setq mud--logged-in t)))) (defun mud--trim-buffer (delta) (mud--DEBUG-expect-to-be-in-bout) (when (> delta 0) (let ((inhibit-read-only t)) ;;(delete-region-with-overlays (point-min) (+ (point-min) delta)) (delete-region (point-min) (+ (point-min) delta)) ) )) ;;(defun clear-overlays-in-region (start end) ;; (interactive "r") ;; (mapcar 'delete-overlay (overlays-in start end))) (defun mud--check-buffer-size () "Check buffer size and trim if necessary" (mud--DEBUG-expect-to-be-in-bout) (let ((max (mud-get-bin-var mud-max-buffer))) (when (and max (> max 0)) (mud--trim-buffer (+ (- (point-max) max) mud-trim-buffer-delta))))) ;;(defun mud-find-receiver () ;; (or (and mud-single-input-mode mud-default-input-mud) ;; (mud-get-from-bin mud-current-list (current-buffer)) ;; (mud-get-from-bout mud-current-list (current-buffer)))) (defsubst buffer-substring-whole-line () "Return the current line plus '\\n' and leave point at end of line." (beginning-of-line) (let ((beg (point))) (end-of-line) (concat (buffer-substring-no-properties beg (point)) "\n"))) (defun mud--buffer-substring-whole-line-and-update-last-line () "Update last line with current line if it's not there; return current line." (let ((new-string (buffer-substring-whole-line))) ;; if not last line in buffer, go to end of buffer and put it there. (cond ((eobp) (insert "\n")) ((progn (forward-char) (eobp))) ;; next line empty? (t (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert new-string) )))) (defsubst buffer-substring-delete (start end) "Delete a region, and return deleted region." (let ((s (buffer-substring start end))) (delete-region start end) s)) (defun mud--buffer-substring-input-region-and-delete () "Delete mud input region, and return it." ;; we're going to insert the user command in the output portion of the ;; buffer, so we can delete it from the input "region". the input region ;; should always contain only the current command. (concat (buffer-substring-delete mud-input-marker (point-max)) "\n" )) (defun mud-is-active () (mud--DEBUG-expect-to-be-in-bin) (or (and (processp mud-process) (eq (process-status mud-process) 'open)) (error "No mud connection active"))) ;;; ;;; Send our $0.02 to the mud ;;; (defun mud-send-input () "Send the current line of input to the mud" (interactive) (when (mud-goto-input) (when (mud-is-active) (let ((new-string (if mud-separate-input-window (mud--buffer-substring-whole-line-and-update-last-line) (mud--buffer-substring-input-region-and-delete)))) (mud-save-string-to-command-history new-string) (setq mud--command-to-yank -1) ;; (mud-input-check-receiver-commands .... ) ;; send the string (save-excursion (mud-send-string-with-echo-1 new-string)) )))) ;;(defun mud-input-check-receiver-commands () ;; (let (new-string mud-receiver mud-receiver-name) ;; ;; handle / commands ;; (if (string-match "^/\$\\S-+\$\\s-*" new-string) ;; (setq mud-receiver-name (substring new-string ;; (match-beginning 1) ;; (match-end 1)) ;; new-string (substring new-string (match-end 1)) ;; mud-receiver (intern mud-receiver-name))) ;; ;; If mud-receiver is unset, try doing something smart with it. ;; (if mud-receiver ;; () ;; ;; Check for commands ;; (if mud-receiver-name ;; (progn ;; ;; Trim the leading " " and trailing ^j if there is one. ;; (if (string-match "^\\s-*\$.*\$ ;;" new-string) ;; (setq new-string (substring new-string (match-beginning 1) ;; (match-end 1)))) ;; (cond ;; ;; List muds ;; ((string= mud-receiver-name "list") ;; (message "Muds: %s" (prin1-to-string mud-current-list))) ;; ;; Connect to a new mud ;; ((string= mud-receiver-name "join") ;; (if (string-match "\\S-+" new-string) ;; (mud new-string) ;; (error "Syntax: /join MUDNAME"))) ;; ;; Change the default input mud ;; ((string= mud-receiver-name "input") ;; (if (string-match "\\S-+" new-string) ;; (if (read-from-string new-string) ;; (progn ;; (setq mud-default-input-mud (read-from-string ;; new-string)) ;; (message "Default input now goes to %s." new-string)) ;; (if (string-match "?" new-string) ;; (message "Default input goes to %s." ;; (prin1-to-string mud-default-input-mud)) ;; (error "You are not connected to %s." ;; mud-receiver-name))) ;; (error "Syntax: /input MUDNAME"))) ;; ;; If all else fails, tell the user they goofed. ;; (t ;; (error "/%s is not a valid command, and you are not connected to a mud called \"%s\"." mud-receiver-name (or (not (string= new-string "")) mud-receiver-name))))) ;; (setq mud-receiver (mud-find-receiver)) ;; )) ;; )) ;; define direction keys (defmacro def-keypad-func (name string) `(defun ,name () (interactive) "Sends the specified direction to mud." (mud-send-string-with-echo ,string))) (def-keypad-func mud-keypad-southwest "southwest\n") (def-keypad-func mud-keypad-south "south\n") (def-keypad-func mud-keypad-southeast "southeast\n") (def-keypad-func mud-keypad-west "west\n") (def-keypad-func mud-keypad-down "down\n") (def-keypad-func mud-keypad-east "east\n") (def-keypad-func mud-keypad-northwest "northwest\n") (def-keypad-func mud-keypad-north "north\n") (def-keypad-func mud-keypad-northeast "northeast\n") (def-keypad-func mud-keypad-up "up\n") (defun insert-string-with-properties (string properties) (let ((start (point))) (insert string) (add-text-properties start (point) properties))) (defun mud-insert-output-string (string) "Insert a string that is meant to be output, in the output buffer. In `mud-separate-input-window' mode, this is equivalent to `insert'. Otherwise, special properties are added (read-only, field, local-map)." (mud--DEBUG-expect-to-be-in-bout) ;; if the output and input buffers are the same (i.e. single window mode) ;; then we must add special properties. (if mud--is-bin (insert-string-with-properties string (list 'read-only t 'field 'mud-output 'local-map mud-output-map)) (insert string))) (defun mud-append-output-1 (string) "Append a string to the mud output buffer. Returns whether window should be recentered." (mud--DEBUG-expect-to-be-in-bout) (let ((inhibit-read-only t) (orig (point-marker)) (moving (= (point) mud--last-output))) (buffer-disable-undo) (goto-char mud--last-output) ;; mud--last-output should automagically advance when we insert text at it. ;; if same buffer as input buffer (i.e. not mud-separate-input-window), ;; then mark the text read only and add other special properties. (mud-insert-output-string string) ;; "moving" at end of buffer. Note that we will never be moving in ;; single-input-window mode since there is always at least a prompt after ;; the output insertion point. (unless moving (goto-char orig)) (set-buffer-modified-p nil) (buffer-enable-undo) ;; whether output window needs to be recentered. (if mud-separate-input-window moving (>= orig mud-input-marker)) )) (defun mud-append-output (string) (mud--DEBUG-expect-to-be-in-bin) (set-buffer mud--bout) (if (mud-append-output-1 string) (mud--recenter-output-window)) (set-buffer mud--bin)) (defun mud-send-string-with-echo-1 (string) ;; TODO: color. (mud--DEBUG-expect-to-be-in-bin) (setq string (mud--translate-string string)) (mud-append-output string) (mud-send-string-1 string)) (defun mud-send-string-with-echo (string) "Send a string to mud, with local echo." (save-excursion (when (mud-goto-input-buffer) (mud-send-string-with-echo-1 string)))) (defun mud-send-string-1 (string) (mud--DEBUG-expect-to-be-in-bin) (when mud-process (process-send-string mud-process string)) (mud--idle-timer-reset)) (defun mud-send-string (string) "Send a string to the specified mud process. As a side effect, kicks the mud's idle timer." (save-excursion (when (mud-goto-input-buffer) (setq string (mud--translate-string string)) (mud-send-string-1 string)))) ;;; ;;; Open up a tcp stream to the mud ;;; (defun mud--stream-setup () "Set up a tcp stream to the mud" (when (processp mud-process) (delete-process mud-process)) ;; Open a new network stream. We set the process-buffer to MUD--BIN instead ;; of MUD--BOUT because that is more useful to us, and it doesn't affect ;; process output directly since we use a filter function. (setq mud-process (mud--open-network-stream mud-name mud--bin mud-host mud-port)) ;; output filter (set-process-filter mud-process 'mud--stream-output-filter-function) (set-process-sentinel mud-process 'mud--sentinel)) (defsubst kill-live-window-unless-same-as (w1 w2) (if (and (window-live-p w1) (not (eq w1 w2))) (delete-window w1))) ;;; Set up the input & output windows for the mud client. Tries to be ;;; intelligent about keeping existing windows where they are and such ;;; like. (defun mud--setup-windows () "Set up the mud input/output windows from the currently selected window. Must be called from a mud input buffer." (mud--DEBUG-expect-to-be-in-bin) (if mud-separate-input-window (progn ;; First, get the mud output window (if (window-live-p mud--wout) (progn (select-window mud--wout) (delete-other-windows mud--wout)) (setq mud--wout (selected-window))) (let ((x-mud--wout mud--wout)) (set-buffer mud--bout) (mud--setq-local mud--wout x-mud--wout) (set-window-buffer mud--wout mud--bout) (set-buffer mud--bin)) (kill-live-window-unless-same-as (get-buffer-window mud--bin) mud--wout) (let ((output-window-height (- (window-height mud--wout) window-min-height))) ;;(if (< mud-wheight window-min-height) ;; (progn ;; (setq mud-wheight-diff (- window-min-height mud-wheight)) ;; (shrink-window (- mud-wheight-diff)) ;; (setq mud-wheight window-min-height))) (setq mud--win (split-window mud--wout output-window-height))) (select-window mud--win) (set-window-buffer mud--win mud--bin) (set-window-dedicated-p mud--wout t) (set-window-dedicated-p mud--win t) ) (setq mud--wout (setq mud--win (selected-window))) (set-window-buffer (selected-window) mud--bin)) ;;(if mud-extract-map ;; (mud--setup-map-window)) ) (defun mud--setup-map-window () "Setup the map window for the MUD." (mud--DEBUG-expect-to-be-in-bin) (let ((x-mud--bmap (or (and (buffer-live-p mud--bmap) mud--bmap) (get-buffer-create (mud-make-buffer-name mud-name 'map)))) x-mud--wmap) (if mud-separate-map-frame ;; create a new frame, select it, set window (let ((frame (selected-frame))) (unless (frame-live-p mud-map-frame) (setq mud-map-frame (make-frame '((name . "Mud map") (minibuffer . nil) (menu-bar-lines . 0) (tool-bar-lines . 0) (modeline . nil) (vertical-scroll-bars . nil) (background-color . "black") (foreground-color . "white") )))) (select-frame mud-map-frame) ;; TODO: resize and re-arrange windows (setq x-mud--wmap (mud--setup-map-buffer x-mud--bmap)) (select-frame frame) ) ;; same frame - split window vertically (split-window-horizontally mud-map-window-width) (setq x-mud--wmap (mud--setup-map-buffer x-mud--bmap)) ;; the split changes window objects for second window. (select-window (get-buffer-window mud--bin)) (setq mud--win (selected-window))) (mud--DEBUG-expect-to-be-in-bin) (set-buffer mud--bout) (mud--setq-local mud--bmap x-mud--bmap) (set-buffer mud--bin) (mud--setq-local mud--bmap x-mud--bmap) (mud--setq-local mud--wmap x-mud--wmap) )) (defmacro mud--x-let (vars &rest body) "\"let x-VAR VAR\" for each VAR in VARS. E.g., (mud--x-let (mud-name mud--bin) (set-buffer mud--bout) x-mud-name) returns mud-name in the original buffer." `(let ,(mapcar (lambda (v) (list (intern (concat "x-" (symbol-name v))) v)) vars) ,@body)) (defun mud--setup-map-buffer (x-mud--bmap) (mud--DEBUG-expect-to-be-in-bin) (mud--x-let (mud-current mud-name mud--bin mud--bout) (set-buffer mud--bout) (setq mud--extract-map-point (copy-marker mud--last-output)) (mud--x-let (mud-output-map) (switch-to-buffer x-mud--bmap) (mud--setq-local mud--is-bmap t) (setq buffer-read-only t) (use-local-map x-mud-output-map) (mud--setup-common-buffer-1 x-mud-current x-mud-name x-mud--bin x-mud--bout) (setq mode-name "Mud-Map") (setq major-mode 'mud-mode) (set-window-dedicated-p (selected-window) t) (mud--setq-local mud--wmap (selected-window)) ; must return wmap ))) (defun mud-kill-map-window () (mud--DEBUG-expect-to-be-in-bin) (select-window mud--win) (when (and (frame-live-p mud-map-frame) (not (eq mud-map-frame mud-frame))) (delete-frame mud-map-frame)) (when (and (window-live-p mud--wmap) (not (eq mud--wmap mud--win))) (delete-window mud--wmap)) (when (buffer-live-p mud--bmap) (kill-buffer mud--bmap)) (setq mud-map-frame nil) (setq mud--wmap nil)) (defun mud-toggle-map-window () "Toggle the mud map window. If it is enabled but not showing, show it. If it is not enabled, enable and show it. If it is enabled and showing, kill and disable it." (interactive) (when (mud-goto-input-buffer) (if mud-extract-map (if (window-live-p mud--wmap) (progn (setq mud-extract-map nil) (mud-kill-map-window)) (mud--setup-map-window)) (setq mud-extract-map t) (mud--setup-map-window)))) (defun mud-turn-on-map-window () "Turn on and SHOW the mud map window." (interactive) (when (mud-goto-input-buffer) ;;(unless mud-extract-map (setq mud-extract-map t) (mud--setup-map-window) ;;) )) (defun mud-turn-off-map-window () "Turn off the mud map window." (interactive) (when (mud-goto-input-buffer) (when mud-extract-map (setq mud-extract-map nil) (mud-kill-map-window)))) (defmacro save-excursion-to-buffer (buffer &rest body) `(let ((old-buffer (current-buffer))) (unwind-protect (progn (set-buffer ,buffer) ,@body) (if (buffer-live-p old-buffer) (set-buffer old-buffer))))) (defun x-to-string (x) (if (stringp x) x (prin1-to-string x))) (defun strip-trailing-newlines (string) (while (string-equal (substring string -1) "\n") (setq string (substring string 0 -1))) string) ;;; ;;; Process Sentinel to catch closing connection! ;;; (defun mud--sentinel (process msg) "Sentinel for mud process." (save-excursion-to-buffer (process-buffer process) (setq msg (strip-trailing-newlines (x-to-string msg))) (message msg) (mud-whine (format "The mud connection is closed (%s)." msg)) ;; FEATURE these should be optional ;; FEATURE auto-reconnect (setq mud-current-list (delq mud-current mud-current-list)) (mud--finished) ) (beep)) (defun mud--finished () "Clean up mud after it has finished." (if mud-separate-input-window (mud--quiet-kill-buffer-window mud--bin)) ;; TODO more? ) (defun mud--quiet-kill-buffer-window (buf) (condition-case error (delete-window (get-buffer-window buf)) (error nil)) ;;(kill-buffer buf) ) (defun mud-whine (string) "Stick an error message into the mud output-window." ;; TODO: color. (mud-append-output (format "mud.el says, \"%s\"\n" string))) (defun mud--remove-carriage-returns (start end) (goto-char start) (while (search-forward "\r" end t) (replace-match ""))) ;;; Fill out displayed lines, and remove ^M's. ;;; ;;; FIXME this won't cope properly with a big word that won't wrap in ;;; the middle of a block - it stops wrapping at the big word, instead ;;; of attempting to wrap the rest of the block. (defun mud--fill-lines () "Fill buffer line by line." (mud--DEBUG-expect-to-be-in-bout) (let ((old-point (point))) (goto-char mud--last-fill) (beginning-of-line) (save-restriction (narrow-to-region (point) mud--last-output) (while (< (point) mud--last-output) (if (<= (move-to-column (+ 1 fill-column)) fill-column) ;; Line is too short to fill, goto next line. (forward-line 1) ;; Look for a break point in the current line (skip-chars-backward "^ \t\n") ;; Are we (a) at the start of the line or (b) at the leading ;; whitespace that we inserted last time? (unless (mud--bolxp) (insert "\n ")) )) ;; Save the fill-point. (setq mud--last-fill (point-marker)) ) (goto-char old-point))) (defun mud--bolxp () "True if at beginning of line or first space in line." (or (bolp) (let ((here (point))) (beginning-of-line) (skip-chars-forward " ") (or (eq (point) here) (progn (goto-char here) nil))))) (defun mud--x-replace-match (newstring num stringpos) (setcdr stringpos (+ (cdr stringpos) (- (length newstring) (- (match-end num) (match-beginning num))))) (setcar stringpos (replace-match newstring nil t (car stringpos) num))) (defun mud--translate-string (string) "Replace local aliases, / commands, etc. This prepares a string to be actually sent to the mud." (let ((stringpos (cons string 0))) (while (string-match "\$[^ ]+\$ *\$[^\n]*?\$\n" (car stringpos) (cdr stringpos)) (let ((cmd (match-string 1 (car stringpos))) (arg (match-string 2 (car stringpos)))) (setcdr stringpos (match-end 0)) (cond ((string-equal cmd "/") ;;(mud--x-replace-match "t self !!/!!" 1 stringpos)) (mud--x-replace-match (mud--handle-slash-cmd arg) 0 stringpos)) ))) (car stringpos))) (defsubst mud--multiply-string (num string) (let ((result "")) (while (> num 0) (setq result (concat result string)) (setq num (1- num))) result)) (defconst mud-slash-directions '((?R . "recall\n") (?n . "north\n") (?e . "east\n") (?s . "south\n") (?w . "west\n") (?u . "up\n") (?d . "down\n") )) (defsubst mud--slash-char (char) (cdr (assoc char mud-slash-directions))) (defun mud--handle-slash-cmd (cmd) "Handle a kc-mud.el '/' command. #?[neswud] becomes # times {north, east, south, west, up, down}. R becomes recall. Example: 'R3en' becomes \"recall\\neast\\neast\\neast\\nnorth\\n\"." ;; this would be easier in C(++)? (let ((pos 0) (length (length cmd)) (result "") num) (while (< pos length) (let ((chr (aref cmd pos))) (if (and (>= chr ?0) (<= chr ?9)) (let ((n (- chr ?0))) (setq num (if num (+ (* num 10) n) n))) (let ((c (mud--slash-char chr))) (setq result (concat result (if c (mud--multiply-string (or num 1) c) (format "tell self mud.el: error, invald slash char '%c'\n" chr) )))) (setq num nil))) (setq pos (1+ pos))) result)) ;;; --------------------------------------------------------------- ;;; KEYMAP FUNCTIONS ;;; --------------------------------------------------------------- (defun mud-enable-logging () (save-excursion (mud-goto-output-buffer) (setq mud--last-log mud--last-output))) ;;; ;;; Quote a file into the mud ;;; ;; TODO (defun mud-insert-file () "Quote a file on the mud." ;;(interactive) ;;(let* (last-line) ;; (save-excursion ;; (set-buffer (get-buffer-create " *mud quote buffer*")) ;; (erase-buffer) ;; ;; No, of course I shouldn't be doing this. And? ;; (call-interactively 'insert-file) ;; (goto-char (point-min)) ;; (insert mud-quote-string) ;; (end-of-line) ;; (insert "\n") ;; (mud-send-string mud (buffer-substring (point-min) ;; (point))) ;; (setq last-line (point)) ;; (while (eq 0 (forward-line 1)) ;; (insert mud-quote-string) ;; (end-of-line) ;; (insert "\n") ;; (mud-send-string mud (buffer-substring last-line ;; (point))) ;; (setq last-line (point))))) ) ;; Say ping with the current time attached. (defun mud-send-ping () "Send a ping to the mud!" (interactive) (mud-send-string (format "say ping %s\n" (current-time-string)))) ;;; ---------------------------------------------------------------- ;;; HOOK FUNCTIONS ;;; ---------------------------------------------------------------- (defun mud-check-for-regexps (start end &rest ignored) "Check mud-regexps-list for a match, and act appropriately." (mud--DEBUG-expect-to-be-in-bout) (save-excursion (let ((search-min (max 1 (- start 3000))) (full-line (eq (char-after end) ?\n))) ;; TODO ? (setq mud--regexps-data (mapcar (lambda (vec) (mud--process-regexp vec search-min full-line)) mud--regexps-data))))) ;;(defun point-last-line () ;; "Return point at the beginning of the last line." ;; (let ((p (point))) ;; (goto-char (point-max)) ;; (forward-line 0) ;; (prog1 ;; (point) ;; (goto-char p)))) ;;(defface mud-regexp-debug-face-1 ;; '((((class color)) (:background "orange" )) ;; (t (:inverse-video t))) ;; "Debug face" ;; :group 'mud) ;;(defface mud-regexp-debug-face-2 ;; '((((class color)) (:background "yellow" )) ;; (t (:inverse-video t))) ;; "Debug face" ;; :group 'mud) ;;(defun mud--make-debug-overlay (face start end) ;; (let ((overlay (make-overlay start end))) ;; (overlay-put overlay 'face face) ;; (overlay-put overlay 'priority 99999) ;; overlay)) ;;; ;;; Handle a single regexp from the above function. ;;; (defun mud--process-regexp (regexp-vector search-min full-line) "Check MUD for a single regexp and do the stuff." ;;(mud--DEBUG-pause-output) (if (vectorp regexp-vector) (progn ;; the search-min is so that output too long ago won't be searched again. (goto-char (max search-min (aref regexp-vector 2))) (mud--process-regexp-1 full-line (aref regexp-vector 0) (aref regexp-vector 1)) ;; reset the vector pointer (aset regexp-vector 2 (point-marker)) regexp-vector) (message "regexp-vector ain't a vector!") nil) ;;(mud--DEBUG-unpause-output) ) (defun mud-message-and-whine (string &rest objects) "'format' a string, then 'message' and `mud-whine'." (let ((msg (apply 'format string objects))) (message msg) (mud-whine msg))) (defun mud--process-regexp-1 (full-line regexp function) (while (mud--re-search-full-line regexp full-line) (condition-case err (funcall function) (error (mud-message-and-whine "Error in hook defined by function %S, regex '%s': '%s'" function regexp (error-message-string err)))))) (defun mud--re-search-full-line (regexp full-line &optional lim) "Search forward for a regexp. If not found or if the search terminated at the end of a partial line, return nil (doesn't affect point). If found successfully, return new point." ;;(mud-make-debug-overlay 'mud-regexp-debug-face-1 (point) (point-max)) (let ((pstart (point)) (pfound (re-search-forward regexp lim t))) (and pfound ;;(mud-make-debug-overlay 'mud-regexp-debug-face-2 (match-beginning 0) (match-end 0)) (or (and (or full-line (/= (point) (point-max))) pfound) (progn (goto-char pstart) nil))))) ;;; TODO!! use text-property-any ;;(defun find-region-with-face (face limit) ;; "Find a full region after point with face FACE. ;;If successful, leaves point in end of region and returns start of region." ;; (while (and (not (eobp)) ;; (not (equal (get-text-property (point) 'face) face))) ;; (forward-char 1)) ;; (unless (eobp) ;; (let ((start (point))) ;; (while (and (not (eobp)) ;; (equal (get-text-property (point) 'face) face)) ;; (forward-char 1)) ;; (if (eobp) ;; ;; reached end of buffer before finding an end to the region ;; (progn ;; (goto-char start) ;; nil) ;; start)))) (defun mud--bol-or-at-prompt-p (p) "Returns whether P is at the beginning of a line or right after a prompt." (let ((curp (point))) (goto-char p) (prog1 (or (bolp) (progn (backward-char 2) (looking-at "] "))) (goto-char curp)))) ;; We can't use `text-property-any' or `text-property-not-all' because they ;; operate using `eq' and the faces we're comparing are `equal' but not `eq'. (defsubst mud--find-prop-change (prop limit) (goto-char (next-single-property-change (point) prop nil limit)) (/= (point) limit)) (defsubst mud--find-prop-start (prop value limit) "Find where text's PROP property has value VALUE, using `equal', up to LIMIT. If found, leave point at new location and return it. If not found, leave point at limit and return nil." (while (and (not (equal (get-text-property (point) prop) value)) (mud--find-prop-change prop limit))) (and (/= (point) limit) (point))) (defsubst mud--find-prop-end (prop value limit) "Find where text's PROP property is no longer VALUE, using `equal', up to LIMIT. If found, leave point at new location and return it. If not found, leave point at start and return nil." (let ((start (point))) (while (and (equal (get-text-property (point) prop) value) (mud--find-prop-change prop limit))) (if (/= (point) limit) (point) (goto-char start) nil))) (defun mud-extract-map (start limit &rest etc) "Extract map and stuff to map buffer." (mud--DEBUG-expect-to-be-in-bout) (when mud-extract-map (let (end) (unless (buffer-live-p mud--bmap) (mud--setup-map-window)) ;; go to where we last left off (goto-char mud--extract-map-point) ;; if mud-extract-map-1 runs out of input, don't update the marker. (catch 'out-of-input ;; use a marker such as point instead of "END" because ;; mud-extract-map-1 will modify text (while (and (setq start (mud--find-prop-start 'face mud-extract-map-face limit)) (mud--find-prop-end 'face mud-extract-map-face limit)) (if (mud--bol-or-at-prompt-p start) (mud-extract-map-1 start limit))) (mud--DEBUG-expect-to-be-in-bout) (setq mud--extract-map-point (point-marker)) )))) ;; do the actual extraction from START to point. (defun mud-extract-map-1 (start limit) (mud--DEBUG-expect-to-be-in-bout) ;; get \n also (if (eq (char-after) 10) (forward-char 1)) ;; if region is one line then it's the room name. ;; - clear the map buffer ;; - copy the room name ;; - if a map follows, ;; - move the map. ;; if > 1 line: ;; - move the region (room description) (save-excursion (let ((p (point))) (let ((roomname (buffer-substring start p)) (roommap "")) (if (eq (count-lines start p) 1) (progn (when (looking-at mud-extract-map-header) (unless (re-search-forward mud-extract-map-footer limit t) (goto-char start) (throw 'out-of-input nil)) (setq roommap (buffer-substring p (point))) (delete-region p (point))) (set-buffer mud--bmap) (let ((inhibit-read-only t)) (erase-buffer) (insert roomname roommap))) (delete-region start p) (set-buffer mud--bmap) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert roomname))) (set-buffer-modified-p nil)))) ;; "didn't" modify either buffer. (set-buffer-modified-p nil)) ;;;;; ;;;;; Highlight a whisper ;;;;; ;;(defun mud-highlight-whisper (mud &optional match-stuff) ;; "Highlight whispers when found." ;; ;;;;;;;; ;;;; (message (format "WHISPER %d! 0=%s" (setq xxw (1+ xxw)) (match-string 0))) ;; ;;;;;;;; ;; (let ((start (nth 0 match-stuff)) ;; (end (nth 1 match-stuff)) ;; (mud-whisper-face (get mud 'mud-whisper-face))) ;; (if (and start ;; end ;; (facep mud-whisper-face)) ;; (put-text-property start end 'face mud-whisper-face)))) ;;;;; ;;;;; Highlight something in a topic ;;;;; ;;(defun mud-highlight-topic (mud &optional match-stuff) ;; "Highlight things in topics when found." ;; (let ((start (nth 0 match-stuff)) ;; (end (nth 1 match-stuff)) ;; (topic-start (nth 4 match-stuff)) ;; (topic-end (nth 5 match-stuff)) ;; (mud-topic-face (get mud 'mud-topic-face))) ;; (if (and start end) ;; ;; Send it off ;; (mud-color-topic mud (buffer-substring topic-start topic-end) start end)))) ;;;;; ;;;;; Highlight a page, and possibly put a message in the minibuffer. ;;;;; Also beep if mud-page-beep is set. ;;;;; ;;(defun mud-highlight-page (mud &optional match-stuff) ;; "Highlight pages when found." ;; (let ((start (nth 0 match-stuff)) ;; (end (nth 1 match-stuff)) ;; (userpage-start (nth 4 match-stuff)) ;; (userpage-end (nth 5 match-stuff)) ;; (locpage-start (nth 6 match-stuff)) ;; (locpage-end (nth 7 match-stuff)) ;; (pagetext-start (nth 8 match-stuff)) ;; (pagetext-end (nth 9 match-stuff)) ;; (mud-page-beep (get mud 'mud-page-beep)) ;; (mud-page-face (get mud 'mud-page-face)) ;; ) ;; (if (and start ;; end ;; (facep mud-page-face)) ;; (put-text-property start end 'face mud-page-face)) ;; (if (and userpage-end userpage-start) ;; (message "%s has paged you. (%s)" ;; (buffer-substring userpage-end userpage-start) ;; (prin1-to-string mud))) ;; (if (and locpage-end locpage-start) ;; (message "%s is looking for you in %s (%s)" ;; (buffer-substring locpage-end locpage-start) ;; (if (and pagetext-end pagetext-start) ;; (buffer-substring pagetext-start pagetext-end) ;; "?") ;; (prin1-to-string mud))) ;; (if mud-page-beep ;; (beep)))) ;;;;; ;;;;; Highlight a URL and display it in the minibuffer. ;;;;; ;;(defun mud-highlight-url (mud &optional match-stuff) ;; "Highlight a URL in the buffer" ;; (let ((last 0) ;; url n ;; (mud-url-face (get mud 'mud-url-face))) ;; (setq n 0) ;; (while (null (nth n match-stuff)) ;; (setq n (+ 2 n))) ;; (setq url (buffer-substring (nth n match-stuff) ;; (nth (+ n 1) match-stuff))) ;; (if (facep mud-url-face) ;; (put-text-property (nth n match-stuff) (nth (+ n 1) match-stuff) ;; 'face mud-url-face)) ;; (while (string-match "%" url last) ;; (setq last (+ 1 (match-end 0))) ;; (setq url (replace-match "%%" nil t url))) ;; (if (get mud 'mud-show-urls) ;; (message (concat "URL: " url))))) ;;;;; ;;;;; Acknowledge a PING message, if we're answering them. ;;;;; ;;(defun mud-acknowledge-ping (mud &optional match-stuff) ;; "Acknowledge a PING message." ;; (let ((victim-start (nth 2 match-stuff)) ;; (victim-end (nth 3 match-stuff)) ;; (method-start (nth 4 match-stuff)) ;; (method-end (nth 5 match-stuff)) ;; method victim ;; (mud-pong (get mud 'mud-pong))) ;; (if (and mud-pong method-end method-start victim-end victim-start) ;; (progn ;; (setq method (buffer-substring method-start method-end) ;; victim (buffer-substring victim-start victim-end)) ;; (if (string= method "say") ;; (setq victim (concat victim ": ")) ;; (setq victim (concat victim "="))) ;; (mud-send-string mud ;; (format "%s %sPONG %s\n" method victim ;; (current-time-string))))))) ;;;;; ;;;;; Respond to a version query ;;;;; ;;(defun mud-tell-version (mud &optional match-stuff) ;; "Report the version of the client to whoever asks." ;; (let ((victim-start (nth 2 match-stuff)) ;; (victim-end (nth 3 match-stuff)) ;; victim) ;; (if (and victim-start victim-end) ;; (progn ;; (setq victim (buffer-substring victim-start victim-end)) ;; (message "%s has asked for your mud.el version." victim) ;; (mud-send-string mud ;; (format "whisper %s mud.el $Revision: 3.69 $\n" victim)) ;; )))) ;;; --------------------------------------------------------------------------- ;;; Utility functions ;;; --------------------------------------------------------------------------- ;;; ;;; Tweak a font interactively ;;; ;;(defun mud-tweak-face (&optional mud) ;; "Tweak a face interactively." ;; (interactive) ;; (or mud ;; (setq mud (mud-pick-from-list mud-list))) ;; ;; bwahhahahah! ;; (let* ((faces (mapcar '(lambda(x) ;; (cons (prin1-to-string (car x)) x)) ;; (delq nil ;; (let (y) ;; (mapcar '(lambda(x) ;; (if y ;; (let ((z (cons y x))) ;; (setq y nil) ;; (if (facep x) ;; z ;; nil)) ;; (setq y x) ;; nil)) ;; (symbol-plist mud)))))) ;; (selected-face-name (mud-completing-read "Face: " faces nil 0 nil)) ;; (selected-face ;; (get mud (nth 1 (assoc selected-face-name faces))))) ;; (message "selected face colour: %s" ;; (prin1-to-string (face-foreground selected-face))))) ;;; ;;; Create a name for logfiling the specified mud. You can override ;;; this if you like. ;;; (defun mud-make-log-filename () "Create a logfile name for MUD-NAME. Customise this if you like. It uses convert-standard-filename to make sure that the file is valid for your OS, so it's probably a good idea to do likewise if you modify this." (convert-standard-filename (expand-file-name (format mud-log-filename-format mud-name)))) ;;; Convenience function for hacking at keymaps, specifically menu entries. ;;; ;;(defun mud-define-key (mud key func text) ;; "Convenience function to define a key for a given mud." ;; (let ((mud--bin (get mud 'mud--bin))) ;; (save-excursion ;; (set-buffer mud--bin) ;; (let ((map (current-local-map))) ;; (define-key map key (if text (cons text func) func)))))) (defun kc-filter-plist-to-alist (alist filter) "Filter an ALIST to a plist. Given a list of pairs of elements in ALIST such as (A1 B1 A2 B2 A3 B3 ...), return ((A1 . B1) (A2 . B2) ...) unless (FILTER Ax)." (let (plist) (while alist (let ((a (car alist)) (b (cadr alist))) (setq alist (cddr alist)) (unless (funcall filter b) (setq plist (cons (cons a b) plist))))) plist)) (defun kc-user-props-filter (x) (or (processp x) (bufferp x) (windowp x) (timerp x) (markerp x))) ;;; ;;; Make a properties list on the menu. ;;; ;;(defun mud-list-props (&optional mud) ;; "List properties of the specified mud." ;; (interactive) ;; (let ((mud (or mud ;; (mud-find-receiver) ;; (cdr (mud-pick-from-list mud-current-list))))) ;; (let ((proplist ;; (kc-filter-plist-to-alist (symbol-plist mud) 'kc-user-props-filter))) ;; (mud-define-key mud [menu-bar mud proplist] ;; (make-sparse-keymap) ;; (format "%s Properties" (symbol-name mud))) ;; ;; Make the menu. The (reverse) is so that mud-name ends up on top. ;; (mud-menu-from-list mud [proplist] (reverse proplist)) ;; ;;; kc: don't need this: ;;;; (mud-define-key mud-current [menu-bar mud proplist update] ;;;; 'mud-list-props ;;;; "refresh properties") ;; ))) ;;; ;;; Make an entry on the Mud menu using a cons list of (NAME . VALUE) ;;; Can handle VALUE being a vector, list or face, in which case it'll ;;; make a submenu. ;;; ;;(defun mud-menu-from-list (mud key list) ;; "Make a menu from a list of cons cells." ;; ;; force the key sequence to be a menu entry ;; (if (and (>= (length key) 2) ;; (equal (aref key 0) 'menu-bar) ;; (equal (aref key 1) 'mud)) ;; () ;; (setq key (vconcat [menu-bar] [mud] key))) ;; ;; process the list ;; (while (car list) ;; (let* ((elt (car list)) ;; name val) ;; ;; Sanity check. I can think of ways to fix this, but I'm not ;; ;; coding them right now. ;; (if (consp elt) ;; (setq name (car elt) ;; val (cdr elt)) ;; (error "mud-menu-from-list list has a non-cons cell in the list.")) ;; (or val ;; (setq val "nil")) ;; ;; Add a menu button for the "category" ;; (mud-define-key mud (vconcat key (vector name)) ;; (make-sparse-keymap) ;; allow submenus ;; (prin1-to-string name)) ;; ;; how do we display the list entry? ;; (cond ;; ;; Vectors & Lists get broken down into submenus ;; ;; Should probably be sequencep, maybe. ;; ((or (listp val) ;; (vectorp val)) ;; (let ((n 0) ;; val-list) ;; (setq val-list (mapcar '(lambda(x) ;; (setq n (+ 1 n))(cons n x)) ;; (if (vectorp val) ;; (append val nil) ;; val))) ;; (mud-menu-from-list mud (vconcat key (vector name)) ;; (reverse val-list)))) ;; ;; Faces get their vital statistics displayed as a submenu ;; ((facep val) ;; (let ((face-details ;; (list ;; (cons 'underline (or (face-underline-p val) "no")) ;; (cons 'stipple (or (face-stipple val) "default")) ;; (cons 'background (or (face-background val) "default")) ;; (cons 'foreground (or (face-foreground val) "default")) ;; (cons 'font (or (face-font val) "default")) ;; ))) ;; (mud-menu-from-list mud (vconcat key (vector name)) ;; face-details))) ;; ;; Anything else just gets put in as-is. ;; (t ;; (mud-define-key mud (vconcat key (vector name) ;; [val]) ;; nil ;; (if (stringp val) ;; val ;; (prin1-to-string val))))) ;; (setq list (cdr list))))) (defsubst mud--random-item (list) (nth (random (length list)) list)) ;;; ;;; Idle text generator ;;; This is for people whose connections will time out if they don't ;;; periodically send data. ;;; (defun mud-send-idle-message (mud--bin) (save-excursion-to-buffer mud--bin (mud-send-string-1 (if (eq mud-idle-chat t) (mud--random-item mud-idle-messages) mud-idle-noop)))) ;;; ;;; Reset the mud's idle timer ;;; (defun mud--idle-timer-reset () "Reset the mud idle timer." (mud--DEBUG-expect-to-be-in-bin) (if mud--idle-timer (cancel-timer mud--idle-timer)) (setq mud--idle-timer (run-at-time mud-idle-time nil 'mud-send-idle-message mud--bin)) nil) ;;; kc: ;;; TODO: ;;(defun mud-clear-output-buffer () ;; "Clears output buffer." ;; (interactive) ;; (when (mud-goto-output-buffer) ;; (let ((buffer-read-only nil)) ;; ;;(delete-region-with-overlays (point-min) (point-max)) ;; (delete-region (point-min) (point-max)) ;; ;;(garbage-collect) ;; ))) ;; doesn't work yet for single window input mode! ;;; COMMAND HISTORY ;;; ;;; To do: ;;; - Put a limit on the size of the command history. ;;; - Maybe reset the current command number on more things ;;; than mud-send-input ;;; - Put the goddamn commands in an array. I know this is ;;; lisp, but really now. ;;; - mud-grab-next-line at the end of the list should just ;;; erase the line and leave in blank. (defun mud-save-string-to-command-history (string) "Put STRING at the beginning of the command history list." (mud--DEBUG-expect-to-be-in-bin) (setq mud--command-history (cons string mud--command-history))) (defun mud-grab-prev-line () "Grab the prev line from the command history and insert it." (interactive) (mud-grab-a-line 1)) (defun mud-grab-next-line () "Grab the next from the command history and insert it." (interactive) (mud-grab-a-line -1)) (defsubst mud--delete-current-line () (beginning-of-line) (let ((beg (point))) (forward-line) (delete-region beg (point)))) (defun mud-grab-a-line (delta) "Move delta lines in the history and insert that line, replacing the current one." (when (mud-goto-input) (let* ((command-number (+ delta mud--command-to-yank)) (command (nth command-number mud--command-history))) (when command (setq mud--command-to-yank command-number) (mud--delete-current-line) (insert command) (delete-backward-char 1) ; delete the newline )))) ;; TODO: take # arg and repeat # times. (defun mud-repeat-previous-command () "Repeat the previous command (send it to mud) (doesn't repeat line in input)." (interactive) (when (mud-goto-input-buffer) (let ((command (car mud--command-history))) (when command (mud-send-string-with-echo-1 command))))) (defsubst mud--number-substring-1+ (command) (and command (or (and (string-match "\$-?[0-9]+\$\\." command) (replace-match (string-1+ (match-string 1 command)) nil nil command 1)) (and (string-match " \$\$[^ ]+$" command) (replace-match "2." nil nil command 1))))) (defun mud-repeat-previous-command-1+ () "Repeat the previous command (send it to mud) by replacing a line such as \"x 42.y\" with \"x 43.y\"." (interactive) (when (mud-goto-input-buffer) (let ((new-command (mud--number-substring-1+ (car mud--command-history)))) (when new-command (mud-save-string-to-command-history new-command) (mud-send-string-with-echo-1 new-command))))) (defsubst mud--number-substring-1- (command) (and command (string-match "\$-?[0-9]+\$\\." command) (replace-match (string-1- (match-string 1 command)) nil nil command 1))) (defun mud-repeat-previous-command-1- () "Repeat the previous command (send it to mud) by replacing a line such as \"x 42.y\" with \"x 43.y\"." (interactive) (when (mud-goto-input-buffer) (let ((new-command (mud--number-substring-1- (car mud--command-history)))) (when new-command (mud-save-string-to-command-history new-command) (mud-send-string-with-echo-1 new-command))))) (defun mud-bout-isearch-backward (&optional regexp-p no-recursive-edit) (interactive "P\np") (mud-goto-output-buffer) (isearch-backward regexp-p no-recursive-edit)) ;;; this is `copy-region-as-kill' s/buffer-substring/buffer-substring-no-properties/ (defun mud-copy-region-no-properties-as-kill (beg end) "Save the region without properties as if killed, but don't kill it. In Transient Mark mode, deactivate the mark. If `interprogram-cut-function' is non-nil, also save the text for a window system cut and paste." (interactive "r") (if (eq last-command 'kill-region) (kill-append (buffer-substring-no-properties beg end) (< end beg)) (kill-new (buffer-substring-no-properties beg end))) (if transient-mark-mode (setq deactivate-mark t)) nil) (defun mud-paste-to-input-region (&optional arg) "Go to the input region, and `yank'." (interactive "P") (when (mud-goto-input) (yank arg))) ;;; COLORING DIFFERENT TOPICS DIFFERENTLY ;;; ;;; coding by dfan, per-mud mods and horrendous indenting by waider ;;(defun mud-get-color-for-topic (mud-current topic) ;; "Return a (COLOR . MARKER) pair associated with TOPIC in MUD-CURRENT." ;; (let* ((mud-topic-color-alist (get mud-current ;; 'mud-topic-color-alist)) ;; (item (assoc topic mud-topic-color-alist))) ;; (if item ;; (cdr item) ;; (mud-get-color-for-new-topic mud-current topic)))) ;;(defun mud-get-color-for-new-topic (mud-current topic) ;; "Find a color in MUD-CURRENT for the new topic TOPIC. ;;Insert it into mud-topic-color-alist and return its pair." ;; (let* ((mud-topic-color-array (get mud-current ;; 'mud-topic-color-array)) ;; (mud-num-colored-topics (get mud-current ;; 'mud-num-colored-topics)) ;; (mud-topic-color-alist (get mud-current ;; 'mud-topic-color-alist)) ;; (num-colors (length mud-topic-color-array)) ;; topic-color) ;; ;; Either add a new color or recycle an old one. ;; (setq topic-color ;; (if (< mud-num-colored-topics num-colors) ;; ;; We have room to just make a new one ;; (let ((this-pair ;; (cons (aref mud-topic-color-array ;; mud-num-colored-topics) 0))) ;; (setq mud-topic-color-alist ;; (append mud-topic-color-alist ;; (list (cons topic this-pair)))) ;; (setq mud-num-colored-topics (1+ mud-num-colored-topics)) ;; this-pair) ;; ;; Find the element with the oldest marker, and overwrite it. ;; (let ((oldest-color-assoc (cons "" (cons "" -1)))) ;; (mapcar (function ;; (lambda (x) ;; (if (or (= (cdr (cdr oldest-color-assoc)) -1) ;; (< (cdr (cdr x)) ;; (cdr (cdr oldest-color-assoc)))) ;; (setq oldest-color-assoc x)))) ;; mud-topic-color-alist) ;; (setcar oldest-color-assoc topic) ;; (cdr oldest-color-assoc)))) ;; ;; Store all the variables we munged ;; (put mud-current 'mud-num-colored-topics mud-num-colored-topics) ;; (put mud-current 'mud-topic-color-alist mud-topic-color-alist) ;; ;; return the color we picked ;; topic-color)) ;;(defun mud-color-topic (mud-current topic start end) ;; "Colorize the text from START to END according to TOPIC." ;; (let ((color-pair (mud-get-color-for-topic mud-current topic))) ;; (let ((topic-face (facemenu-get-face ;; (intern (concat "fg:" (car color-pair)))))) ;; (setcdr color-pair end) ; update the marker ;; (put-text-property start end 'face topic-face)))) ;;; NERDSHOLM SPECIFIC STUFF ;;; ;;(defvar mud-bbs-regexp "^%% \\S-+ has posted to the BBS") ;;(defvar mud-dir-regexp ;; "^%% \\S-+ has set an entry in the participants' directory") ;;(defun mud-Nerdsholm-setup() ;; ;; Nerdsholm has a bbs tied to it. Posting to the bbs generates a ;; ;; message in the mud: ;; ;; %% waider has posted to the BBS re: presentation of topics (usage) ;; ;; And there's the participants' directory: ;; ;; %% waider has set an entry in the participants' directory ;; (put 'Nerdsholm 'mud-bbs-url "http://nerdsholm.boutell.com/bbs.cgi") ;; (put 'Nerdsholm 'mud-dir-url "http://nerdsholm.boutell.com/dir.cgi") ;; (let ((regexps-list mud-default-regexps-list)) ;; (add-to-list 'regexps-list ;; (vector mud-bbs-regexp 'mud-highlight-bbs)) ;; (add-to-list 'regexps-list ;; (vector mud-dir-regexp 'mud-highlight-dir)) ;; (put 'Nerdsholm 'mud-regexps-list regexps-list))) ;;;;; ;;;;; Like URL matching, really ;;;;; ;;(defun mud-highlight-bbs( mud-current &optional match-stuff ) ;; "Stick a URL onto BBS post alerts." ;; (let ((mud-bbs-url (get mud-current 'mud-bbs-url))) ;; (goto-char (nth 1 match-stuff)) ;; (insert (format " (%s)" mud-bbs-url)))) ;;(defun mud-highlight-dir( mud-current &optional match-stuff ) ;; "Stick a URL onto directory post alerts." ;; (let ((mud-dir-url (get mud-current 'mud-dir-url))) ;; (goto-char (nth 1 match-stuff)) ;; (insert (format " (%s)" mud-dir-url)))) (run-hooks 'mud-load-hook) (provide 'kc-mud) (provide 'mud) ;;; Quarl's diatribe on previous authors' code: ;;; The previous programmer(s) was definitely a "C programmer". For example, ;;; consider this piece of code. ;;; (let (read-only) ;;; (setq read-only buffer-read-only) ;;; (if read-only ;;; (toggle-read-only)) ;;; (insert some-text) ;;; (if read-only ;;; (toggle-read-only))) ;;; [ Since the output buffer should be maintained read-only to the user, we ;;; need to toggle its read-only status to false while writing. ] ;;; ;;; SO many things wrong with this code! ;;; 1. The fact that this wasn't a function by itself since it appeared so ;;; many times. [ Including code around it like ;;; (save-excursion (set-buffer ... ) ... ) ]. ;;; 2. (let (var) (setq var val)) instead of (let ((var val))). Very "C". ;;; 3. Using (toggle-read-only) instead of (setq buffer-read-only ;;; nil/t). [ toggle-read-only is an interactive function that does some ;;; unneccessary argument handling. ] ;;; 4. Not understanding local binding! You can "let" buffer-read-only! ;;; ;;; Two ways to do it: ;;; (let ((buffer-read-only nil)) ;;; (insert some-text)) ;;; ;;; (let ((inhibit-read-only t)) ;;; (insert some-text)) ;;; ;;; There were definitely multiple authors before I got to this in ;;; 2001. However it seems to have been maintained by the original author ;;; "Waider" until 1999. Maybe we can do some fancy analysis like J, P, E, ;;; etc. for the Hebrew Bible. W, D, Q, etc.