;;; MUD YOUR EMACS! ;;; WARNING: THIS IS AN UNRELEASED VERSION. ;;; I just need it in the office, that's why it's on the site. It works, but ;;; it might break on you. ;;; $Id: mud.el,v 2.8 2000/03/22 22:33:07 waider Exp $ ;;; Waider, Started April '96 ;;; ;;; Easy Mud Access Client System??? ;;; ;;; The current version of mud.el is available at ;;; this ;;; location. If all else fails, try mail to ;;; waider@waider.ie ;;; ;;; FIXME LIST ;;; 1. Doesn't set up buffers properly -> Does now, bar some minor stupidity ;;; 2. Easier switching from one mud to the other - menu? ;;; 3. Indication of which mud is the default in multiple input mode. ;;; 4. Case-insensitive mud names ;;; 5. Fill function should figure out what it's done to the buffer ;;; size, then traverse the regexps list and hack all the offsets ;;; accordingly. ;;; 6. Customization stuff. ;;; 7. Timestamp code is a little ugly, but it works. Mostly. ;;; 8. Long-standing bug in topic coloring. Hard to reproduce. ;;; 9. More / commands and menu options? ;;; 10. Use font-lock for highlighting? Not sure this is a good idea. ;;; 11. XEmacs - timers don't work yet, nor do menus. ;;; Hacks dfan has inflicted on this version: ;;; - Command history (alpha quality) ;;; - Backspace stops at the beginning of the line ;;; - If point is at the end of the output buffer, keep putting it ;;; at the end of the buffer when we get more input. ;;; - User variable for whether URLs are shown in the minibuffer. ;;; - Topics are colorized uniquely. ;;; Make custom stuff work even without customize ;;; Courtesy of Hrvoje Niksic (eval-and-compile (condition-case () (require 'custom) (error nil)) (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) ;; We have the old custom-library, hack around it! (defmacro defgroup (&rest args) nil) (defmacro defcustom (var value doc &rest args) `(defvar ,var ,value ,doc)) (defmacro defface (var value doc &rest args) `(make-face ,var)) (defmacro define-widget (&rest args) nil))) (defgroup mud nil "Connecting to PerlMUD systems." :group 'games) (put 'mud 'custom-loads '("mud.el")) ;;; ;;; 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 ;;; waider@waider.ie ;;; ;;; 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 :) ;;; (defgroup mud-firewall nil "Settings for MUDding via a firewall." :group 'mud) (defcustom gw-host nil "*Name of your firewall host" :group 'mud-firewall :type 'string) (defcustom gw-port nil "*Port to connect to on the firewall host" :group 'mud-firewall :type 'integer) (defcustom gw-prompt nil "*Firewall's prompt string." :group 'mud-firewall :type 'string) ;; XXX Actually this isn't used. ;;; ;;; 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 (setq proc (open-network-stream name buffer host port)) (message "Connected to host.")) proc)) ;;; ;;; mud.el proper ;;; ;;; Things needed here: (a) Move everything to properties? ;;; (b) Add a 'mud-type' flag. ;;; ;;; Name Host Port Login (defcustom mud-list '((Nerdsholm ("boutell.com" 4096 t))) "*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." :group 'mud :type '(repeat sexp)) ;;; :type '(repeat (list symbol (list string integer)))) ;;; XXX (defcustom mud-default 'Nerdsholm "*default mud to log in to." :group 'mud :type 'symbol) ;;; FIXME make a choice from mud-list ;;; Note: all mud-default-* variables map to mud-* properties on the ;;; mud symbols. So, for example, if mud-user is an undefined property ;;; for Nerdsholm, it gets set to mud-default-user. ;;; Auto-Login support (defcustom mud-default-user user-login-name "*default username to connect with. If this is left unset, you will be prompted for a username." :group 'mud :type 'string) (defcustom mud-default-pass nil "*default password for mud-default-user. If this is left unset, you will be prompted for a password." :group 'mud :type 'string) ;;; Mud feature switches - these are global defaults; local versions ;;; are set using properties. (defcustom mud-default-logging nil "*Should we log mud output in a file?" :group 'mud :type '(choice (const :tag "Don't log to file." nil) (const :tag "Log to file." t))) (defcustom mud-default-page-beep t "*Should the mud make noise when you are paged?" :group 'mud :type '(choice (const :tag "Don't beep when I am paged." nil) (const :tag "Beep when I am paged." t))) (defcustom mud-default-max-buffer 4096 "*Maximum size of a mud buffer. Once it exceeds this size, the buffer will be trimmed from the top. This applies to both input and output buffers." :group 'mud :type 'integer) (defcustom mud-default-pong nil "*Should we react to pings from other users? If a user sends a message to you with the word \"PING\" in it, mud.el can respond with the word \"PONG\" followed by a timestamp. This option governs whether mud.el will respond or not." :group 'mud :type '(choice (const :tag "Don't respond to \"PING\" messages." nil) (const :tag "Respond to \"PING\" messages." t))) (defcustom mud-default-keep-visible t "*Should the output buffer pop up on receiving mud text? If the output buffer has been buried and there is new output to display, this option tells mud.el if it should raise the output buffer to a visible position." :group 'mud :type '(choice (const :tag "Don't raise output buffer on output." nil) (const :tag "Raise output buffer on output." t))) (defcustom mud-default-quote ": quotes: " "*String to precede file quotes with. This text is prepended to each line of any file quoted to the MUD using `mud-insert-file'." :group 'mud :type 'string) (defcustom mud-default-show-urls t "*Should URLs appear in the minibuffer? Normally, URLs are highlighted and click-enabled in the main buffer. This option tells mud.el if it should also display URLs in the minibuffer." :group 'mud :type '(choice (const :tag "Don't display URLs in the minibuffer." nil) (const :tag "Display URLs in the minibuffer." t))) (defcustom mud-default-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." :group 'mud :type (list 'choice '(const :tag "Don't generate idle messages." nil) '(const :tag "Generate idle messages from `mud-idle-messages'." t) '(const :tag "Generate NOOP idle messages." 0))) (defcustom mud-default-idle-time "5 min" "*Default timeout between idle messages. This timer is reset by user activity on the MUD." :group 'mud :type 'string) ;;; XXX is there a "time" type? (defcustom 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." :group 'mud :type 'sexp) ;;; XXX (defcustom mud-default-idle-noop "\n" "*Do-nothing string for idle timer." :group 'mud :type 'string) (defcustom mud-default-input-mud nil "*default mud to send data to in single input mode." :group 'mud :type 'symbol) ;;; XXX from list of muds (defcustom mud-single-input-mode nil "*Single or Multiple input windows?" :group 'mud :type '(choice (const :tag "Use a separate input window for each MUD." nil) (const :tag "Use a single input window for all MUDs." t))) (defcustom mud-default-timestamps nil "*Use timestamps on output text?" :group 'mud :type '(choice (const :tag "Don't print timestamps on MUD output." nil) (const :tag "Print timestamps on MUD output." t))) ;;; Compatibility Functions ;;; Earlier versions of emacs don't seem to have add-hook or ;;; add-to-list, so we'll fake them if necessary. (or (fboundp 'add-hook) (defun add-hook (hook function &optional append) "Add to the value of HOOK the function FUNCTION. FUNCTION is not added if already present. FUNCTION is added (if necessary) at the beginning of the hook list unless the optional argument APPEND is non-nil, in which case FUNCTION is added at the end. HOOK should be a symbol, and FUNCTION may be any valid function. If HOOK is void, it is first set to nil. If HOOK's value is a single function, it is changed to a list of functions." (or (boundp hook) (set hook nil)) ;; If the hook value is a single function, turn it into a list. (let ((old (symbol-value hook))) (if (or (not (listp old)) (eq (car old) 'lambda)) (set hook (list old)))) (or (if (consp function) ;; Clever way to tell whether a given lambda-expression ;; is equal to anything in the hook. (let ((tail (assoc (cdr function) (symbol-value hook)))) (equal function tail)) (memq function (symbol-value hook))) (set hook (if append (nconc (symbol-value hook) (list function)) (cons function (symbol-value hook))))))) (or (fboundp 'add-to-list) (defun add-to-list (list-var element) "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. The test for presence of ELEMENT is done with `equal'. If you want to use `add-to-list' on a variable that is not defined until a certain package is loaded, you should put the call to `add-to-list' into a hook function that will be run only after loading the package. `eval-after-load' provides one way to do this. In some cases other hooks, such as major mode hooks, can do the job." (or (member element (symbol-value list-var)) (set list-var (cons element (symbol-value list-var)))))) ;;; 18.59 (on a Mac) support functions. Yes, I am a freak of nature. ;;; Lawks-a-mussy! 18.59.1 doesn't even have *member* (or (fboundp 'member) (defun member (element list-var) (if (listp list-var) (let ((list-tmp list-var)) (catch 'success (while (car list-tmp) (if (equal (car list-tmp) element) (throw 'success t) (setq list-tmp (cdr list-tmp)))) nil)) (error "arg 2 of member should be a list")))) ;;; Fake this (or (fboundp 'facep) (defun facep (face) nil)) ;;; Buffer/Window hackery. These operate in pure BFI mode; they will ;;; try to switch to the required buffer/window momentarily to see if ;;; it exists. Anything else requires incestuous knowledge of emacs' ;;; storage lists, I suspect. (or (fboundp 'buffer-live-p) (defun buffer-live-p (buf) "Hello buffer BUF, are you alive?" (condition-case error (save-excursion (save-window-excursion ;; why isn't there a 'save-all-excursion'? (set-buffer buf) t)) (error nil)))) (or (fboundp 'window-live-p) "Hello window WIN, are you alive?" (defun window-live-p (win) (condition-case error (save-excursion (save-window-excursion (select-window win) t)) (error nil)))) ;;; Somewhere along the way we changed how many parameters ;;; completing-read uses. Emacs 18->19, I think. Again, we're using ;;; complete BFI for this. This will make byte-compile whine at you, ;;; btw. (defun mud-completing-read( prompt table predicate require initial hist) (condition-case error (completing-read prompt table predicate require initial hist) ;; Er, what's the tidy way to do this again? (error (if (string-match "wrong-number-of-arguments" (format "%s" error)) (completing-read prompt table predicate require initial))))) ;;; Oh GHOD. Why can't the *emacs folk just GET ALONG? XEmacs uses ;;; itimers, which are subtly incompatible with emacs' timers. So we ;;; need to wrap the whole lot in convenience functions. (if (fboundp 'run-at-time) () (defun run-at-time ( &rest args ) "can't get this to work just yet." nil) (defun timerp( &rest args ) nil)) ;;; The Buck Starts Here ;;; Mud hook stuff (defvar mud-placeholders-list nil "*DEPRECATED but required temporarily for some internal stuff.") ;;; Next two are for special builtin hooks. DON'T remove them, and if ;;; you do, DON'T complain that the mud is broken. I wonder if emacs ;;; allows me to have immutable hook entries? (add-to-list 'mud-placeholders-list 'mud-last-log) (add-to-list 'mud-placeholders-list 'mud-last-fill) ;;; ;;; All new singing and dancing hooks. ;;; (defcustom mud-default-processing-hooks nil "*List of functions to run when the mud generates output. This replaces 'mud-default-output-hooks'; you can use your old hooks by adding a second parameter to their parameter lists. The parameters passed to each hook are the current mud and the output that caused the hooks to be run. Most of the fun things you can do should probably be done with the regexp matcher - see mud-default-regexps-list." :group 'mud :type 'hook) ;;; Add the new hooks in. (add-hook 'mud-default-processing-hooks 'mud-check-for-regexps) ;; FIXME default (defcustom mud-send-string-hooks nil "*List of hooks to run after a string is sent to the mud. mud-send-string is loop-protected, so it's okay to send strings to the mud from your hook function." :group 'mud :type 'hook) (defcustom mud-default-mode-hooks nil "*List of hooks to run when a buffer is switched to mud-mode." :group 'mud :type 'hook) ;;; Mud hilighting faces ;;; Convention of sorts: ;;; mud-default-X-face, mud-X-face, and mud-highlight-X all relate to ;;; highlighting X's. As per guck above, mud-default-X-face gets ;;; mapped to a mud-local mud-X-face. ;;; ;;; new, improved code, using defface. Seems at least as convoluted as ;;; the old make-face/copy-face stuff. (if (fboundp 'make-face) ;; 18.59.1 doesn't know from faces at all. (progn (defface mud-default-face nil "*default text face for mud." :group 'mud) (defface mud-default-page-face '((t (:foreground "blue"))) "*Face to highlight paged messages with." :group 'mud) ;; Ideally, we should copy this from url-highlight-face. How do I ;; do that with defface? (defface mud-default-url-face '((t (:foreground "red"))) "*Face to highlight urls with." :group 'mud) (defface mud-default-whisper-face '((t (:foreground "brown"))) "*Face to highlight whispers with. Making this something close to your background colour (e.g. brown on black) actually does give you a sense of whispered information. Or maybe that's just me and my synasthesia." :group 'mud) (defface mud-default-timestamp-face '((t (:foreground "green"))) "*Face to colour timestamps." :group 'mud) )) (defcustom mud-default-topic-color-array [ "medium slate blue" "dark green" "purple" "DarkGoldenRod4" "IndianRed4" "OliveDrab4" "medium blue" "yellow4" "pink" ] "An array of colors to be used for topics." :group 'mud :type 'vector) (defcustom mud-default-smartclient t "*Does the client default to smart mode or not? In smartclient mode, mud.el checks if you're connecting to a new enough PerlMUD that the \"smartclient\" directive works at login time, which means that topics (see PerlMUD documentation) cannot be spoofed." :group 'mud :type '(choice (const :tag "Don't default to smartclient mode." nil) (const :tag "Default to smartclient mode." t))) ;;; Mud highlighting regexps. Carefully constructed by ancient methods ;;; from wattle and pitch (attribution smarry, I think?) so hack at ;;; them at your peril. (defcustom mud-whisper-regexp "^\$You whisper\\|\\S-+ whispers,\$ .*\$[\r\n] .*\$*" "Regular expression that matches 'whisper traffic'." :group 'mud :type 'regexp) (defcustom mud-page-regexp "^\$You paged\\|\\(\\S-+\$ pages:\\|\$\\S-+\$ is looking for you in\\) \$[^\r\n]*\$.*$" "Regular expression that matches 'page traffic'." :group 'mud :type 'regexp) (defcustom 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." :group 'mud :type 'regexp);; found in vm :) (defcustom mud-ping-regexp "^\$\\S-+\$ \$say\\|whisper\\|page\$s\$ to \\S-+\$?[,:] \"?[Pp][Ii][Nn][Gg].*$" "Regular expression that matches a ping request." :group 'mud :type 'regexp) (defcustom mud-topic-regexp "^\\S-+ .*\$[\r\n] .*\$* <\$\\S-+\$> $" "Regular expression that matches a topic." :group 'mud :type 'regexp) (defcustom mud-smart-topic-regexp "^\\[{}\\]\\S-+ .*\$[\r\n] .*\$* <\$\\S-+\$> $" "Regular expression that matches a topic in smartclient mode." :group 'mud :type 'regexp) (defcustom mud-version-regexp "^\$\\S-+\$ whispers, \"version\"" "Regular expression that matches a version request." :group 'mud :type 'regexp) ;;; Here are all the default internal hooks. (defun mud-init-default-regexps( sym val ) "init function for custom to call." ;; putting URL highlighting at the top of the list means that URLs ;; get highlighted no matter what the context - i.e. if someone ;; whispers a URL to you, it'll be URL-coloured even though the rest ;; of the text will be whisper-coloured. (add-to-list sym (vector mud-url-regexp 'mud-highlight-url 0)) (add-to-list sym (vector mud-whisper-regexp 'mud-highlight-whisper 0)) (add-to-list sym (vector mud-page-regexp 'mud-highlight-page 0)) (add-to-list sym (vector mud-ping-regexp 'mud-acknowledge-ping 0)) (add-to-list sym (vector mud-version-regexp 'mud-tell-version 0))) (defcustom mud-default-regexps-list nil "*List of vectors, [regexp func last-matched], to run on the mud buffer. This replaces 'mud-regexps' to perform useful arbitrary regexp hacking. Each regexp keeps its own placeholder, so you no longer need to maintain placeholder variables. The function parameters should be MUD-CURRENT and &optional MATCH-STUFF - the code now passes the entire match-data structure in as a list, so you can find out what matched what. The regexp matching will back out from any matches that run up against an incomplete line, so it should be possible for matches to work properly even on a laggy connection. This is sufficiently useful that almost all the hooks in mud.el 2.4 have been replaced with arbitrary regexp stuff. Known bug: The placeholder code isn't 100% accurate, but should be sufficiently accurate to not bother you." :group 'mud :type 'sexp ;; :initialize 'mud-init-default-regexps) how do I make this work? ) ;;; If you don't really have custom, call the init function by hand: (or mud-default-regexps-list ;; dubious, but usable (mud-init-default-regexps 'mud-default-regexps-list nil)) ;;; Internal use only and all that sort of stuff. (defvar mud-output-map nil "Keymap for mud output.") (defvar mud-input-map nil "Keymap for mud input.") (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-mode 'text-mode "MUD mode") ;;; ;;; Start here! ;;; ;;;### autoload (defun mud(&optional mud-name) "Connect to a mud" (interactive) (let (mud-bin mud-bout mud-details mud-host mud-port mud-process mud-new mud-user mud-pass) ;; Find out what mud to log into, if it's not specified. (if mud-name (if (equal mud-name "") (setq mud-name (prin1-to-string mud-default))) (setq mud-name (car (mud-pick-from-list mud-list mud-default)))) ;; Retrieve the info for this mud. (setq mud-details (or (assoc (car (read-from-string mud-name)) mud-list) (mud-get-details (car (read-from-string mud-name))))) (setq mud-new (car mud-details)) ;; happily, nth returns nil for out-of-bounds reads. Unlike aref, ;; whine whine. (setq mud-host (nth 0 (car (cdr mud-details)))) (setq mud-port (nth 1 (car (cdr mud-details)))) (setq mud-user (nth 2 (car (cdr mud-details)))) (setq mud-pass (nth 3 (car (cdr mud-details)))) ;; Set up the buffers (if mud-single-input-mode (setq mud-bin (get-buffer-create "mud.el - ECHO IN")) (setq mud-bin (get-buffer-create (concat mud-name " - ECHO IN")))) (setq mud-bout (get-buffer-create (concat mud-name " - ECHO OUT"))) ;; Buffer mode (save-excursion (set-buffer mud-bout) (setq major-mode 'mud-mode) (setq fill-column 78) ;; FIXME option (set-buffer mud-bin) (setq major-mode 'mud-mode)) ;; Now set up the windows for the buffers (leaves us in the input buffer) (put mud-new 'mud-bin mud-bin) (put mud-new 'mud-bout mud-bout) (mud-windows-setup mud-new) (setq mud-process (mud-stream-setup mud-name mud-host mud-port)) ;; list of previous commands, most recent first (put mud-new 'mud-command-history nil) ;; which command we're on in that list (put mud-new 'mud-command-to-yank -1) ;; Save some mud details (put mud-new 'mud-process mud-process) (put mud-new 'mud-name mud-name) ;; Define keys for the output buffer ;; keymap to bounce to the input buffer (if mud-output-map () (setq mud-output-map (make-keymap)) (suppress-keymap mud-output-map t) (let ((i 32)) (while (<= i 127) (define-key mud-output-map (char-to-string i) 'mud-bounce-input) (setq i (1+ i))) (define-key mud-output-map [return] 'mud-bounce-input) ;; For some reason, running emacs in tty mode causes the ;; return key to generate ^M, which appears in view-lossage as ;; [RET] but doesn't seem to actually /mean/ [RET] as far as ;; keymaps are concerned. This is utter brokenness on the part ;; of emacs, IMHO. Anyway, I'll cope, I'm sure. (define-key mud-output-map "\C-m" 'mud-bounce-input))) (save-excursion (set-buffer mud-bout) (use-local-map mud-output-map) ;; Add a hook for browse-url if it's loaded. ;; FIXME xemacs calls this button2, not mouse-2. How PC. (if (fboundp 'browse-url-at-mouse) (local-set-key [mouse-2] 'mud-browse-url-at-mouse))) ;; Define keys for the input buffer (if mud-input-map () (setq mud-input-map (make-keymap)) (define-key mud-input-map "\r" 'mud-send-input) (define-key mud-input-map "\C-cp" 'mud-toggle-page) (define-key mud-input-map "\C-c\C-p" 'mud-send-ping) (define-key mud-input-map "\C-cl" 'mud-toggle-log) (define-key mud-input-map "\M-n" 'mud-grab-next-line) (define-key mud-input-map "\M-p" 'mud-grab-prev-line) (define-key mud-input-map "\C-?" 'delete-backward-char-maybe) (define-key mud-input-map "\C-ci" 'mud-insert-file)) ;; Initialise properties ;; COMPATIBILTY CHECK ;; mud-default-output-hooks deprecated in 2.5 ;; mud-regexps deprecated in 2.5 ;; current version is $Revision: 2.8 $ (mud-deprecated mud-new 'mud-default-output-hooks nil) (mud-deprecated mud-new 'mud-regexps nil) ;; Bits for hooks (mud-init-feature mud-new 'mud-keep-visible mud-default-keep-visible) (mud-init-feature mud-new 'mud-page-beep mud-default-page-beep) (mud-init-feature mud-new 'mud-pong mud-default-pong) (mud-init-feature mud-new 'mud-quote-string mud-default-quote) (mud-init-feature mud-new 'mud-processing-hooks mud-default-processing-hooks) (mud-init-feature mud-new 'mud-regexps-list mud-default-regexps-list) (mud-init-feature mud-new 'mud-timestamps mud-default-timestamps) ;; Topic coloring. What do you mean, a 'u' in color? (mud-init-feature mud-new 'mud-smartclient mud-default-smartclient) (mud-init-feature mud-new 'mud-topic-color-array mud-default-topic-color-array) (mud-init-feature mud-new 'mud-num-colored-topics 0) (mud-init-feature mud-new 'mud-topic-color-alist nil) ;; this is a little clumsier than I'd like, but. (let ((mud-regexps-list (get mud-new 'mud-regexps-list))) (if (get mud-new 'mud-smartclient) (add-to-list 'mud-regexps-list (vector mud-smart-topic-regexp 'mud-highlight-topic)) (add-to-list 'mud-regexps-list (vector mud-topic-regexp 'mud-highlight-topic))) ;; okay to use "put" since we did "get" above (put mud-new 'mud-regexps-list mud-regexps-list)) (mud-init-feature mud-new 'mud-show-urls mud-default-show-urls) ;; Set up faces (if (fboundp 'copy-face) (progn (mud-init-feature mud-new 'mud-face (make-face 'mud-default-face)) (mud-init-feature mud-new 'mud-page-face (make-face 'mud-default-page-face)) (mud-init-feature mud-new 'mud-url-face (make-face 'mud-default-url-face)) (mud-init-feature mud-new 'mud-whisper-face (make-face 'mud-default-whisper-face)) (mud-init-feature mud-new 'mud-timestamp-face (make-face 'mud-default-timestamp-face)) )) ;; Idle timer (mud-init-feature mud-new 'mud-idle-chat mud-default-idle-chat) (mud-init-feature mud-new 'mud-idle-noop mud-default-idle-noop) (mud-init-feature mud-new 'mud-idle-time mud-default-idle-time) ;; Autologon stuff (mud-init-feature mud-new 'mud-user mud-user) (mud-init-feature mud-new 'mud-pass mud-pass) (put mud-new 'mud-conn nil) (put mud-new 'mud-tries 0) ;; Log to file (mud-init-feature mud-new 'mud-logging mud-default-logging) (if (get mud-new 'mud-logging) (progn (mud-init-feature mud-new 'mud-log-file (mud-make-log-filename mud-name)))) ;; Set up the idle-timer (if (get mud-new 'mud-idle-chat) (mud-idle-timer-reset mud-new)) ;; Menu-bar setup. Kinda hacky, but will do. (let ((map (make-sparse-keymap "Mud"))) (define-key mud-input-map [menu-bar] (make-sparse-keymap)) (define-key mud-input-map [menu-bar mud] (cons "Mud" map)) (define-key map [send-ping] '("Send a ping" . mud-send-ping)) (define-key map [toggle-page] (cons (concat (if (get mud-new 'mud-page-beep) "Disable" "Enable") " beep-on-page" ) 'mud-toggle-page)) (define-key map [toggle-log] (cons (concat (if (get mud-new 'mud-logging) "Disable" "Enable") " log-to-file" ) 'mud-toggle-log)) (define-key map [toggle-idle] (cons (concat (if (get mud-new 'mud-idle-timer) "Disable" "Enable") " idle messages" ) 'mud-toggle-idle)) (define-key map [toggle-pong] (cons (concat (if (get mud-new 'mud-pong) "Disable" "Enable") " PONG messages" ) 'mud-toggle-pong)) (define-key map [insert-file] '("Quote a file" . mud-insert-file)) ) (use-local-map (copy-keymap mud-input-map)) (message "Building props list...") ;; (mud-list-props mud-new) (message "Building props list...done") ;; Add to 'live' list (setq mud-current-list (append (list mud-new) mud-current-list)) (if mud-single-input-mode (setq mud-default-input-mud mud-new)) ;; Call a hook, for good measure ;; fixme do this right (run-hooks (or (get mud-new 'mud-mode-hooks) mud-default-mode-hooks)) )) ;;; ;;; 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) (if (fboundp 'browse-url-at-mouse) (progn (message "Sending URL to browse-url...") (call-interactively 'browse-url-at-mouse) (message "Sending URL to browse-url...done.")))) ;;; ;;; Get a mud symbol from a string. Return nil if there's no such ;;; mud. ;;; (defun mud-mud-symbol-from-string( string ) "Return the symbol named in STRING if that symbol is defined." (let ((sym (car (read-from-string string)))) (if (get sym 'mud-name) sym nil))) (defun mud-symbol-from-string( string ) "get the symbol part from read-from-string( STRING ). Maybe it's time I learned about lisp macros." (car (read-from-string string))) ;;; ;;; Choose a mud from a list, with optional default. ;;; (defun mud-pick-from-list( mud-pick-list &optional mud-pick-default) "Select a mud from LIST and return the string & symbol." (let ((mud-completion-list (mapcar '(lambda(x) (cons (prin1-to-string (car x)) (car x))) mud-pick-list)) mud-entered mud-selected) ;; Sanity check (if (symbolp mud-pick-default) (if mud-pick-default (if (assoc (prin1-to-string mud-pick-default) mud-completion-list) () (message "mud-default [%s] is not on mud-list!" mud-pick-default) (sit-for 1) (setq mud-pick-default (car (car mud-list)))) (setq mud-pick-default (car (car mud-list)))) (message "mud-default [%s] is not a symbol!" mud-pick-default) (sit-for 1) (setq mud-pick-default (car (car mud-list)))) (setq mud-entered (mud-completing-read "Mud: " mud-completion-list nil nil (prin1-to-string mud-pick-default) mud-history-list)) ;; If something was entered, try pulling it from mud-list. If it's ;; not there, ask for details. If nothing was entered, return the ;; default. (if (> (length mud-entered) 0) (setq mud-selected (cons mud-entered (car (read-from-string mud-entered)))) (setq mud-selected (cons (prin1-to-string mud-pick-default) mud-pick-default))) mud-selected)) ;;; ;;; Pick up host & port for an unrecognised mud. ;;; (defun mud-get-details( mud-entered ) "Get details for an arbitrary MUD-ENTERED." (let (mud-port mud-host) (setq mud-host (read-from-minibuffer (format "What is the hostname for %s? " mud-entered) (format "%s" mud-entered) nil nil nil)) (if (string= mud-host "") (setq mud-host (format "%s" mud-entered))) (setq mud-port (read-from-minibuffer (format "What is the port for %s? " mud-entered) "4096" nil nil nil)) (if (string= mud-port "") (setq mud-port 4096) (setq mud-port (string-to-int mud-port))) ;; Return data (list mud-entered (list mud-host mud-port t)))) ;;; ;;; Bounce input to the correct buffer. ;;; ;;; FIXME still has some difficulty with frames in combination with ;;; focus-follows-mouse. ;;; (defun mud-bounce-input() (interactive);; Keymap functions need this, apparently (let ((mud-current (mud-get-from-bout mud-current-list (current-buffer))) (input (aref (recent-keys) (1- (length (recent-keys))))) mud-bin mud-win) (if mud-current (progn (setq mud-bin (get mud-current 'mud-bin)) (setq mud-win (get-buffer-window mud-bin)) ;; switch to the right window and stuff what we've got. (if (and (windowp mud-win) (window-live-p mud-win) (bufferp mud-bin) (buffer-live-p mud-bin)) ;; Buffer is on-screen, don't need to get it. ;; Else go fishing for window (put mud-current 'mud-win nil) (mud-windows-setup mud-current)) (setq mud-bin (get mud-current 'mud-bin)) (setq mud-win (get-buffer-window mud-bin)) (select-window mud-win) (if (and (char-or-string-p input) (or (and (stringp input) ;; More tty-mode sillywalking (not (string= input "\C-m"))) (not (= input 13)))) (insert input)))))) ;;; ;;; Gather any output the mud has to offer ;;; (defun mud-stream-output(process output) "Get anything the mud said since we last looked" (let* ((cur (selected-window)) (mud-current (mud-get-from-process mud-current-list process)) (mud-logging (get mud-current 'mud-logging)) (keep-visible (get mud-current 'mud-keep-visible)) (bout (get mud-current 'mud-bout)) ;; FIXME if bout is nil, this chokes. This can't happen, of ;; course, but it has done so once. Now how the hell? (win (get-buffer-window bout t)) (mud-processing-hooks (get mud-current 'mud-processing-hooks)) (mud-face (get mud-current 'mud-face)) (mud-timestamps (get mud-current 'mud-timestamps)) hook-error (at-end-of-buf nil)) ; point at end of bout? (save-excursion (set-buffer bout) (save-excursion ; to save current point within ; bout as well (setq at-end-of-buf (= (point) (point-max))) (goto-char (point-max)) (let* ((start (point))) (and buffer-read-only (toggle-read-only nil)) (insert output) (and (facep 'mud-face) (put-text-property start (point-max) 'face mud-face))) ;; PROCESS OUTPUT FROM MUD ;; Run hooks for output. This is covered with an error handler ;; and a save-excursion so you can't screw up too badly. ;; ;; However, I've discovered that /I/ can screw up badly... (if (condition-case error (save-excursion (and mud-processing-hooks (run-hook-with-args 'mud-processing-hooks mud-current output)) t) (error (progn (setq hook-error (prin1-to-string error)) nil))) ;; hooks ran successfully () ;; whoops! ;; FEATURE should be a bit more specific here, if possible. ;; What broke (mud-whine mud-current "One of your hook functions is broken.") (mud-whine mud-current (format "The error message was: %s" hook-error))) ;; Special hooks. These are always called, where as stuff on the ;; hooks list is optional and can be removed if desired. ;; Auto Login (if (and (get mud-current 'mud-user) (not (get mud-current 'mud-conn))) (mud-check-logon mud-current)) ;; NB This should be the last thing called as it destroys ;; essential information about the way the line arrived. (mud-fill-lines mud-current) ;; However, we do like to log /after/ the buffer has been ;; pretty-printed (if mud-logging (mud-log-to-file mud-current)) ;; And then resize the thing. This is REALLY the last thing to ;; be called. (mud-check-buffer-size mud-current) ;; END OF PROCESSING ;; Pretend we didn't modify the buffer and make damn sure YOU can't. (toggle-read-only t) (set-buffer-modified-p nil))) ;; display the mud output buffer if required (if keep-visible (or win (setq win (display-buffer bout nil)))) ;; scroll window to bottom if ;; (a) it's visible ;; (b) we're not in it right now ;; (otherwise scrollback is awkward and ugly) (if (and win (not (equal cur win))) (progn (save-excursion (select-window win) (goto-char (point-max)) (recenter -1) (select-window cur))) ;; Also, if point was already at the end of the window, we update ;; it to still be so. If I (dfan) had my way, this would ;; actually be only thing causing the window to scroll. (if at-end-of-buf (let ((cur-buf (current-buffer))) ;; Don't use save-excursion because that will undo the ;; very action we're trying to perform if we're already in ;; bout! (set-buffer bout) (goto-char (point-max)) (set-buffer cur-buf)))) (if (get mud-current 'mud-speak) (mud-say output) ) )) ;;; ;;; Log the mud output to a file ;;; (defun mud-log-to-file( mud-current ) "Log mud output to the mud's logfile." (let ((mud-log-file (get mud-current 'mud-log-file)) (mud-last-log (get mud-current 'mud-last-log)) (mud-logging (get mud-current 'mud-logging))) (if mud-logging (progn (write-region (or mud-last-log 1) (point-max) mud-log-file t 'silent) (put mud-current 'mud-last-log (point-max)))))) ;;; ;;; Try logging onto the mud once we get a prompt ;;; ;;; FEATURE: Make this work for more than PerlMUD. (defun mud-check-logon( mud-current ) "Try to log onto the mud automatically." (let ((mud-user (get mud-current 'mud-user)) (mud-pass (get mud-current 'mud-pass)) (mud-tries (get mud-current 'mud-tries)) (mud-smartclient (get mud-current 'mud-smartclient))) (if (eq mud-user t) (progn (setq mud-user mud-default-user) (setq mud-pass mud-default-pass))) (save-excursion (goto-char (point-max)) ;; See if we already connected (if (> mud-tries 0) (progn (or (re-search-backward "connection is closed" nil t) ;; dubious (goto-char (point-min))) (if (re-search-forward "login succeeded" nil t) (put mud-current 'mud-conn t)))) (if (get mud-current 'mud-conn) () (mud-whine mud-current (format "Trying autologin to %s as %s (attempt %d of 3)" mud-current mud-user mud-tries)) (mud-send-string mud-current (concat (if mud-smartclient "smartclient\n" "") (concat "connect " mud-user " " mud-pass "\n"))) (setq mud-tries (+ 1 mud-tries)) (put mud-current 'mud-tries mud-tries) (if (> mud-tries 3) (progn (message "Autoconnect failed, you'll have to log in manually.") (put mud-current 'mud-conn t) (sit-for 2))))))) ;;; ;;; Keep the windows to a reasonable size, since otherwise emacs seems ;;; to get upset. Dunno why, I don't remember the original mud.el ;;; having problems with that. ;;; It may have something to do with the fact that the wrap-code was ;;; processing an entire buffer, mind you... fixed that. (defun mud-check-buffer-size( mud-current ) "Check buffer size and trim if necessary" (let ((mud-bin (get mud-current 'mud-bin)) (mud-bout (get mud-current 'mud-bout)) (mud-max-buffer (or (get mud-current 'mud-max-buffer) 0))) (save-excursion (set-buffer mud-bin) (if (eq mud-max-buffer 0) () ;; do nothing (let ((size (point-max))) (and (> size mud-max-buffer) (goto-char (+ (point-min) (- size mud-max-buffer))) (delete-region (point-min) (point))))) (set-buffer mud-bout) (if (eq mud-max-buffer 0) () ;; do nothing (let ((delta (- (point-max) mud-max-buffer))) (if (> delta 0) (progn (delete-region (point-min) (+ (point-min) delta)) ;; Reset the variables (if (listp mud-placeholders-list);; should be ;; process it. (let ((m-ph-l mud-placeholders-list)) (while (car m-ph-l) (put mud-current (car m-ph-l) (- (or (get mud-current (car m-ph-l)) 0) delta)) (setq m-ph-l (cdr m-ph-l)))) ;; If it's set and not a list, complain. (if mud-placeholders-list (mud-whine mud-current "mud-placeholders-list isn't a list.")))))))))) ;;; ;;; Send our $0.02 to the mud ;;; (defun mud-send-input() "Send the current line of input to the mud" (interactive) (beginning-of-line) (let ((beg (point)) (mud-current (mud-get-from-bin mud-current-list (current-buffer))) new-string mud-receiver mud-receiver-name slash-command) (end-of-line) (insert "\n") (setq new-string (buffer-substring beg (point))) (mud-save-string-to-command-history new-string) (put mud-current 'mud-command-to-yank -1) ;; 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 (mud-mud-symbol-from-string 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"))) ;; Trigger the autologin stuff ((string= mud-receiver-name "login") (mud-check-logon mud-current)) ;; Change the default input mud ((string= mud-receiver-name "input") (if (string-match "\\S-+" new-string) (if (car (read-from-string new-string)) (progn (setq mud-default-input-mud (car (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))))) (if mud-single-input-mode (setq mud-receiver mud-default-input-mud) (setq mud-receiver (mud-get-from-bin mud-current-list (current-buffer)))))) ;; send the string (if mud-receiver (mud-send-string mud-receiver new-string)))) (defun mud-send-string( mud-current string ) "Send a string to the specified mud process. As a side effect, kicks the mud's idle timer." (let ((mud-process (get mud-current 'mud-process))) (and mud-process (process-send-string (get mud-current 'mud-process) string)) (if (get mud-current 'hooking-send-string) ;; deloop () (put mud-current 'hooking-send-string t) ;; is there a clean way? (condition-case error (run-hook-with-args 'mud-send-string-hooks mud-current string) (error nil)) (put mud-current 'hooking-send-string nil)) (mud-idle-timer-reset mud-current))) ;;; ;;; Open up a tcp stream to the mud ;;; (defun mud-stream-setup(mud host port) "Set up a tcp stream to the mud" ;; See if we have the process already ;; This should really check to see if the process has the same parameters ;; (host & port at least) as are being passed in (let (proc) (if (setq proc (get-process mud)) (progn (or (equal (process-status proc) 'run) (progn (delete-process proc) (setq proc nil))))) ;; Set the proc variable to a new stream if necessary (setq proc (or proc (mud-open-network-stream mud nil host port))) ;; KILL KILL KILL death to multibyte mode, dammit. (condition-case error (set-process-coding-system proc nil nil) (error nil)) ;; bolt on the output filter (set-process-filter proc 'mud-stream-output) (set-process-sentinel proc 'mud-sentinel) ;; Return the process proc)) ;;; ;;; Set up the input & output windows for the mud client ;;; Tries to be intelligent about keeping existing windows where they are ;;; and such like. Could do with more such intelligence. ;;; (defun mud-windows-setup( mud-current ) "Set up the mud input/output windows from the currently selected window." (interactive) (let ((wout (get mud-current 'mud-wout)) (win (get mud-current 'mud-win)) (bout (get mud-current 'mud-bout)) (bin (get mud-current 'mud-bin)) (mud-name (get mud-current 'mud-name)) mud-wheight mud-wheight-diff) ;; Check for buffers already visible (if (get-buffer-window bout) (setq wout (get-buffer-window bout))) ;; First, get the mud output window (if (and (windowp wout) (window-live-p wout)) (select-window wout) (setq wout (selected-window))) ;; Add the buffer (put mud-current 'mud-wout wout) (set-window-buffer wout bout) ;; Special case. If the input window is visible, we'll hide it, ;; since you tend to get weird window configurations otherwise. (if (get-buffer-window bin) (setq win (get-buffer-window bin))) (if (and (windowp win) (window-live-p win)) ;; Stop wout from being nuked... (if (eq win wout) ;; In theory, here, we could look for another visible ;; mud-output-window, split it in two, and set wout to one ;; of the halves, THEN delete win. ;; FITNR, maybe :) () (delete-window win))) ;; Now do the input window ;; The input window height = minimum height ;; The output window height = current height - minimum height (setq mud-wheight (- (window-height 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 win (split-window wout mud-wheight)) (select-window win) (if (buffer-live-p bin) () ;; Oh you CABBAGE. You deleted the input buffer. (if mud-single-input-mode (setq bin (get-buffer-create "mud.el - ECHO IN")) (setq bin (get-buffer-create (concat mud-name " - ECHO IN")))) (put mud-current 'mud-bin bin) (set-buffer bin) (use-local-map (copy-keymap mud-input-map))) (set-window-buffer win bin) (put mud-current 'mud-win win))) ;;; ;;; Figure out the mud name from the process ;;; Could probably roll these into one function, actually. ;;; (defun mud-get-from-process( list process ) "Retrieve the mud symbol name from the process attached to it" ;; A little BFI :) (if (car list) (if (equal process (get (car list) 'mud-process)) (car list) ;; ELSE (mud-get-from-process (cdr list) process)) ;; ELSE doom! doom! nil)) ;;; ;;; Figure out the mud name from the input-buffer ;;; (defun mud-get-from-bin( list bin ) "Retrieve the mud symbol name from the input buffer attached to it" (if (car list) (if (equal bin (get (car list) 'mud-bin)) (car list) ;; ELSE (mud-get-from-bin (cdr list) bin)) ;; ELSE doom! doom! nil)) ;;; ;;; Figure out the mud name from the input-buffer ;;; (defun mud-get-from-bout( list bout ) "Retrieve the mud symbol name from the input buffer attached to it" (if (car list) (if (equal bout (get (car list) 'mud-bout)) (car list) ;; ELSE (mud-get-from-bout (cdr list) bout)) ;; ELSE doom! doom! nil)) ;;; ;;; Process Sentinel to catch closing connection c c c c c! ;;; (defun mud-sentinel( process msg ) "Sentinel for mud process." (let ((mud-current (mud-get-from-process mud-current-list process)) mud-win) (message (prin1-to-string msg)) (message (concat "Connection to " (prin1-to-string mud-current) " closed.")) (mud-whine mud-current "The mud connection is closed.") ;; FEATURE these should be optional ;; FEATURE auto-reconnect (setq mud-current-list (delete mud-current mud-current-list)) (put mud-current 'mud-conn nil) (put mud-current 'mud-tries 0) ;; Are we in single-input-mode? (if mud-single-input-mode (progn ;; This tries to delete the window. If it's the sole window, ;; because you've been fiddling with the windows, then it'll ;; quietly fail. (condition-case error (delete-window (get-buffer-window (get mud-current 'mud-bout))) (error nil)) ;; If there's anything left on the list, update the default ;; mud and display its window (if mud-current-list (progn (setq mud-default-input-mud (car mud-current-list)) (setq mud-win (get-buffer-window (get mud-default-input-mud 'mud-bout))) (if (and (windowp mud-win) (window-live-p mud-win)) ;; Buffer is on-screen, don't need to get it. () ;; Else go fishing for window (put mud-default-input-mud 'mud-wout nil) (mud-windows-setup mud-default-input-mud)) (select-window (get-buffer-window (get mud-default-input-mud 'mud-bin))) )) ;; If that was the last mud, delete the input buffer and its window (if (not mud-current-list) (progn (condition-case error (delete-window (get-buffer-window (get mud-current 'mud-bin))) (error nil)) (kill-buffer (get mud-current 'mud-bin))))) ;; Not in single-input mode: delete the input buffer and its ;; window. (condition-case error (delete-window (get-buffer-window (get mud-current 'mud-bin))) (error nil)) (kill-buffer (get mud-current 'mud-bin))) (beep))) ;;; ;;; Stick an error message into the mud output-window. ;;; (defun mud-whine( mud-current string ) (let ((mud-bout (get mud-current 'mud-bout))) (if mud-bout (save-excursion (set-buffer mud-bout) (goto-char (point-max)) (let ((readonly buffer-read-only)) (if readonly (toggle-read-only nil)) (insert (concat "mud.el says, \"" string "\"\n")) (if readonly (toggle-read-only t))))))) ;;; ;;; And THIS is to fill out the displayed lines, and remove those pesky ^M's. ;;; (defun mud-fill-lines( mud-current ) "Fill buffer line by line." (let ((last-fill (get mud-current 'mud-last-fill)) (mud-timestamps (get mud-current 'mud-timestamps)) (mud-timestamp-face (get mud-current 'mud-timestamp-face))) (save-excursion (or last-fill (setq last-fill (point-min))) (if (> last-fill (point-max)) (setq last-fill (point-min))) (goto-char last-fill) (beginning-of-line) ;; Nuke all the ^Ms, and put in timestamps (save-excursion (if (and (bolp) mud-timestamps (not (looking-at "[0-9][0-9]:[0-9][0-9]"))) ;; ugly (let* ((start (point))) (insert (concat (substring (current-time-string) 11 16) " ")) (put-text-property start (+ 6 start) 'face mud-timestamp-face))) (while (search-forward "\r" nil t) (replace-match "") (forward-char 1) (if (and (not (eobp)) mud-timestamps) (let* ((start (point))) (insert (concat (substring (current-time-string) 11 16) " ")) (put-text-property start (+ 6 start) 'face mud-timestamp-face))))) ;; Actual filling. (while (not (eobp)) (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? (if (or (bolp) (save-excursion (let ((here (point))) (beginning-of-line) (skip-chars-forward " \t") (if (eq (point) here) t nil)))) ;; Can't wrap this one, so stuff it. (progn (move-to-column fill-column) (skip-chars-forward "^ \t\r\n") (while (looking-at "[ \t]") ;; nuke whitespace to next 'word' (delete-char 1)) (or (eolp) (save-excursion (insert "\n ") (if mud-timestamps (insert " "))))) ;; Else wrap the line (save-excursion (insert "\n ") (if mud-timestamps (insert " ")))) (forward-line 1) ))) ;; Save the fill-point. (put mud-current 'mud-last-fill (point-max)))) ;;; --------------------------------------------------------------- ;;; KEYMAP FUNCTIONS ;;; --------------------------------------------------------------- ;;; ;;; Toggle page-me beeping on and off ;;; (defun mud-toggle-page() "Toggle page-me beeping on and off" (interactive) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (paging (get mud-current 'mud-page-beep))) (if paging (progn (put mud-current 'mud-page-beep nil) (message "Beeping on page disabled.")) (put mud-current 'mud-page-beep t) (message "Beeping on page enabled.")) ;; Update the menus (mud-update-menu-toggle mud-current [menu-bar mud toggle-page] paging "beep-on-page"))) ;;; ;;; Enable/Disable log to file. Uses convert-standard-file to make ;;; sure the filename is valid, since this function has now been ;;; usefully implemented in NTemacs at least. ;;; (defun mud-toggle-log() "Toggle logging on and off." (interactive) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (mud-logging (get mud-current 'mud-logging)) (mud-name (get mud-current 'mud-name)) mud-log-file) (if mud-logging (progn (put mud-current 'mud-logging nil) (message "Log-to-file disabled.")) (put mud-current 'mud-logging t) (mud-init-feature mud-current 'mud-log-file (mud-make-log-filename mud-name)) (setq mud-log-file (convert-standard-filename (or (get mud-current 'mud-log-file) "gen-mud.log"))) (save-excursion (set-buffer (get mud-current 'mud-bout)) (put mud-current 'mud-last-log (point))) (message "Log-to-file enabled, writing to %s." mud-log-file)) ;; Update menus (mud-update-menu-toggle mud-current [menu-bar mud toggle-log] mud-logging "log-to-file"))) ;;; ;;; Toggle idle messaging on and off ;;; (defun mud-toggle-idle() "Toggle idle messaging on and off" (interactive) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (idling (get mud-current 'mud-idle-chat))) (if (eq idling t) (progn (put mud-current 'mud-idle-chat 0) (message "Idle messages disabled, quiet idle enabled.")) ;; else idling = 0? (if idling (progn (put mud-current 'mud-idle-chat nil) (message "Idle messages disabled.")) ;; else idling = nil (put mud-current 'mud-idle-chat t) (message "Idle messages enabled, verbose."))) ;; Update the menus (mud-update-menu-toggle mud-current [menu-bar mud toggle-idle] idling "idle messages"))) ;;; ;;; Toggle PONG (ping response) on and off ;;; (defun mud-toggle-pong() "Toggle pong messaging on and off" (interactive) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (ponging (get mud-current 'mud-pong))) (if ponging (progn (put mud-current 'mud-pong nil) (message "Pong messages disabled.")) (put mud-current 'mud-pong t) (message "Pong messages enabled.")) ;; Update the menus (mud-update-menu-toggle mud-current [menu-bar mud toggle-pong] ponging "PONG messages"))) ;;; ;;; Quote a file into the mud ;;; (defun mud-insert-file() "Quote a file on the mud." (interactive) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (mud-quote-string (get mud-current 'mud-quote-string)) 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-current (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-current (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) (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer)))) (mud-send-string mud-current (concat "say ping " (current-time-string) "\n")))) (defun delete-backward-char-maybe () "delete-backward-char if we're not at the beginning of the line." (interactive) (if (not (= (current-column) 0)) (delete-backward-char 1))) ;;; ---------------------------------------------------------------- ;;; HOOK FUNCTIONS ;;; ---------------------------------------------------------------- ;;; Yay! New hook functions, much more fun to work with. ;;; ;;; 1. Don't mess with the ^M characters. They're used by the ;;; line-filling code. ;;; ;;; 2. You're getting raw mud output here. It's not ;;; pretty-printed. This means you can play with it before the ;;; line-filling code lays hands on it. ;;; ;;; 3. If you're going to move the point or switch to another buffer, ;;; use a save-excursion to ensure that any hook functions called ;;; after yours start at the same point as you did. There's a ;;; save-excursion around the entire of the run-hooks call, but ;;; that's not quite good enough. ;;; ;;; 4. If you need to maintain a 'last-place-we-did-this' variable, ;;; you'll need to add it as a symbol to the ;;; mud-placeholders-list. See the head of the file for how to do ;;; this. ;;; ;;; 5. You get two parameters, mud-current and the text that caused ;;; the hook to be called. You can get everything else from ;;; mud-current; see below for examples. ;;; ;;; 6. You can report errors using (mud-whine mud-current "text"), ;;; which will appear in your output buffer as ;;; mud.el says, "text" ;;; which I think is really cute. ;;; ;;; 7. If you screw up your code, you'll get a message like the above ;;; when the hook throws an error, but the mud should keep going. ;;; ;;; 8. The arbitrary regexp matcher is good enough that you should be ;;; able to use that for 99% of your hookage needs. It contains ;;; built-in tracking of "last place we got a match", so you don't ;;; have to worry about that. It also hands you the entire ;;; match-data structure. See below for examples; almost all of ;;; mud.el's original hook functionality has been folded into ;;; regexp stuff. ;;; ;;; New regexp-matching function, designed to be smarter. ;;; (defun mud-check-for-regexps( mud-current output ) "Check mud-regexps-list for a match, and act appropriately." (let ((mud-regexps-list (get mud-current 'mud-regexps-list)) new-vec) (if mud-regexps-list (progn (if (listp mud-regexps-list) (let ((mud-tmp-list mud-regexps-list) mud-regexps-list) (while (car mud-tmp-list) (setq new-vec (mud-process-regexp mud-current (car mud-tmp-list) output)) (and (vectorp new-vec) (setq mud-regexps-list (append mud-regexps-list (list new-vec)))) (setq mud-tmp-list (cdr mud-tmp-list))) (put mud-current 'mud-regexps-list mud-regexps-list)) (message "mud-regexps-list is not a list!")))))) ;;; ;;; Handle a single regexp from the above function. ;;; (defun mud-process-regexp( mud-current regexp-vector output) "Check mud-current for a single regexp and do the stuff." (let ((mud-max-buffer (or (get mud-current 'mud-max-buffer) (save-excursion (set-buffer (get mud-current 'mud-bout)) (- (point-max) (point-min))))) regexp function last-match start maybe-end end) (if (vectorp regexp-vector) (progn (setq regexp (aref regexp-vector 0) function (aref regexp-vector 1)) (if (< (length regexp-vector) 3) (setq regexp-vector (vconcat regexp-vector (vector mud-max-buffer)))) (setq last-match (+ (aref regexp-vector 2) (length output))) ;; last-match is the number of characters from the end of ;; the buffer that we found the previous match. We've just ;; added OUTPUT to the buffer, so we need to add its length ;; to last-match. This saves having to maintain variables in ;; a seperate list/function like the original hooks do. ;; Now, check if last-match is still within the buffer. If ;; not, change it. (setq start (- (point-max) last-match)) (or (< (point-min) start) (setq start (point-min))) (save-excursion (goto-char start) (setq maybe-end start end start) (while (re-search-forward regexp nil t) (setq maybe-end end end (match-end 0)) (funcall function mud-current (match-data))) ;; if the regexp ran right up to the end of the buffer, ;; check that the line it matched was complete. This ;; allows regexps to track across updates properly, ;; e.g. during laggy networks where half a URL appears in ;; one update and the rest of the URL in the next. (if (= (point-max) end) (if (string= (substring output -1) " ") () (setq end maybe-end))) ;; reset the vector pointer (setq last-match (- (point-max) end)) (aset regexp-vector 2 last-match) regexp-vector)) (message "regexp-vector ain't a vector!") nil))) ;;; ;;; Highlight a whisper ;;; (defun mud-highlight-whisper( mud-current &optional match-stuff ) "Highlight whispers when found." (let ((start (nth 0 match-stuff)) (end (nth 1 match-stuff)) (mud-whisper-face (get mud-current '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-current &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-current 'mud-topic-face))) (if (and (markerp start) (markerp end) (markerp topic-start) (markerp topic-end)) ;; Send it off (mud-color-topic mud-current (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-current &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-current 'mud-page-beep)) (mud-page-face (get mud-current 'mud-page-face)) (mud-page-popup (get mud-current 'mud-page-popup)) message-text) (if (and start end (facep mud-page-face)) (put-text-property start end 'face mud-page-face)) (if (and userpage-end userpage-start) (setq message-text (format "%s has paged you. (%s)" (buffer-substring userpage-end userpage-start) (prin1-to-string mud-current)))) (if (and locpage-end locpage-start) (setq message-text (format "%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-current)))) ;; Raise the message frame if it's set ; (if mud-page-popup ; (progn ; (let* ((myframe (selected-frame)) ; (message-frame ; (make-frame (list (cons 'name "mud.el alert") ; (cons 'height 3) ; (cons 'width (length message-text)) ; (cons 'minibuffer 'none))))) ; (select-frame message-frame) ; (raise-frame message-frame) ; (save-excursion ; (set-buffer (get-buffer-create " *page*")) ; (goto-char (point-max)) ; (insert message-text) ; (insert ?\n) ; (display-buffer " *page*")) ; (select-frame myframe)))) (message message-text) ;; beep if necessary (if mud-page-beep (beep)))) ;;; ;;; Highlight a URL and display it in the minibuffer. ;;; (defun mud-highlight-url( mud-current &optional match-stuff) "Highlight a URL in the buffer" (let ((last 0) url n (mud-url-face (get mud-current '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-current 'mud-show-urls) (message (concat "URL: " url))))) ;;; ;;; Acknowledge a PING message, if we're answering them. ;;; (defun mud-acknowledge-ping( mud-current &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-current '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-current (format "%s %sPONG %s\n" method victim (current-time-string))))))) ;;; ;;; Respond to a version query ;;; (defun mud-tell-version( mud-current &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-current (format "whisper %s=mud.el $Revision: 2.8 $\n" victim)) )))) ;;; --------------------------------------------------------------------------- ;;; Utility functions ;;; --------------------------------------------------------------------------- ;;; ;;; Make a hook. This is me being /really/ nice. ;;; (defun mud-create-hook( &optional mud regexp function ) "Create a new hook for the current mud." (interactive) (let (mud-current) (or mud (setq mud (mud-get-from-bout mud-current-list (current-buffer))) (setq mud (mud-get-from-bin mud-current-list (current-buffer))) (setq mud (cdr (mud-pick-from-list mud-current-list)))) (catch 'done (if (stringp mud) (setq mud-current (car (read-from-string mud))) (if (symbolp mud) (setq mud-current mud))) (or mud-current (progn (message "Sorry, I don't know anything about a mud called %s." (prin1-to-string mud)) (throw 'done nil))) (or regexp (setq regexp (read-from-minibuffer "Regexp: " nil nil nil regexp-history))) ;; Verify regexp (condition-case error (string-match regexp "TEST") (error (message "Your regexp is broken!") (setq regexp nil) (throw 'done nil))) ;; FEATURE completing-read on functions. (or function (setq function (read-from-minibuffer "Function: " nil nil t nil))) (or (fboundp function) (progn (message "Sorry, I don't know any function called %s.\n" (prin1-to-string function)) (throw 'done nil))) (message "When I see \"%s\" in %s, I'll call %s." regexp (prin1-to-string mud) (prin1-to-string function)) (let ((mud-regexps-list (get mud-current 'mud-regexps-list)) (new-regexp (vector regexp function))) (add-to-list 'mud-regexps-list new-regexp) (put mud-current 'mud-regexps-list mud-regexps-list))))) ;;; ;;; Tweak a font interactively ;;; (defun mud-tweak-face( &optional mud-current ) "Tweak a face interactively." (interactive) (or mud-current (setq mud-current (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-current)))))) (selected-face-name (mud-completing-read "Face: " faces nil 0 nil)) (selected-face (get mud-current (nth 1 (assoc selected-face-name faces))))) (message "selected face colour: %s" (prin1-to-string (face-foreground selected-face))))) ;;; ;;; Delete output lines from the buffer. Gagging, basically. ;;; (defun mud-delete-lines( mud-current ) "Delete lines output from the mud. Uses match-data to find them." (let ((beg (match-beginning 0)) (end (match-end 0))) (delete-region beg end) )) ;;; ;;; Initialise a mud feature unless it's already been set. ;;; (defun mud-init-feature( mud-current featurename value ) "Set MUD-CURRENT's FEATURENAME property to VALUE unless it's already set." (or (member featurename (symbol-plist mud-current)) (put mud-current featurename value))) ;;; ;;; Handle deprecated symbols nicely. ;;; (defun mud-deprecated( mud-current oldvar newvar ) "Check if a deprecated variable is in use. If you use a deprecated variable, mud.el will tell you the new variable to use and copy from the old variable to the new." (if (boundp oldvar) (if newvar (progn (mud-whine mud-current (concat "Use of " (prin1-to-string oldvar) " is deprecated. Please use " (prin1-to-string newvar) " instead.")) (mud-fill-lines mud-current) ;; YARG! Isn't there a nicer way to do this? (set (make-symbol (symbol-name newvar)) (symbol-value oldvar))) (mud-whine mud-current (concat "Use of " (prin1-to-string oldvar) " is deprecated, and there is no direct" " replacement. Please check the release" " notes for this version of mud.el.")) (mud-fill-lines mud-current)))) ;;; ;;; Create a name for logfiling the specified mud. You can override ;;; this if you like. ;;; (defun mud-make-log-filename( mud-name ) "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 (concat "~/" mud-name ".log")))) ;;; ;;; Update menus when a value is toggled. Aren't I nice? ;;; (defun mud-update-menu-toggle( mud-current key value text) "Update the Mud menu entry in MUD-CURRENT's keymap for KEY. The menu entry is set to \"Enable\" or \"Disable\" (depending on VALUE) plus the trailing TEXT." (let ((mud-bin (get mud-current 'mud-bin)) (mud-bout (get mud-current 'mud-bout))) (save-excursion (set-buffer mud-bin) (define-key (current-local-map) key (cons (concat (if value "Enable " "Disable ") text) (lookup-key (current-local-map) key)))))) ;;; ;;; Convenience function for hacking at keymaps, specifically menu ;;; entries. ;;; (defun mud-define-key( mud-current key func text ) "Convenience function to define a key for a given mud." (let ((mud-bin (get mud-current 'mud-bin))) (save-excursion (set-buffer mud-bin) (let ((map (current-local-map))) (define-key map key (if text (cons text func) func)))))) ;;; ;;; Make a properties list on the menu. More showing off. Jeez. ;;; (defun mud-list-props( &optional mud ) "List properties of the specified mud." (interactive) (let (mud-current) (or mud (setq mud (mud-get-from-bout mud-current-list (current-buffer))) (setq mud (mud-get-from-bin mud-current-list (current-buffer))) (setq mud (cdr (mud-pick-from-list mud-current-list)))) (if (stringp mud) (setq mud-current (car (read-from-string mud))) (if (symbolp mud) (setq mud-current mud))) (let ((proplist (delq nil (let (y) (mapcar '(lambda(x) (if y (let ((z (cons y x))) (setq y nil) (if (and (not (processp x)) (not (bufferp x)) (not (windowp x)) (not (timerp x))) z nil)) (setq y x) nil)) (symbol-plist mud-current)))))) (mud-define-key mud-current [menu-bar mud proplist] (make-sparse-keymap) (format "%s Properties" (prin1-to-string mud-current))) ;; Make the menu. The (reverse) is so that mud-name ends up on top. (mud-menu-from-list mud-current [proplist] (reverse proplist)) (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. Actually, this is all just showing off :) ;;; (defun mud-menu-from-list( mud-current 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-current (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)) ;; atorbarkingbabonel! alists ;; break here. ;; FIXME recursively call ;; sequence-or-not(x) (if (sequencep x) (cons n (prin1-to-string x)) (cons n x))) (if (vectorp val) (append val nil) val))) (mud-menu-from-list mud-current (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 (intern val)) "no")) ;; ;; no stipple in xemacs. losers. ;; ;;(cons 'stipple (or (face-stipple val) "default")) ;; (cons 'background (or (face-background (intern val)) "default")) ;; (cons 'foreground (or (face-foreground (intern val)) "default")) ;; (cons 'font (or (face-font (intern val)) "default")) ;; ))) ;; ;; (mud-menu-from-list mud-current (vconcat key ;; (vector name)) ;; face-details))) t) ;; Anything else just gets put in as-is. (t (mud-define-key mud-current (vconcat key (vector name) [val]) nil (if (stringp val) val (prin1-to-string val))))) (setq list (cdr list))))) ;;; ;;; Idle text generator ;;; This is for people whose connections will time out if they don't ;;; periodically send data. Like me, for example. ;;; (defun mud-send-idle-message(mud-current) (let ((verbose (get mud-current 'mud-idle-chat))) (if (eq verbose t) (let ((n (length mud-idle-messages))) (idle-string (nth (random n) mud-idle-messages)) (mud-send-string mud-current (concat ": " idle-string "\n"))) ;; else (mud-send-string mud-current (get mud-current 'mud-idle-noop))))) ;;; ;;; Reset the mud's idle timer ;;; (defun mud-idle-timer-reset(mud-current) (if (symbolp mud-current) (let ((mud-idle-timer (get mud-current 'mud-idle-timer)) (mud-idle-time (or (get mud-current 'mud-idle-time) mud-default-idle-time "30 min"))) (and mud-idle-timer (cancel-timer mud-idle-timer)) (setq mud-idle-timer (run-at-time mud-idle-time nil 'mud-send-idle-message mud-current)) (put mud-current 'mud-idle-timer mud-idle-timer)))) ;;; 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." (let ((mud-current (mud-get-from-bin mud-current-list (current-buffer)))) (put mud-current 'mud-command-history (cons string (get mud-current '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)) (defun mud-grab-a-line (delta) "Move delta lines in the history and insert that line, replacing the current one." (let* ((mud-current (mud-get-from-bin mud-current-list (current-buffer))) (command-history (get mud-current 'mud-command-history)) (command-number (get mud-current 'mud-command-to-yank)) command-iterator) (setq command-number (+ delta command-number)) ;; Yuck, but we shouldn't have to move that far (setq command-iterator command-number) (if (>= command-iterator 0) (progn (while (> command-iterator 0) (setq command-history (cdr-safe command-history)) (setq command-iterator (1- command-iterator))) (if (consp command-history) (let ((command (car command-history))) (put mud-current 'mud-command-to-yank command-number) ;; Erase current line (beginning-of-line) (let ((beg (point))) (forward-line) (delete-region beg (point))) (insert command) (delete-backward-char 1) ; delete the newline, ha ha )))))) ;;; 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)) ;;; ;;; [dfan] Colo(u)r in a topic. ;;; (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 (make-face (mud-symbol-from-string (concat "fg:" (car color-pair)))))) (set-face-foreground topic-face (car color-pair)) (setcdr color-pair end) ; update the marker (put-text-property start end 'face topic-face)))) (defgroup mud-specific nil "Settings for specific muds." :group 'mud) ;;; NERDSHOLM SPECIFIC STUFF ;;; ;;; If you have to ask, uh, yeah. Whatever. The exit's two doors ;;; down. Don't let the door hit you on the way out. (defgroup Nerdsholm-specific nil "Settings specific to Nerdsholm." :group 'mud-specific) (defcustom mud-bbs-regexp "^%% \\S-+ has posted to the BBS" "*Regexp matching notice of postings to the BBS." :group 'Nerdsholm-specific :type 'regexp) (defcustom mud-dir-regexp "^%% \\S-+ has set an entry in the participants' directory" "*Regexp matching notice of postings to the participants' directory." :group 'Nerdsholm-specific :type 'regexp) (defcustom mud-match-regexp "^[^?\r\n]*\\<\$[a-zA-Z]+[0-9][0-9][0-9]@[a-zA-Z-]+\$\\>" "*Regexp matching a MatchMaker[tm] ID" :group 'Nerdsholm-specific :type 'regexp) (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 ;; And the less said about matchmaker.com, the better. (put 'Nerdsholm 'mud-bbs-url "http://nerdsholm.boutell.com/bbs.cgi") (put 'Nerdsholm 'mud-dir-url "http://nerdsholm.boutell.com/dir.cgi") (put 'Nerdsholm 'mud-match-url "http://www.ireland.matchmaker.com/browse?") (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)) (add-to-list 'regexps-list (vector mud-match-regexp 'mud-highlight-match)) (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)))) ;; gross silliness (defun mud-highlight-match( mud-current &optional match-stuff ) "Stick a URL onto matchmaker IDs" (let ((mud-match-url (get mud-current 'mud-match-url))) (goto-char (nth 2 match-stuff)) (insert (format "%s" mud-match-url)))) ;;; GROSS silliness (defvar mud-speech-process nil) (defun mud-say( string ) "Use the speech synth to say something." (or mud-speech-process (setq mud-speech-process (start-process "speech" nil (expand-file-name "~/src/c/speech/cmdlinespeakfile")))) (process-send-string mud-speech-process string)) ;;; Hook in my gronk hacks, so people can see what I'm listening ;;; to. Why? Because I can! (if (featurep 'gronk) (progn (defun mud-gronk-doing( mud-current text ) (let ((mud-playing (get mud-current 'mud-playing)) (now-playing (gronk-current))) (if (equal mud-playing now-playing) () (let ((doing (format "@doing Now playing _%s_ by %s.\r\n" (nth 2 now-playing) (nth 0 now-playing)))) (mud-send-string mud-current doing) (put mud-current 'mud-playing now-playing))))) (add-hook 'mud-send-string-hooks 'mud-gronk-doing))) ;; just in case someone wants to require this... (provide 'mud)