;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; TNT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Copyright (c) 1998 America Online, Inc. All Rights Reserved. ;;;; ;;;; AOL grants you ("Licensee") a non-exclusive, royalty free, license to ;;;; use, modify and redistribute this software in source and binary code ;;;; form, provided that i) this copyright notice and license appear on all ;;;; copies of the software; and ii) Licensee does not utilize the software ;;;; in a manner which is disparaging to AOL. ;;;; ;;;; This software is provided "AS IS," without a warranty of any kind. ALL ;;;; EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, INCLUDING ;;;; ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE ;;;; OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. AOL AND ITS LICENSORS SHALL NOT ;;;; BE LIABLE FOR ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, ;;;; MODIFYING OR DISTRIBUTING THE SOFTWARE OR ITS DERIVATIVES. IN NO EVENT ;;;; WILL AOL OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, ;;;; OR FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE ;;;; DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, ARISING ;;;; OUT OF THE USE OF OR INABILITY TO USE SOFTWARE, EVEN IF AOL HAS BEEN ;;;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. ;;;; ;;;; This software is not designed or intended for use in on-line control of ;;;; aircraft, air traffic, aircraft navigation or aircraft communications; ;;;; or in the design, construction, operation or maintenance of any nuclear ;;;; facility. Licensee represents and warrants that it will not use or ;;;; redistribute the Software for such purposes. ;;;; TODO: ;;;; implement permit/deny ;;;; point reset by erase-buffer to beginning of buddy buffer during update ;;;; consider using use-hard-newlines variable ;;;; make processed im messages read-only ;;;; mouse mappings (provide 'tnt) (require 'toc) (defconst tnt-version "TNT 1.7") ;;; Config variables (defvar tnt-toc-host "toc.oscar.aol.com") (defvar tnt-toc-port 5190) (defvar tnt-login-host "login.oscar.aol.com") (defvar tnt-login-port 5190) (defvar tnt-language "english") (defvar tnt-default-username nil) (defvar tnt-default-password nil) (defvar tnt-inhibit-key-bindings nil) ;;; Key bindings (if tnt-inhibit-key-bindings () (global-set-key "\C-xto" 'tnt-open) (global-set-key "\C-xtk" 'tnt-kill) (global-set-key "\C-xti" 'tnt-im) (global-set-key "\C-xtj" 'tnt-join-chat) (global-set-key "\C-xtb" 'tnt-show-buddies) (global-set-key "\C-xta" 'tnt-accept) (global-set-key "\C-xtr" 'tnt-reject) (global-set-key "\C-xtp" 'tnt-prev-event) (global-set-key "\C-xtn" 'tnt-next-event) (global-set-key "\C-xtB" 'tnt-edit-buddies) (global-set-key "\C-xtm" 'tnt-motd)) ;;; Globals (defvar tnt-current-user nil) ;;;---------------------------------------------------------------------------- ;;; Signon/Signoff ;;;---------------------------------------------------------------------------- (defvar tnt-username) (defvar tnt-password) (defun tnt-open (username password) "Starts a new TNT session." (interactive "p\np");; gag! (if tnt-current-user (error "Already online as %s" tnt-current-user) (setq tnt-username (or (and (stringp username) username) tnt-default-username (read-from-minibuffer "Screen name: ")) tnt-password (or (and (stringp password) password) tnt-default-password (tnt-read-from-minibuffer-no-echo "Password: "))) (setq toc-opened-function 'tnt-handle-opened toc-closed-function 'tnt-handle-closed toc-sign-on-function 'tnt-handle-sign-on toc-config-function 'tnt-handle-config toc-nick-function 'tnt-handle-nick toc-update-buddy-function 'tnt-handle-update-buddy toc-im-in-function 'tnt-handle-im-in toc-chat-join-function 'tnt-handle-chat-join toc-chat-in-function 'tnt-handle-chat-in toc-chat-invite-function 'tnt-handle-chat-invite toc-chat-update-buddy-function 'tnt-handle-chat-update-buddy toc-error-function 'tnt-handle-error) (toc-open tnt-toc-host tnt-toc-port tnt-username)) (run-hooks 'tnt-login-hooks)) (defun tnt-kill () "Ends the current TNT session and signs off from the host." (interactive) (if (null tnt-current-user) (error "Already offline") (toc-close) (tnt-set-online-state nil) (setq tnt-current-user nil) (tnt-buddy-shutdown) (message "Signed off") (run-hooks 'tnt-logout-hooks))) ;;;---------------------------------------------------------------------------- ;;; Instant message mode ;;;---------------------------------------------------------------------------- (defvar tnt-im-mode-syntax-table nil) (defvar tnt-im-mode-abbrev-table nil) (defvar tnt-im-mode-map nil) (defvar tnt-im-user) (defvar tnt-message-marker) (make-variable-buffer-local 'tnt-im-user) (define-abbrev-table 'tnt-im-mode-abbrev-table ()) (if tnt-im-mode-syntax-table () (setq tnt-im-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\" ". " tnt-im-mode-syntax-table) (modify-syntax-entry ?\\ ". " tnt-im-mode-syntax-table) (modify-syntax-entry ?' "w " tnt-im-mode-syntax-table)) (if tnt-im-mode-map () (setq tnt-im-mode-map (make-sparse-keymap)) (define-key tnt-im-mode-map "\r" 'tnt-send-text-as-instant-message)) (defun tnt-im-mode () "Major mode for sending Instant Messages. Special commands: \\{tnt-im-mode-map}" (interactive) (kill-all-local-variables) (use-local-map tnt-im-mode-map) (setq mode-name "IM") (setq major-mode 'tnt-im-mode) (setq local-abbrev-table tnt-im-mode-abbrev-table) (set-syntax-table tnt-im-mode-syntax-table) (auto-fill-mode) (run-hooks 'tnt-im-mode-hook)) (defun tnt-im (user) "Opens an instant-message conversation with a user." (interactive "p") (let* ((completion-ignore-case t) (input (or (and (stringp user) user) (completing-read "Send IM to: " (tnt-buddy-collection))))) (switch-to-buffer (tnt-im-buffer input)))) (defun tnt-im-buffer-name (user) ;; Returns the name of the IM buffer for USER. (format "*im-%s*" (toc-normalize user))) (defun tnt-im-buffer (user) ;; Returns the IM buffer for USER. (let ((buffer-name (tnt-im-buffer-name user))) (or (get-buffer buffer-name) (let ((buffer (get-buffer-create buffer-name))) (save-excursion (set-buffer buffer) (tnt-im-mode) (setq tnt-im-user user) (setq tnt-message-marker (make-marker)) (insert (format "[Conversation with %s on %s]\n\n" (tnt-buddy-official-name user) (current-time-string))) (set-marker tnt-message-marker (point))) buffer)))) (defun tnt-send-text-as-instant-message () "Sends text at end of buffer as an IM." (interactive) (let ((message (tnt-get-input-message))) (tnt-append-message tnt-current-user message) (recenter -1) (toc-send-im tnt-im-user message))) ;;;---------------------------------------------------------------------------- ;;; Chat mode ;;;---------------------------------------------------------------------------- (defvar tnt-chat-mode-syntax-table nil) (defvar tnt-chat-mode-abbrev-table nil) (defvar tnt-chat-mode-map nil) (defvar tnt-chat-alist nil) ; room id to room name (defvar tnt-chat-room) (defvar tnt-chat-roomid) (defvar tnt-chat-participants) (make-variable-buffer-local 'tnt-chat-room) (make-variable-buffer-local 'tnt-chat-roomid) (make-variable-buffer-local 'tnt-chat-participants) (define-abbrev-table 'tnt-chat-mode-abbrev-table ()) (if tnt-chat-mode-syntax-table () (setq tnt-chat-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\" ". " tnt-chat-mode-syntax-table) (modify-syntax-entry ?\\ ". " tnt-chat-mode-syntax-table) (modify-syntax-entry ?' "w " tnt-chat-mode-syntax-table)) (if tnt-chat-mode-map () (setq tnt-chat-mode-map (make-sparse-keymap)) (define-key tnt-chat-mode-map "\r" 'tnt-send-text-as-chat-message) (define-key tnt-chat-mode-map "\n" 'tnt-send-text-as-chat-whisper) (define-key tnt-chat-mode-map "\t" 'tnt-send-text-as-chat-invitation) (define-key tnt-chat-mode-map "\M-p" 'tnt-show-chat-participants)) (defun tnt-chat-mode () "Major mode for sending Instant Messages. Special commands: \\{tnt-chat-mode-map}" (interactive) (kill-all-local-variables) (use-local-map tnt-chat-mode-map) (setq mode-name "Chat") (setq major-mode 'tnt-chat-mode) (setq local-abbrev-table tnt-chat-mode-abbrev-table) (set-syntax-table tnt-chat-mode-syntax-table) (auto-fill-mode) (run-hooks 'tnt-chat-mode-hook)) (defun tnt-join-chat (room) "Joins a chat room." (interactive "p") (if (null tnt-current-user) (error "You must be online to join a chat room.") (let* ((input (or (and (stringp room) room) (read-from-minibuffer "Join chat room: " (format "%s Chat%03d" tnt-current-user (random 1000)))))) (toc-chat-join 4 input) (switch-to-buffer (tnt-chat-buffer input))))) (defun tnt-chat-buffer-name (room) ;; Returns the name of the chat buffer for ROOM. (format "*chat-%s*" (toc-normalize room))) (defun tnt-chat-buffer (room) ;; Returns the chat buffer for ROOM. (let ((buffer-name (tnt-chat-buffer-name room))) (or (get-buffer buffer-name) (let ((buffer (get-buffer-create buffer-name))) (save-excursion (set-buffer buffer) (tnt-chat-mode) (make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'tnt-chat-buffer-killed nil t) (setq tnt-chat-room room) (setq tnt-chat-participants nil) (setq tnt-message-marker (make-marker)) (insert (format "[Chat room \"%s\" on %s]\n\n" room (current-time-string))) (set-marker tnt-message-marker (point))) buffer)))) (defun tnt-chat-buffer-killed () (if tnt-current-user (toc-chat-leave tnt-chat-roomid))) (defun tnt-send-text-as-chat-message () (interactive) (let ((message (tnt-get-input-message))) (toc-chat-send tnt-chat-roomid message))) (defun tnt-send-text-as-chat-whisper (user) (interactive "p") (let ((user (or (and (stringp user) user) (completing-read "Whisper to user: " (tnt-participant-collection)))) (message (tnt-get-input-message))) (if (= (length message) 0) (setq message (read-from-minibuffer "Message: "))) (tnt-append-message (format "%s (whispers to %s)" tnt-current-user (tnt-buddy-official-name user)) message) (recenter -1) (toc-chat-whisper tnt-chat-roomid user message))) (defun tnt-participant-collection () (mapcar '(lambda(x) (list x)) tnt-chat-participants)) (defun tnt-send-text-as-chat-invitation (users) (interactive "p") (let ((user-list (or (and (listp users) users) (tnt-completing-read-list "Users to invite: " (tnt-buddy-collection))))) (if user-list (let ((msg (tnt-get-input-message))) (if (= (length msg) 0) (setq msg (read-from-minibuffer "Message: " "Join me in this Buddy Chat."))) (tnt-append-message (format "%s (invites %s)" tnt-current-user (mapconcat 'tnt-buddy-official-name user-list ", ")) msg) (recenter -1) (apply 'toc-chat-invite tnt-chat-roomid msg user-list))))) (defun tnt-show-chat-participants () "Append a list of chat room participants to a chat buffer." (interactive) (let ((string (mapconcat '(lambda (x) x) tnt-chat-participants ", "))) (tnt-append-message nil (format "Participants: %s" string)))) (defun tnt-chat-event-pop-function (accept) ;; Called when chat event is popped. If event is accepted, the ;; current buffer is the chat buffer. (if accept (toc-chat-accept tnt-chat-roomid))) ;;;---------------------------------------------------------------------------- ;;; Utilites for the messaging modes (im, chat) ;;;---------------------------------------------------------------------------- (make-variable-buffer-local 'tnt-message-marker) (defun tnt-append-message-and-adjust-window (buffer user message) (let ((window (get-buffer-window buffer))) (save-excursion (set-buffer buffer) (tnt-append-message user (tnt-strip-html message)) (if window (let ((old-window (selected-window))) (select-window window) (recenter -1) (select-window old-window)))))) (defun tnt-append-message (user message) ;; Prepends USER to MESSAGE and appends the result to the buffer. (save-excursion (let ((old-point (marker-position tnt-message-marker))) (goto-char tnt-message-marker) (insert-before-markers (if user (format "%s: %s\n\n" user message) (format "[%s]\n\n" message))) (fill-region old-point (point))))) (defun tnt-get-input-message () (let ((message (buffer-substring tnt-message-marker (point-max)))) (kill-region tnt-message-marker (point-max)) (goto-char (point-max)) (recenter -1) (tnt-neliminate-newlines message))) ;;;---------------------------------------------------------------------------- ;;; Buddy list mode ;;;---------------------------------------------------------------------------- (defvar tnt-buddy-list-mode-syntax-table nil) (defvar tnt-buddy-list-mode-abbrev-table nil) (defvar tnt-buddy-list-mode-map nil) (defvar tnt-buddy-blist nil) (defvar tnt-buddy-alist nil) (define-abbrev-table 'tnt-buddy-list-mode-abbrev-table ()) (if tnt-buddy-list-mode-syntax-table () (setq tnt-buddy-list-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\" ". " tnt-buddy-list-mode-syntax-table) (modify-syntax-entry ?\\ ". " tnt-buddy-list-mode-syntax-table) (modify-syntax-entry ?' "w " tnt-buddy-list-mode-syntax-table)) (if tnt-buddy-list-mode-map () (setq tnt-buddy-list-mode-map (make-sparse-keymap)) (define-key tnt-buddy-list-mode-map "n" 'tnt-next-buddy) (define-key tnt-buddy-list-mode-map "p" 'tnt-prev-buddy) (define-key tnt-buddy-list-mode-map "N" 'tnt-next-group) (define-key tnt-buddy-list-mode-map "P" 'tnt-prev-group) (define-key tnt-buddy-list-mode-map "i" 'tnt-im-buddy)) (defun tnt-buddy-list-mode () "Major mode for viewing a buddy list. Special commands: \\{tnt-buddy-list-mode-map}" (interactive) (kill-all-local-variables) (use-local-map tnt-buddy-list-mode-map) (setq mode-name "Buddy List") (setq major-mode 'tnt-buddy-list-mode) (setq local-abbrev-table tnt-buddy-list-mode-abbrev-table) (set-syntax-table tnt-buddy-list-mode-syntax-table) (run-hooks 'tnt-buddy-list-mode-hook)) (defun tnt-show-buddies () "Shows the buddy list in the selected window." (interactive) (tnt-build-buddy-buffer) (switch-to-buffer (tnt-buddy-buffer))) (defun tnt-buddy-buffer () (let ((buffer-name "*buddies*")) (or (get-buffer buffer-name) (let ((buffer (get-buffer-create buffer-name))) (save-excursion (set-buffer buffer) (tnt-buddy-list-mode) (setq buffer-read-only t)) buffer)))) (defun tnt-build-buddy-buffer () (save-excursion (set-buffer (tnt-buddy-buffer)) (let ((buffer-read-only nil)) (erase-buffer) (tnt-blist-to-buffer tnt-buddy-blist '(lambda (nick) (let ((unick (tnt-buddy-status nick))) (if unick (format " %s" unick))))) (set-buffer-modified-p nil)))) (defun tnt-im-buddy () "Initiates an IM conversation with the selected buddy." (interactive) (save-excursion (beginning-of-line) (if (null (re-search-forward " *\\([^\n]*\\)\n" nil t)) (error "Position cursor on a buddy name") (tnt-im (buffer-substring (match-beginning 1) (match-end 1)))))) (defun tnt-next-buddy () "Moves the cursor to the next buddy." (interactive) (beginning-of-line) (if (null (re-search-forward "\n " nil t)) (error "No next buddy")) (goto-char (match-beginning 0)) (forward-char)) (defun tnt-prev-buddy () "Moves the cursor to the previous buddy." (interactive) (beginning-of-line) (if (null (re-search-backward "\n " nil t)) (error "No previous buddy")) (goto-char (match-beginning 0)) (forward-char)) (defun tnt-next-group () "Moves the cursor to the first buddy of the next group." (interactive) (beginning-of-line) (if (null (re-search-forward "\n[^ ]" nil t)) (error "No next group")) (tnt-next-buddy)) (defun tnt-prev-group () "Moves the cursor to the last buddy of the previous group." (interactive) (beginning-of-line) (if (null (re-search-backward "\n[^ ]" nil t)) (error "No previous buddy")) (goto-char (match-beginning 0)) (tnt-prev-buddy)) (defun tnt-initialize-buddy-list (config) (setq tnt-buddy-blist (tnt-config-to-blist config)) (let ((buddies (tnt-extract-normalized-buddies tnt-buddy-blist))) (apply 'toc-add-buddy buddies))) (defun tnt-buddy-shutdown () (setq tnt-buddy-blist nil tnt-buddy-alist nil) (tnt-build-buddy-buffer)) (defun tnt-set-buddy-status (nick onlinep) (let* ((nnick (toc-normalize nick)) (pair (assoc nnick tnt-buddy-alist)) (status (if onlinep nick)) (old-status (and pair (cdr pair)))) (if pair (setcdr pair status) (setq tnt-buddy-alist (cons (cons nnick status) tnt-buddy-alist))) (if (string= status old-status) () (tnt-build-buddy-buffer)))) (defun tnt-buddy-status (nick) (let* ((nnick (toc-normalize nick)) (pair (assoc nnick tnt-buddy-alist))) (if pair (cdr pair)))) (defun tnt-buddy-official-name (buddy) ;; Return official screen name of buddy if known, otherwise ;; just return buddy. (or (tnt-buddy-status buddy) buddy)) (defun tnt-buddy-collection () ;; Return a "collection" of online buddies for completion commands. (mapcar '(lambda(x) (list (cdr x))) tnt-buddy-alist)) ;;;---------------------------------------------------------------------------- ;;; Buddy-list edit mode ;;;---------------------------------------------------------------------------- (defvar tnt-buddy-edit-mode-syntax-table nil) (defvar tnt-buddy-edit-mode-abbrev-table nil) (defvar tnt-buddy-edit-mode-map nil) (define-abbrev-table 'tnt-buddy-edit-mode-abbrev-table ()) (if tnt-buddy-edit-mode-syntax-table () (setq tnt-buddy-edit-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\" ". " tnt-buddy-edit-mode-syntax-table) (modify-syntax-entry ?\\ ". " tnt-buddy-edit-mode-syntax-table) (modify-syntax-entry ?' "w " tnt-buddy-edit-mode-syntax-table)) (if tnt-buddy-edit-mode-map () (setq tnt-buddy-edit-mode-map (make-sparse-keymap)) (define-key tnt-buddy-edit-mode-map "\C-x\C-s" 'tnt-save-buddy-list) ) (defun tnt-buddy-edit-mode () "Major mode for editing a buddy list. Special commands: \\{tnt-buddy-edit-mode-map}" (interactive) (kill-all-local-variables) (use-local-map tnt-buddy-edit-mode-map) (setq mode-name "Buddy Edit") (setq major-mode 'tnt-buddy-edit-mode) (setq local-abbrev-table tnt-buddy-edit-mode-abbrev-table) (set-syntax-table tnt-buddy-edit-mode-syntax-table) (run-hooks 'tnt-buddy-edit-mode-hook)) (defun tnt-edit-buddies () "Shows the buddy-list editor editor in the selected window." (interactive) (switch-to-buffer (tnt-buddy-edit-buffer))) (defconst tnt-buddy-edit-buffer-name "*edit-buddies*") (defun tnt-buddy-edit-buffer () (let ((buffer-name tnt-buddy-edit-buffer-name)) (or (get-buffer buffer-name) (let ((buffer (get-buffer-create buffer-name))) (save-excursion (set-buffer buffer) (tnt-buddy-edit-mode) ;; make-local-hook doesn't work here; tries to call t (make-local-variable 'kill-buffer-query-functions) (add-hook 'kill-buffer-query-functions 'tnt-buddy-edit-kill-query) (tnt-build-buddy-edit-buffer) (set-buffer-modified-p nil)) buffer)))) (defun tnt-build-buddy-edit-buffer () (save-excursion (set-buffer (tnt-buddy-edit-buffer)) (erase-buffer) (tnt-blist-to-buffer tnt-buddy-blist))) (defun tnt-buddy-edit-kill-query () (or (null (buffer-modified-p)) (yes-or-no-p "Buddy list modified; kill anyway? "))) (defun tnt-save-buddy-list () "Saves a buddy-edit buffer on the host." (interactive) (if (null tnt-current-user) (error "You must be online to save a buddy list") (let* ((new-blist (tnt-buffer-to-blist)) (old-blist tnt-buddy-blist) (new-list (tnt-extract-normalized-buddies new-blist)) (old-list (tnt-extract-normalized-buddies old-blist)) (diffs (tnt-sorted-list-diff old-list new-list))) (if (cdr diffs) (apply 'toc-add-buddy (cdr diffs))) (if (car diffs) (apply 'toc-remove-buddy (car diffs))) (toc-set-config (tnt-blist-to-config new-blist)) (setq tnt-buddy-blist new-blist)) (set-buffer-modified-p nil) (tnt-build-buddy-buffer))) ;;;---------------------------------------------------------------------------- ;;; Buddy utilities ;;;---------------------------------------------------------------------------- (defun tnt-buffer-to-blist () (save-excursion (goto-char (point-min)) (let ((blist nil)) (while (re-search-forward "\\([ \t]*\\)\\([^\n]*\\)\n" nil t) (let ((pref (buffer-substring (match-beginning 1) (match-end 1))) (body (buffer-substring (match-beginning 2) (match-end 2)))) (goto-char (match-end 0)) (let ((has-pref (> (length pref) 0)) (has-body (string-match "[^ \t]" body))) (cond ((and has-body has-pref) ; is a buddy (setcar blist (cons body (car blist)))) (has-body ; is a group (setq blist (cons (list body) blist))))))) (mapcar 'nreverse (nreverse blist))))) (defun tnt-blist-to-buffer (blist &optional filter) (while blist (let ((name-list (car blist))) (insert (format "%s\n" (car name-list))) (setq name-list (cdr name-list)) (while name-list (let* ((name (car name-list)) (fname (if filter (funcall filter name) (format " %s" name)))) (if fname (insert (format "%s\n" fname)))) (setq name-list (cdr name-list))) (setq blist (cdr blist)) (if blist (insert "\n"))))) (defun tnt-config-to-blist (config) (let ((index 0) (blist nil)) (while (and config (string-match ". [^\n]*\n" config index)) (let* ((beg (match-beginning 0)) (end (match-end 0)) (code (aref config beg)) (arg (substring config (+ beg 2) (- end 1)))) (cond ((= code ?g) (setq blist (cons (list arg) blist))) ((= code ?b) (setcar blist (cons arg (car blist))))) (setq index end))) (mapcar 'nreverse (nreverse blist)))) (defun tnt-blist-to-config (blist) (let ((config "")) (while blist (let ((name-list (car blist))) (setq config (format "%sg %s\n" config (car name-list))) (setq name-list (cdr name-list)) (while name-list (setq config (format "%sb %s\n" config (car name-list))) (setq name-list (cdr name-list))) (setq blist (cdr blist)))) config)) (defun tnt-extract-normalized-buddies (blist) (tnt-nsort-and-remove-dups (mapcar 'toc-normalize (apply 'append (mapcar 'cdr blist))))) ;;;---------------------------------------------------------------------------- ;;; Pending-event ring ;;;---------------------------------------------------------------------------- (defvar tnt-event-ring nil) ; (buffer-name . (message . callback)) (defun tnt-accept () "Accepts an instant message or chat invitation." (interactive) (tnt-pop-event t)) (defun tnt-reject (warn) "Rejects an instant message or chat invitation; warns if prefix arg." (interactive "P") (tnt-pop-event nil)) (defun tnt-next-event () "Shows the next event in the notification ring." (interactive) (setq tnt-event-ring (tnt-rotate-right tnt-event-ring)) (tnt-show-top-event)) (defun tnt-prev-event () "Show the previous event in the notification ring." (interactive) (setq tnt-event-ring (tnt-rotate-left tnt-event-ring)) (tnt-show-top-event)) (defun tnt-push-event (message buffer-name function) ;; Push new event onto the event ring. (if (assoc buffer-name tnt-event-ring) () (setq tnt-event-ring (cons (cons buffer-name (cons message function)) tnt-event-ring)) (tnt-show-top-event))) (defun tnt-pop-event (accept) ;; Remove the top event from the event ring. (if tnt-event-ring (let* ((event (car tnt-event-ring)) (buffer-name (car event)) (function (cdr (cdr event)))) (setq tnt-event-ring (cdr tnt-event-ring)) (if accept (switch-to-buffer buffer-name) (kill-buffer buffer-name)) (if function (funcall function accept)) (if tnt-event-ring (tnt-show-top-event) (tnt-persistent-message))))) (defun tnt-show-top-event () ;; Display the message associated with the top event in the minibuffer. (if tnt-event-ring (let* ((event (car tnt-event-ring)) (message (car (cdr event)))) (tnt-persistent-message "%s ('%s' to accept) %s" message (substitute-command-keys "\\[tnt-accept]") (let ((len (length tnt-event-ring))) (if (= len 1) "" (format "[%d more]" (1- len)))))))) ;;;---------------------------------------------------------------------------- ;;; Mode line ;;;---------------------------------------------------------------------------- (defvar tnt-mode-string "") (defun tnt-set-online-state (is-online) ;; Sets or clears the mode-line online indicator. (setq tnt-mode-string (if is-online (format " [%s]" tnt-current-user) "")) (or global-mode-string (setq global-mode-string '(""))) (or (memq 'tnt-mode-string global-mode-string) (setq global-mode-string (append global-mode-string '(tnt-mode-string)))) (force-mode-line-update)) ;;;---------------------------------------------------------------------------- ;;; Handlers for TOC events ;;;---------------------------------------------------------------------------- (defun tnt-handle-opened () (toc-signon tnt-login-host tnt-login-port tnt-username tnt-password tnt-language tnt-version)) (defun tnt-handle-closed () (tnt-set-online-state nil) (setq tnt-current-user nil) (tnt-buddy-shutdown) (tnt-error "TNT connection closed")) (defun tnt-handle-sign-on (version) (message "Signed on") (toc-init-done)) (defun tnt-handle-config (config) (tnt-initialize-buddy-list config)) (defun tnt-handle-nick (nick) (setq tnt-current-user nick) (or tnt-buddy-blist (setq tnt-buddy-blist (list (list "Buddies" nick)))) (tnt-set-online-state t)) (defun tnt-handle-update-buddy (nick online evil signon idle) (tnt-set-buddy-status nick online)) (defun tnt-handle-im-in (user auto message) (let ((buffer (tnt-im-buffer user))) (tnt-append-message-and-adjust-window buffer user message) (beep) (if (null (get-buffer-window buffer)) (tnt-push-event (format "Message from %s available" user) (tnt-im-buffer-name user) nil)))) (defun tnt-handle-chat-join (roomid room) (let ((buffer (tnt-chat-buffer room))) (save-excursion (set-buffer buffer) (setq tnt-chat-roomid roomid))) (let ((assoc (assoc roomid tnt-chat-alist))) (if assoc () (setq tnt-chat-alist (cons (cons roomid room) tnt-chat-alist))))) (defun tnt-handle-chat-in (roomid user whisperp message) (let ((buffer (tnt-chat-buffer (cdr (assoc roomid tnt-chat-alist))))) (tnt-append-message-and-adjust-window buffer (if whisperp (format "%s (whispers)" user) user) message))) (defun tnt-handle-chat-invite (room roomid sender message) (tnt-handle-chat-join roomid room) ; associate roomid with room (let ((buffer (tnt-chat-buffer room))) (save-excursion (set-buffer buffer) (tnt-append-message (format "%s (invitation)" sender) (tnt-strip-html message))) (tnt-push-event (format "Chat invitation from %s arrived" sender) buffer 'tnt-chat-event-pop-function) (beep))) (defun tnt-handle-chat-update-buddy (roomid inside users) (save-excursion (set-buffer (tnt-chat-buffer (cdr (assoc roomid tnt-chat-alist)))) (let ((user-string (mapconcat '(lambda (x) x) users ", "))) (tnt-append-message nil (if tnt-chat-participants (format "%s %s" user-string (if inside "joined" "left")) (format "Participants: %s" user-string)))) (if inside (setq tnt-chat-participants (append users tnt-chat-participants)) (while users (let ((user (car users))) (setq tnt-chat-participants (delete user tnt-chat-participants)) (setq users (cdr users))))))) (defun tnt-handle-error (code args) (cond ((= code 901) (tnt-error "User %s not online" (car args))) ((= code 902) (tnt-error "Warning of %s is not allowed" (car args))) ((= code 903) (tnt-error "Message dropped - you are sending too fast")) ((= code 950) (tnt-error "Chat room %s is not available" (car args))) ((= code 960) (tnt-error "Message dropped - sending too fast for %s" (car args))) ((= code 961) (tnt-error "Message from %s dropped - too big" (car args))) ((= code 962) (tnt-error "Message from %s dropped - sent too fast" (car args))))) ;;;---------------------------------------------------------------------------- ;;; Minibuffer utilities ;;;---------------------------------------------------------------------------- (defun tnt-read-from-minibuffer-no-echo (prompt) ;; Reads a string from the minibuffer without echoing it. (let ((keymap (make-keymap)) (i ? )) (while (<= i 126) (define-key keymap (char-to-string i) '(lambda () (interactive) (insert last-command-char) (put-text-property (1- (point)) (point) 'invisible t))) (setq i (1+ i))) (define-key keymap "\r" 'exit-minibuffer) (let ((str (read-from-minibuffer prompt "" keymap))) (set-text-properties 0 (length str) nil str) str))) (defun tnt-completing-read-list (prompt collection) ;; Reads a list from the minibuffer with completion. (let ((str (let ((collection collection)) (completing-read prompt 'tnt-completion-func))) (index 0) (list nil)) (while (and (< index (length str)) (string-match "\\([^,]*\\),?" str index)) (setq list (cons (substring str (match-beginning 1) (match-end 1)) list)) (setq index (match-end 0))) (nreverse list))) (defun tnt-persistent-message (&optional fmt &rest args) ;; Displays a persistent message in the echo area. (save-excursion (set-buffer (get-buffer " *Minibuf-0*")) (erase-buffer) (if fmt (insert (apply 'format fmt args))) (message nil))) (defun tnt-error (&rest args) ;; Displays message in echo area and beeps. Use this instead ;; of (error) for asynchronous errors. (apply 'message args) (beep)) (defvar collection) ; to shut up byte compiler (defun tnt-completion-func (str pred flag) ;; Minibuffer completion function that allows lists of comma-separated ;; items to be entered, with completion applying to each item. Before ;; calling, bind COLLECTION to the collection to be used for completion. (save-excursion (goto-char (point-min)) (re-search-forward " *\\([^,]*\\)$")) (let ((first-part (buffer-substring (point-min) (match-beginning 1))) (last-word (buffer-substring (match-beginning 1) (match-end 1)))) (cond ((eq flag nil) (let ((completion (try-completion last-word collection pred))) (if (stringp completion) (concat first-part completion) completion))) ((eq flag t) (all-completions last-word collection pred))))) ;;;---------------------------------------------------------------------------- ;;; String list utilities ;;;---------------------------------------------------------------------------- (defun tnt-sorted-list-diff (old-list new-list) ;; Compares OLD-LIST and NEW-LIST. Returns a cons of whose car is a ;; list of deletions and whose cdr is a list of insertions. (let ((insert-list nil) (delete-list nil)) (while (or old-list new-list) (let ((old-item (car old-list)) (new-item (car new-list))) (cond ((or (null new-item) (and old-item (string< old-item new-item))) (setq delete-list (cons old-item delete-list)) (setq old-list (cdr old-list))) ((or (null old-item) (and new-item (string< new-item old-item))) (setq insert-list (cons new-item insert-list)) (setq new-list (cdr new-list))) (t (setq new-list (cdr new-list)) (setq old-list (cdr old-list)))))) (cons delete-list insert-list))) (defun tnt-nsort-and-remove-dups (list) ;; Sorts LIST into alphabetical order and removes duplicates. Returns ;; the sorted list. The original list is modified in the process. (setq list (sort list 'string<)) (let ((p list)) (while p (while (and (cdr p) (string= (car p) (car (cdr p)))) (setcdr p (cdr (cdr p)))) (setq p (cdr p)))) list) ;;;---------------------------------------------------------------------------- ;;; String utilities ;;;---------------------------------------------------------------------------- (defun tnt-strip-html (str) ;; Strips all HTML tags out of STR. (let ((start-index 0) end-index (segs nil)) (while (setq end-index (string-match "<[^ ][^>]*>" str start-index)) (setq segs (cons (substring str start-index end-index) segs)) (setq start-index (match-end 0))) (setq segs (cons (substring str start-index) segs)) (apply 'concat (nreverse segs)))) (defun tnt-neliminate-newlines (str) ;; Converts newlines in STR to spaces. Modifies STR. (let ((pos 0) (len (length str))) (while (< pos len) (if (= (aref str pos) ?\n) (aset str pos ? )) (setq pos (1+ pos))) str)) ;;;---------------------------------------------------------------------------- ;;; List utilities ;;;---------------------------------------------------------------------------- (defun tnt-rotate-left (list) ;; Rotates LIST left. (cond (list (setcdr list (nreverse (cdr list))) (nreverse list)))) (defun tnt-rotate-right (list) ;; Rotates LIST right. (nreverse (tnt-rotate-left (nreverse list)))) ;;;---------------------------------------------------------------------------- ;;; Send idle time to TOC server should work in emacs versions 19.31 and up ;;;---------------------------------------------------------------------------- (defvar tnt-debug nil "Print dubugging info from tnt commands") (defun toc-set-idle (sec) ;;; this should really go in toc.el but it's easier to just patch 1 file (tocstr-send (format "toc_set_idle %d" sec))) (defun tnt-set-idle (sec) (if tnt-debug (message "tnt-set-idle %d %d" sec tnt-idle-status)) (cond ((< sec tnt-idle-threshold) (if (and tnt-idle-noisy (>= tnt-idle-status tnt-idle-threshold)) (message "tnt status set to active")) (toc-set-idle 0)) (t (if (and tnt-idle-noisy (< tnt-idle-status tnt-idle-threshold)) (message "tnt status set to idle %d" sec)) (toc-set-idle sec))) (setq tnt-idle-status sec)) (defun tnt-idle-timer-function (sec) (if tnt-debug (message "tnt-idle-timer-function")) (add-hook 'post-command-hook 'tnt-update-active-time) (if (not tnt-compute-idle-timer) (if tnt-compute-idle (setq tnt-compute-idle-timer (run-with-timer 0 sec 'tnt-during-idle-timer-function sec)) (if (= 0 tnt-idle-status) (tnt-set-idle sec))))) (defun tnt-during-idle-timer-function (sec) (let ((computed (funcall tnt-compute-idle))) (if tnt-debug (message "tnt-during-idle-timer-function %d %d" computed (+ sec tnt-idle-status))) (cond ((and computed (<= computed (+ sec tnt-idle-status))) (tnt-set-idle computed)) (t (setq tnt-idle-status (+ sec tnt-idle-status)))))) ; (message "tnt-set-idle %d" sec) ; (let (idle) ; (cond ((= sec 0) ; (if tnt-idle-noisy (message "tnt status set to active")) ; (toc-set-idle 0) ; (setq tnt-idle-status 0)) ; ((and (eq type 'idle) tnt-compute-idle) ; (setq tnt-compute-idle-timer ; (run-with-timer tnt-set-idle-timer ; 0 tnt-idle-threshold 'tnt-set-idle ; tnt-idle-threshold 'compute))) ; ( ; (setq idle (funcall tnt-compute-idle))) ; (add-hook 'post-command-hook 'tnt-update-active-time) ; (message "computed: %d; emacs: %d" idle (+ sec tnt-idle-status)) ; (cond ((< idle (+ sec tnt-idle-status)) ; (toc-set-idle idle) ; (mesage "setting idle to %d" idle) ; (setq tnt-idle-status idle)) ; (t (setq tnt-idle-status (+ sec tnt-idle-status))))) ; ((= 0 tnt-idle-status) ; (add-hook 'post-command-hook 'tnt-update-active-time) ; (if tnt-idle-noisy (message "tnt status set to idle")) ; (toc-set-idle sec) ; (setq tnt-idle-status sec)) ; (t (setq tnt-idle-status (+ sec tnt-idle-status)))))) (defvar tnt-compute-idle 'tnt-compute-idle-time-using-w "Procedure tnt should call to try to compute idle time for terminals, set to nil if you only want emacs' idleness") (defvar tnt-idle-status 0 "True is toc server has been told the user is idle") (defvar tnt-idle-threshold 600 "Number of seconds of idle time before telling server default to 10 minutes since that seems to be how AIM behaves") ;;(setq tnt-idle-threshold 60) (defvar tnt-idle-timer nil) (defvar tnt-compute-idle-timer nil) (defun tnt-update-active-time nil "Set to non-idle and make not run again" (if tnt-debug (message "command hook triggered")) (remove-hook 'post-command-hook 'tnt-update-active-time) (if tnt-compute-idle-timer (cancel-timer tnt-compute-idle-timer)) (setq tnt-compute-idle-timer nil) (tnt-set-idle 0)) (defun tnt-start-idle-timer nil (if tnt-idle-timer (tnt-stop-idle-timer)) (setq tnt-idle-timer (run-with-idle-timer tnt-idle-threshold t 'tnt-idle-timer-function tnt-idle-threshold) tnt-idle-status 0)) (defun tnt-stop-idle-timer nil ;; make sure neither timer is still running (remove-hook 'post-command-hook 'tnt-update-active-time) (cancel-timer tnt-idle-timer) (if tnt-compute-idle-timer (cancel-timer tnt-compute-idle-timer)) (setq tnt-idle-timer nil tnt-compute-idle-timer nil)) (defvar tnt-idle-noisy t "Set to true if a message should appear when idle status changes") ; ;;; (if tocstr-process ... (defun tnt-compute-idle-time-using-w nil "Use finger @localhost to try to determine idle time" (let (col b e idle-time new-t (user (getenv "USER"))) (set-buffer (generate-new-buffer " *tnt-tmp*")) (erase-buffer) ;; (shell-command-on-region 1 1 "finger @localhost" t) (shell-command-on-region 1 1 (concat "w " user) t) (goto-char (point-min)) (if (re-search-forward "[iI][dD][lL][eE]" nil t) (setq col (- (point) (progn (beginning-of-line) (point)))) (error "tnt-compute-idle-time-using-w unexpected output")) ;; (if col (message (format "%d" col))) (while (and col (or (not idle-time) (> idle-time 0)) (progn (beginning-of-line 2) (not (= (point) (point-max))))) (forward-char col) (setq e (point) b (+ 1 (search-backward " "))) (goto-char b) (setq new-t (cond (;;(or (= b e) ;;(string-equal "-" (buffer-substring b e))) 0) ((string-equal (buffer-substring b e) (number-to-string (string-to-number (buffer-substring b e)))) ;; number of minutes (* 60 (string-to-number (buffer-substring b e)))) ((search-forward " " e t) ;; "mm:ss " format on Linux ;; (message "%d" (point)) (goto-char b) (search-forward ":" e t) (+ (* 60 (string-to-number (buffer-substring b (- (point) 1)))) (string-to-number (buffer-substring (point) e)))) ((search-forward ":" e t) ;; hh:mm normal or "h:##m" Linux (* 60 (+ (* 60 (string-to-number (buffer-substring b (- (point) 1)))) (string-to-number (buffer-substring (point) e))))) ((search-forward "d" e t) ;; number of days (* 60 60 24 (string-to-number (buffer-substring b (point))))) ((search-forward "s" e t) ;; #.## number of seconds on Linux (string-to-number (buffer-substring b (point)))) (t (error "tnt-compute-idle-time-using-w unexpected output")))) ;; (message "%d" new-t) (if (or (not idle-time) (< new-t idle-time)) (setq idle-time new-t)) (if tnt-debug (message "%d %d \"%s\" --> %d" b e (buffer-substring b e) new-t))) (kill-buffer (current-buffer)) ;; (message "Idle time: %d" idle-time) idle-time)) ;;(tnt-compute-idle-time-using-w) ;;(defvar t2 nil) ;;(setq t2 (run-with-timer 60 60 'tnt-finger-idle-time)) ;;(cancel-timer t2) (defun tnt-motd ( &optional dismiss) "display text in motd if any, to be run on login" (interactive) (if tnt-motd (progn (switch-to-buffer "*tnt-motd*") (erase-buffer) (insert tnt-motd) (beginning-of-buffer) (not-modified) (view-mode) (message "Hit any q to dismiss buffer...")))) (defun tnt-motd-dismiss nil "Remove the tnt-motd from the screen" ;; (remove-hook 'pre-command-hook 'tnt-motd-dismiss) (remove-hook 'first-change-hook 'tnt-motd-dismiss) (if (eq (current-buffer) (set-buffer "*tnt-motd*")) (bury-buffer))) (setq post-command-hook '()) (defvar tnt-motd "test") (setq tnt-motd " TNT startup motd ---------------- Distribution site: http://www.aim.aol.com/tnt/ Patches: http://www.derf.net/derfware/tnt/ The version in the sipb locker is being maintained by jdaniel@mit.edu. Send bug fixes or requests to that email address. It includes the idle time patch and a lot of changes I have made myself. Commands: C-x t B tnt-edit-buddies C-x t n tnt-next-event C-x t p tnt-prev-event C-x t r tnt-reject C-x t a tnt-accept C-x t b tnt-show-buddies C-x t j tnt-join-chat C-x t i tnt-im C-x t k tnt-kill C-x t o tnt-open C-x t m tnt-motd It is reccommended that you save a copy of your buddy list locally because the server has been known to crash and is not currently backed up. ") (defvar tnt-login-hooks nil "Hooks to run when you log into tnt") (defvar tnt-logout-hooks nil "Hooks to run when you log out of tnt") (add-hook 'tnt-login-hooks 'tnt-start-idle-timer) (add-hook 'tnt-login-hooks 'tnt-motd) (add-hook 'tnt-logout-hooks 'tnt-stop-idle-timer) ;;(tnt-motd)