;;; emchat-log.el --- Logging code for EMchat. ;; Copyright (C) 2002 - 2011 Steve Youngs ;; Author: Steve Youngs ;; Maintainer: Steve Youngs ;; Created: 2002-10-01 ;; Homepage: http://www.emchat.org/ ;; Keywords: comm ICQ ;; This file is part of EMchat. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; ;; Logs incoming and outgoing events in EMchat. (eval-and-compile (defvar emchat-directory nil) (require 'emchat-emphasis) (require 'emchat-curl) (require 'emchat-menu) (require 'emchat-track) (require 'outline)) (eval-when-compile (defvar emchat-history-enabled-flag nil) (defvar emchat-history-directory) (autoload #'smiley-region "smiley" nil t)) (defgroup emchat-log nil "Message logging preferences." :group 'emchat) (defcustom emchat-log-fill-column 0 "Fill column for `emchat-log-buffer'. If this is set to 0 \(zero\), the default, the fill-column in the log buffer is left alone. In other words, default value for fill-column." :type 'integer :group 'emchat-log) (defcustom emchat-log-filename (expand-file-name "log" emchat-directory) "*Pathname and filename for storing emchat log. Automatically created if the directory is non-existent." :type 'file :group 'emchat-log) (defcustom emchat-log-buffer-position-flag 'tail "*Non-nil means automatically updating buffer position. Nil means no automatic update, 'tail means keeping the bottom of the buffer visible, other non-nil means keeping the top of the buffer visible." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-info-flag 'tail "*Non-nil means log misc info. These include any info from ICQ server other than buddy messages, status change notice, and query results. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-buddy-status-flag 'tail "*Non-nil means log buddy status change notice. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-buddy-message-flag 'tail "*Non-nil means log buddy messages from ICQ server. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-outgoing-flag 'tail "*Non-nil means log outgoing messages to ICQ server. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-error-flag 'tail "*Non-nil means log critical error messages. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-debug-flag nil "*Non-nil means log verbose debugging messages. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-system-flag 'tail "*Non-nil means log system messages. These include network status, login status, and others. Nil means no log, 'tail means putting new log at the end of the log buffer, other non-nil means putting new log at the beginning." :group 'emchat-log :type '(choice (item t) (item tail) (item nil))) (defcustom emchat-log-info-mark nil "*Non-nil means mark unread. These include any info from ICQ server other than buddy messages, status change notice, and query results. Nil means mark read." :group 'emchat-log :type 'boolean) (defcustom emchat-log-buddy-status-mark nil "*Non-nil means mark buddy status change notice unread. Nil means mark read." :type 'boolean :group 'emchat-log) (defcustom emchat-log-buddy-message-mark t "*Non-nil means mark buddy messages unread. Nil means mark read." :type 'boolean :group 'emchat-log) (defcustom emchat-log-outgoing-mark nil "*Non-nil means mark outgoing messages unread. Nil means mark read." :group 'emchat-log :type 'boolean) (defcustom emchat-log-error-mark t "*Non-nil means mark critical error messages unread. Nil means mark read." :group 'emchat-log :type 'boolean) (defcustom emchat-log-debug-mark t "*Non-nil means mark verbose debugging messages unread. Nil means mark read." :group 'emchat-log :type 'boolean) (defcustom emchat-log-system-mark nil "*Non-nil means mark system messages unread. Nil means mark read." :group 'emchat-log :type 'boolean) (defcustom emchat-save-log-on-exit-p t "*Non-nil means the log file will be automatically saved when exiting." :group 'emchat-log :type 'boolean :tag "Save log on exit") (defcustom emchat-smiley nil "*Non-nil means smileys are enabled." :group 'emchat-interface :type '(choice (item t) (item nil))) (defcustom emchat-notify-flag t "*Non-nil to send notifications via libnotify. Currently this simply uses `notify-send' shell command." :group 'emchat-log :type 'boolean) (defcustom emchat-notify-events-type 'msg "*What event types to send notifications for. Possible values are: all -- all events \(anything and everything that is logged\). incoming -- only incoming messages plus system and debug events. This would include friends status changes. msg -- incoming user messages only \(default\). nil -- no events." :group 'emchat-log :type '(choice (item :tag "All Events" all) (item :tag "Incoming msg + sys + debug events" incoming) (item :tag "Incoming user messages" msg) (item :tag "Nothing" nil))) (defcustom emchat-notify-command (executable-find "notify-send") "*The shell command used to send notifications." :group 'emchat-log :type 'string) ;;; Internal variables (defvar emchat-log-buffer nil "Buffer for log.") (defconst emchat-log-entry-re "[SMTWRFA][0-9][0-9]:[0-9][0-9]" "Regular expression matching the beginning of a log entry.") (defvar emchat-log-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?~ "w " table) (modify-syntax-entry ?` "w " table) (modify-syntax-entry ?! "w " table) (modify-syntax-entry ?@ "w " table) (modify-syntax-entry ?# "w " table) (modify-syntax-entry ?$ "w " table) (modify-syntax-entry ?% "w " table) (modify-syntax-entry ?^ "w " table) (modify-syntax-entry ?& "w " table) (modify-syntax-entry ?( "w " table) (modify-syntax-entry ?) "w " table) (modify-syntax-entry ?- "w " table) (modify-syntax-entry ?+ "w " table) (modify-syntax-entry ?= "w " table) (modify-syntax-entry ?{ "w " table) (modify-syntax-entry ?[ "w " table) (modify-syntax-entry ?} "w " table) (modify-syntax-entry ?] "w " table) (modify-syntax-entry ?\\ "w " table) (modify-syntax-entry ?| "w " table) (modify-syntax-entry ?: "w " table) (modify-syntax-entry ?\; "w " table) (modify-syntax-entry ?\" "w " table) (modify-syntax-entry ?' "w " table) (modify-syntax-entry ?< "w " table) (modify-syntax-entry ?, "w " table) (modify-syntax-entry ?> "w " table) (modify-syntax-entry ?. "w " table) (modify-syntax-entry ?\? "w " table) table) "Syntax table used while in `emchat-log-mode'.") (defun emchat-log-update-modeline () (let ((invisible emchat-user-meta-invisible)) (if invisible (setq modeline-buffer-identification (list (cons modeline-buffer-id-left-extent (cons 10 (list "[" 'emchat-user-alias "]: "))) (cons modeline-buffer-id-right-extent (cons 1 (list "<" 'emchat-user-status 'emchat-user-meta-invisibility-indicator ">"))))) (setq modeline-buffer-identification (list (cons modeline-buffer-id-left-extent (cons 10 (list "[" 'emchat-user-alias "]: "))) (cons modeline-buffer-id-right-extent (cons 1 (list "<" 'emchat-user-status ">")))))))) (defun emchat-log-mode () "Major mode for logging messages in emchat. Commands: \\{emchat-log-mode-map} Turning on `emchat-log-mode' runs the hook `emchat-log-mode-hook'." (interactive) (kill-all-local-variables) (use-local-map emchat-log-mode-map) (setq mode-name "emchat-log") (setq major-mode 'emchat-log-mode) ;; put easy-menu-add after set mode-name (easy-menu-add emchat-main-easymenu) (easy-menu-add emchat-buddy-menu) (easy-menu-add emchat-log-menu) (unless (zerop emchat-log-fill-column) (setq fill-column emchat-log-fill-column)) ;; No menubar from outline mode. (let ((features (remove 'menubar features))) (outline-minor-mode)) (set (make-local-variable 'outline-regexp) (concat emchat-log-entry-re " ")) (emchat-log-update-modeline) ;; Use our syntax-table (set-syntax-table emchat-log-mode-syntax-table) (run-hooks 'emchat-log-mode-hook)) (defvar emchat-log-logo (expand-file-name "logo.png" emchat-glyph-dir) "The logo used at the top of a new log buffer.") (defvar emchat-log-header (expand-file-name "log-header.xbm" emchat-glyph-dir) "The intro at the top of a new log buffer.") ;;;###autoload (defun emchat-log-show-buffer (&optional new no-select) "Switch to `emchat-log-buffer'. Create buffer with log file if buffer does not exists already. Non-nil NEW means rotate and create a new log file. Non-nil NO-SELECT means don't select log window. See `emchat-log-filename'." (interactive) (when new ;; save and close current log first if any (setq emchat-log-buffer (find-buffer-visiting emchat-log-filename)) (if emchat-log-buffer (with-current-buffer emchat-log-buffer (save-buffer) (kill-buffer nil))) ;; rename old log in disk (if (file-exists-p emchat-log-filename) (rename-file emchat-log-filename (concat emchat-log-filename ;; in case you do something stupid with it (format-time-string "-%Y-%b%d-%H%M-%S"))))) (unless (buffer-live-p emchat-log-buffer) (setq emchat-log-buffer (find-file-noselect emchat-log-filename)) (with-current-buffer emchat-log-buffer (emchat-log-mode) (when (zerop (buffer-size)) (if (and (device-on-window-system-p) (featurep '(and png xbm))) (progn (insert "\n") (let ((ext (make-extent (point) (point)))) (set-extent-begin-glyph ext (make-glyph `([png :file ,emchat-log-logo]))) (set-extent-end-glyph ext (make-glyph `([xbm :file ,emchat-log-header]))) (insert "\n\n"))) (insert "===========================================\n" "Welcome to EMchat - The (S)XEmacs IM Client\n\n" "If you like this software, please consider\n" " \'M-x emchat-donation RET\'\n" "===========================================\n\n"))))) (unless no-select (switch-to-buffer emchat-log-buffer))) (defun emchat-log-new-file () "Rotate and create a new log file." (interactive) (emchat-log-show-buffer 'new)) (defun emchat-log-update-history (id message weekday) "Updates the history for ID, with MESSAGE. WEEKDAY is an array of 7 characters indicating a day of the week for the timestamp." (when (and (member id emchat-visible-contacts) (not (member id emchat-invisible-contacts)) (not (search "***|" message))) (let ((hfile (emchat-world-getf id 'history))) (save-excursion (with-current-buffer (find-file-noselect hfile 'nowarn) (when buffer-read-only (toggle-read-only)) (goto-char (point-max)) (insert (format-time-string "%e %b ") (aref weekday (string-to-number (format-time-string "%w"))) (format-time-string "%R ") (format "[%s] %s" id message)) (let ((beg (point-at-bol))) (fill-region beg (point-max)))))))) (defun emchat-log-update-tracker (id message) "Update the EMchat track modeline indicator. ID is the entity that sent MESSAGE." (unless (get 'emchat-track 'initialized) (emchat-track-init)) (and (not (get-buffer-window emchat-log-buffer)) (ecase emchat-track-events-type (all (emchat-track-add-nick id)) (incoming (and (not (search ">>>" message)) ; XXX (not (search "***|" message)) ; XXX (emchat-track-add-nick id))) (msg (and (not (equal id "!debug")) ; XXX (not (equal id "!error")) ; XXX (not (equal id "!system")) ; XXX (not (search ">>>" message)) ; XXX (not (search "***|" message)) ; XXX (emchat-track-add-nick id)))))) (defun emchat-log-update-balloon (id) "Update the balloon-help extent property for ID." (save-excursion (search-backward id) (let* ((exp (extent-at (point))) (bhelp (format "%s (%s)\n Status: %s\n Groups: %s\nHistory: %s\n\n\n" id (emchat-alias-uin id) (or (emchat-world-getf id 'status) "offline") (or (emchat-world-getf id 'group) "none") (or (emchat-world-getf id 'history) "none"))) (face (emchat-status-face (emchat-world-getf id 'status)))) (when (extentp exp) (set-extent-property exp 'face face) (set-extent-property exp 'balloon-help bhelp))))) (defun emchat-notify (id message) "Send a notification about MESSAGE from ID." (let ((notify emchat-notify-command) (icon (expand-file-name "emchat-icon.png" emchat-glyph-dir)) (urgency "normal")) (when notify (unless (eq (selected-frame) emchat-frame) (ecase emchat-notify-events-type (all (call-process notify nil nil nil "-i" icon "-u" urgency (format "New Message From: %s" id) message)) (incoming (and (not (search ">>>" message)) (not (search "***|" message)) (call-process notify nil nil nil "-i" icon "-u" urgency (format "New Message From: %s" id) message))) (msg (and (not (equal id "!debug")) (not (equal id "!error")) (not (equal id "!system")) (not (search ">>>" message)) (not (search "***|" message)) (call-process notify nil nil nil "-i" icon "-u" urgency (format "New Message From: %s" id) message)))))))) (defun emchat-log (id message option mark-unread) "Log message under ID. Put MESSAGE at the end of log buffer if OPTION is non-nil. Mark MESSAGE unread if MARK-UNREAD is non-nil" (if (and option (buffer-live-p emchat-log-buffer)) (with-current-buffer emchat-log-buffer (save-excursion (let ((start-point (if (eq option 'tail) (point-max) (point-min))) (weekday ["S" "M" "T" "W" "R" "F" "A"]) ;; to fill messages correctly (paragraph-start "")) (goto-char start-point) (insert (aref weekday (string-to-number (format-time-string "%w"))) (format-time-string "%R ") ;; use concat instead of format for extent (concat "[" id "] " message "\n")) (fill-region start-point (point)) (when emchat-notify-flag (emchat-notify id message)) (when emchat-history-enabled-flag (emchat-log-update-history id message weekday)) (when emchat-track-enable (emchat-log-update-tracker id message)) (when (member id emchat-all-aliases) (emchat-log-update-balloon id)) (when emchat-smiley (smiley-region start-point (point))) (when emchat-emphasis-enabled-flag (emchat-emphasis-treat-message start-point (point))) (emchat-emphasis-hyperlink-message start-point (point)) (goto-char start-point) (if mark-unread (emchat-log-mark-unread) (emchat-log-mark-read)))) (if emchat-log-buffer-position-flag (if (eq emchat-log-buffer-position-flag 'tail) (progn (goto-char (point-max)) (re-search-backward (concat "^" emchat-log-entry-re " "))) (progn (goto-char (point-min)) (re-search-forward (concat "^" emchat-log-entry-re " ")))))))) (defun emchat-log-info (&rest messages) "See `emchat-log-info-flag'. MESSAGES is an argument list for `format' to be inserted." (emchat-log "!info" (apply 'format messages) emchat-log-info-flag emchat-log-info-mark)) (defun emchat-log-buddy-status (alias &rest messages) "See `emchat-log-buddy-status-flag'. ALIAS is an id to be logged under. MESSAGES is an argument list for `format' to be inserted." (emchat-log alias (apply 'format messages) emchat-log-buddy-status-flag emchat-log-buddy-status-mark)) (defun emchat-log-buddy-message (alias fmt &rest fmt-messages) "See `emchat-log-buddy-message-flag'. ALIAS is an id to be logged under. FMT is message format, passed directly to `format'. FMT-MESSAGES are arguments for `format'." (emchat-log alias (apply 'format fmt fmt-messages) emchat-log-buddy-message-flag emchat-log-buddy-message-mark)) (defun emchat-log-buddy-url (alias message url) "See `emchat-log-buddy-message-flag'. ALIAS is an id MESSAGE to be logged under. URL will be highlighted." ;; idea from Erik Arneson (set-extent-properties (make-extent 0 (length url) url) `(highlight t duplicable t keymap ,emchat-hyperlink-map balloon-help "Mouse button2 -- Follow this link." face ,widget-button-face)) (emchat-log alias (concat message "\nURL: " url) emchat-log-buddy-message-flag emchat-log-buddy-message-mark)) (defun emchat-log-outgoing (alias &rest messages) "See `emchat-log-outgoing-flag'. ALIAS is an id to be logged under. MESSAGES is an argument list for `format' to be inserted." (emchat-log alias (apply 'format messages) emchat-log-outgoing-flag emchat-log-outgoing-mark)) (defun emchat-log-error (&rest messages) "See `emchat-log-error-flag'. MESSAGES is an argument list for `format' to be inserted." (emchat-log "!error" (apply 'format messages) emchat-log-error-flag emchat-log-error-mark)) (defun emchat-log-debug (&rest messages) "See `emchat-log-debug-flag'. MESSAGES is an argument list for `format' to be inserted." (emchat-log "!debug" (apply 'format messages) emchat-log-debug-flag emchat-log-debug-mark)) (defun emchat-log-system (&rest messages) "See `emchat-log-system-flag'. MESSAGES is an argument list for `format' to be inserted." (emchat-log "!system" (apply 'format messages) emchat-log-system-flag emchat-log-system-mark) (run-hooks 'emchat-system-message-hook)) (defface emchat-face-log-unread '((((background dark)) (:foreground "red")) (((background light)) (:foreground "red4" :bold t))) "Face for unread log messages." :group 'emchat-log) (defface emchat-face-log-read '((((background dark)) (:foreground "turquoise")) (((background light)) (:foreground "steelblue"))) "Face for read log messages." :group 'emchat-log) (defvar emchat-log-mark-alist '((unread . emchat-face-log-unread) (read . emchat-face-log-read)) "Alist of log message marks and their colors.") (defun emchat-log-mark (&optional mark) "Mark log message around point using MARK. Possible MARK: 'read, 'unread, 'toggle. Nil MARK means 'read. See `emchat-face-log-unread' and `emchat-face-log-read'." (save-excursion ;; so that we can mark current line even at bol (end-of-line) (let ((len 8) (p (search-backward-regexp (concat "^" emchat-log-entry-re " ") nil t)) (face (cdr (assoc mark emchat-log-mark-alist)))) (if p (add-text-properties p (+ len p -2) (list 'face face 'start-open t)))))) (defun emchat-log-mark-region (start end &optional mark) "Mark all log messages in the region. MARK is any mark in `emchat-log-mark'." (interactive "r") (save-excursion (goto-char start) ;; Due to bad design of outline.el, we use condition-case to guard ;; against error when advancing at the end of buffer. (condition-case nil (while (<= (point) end) (emchat-log-mark mark) (emchat-log-next 1)) (error nil)))) (defun emchat-log-mark-unread (&optional mark-region) "Mark log message around point as unread. Non-nil MARK-REGION or prefix argument means marks all log in the region." (interactive "P") (if mark-region (emchat-log-mark-region (region-beginning) (region-end) 'unread) (emchat-log-mark 'unread))) (defun emchat-log-mark-read (&optional mark-region) "Mark log message around point as read. Non-nil MARK-REGION or prefix argument means marks all log in the region." (interactive "P") (if mark-region (emchat-log-mark-region (region-beginning) (region-end) 'read) (emchat-log-mark 'read)) (if (interactive-p) (run-hooks 'emchat-read-message-hook))) (defun emchat-log-around () "Return the log message around. If called interactively, display and push log into `kill-ring'." (interactive) (let* ((log-start (save-excursion (outline-back-to-heading) (search-forward "] " nil t) (point))) (log-end (or (save-excursion (condition-case nil (outline-get-next-sibling) (error nil))) (point-max))) (log (buffer-substring log-start log-end))) (when (interactive-p) (message log) (kill-new log)) log)) (defalias 'emchat-log-contract 'hide-subtree) (defalias 'emchat-log-expand 'show-subtree) (defalias 'emchat-log-previous 'outline-backward-same-level) (defalias 'emchat-log-next 'outline-forward-same-level) (defun emchat-log-next-unread () "Moves point to the next unread message. Does nothing if there are no unread messages after point." (interactive) (let ((here (point))) (goto-char (catch 'where (progn (while (not (eq here (point-max))) ; mildly bogus target (let ((next (next-single-property-change here 'face))) (unless next (throw 'where (point))) (if (eq (get-text-property next 'face) (cdr (assoc 'unread emchat-log-mark-alist))) (throw 'where next) (setq here next))))))))) (defun emchat-log-previous-unread () "Moves point to the previous unread message. Does nothing if there are no unread messages after point." (interactive) (let ((here (point))) (goto-char (catch 'where (progn (while (not (eq here (point-max))) ; mildly bogus target (let ((prev (previous-single-property-change here 'face))) (unless prev (throw 'where (point))) (if (eq (get-text-property prev 'face) (cdr (assoc 'unread emchat-log-mark-alist))) (throw 'where prev) (setq here prev))))))))) (provide 'emchat-log) ;;; emchat-log.el ends here