cgit.sxemacs.org Git - emchat/blob - emchat-status.el

   1 ;;; emchat-status.el --- Status code for EMchat
   2
   3 ;; Copyright (C) 2002 - 2011 Steve Youngs
   4
   5 ;; Author:        Steve Youngs <steve@emchat.org>
   6 ;; Maintainer:    Steve Youngs <steve@emchat.org>
   7 ;; Created:       2002-10-02
   8 ;; Homepage:      http://www.emchat.org/
   9 ;; Keywords:      comm ICQ
  10
  11 ;; This file is part of EMchat.
  12
  13 ;; Redistribution and use in source and binary forms, with or without
  14 ;; modification, are permitted provided that the following conditions
  15 ;; are met:
  16 ;;
  17 ;; 1. Redistributions of source code must retain the above copyright
  18 ;;    notice, this list of conditions and the following disclaimer.
  19 ;;
  20 ;; 2. Redistributions in binary form must reproduce the above copyright
  21 ;;    notice, this list of conditions and the following disclaimer in the
  22 ;;    documentation and/or other materials provided with the distribution.
  23 ;;
  24 ;; 3. Neither the name of the author nor the names of any contributors
  25 ;;    may be used to endorse or promote products derived from this
  26 ;;    software without specific prior written permission.
  27 ;;
  28 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  29 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  32 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  33 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  34 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  35 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  36 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  37 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  38 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39
  40 (eval-and-compile
  41   (require 'emchat-log)
  42   (require 'emchat-world)
  43   (require 'emchat-meta)
  44   (require 'emchat)
  45   (require 'wid-edit))
  46
  47 (eval-when-compile
  48   (defvar emchat-buddy-view)
  49   (defvar emchat-wharf-frame-use-p))
  50
  51 (autoload 'emchat-buddy-update-face "emchat-buddy")
  52
  53
  54 (defcustom emchat-buddy-status-color-hint-flag t
  55   "*Non-nil means put status color hints."
  56   :type 'boolean
  57   :group 'emchat-buddy)
  58
  59 ;;;###autoload
  60 (defcustom emchat-status-window-height 8
  61   "*Height of window for `emchat-status-buffer'."
  62   :group 'emchat-interface)
  63
  64 (defcustom emchat-status-use-gutter nil
  65   "*When non-nil, display statuses in the gutter, not in a buffer."
  66   :type 'boolean
  67   :group 'emchat-interface)
  68
  69 (defcustom emchat-status-gutter-orientation 'top
  70   "Where to display the status gutter.
  71
  72 Valid values are: top, bottom, left, right."
  73   :type '(choice (item :tag "Top" :value top)
  74                  (item :tag "Bottom" :value bottom)
  75                  (item :tag "Left" :value left)
  76                  (item :tag "Right" :value right))
  77   :group 'emchat-interface)
  78
  79 ;;;###autoload
  80 (defvar emchat-valid-statuses
  81   '("online" "away" "occ" "dnd" "ffc" "na")
  82   "All statuses valid for selection.
  83 Used by `emchat-change-status' and in `emchat-buddy-buffer'.")
  84
  85 ;;;###autoload
  86 (defcustom emchat-user-initial-status "online"
  87   "*Initial user status when login."
  88   :group 'emchat-option
  89   :type
  90   (cons 'choice
  91         (mapcar
  92          (lambda (x) (list 'item x))
  93          emchat-valid-statuses)))
  94
  95 (defcustom emchat-status-update-hook nil
  96   "*Hooks to run when a buddy change his status.
  97 Dynamically ALIAS and STATUS are binded to be used in hooks."
  98   :group 'emchat-option
  99   :type 'hook)
 100
 101 (defface emchat-face-online
 102   '((((background dark))
 103      (:foreground "green"))
 104     (((background light))
 105      (:foreground "green4")))
 106   "Face for ONLINE status."
 107   :group 'emchat-buddy)
 108
 109 (defface emchat-face-away
 110   '((((background dark))
 111      (:foreground "red"))
 112     (((background light))
 113      (:foreground "red4")))
 114   "Face for AWAY status."
 115   :group 'emchat-buddy)
 116
 117 (defface emchat-face-occ
 118   '((((background dark))
 119      (:foreground "orange"))
 120     (((background light))
 121      (:foreground "orange4")))
 122   "Face for OCCUPIED status."
 123   :group 'emchat-buddy)
 124
 125 (defface emchat-face-dnd
 126   '((((background dark))
 127      (:foreground "lightblue"))
 128     (((background light))
 129      (:foreground "blue")))
 130   "Face for DO NOT DISTURB status."
 131   :group 'emchat-buddy)
 132
 133 (defface emchat-face-ffc
 134   '((((background dark))
 135      (:foreground "yellow"))
 136     (((background light))
 137      (:foreground "yellow4")))
 138   "Face for FREE FOR CHAT status."
 139   :group 'emchat-buddy)
 140
 141 (defface emchat-face-na
 142   '((((background dark))
 143      (:foreground "pink"))
 144     (((background light))
 145      (:foreground "deeppink")))
 146   "Face for NOT AVAILABLE status."
 147   :group 'emchat-buddy)
 148
 149 (defface emchat-face-invisible
 150   '((((background dark))
 151      (:foreground "grey"))
 152     (((background light))
 153      (:foreground "grey40")))
 154   "Face for OFFLINE status."
 155   :group 'emchat-buddy)
 156
 157 ;;; Internal variables
 158
 159 (defvar emchat-statuses
 160   ;; basically status is only ONE byte (except for invisible?)
 161   ;; byte after status byte is random
 162   '((online "online" emchat-face-online)
 163     (away "away" emchat-face-away emchat-auto-reply-away)
 164     (na "na" emchat-face-na emchat-auto-reply-na)
 165     (occupied "occ" emchat-face-occ emchat-auto-reply-occ)
 166     (dnd "dnd" emchat-face-dnd emchat-auto-reply-dnd)
 167     (ffc "ffc" emchat-face-ffc)
 168     (offline "offline" nil)
 169     (invisible "invisible" emchat-face-invisible))
 170   "Status info: v8 status, text code, face, auto-reply.")
 171
 172 (defun emchat-status-face (name)
 173   "Return the face of status from its NAME."
 174   (caddar
 175    (member* name emchat-statuses
 176             :key 'second
 177             :test 'string=)))
 178
 179 (defun emchat-status-v8 (name)
 180   "Return the symbol for status NAME."
 181   (caar
 182    (member* name emchat-statuses
 183             :key 'second
 184             :test 'string=)))
 185
 186 (defun emchat-status-auto-reply (name)
 187   "Return the symbol of auto-reply of status from its NAME."
 188   (fourth (car
 189            (member* name emchat-statuses
 190             :key 'second
 191             :test 'string=))))
 192
 193 (defun emchat-status-idle-reply (name)
 194   "Return the symbol of idle-reply of status from its NAME."
 195   (let ((sym (emchat-status-auto-reply name)))
 196     (with-temp-buffer
 197       (insert (symbol-name sym))
 198       (while (search-backward "auto" nil t)
 199         (replace-match "idle" nil t))
 200       (intern (buffer-string)))))
 201
 202 (defun emchat-status-name (proto-status)
 203   "Return the name of status from its the binary string BIN."
 204   (cadr (assoc proto-status emchat-statuses)))
 205
 206 (defun emchat-buddy-update-status (alias status)
 207   "Update ALIAS with new STATUS."
 208   ;; update alias variables
 209   (unless (member status (mapcar 'second emchat-statuses))
 210     (push (cons 'unknown-status emchat-recent-packet)
 211           emchat-error-packets)
 212     (emchat-log-error "Unknown status: %s" status)
 213     (setq status "online"))             ; assumed online
 214
 215   ;; kludge-o-matic
 216   (when (and (equal alias emchat-user-alias)
 217              (string= status "invisible"))
 218     (setq status emchat-user-status))
 219
 220   (unless (emchat-world-getf alias 'status)
 221     (emchat-world-putf alias 'status "offline"))
 222
 223   (unless (equal status (emchat-world-getf alias 'status))
 224     (emchat-world-putf alias 'status status)
 225     (emchat-log-buddy-status alias "***| %s" status)
 226     (when (string= status "online")
 227       (emchat-play-sound-maybe 'buddy-sound))
 228     (if (string= status "offline")
 229         (if (member alias emchat-connected-aliases)
 230             (setq emchat-connected-aliases
 231                   (delete alias emchat-connected-aliases))
 232           (emchat-log-buddy-status alias "***| has been invisible"))
 233       ;; if not offline
 234       (add-to-list 'emchat-connected-aliases alias))
 235
 236     ;; update buffer
 237
 238     ;; view != all + offline -> delete
 239     ;; view = all + offline -> offline-face
 240     (if (and (string= status "offline")
 241              (not (eq emchat-buddy-view 'emchat-all-aliases)))
 242         (emchat-buddy-update-face alias 'delete)
 243       (if (or (member alias (symbol-value emchat-buddy-view))
 244               (string= status "offline"))
 245           (emchat-buddy-update-face alias)))))
 246
 247 ;;;###autoload
 248 (defvar emchat-user-status "offline"
 249   "Current user status.")
 250
 251 (defun emchat-do-status-update (ectx uin status)
 252   "Handle server command 01a4 in PACKET."
 253   (let ((alias (emchat-uin-alias (emchat-stringular-uin uin)))
 254         (status (emchat-status-name status)))
 255     (emchat-buddy-update-status alias status)
 256     (run-hooks 'emchat-status-update-hook)))
 257
 258 (defun emchat-turn-on-invisibility ()
 259   (emchat-v8-snac-cli-setstatus
 260    emchat-ctx (append (list (emchat-status-v8 emchat-user-status))
 261                     (and emchat-user-meta-web-aware '(web-aware))
 262                     '(invisible)))
 263   (emchat-log-buddy-status emchat-user-alias "***| %s (invisible)" emchat-user-status)
 264   (setq emchat-user-meta-invisible t))
 265
 266 (defun emchat-turn-off-invisibility ()
 267   (emchat-v8-snac-cli-setstatus
 268    emchat-ctx (append (list (emchat-status-v8 emchat-user-status))
 269                     (and emchat-user-meta-web-aware '(web-aware))))
 270   (emchat-log-buddy-status emchat-user-alias "***| %s (visible)" emchat-user-status)
 271   (setq emchat-user-meta-invisible nil))
 272
 273 (defun emchat-toggle-invisibility ()
 274   "Toggle \"invisible\" status."
 275   (interactive)
 276   (setq emchat-user-meta-invisible (null emchat-user-meta-invisible))
 277   (if emchat-user-meta-invisible
 278       (emchat-turn-on-invisibility)
 279     (emchat-turn-off-invisibility))
 280   (with-current-buffer emchat-log-buffer
 281     (emchat-log-update-modeline)))
 282
 283 (defun emchat-change-status (status &optional no-network)
 284   "Change to new STATUS.
 285 Non-nil NO-NETWORK means not to send any network packet, only update
 286 variable and modeline."
 287   (interactive
 288    (list (emchat-completing-read "status: " emchat-valid-statuses nil t)))
 289   (unless (equal status emchat-user-status)
 290     (when emchat-user-auto-away-p
 291       (setq emchat-user-auto-away-p nil))
 292     (emchat-log-system "Changed status to %s" status)
 293     (when (equal status "online")
 294       (setq emchat-auto-reply-never emchat-auto-response-never-send-to)
 295       (loop for alias in emchat-online-notifiers
 296         do (emchat-v8-send-simple-message
 297             emchat-ctx (emchat-numeric-uin (emchat-alias-uin alias))
 298             "I'm back online.
 299 You won't be notified again unless you re-request
 300 it with \",,notify-me\".")
 301         do (emchat-log-system (format "Online notification sent to: %s" alias)))
 302       (setq emchat-online-notifiers nil))
 303     (setq emchat-user-status status)
 304     (when emchat-wharf-frame-use-p
 305       (declare-fboundp (emchat-wharf-update-status)))
 306     (redraw-modeline 'all)
 307     (unless no-network
 308       (emchat-v8-snac-cli-setstatus
 309        emchat-ctx (append (list (emchat-status-v8 status))
 310                         (and emchat-user-meta-web-aware '(web-aware))
 311                         (and emchat-user-meta-invisible '(invisible)))))))
 312
 313 ;;;###autoload
 314 (defvar emchat-status-buffer nil
 315   "Buffer for statuses.")
 316
 317 ;;;###autoload
 318 (defun emchat-status-show-buffer (&optional new no-select)
 319   "Switch to `emchat-status-buffer'.
 320 Create buffer if buffer does not exists already or
 321 NEW is non-nil.
 322 Don't select status window if NO-SELECT is non-nil."
 323   (interactive)
 324   (when (or (not (buffer-live-p emchat-status-buffer))
 325             new)
 326     (setq emchat-status-buffer (get-buffer-create "*Status*"))
 327     (set-buffer emchat-status-buffer)
 328     (set-specifier horizontal-scrollbar-visible-p nil
 329                    (cons (current-buffer) nil))
 330     (set-specifier vertical-scrollbar-visible-p nil
 331                    (cons (current-buffer) nil))
 332     (set-specifier has-modeline-p nil
 333                    (cons (current-buffer) nil))
 334     (erase-buffer)
 335     (set (make-local-variable 'widget-button-face) 'emchat-face-online)
 336     (widget-create 'link
 337                    :help-echo "Change status to \"Online\""
 338                    :action (lambda (&rest ignore)
 339                              (emchat-change-status "online"))
 340                    "Online")
 341     (widget-insert "\n")
 342     (set (make-local-variable 'widget-button-face) 'emchat-face-away)
 343     (widget-create 'link
 344                    :help-echo "Change status to \"Away\""
 345                    :action (lambda (&rest ignore)
 346                              (emchat-change-status "away"))
 347                    "Away")
 348     (widget-insert "\n")
 349     (set (make-local-variable 'widget-button-face) 'emchat-face-occ)
 350     (widget-create 'link
 351                    :help-echo "Change status to \"Occupied\""
 352                    :action (lambda (&rest ignore)
 353                              (emchat-change-status "occ"))
 354                    "Occupied")
 355     (widget-insert "\n")
 356     (set (make-local-variable 'widget-button-face) 'emchat-face-dnd)
 357     (widget-create 'link
 358                    :help-echo "Change status to \"Do Not Disturb\""
 359                    :action (lambda (&rest ignore)
 360                              (emchat-change-status "dnd"))
 361                    "Do Not Disturb")
 362     (widget-insert "\n")
 363     (set (make-local-variable 'widget-button-face) 'emchat-face-na)
 364     (widget-create 'link
 365                    :help-echo "Change status to \"Not Available\""
 366                    :action (lambda (&rest ignore)
 367                              (emchat-change-status "na"))
 368                    "Not Available")
 369     (widget-insert "\n")
 370     (set (make-local-variable 'widget-button-face) 'emchat-face-ffc)
 371     (widget-create 'link
 372                    :help-echo "Change status to \"Free For Chat\""
 373                    :action (lambda (&rest ignore)
 374                              (emchat-change-status "ffc"))
 375                    "Free For Chat")
 376     (widget-insert "\n")
 377     (set (make-local-variable 'widget-button-face) 'emchat-face-invisible)
 378     (widget-create 'link
 379                    :help-echo "Toggle your visibility"
 380                    :action (lambda (&rest ignore)
 381                              (emchat-toggle-invisibility))
 382                    "Invisible on/off")
 383     (toggle-read-only 1)
 384     (unless no-select
 385       (switch-to-buffer emchat-status-buffer))))
 386
 387 ;;; Status gutter
 388 ;;; WARNING: This is experimental and unfinished.
 389 (defvar emchat-status-gutter-tab nil
 390   "A tab widget in the gutter for switching online statuses.
 391 Do not set this.  Use `set-glyph-image' to change the properties of
 392 the tab.")
 393
 394 (defun emchat-status-maybe-login ()
 395   "Convenience function for the status gutter.
 396 If a connection to the ICQ server exists, just change status to
 397 online, otherwise login."
 398   (if (emchat-connected-p emchat-ctx)
 399       (emchat-change-status "online")
 400     (emchat-login)))
 401
 402 (defvar emchat-status-tabs
 403   '(["Online" (emchat-status-maybe-login)
 404      :selected (equal emchat-user-status "online")]
 405     ["Away" (emchat-change-status "away")
 406      :selected (equal emchat-user-status "away")]
 407     ["Occupied" (emchat-change-status "occ")
 408      :selected (equal emchat-user-status "occ")]
 409     ["Do Not Disturb" (emchat-change-status "dnd")
 410      :selected (equal emchat-user-status "dnd")]
 411     ["Not Available" (emchat-change-status "na")
 412      :selected (equal emchat-user-status "na")]
 413     ["FFC" (emchat-change-status "ffc")
 414      :selected (equal emchat-user-status "ffc")]
 415     ["Inv on/off" (emchat-toggle-invisibility) :selected nil]
 416     ["Offline" (emchat-logout)
 417      :selected (equal emchat-user-status "offline")])
 418   "Buttons for the EMchat status gutter.")
 419
 420 ;;; FIXME: Left and right gutters are broken, also, I don't like
 421 ;;; setting `default-gutter-position' to change the orientation
 422 ;;; although the docs seem to suggest that this is the only way to
 423 ;;; do it...
 424 ;;   ,----[ C-h v right-gutter RET ]
 425 ;;   | `right-gutter' is a built-in constant specifier variable.
 426 ;;   |
 427 ;;   | Value: #<gutter-specifier global=<unspecified> fallback=((nil)) 0x145>
 428 ;;   |
 429 ;;   | Documentation:
 430 ;;   | Specifier for the gutter at the right edge of the frame.
 431 ;;   | Use `set-specifier' to change this.
 432 ;;   | See `default-gutter' for a description of a valid gutter instantiator.
 433 ;;   |
 434 ;;   | Note that, unless the `default-gutter-position' is `right', by
 435 ;;   | default the height of the right gutter (controlled by
 436 ;;   | `right-gutter-width') is 0; thus, a right gutter will not be
 437 ;;   | displayed even if you provide a value for `right-gutter'.
 438 ;;   `----
 439
 440 (defun emchat-add-tab-to-gutter ()
 441   (let* ((gutter-string (copy-sequence "\n"))
 442          (status-gutter-extent (make-extent 0 1 gutter-string)))
 443     (set-extent-begin-glyph status-gutter-extent
 444                             (setq emchat-status-gutter-tab
 445                                   (make-glyph)))
 446     (mapcar
 447      (lambda (x)
 448        (remove-gutter-element top-gutter 'status-tab emchat-frame x)
 449        (remove-gutter-element bottom-gutter 'status-tab emchat-frame x)
 450        (remove-gutter-element left-gutter 'status-tab emchat-frame x)
 451        (remove-gutter-element right-gutter 'status-tab emchat-frame x))
 452      (console-type-list))
 453     (mapcar
 454      (lambda (x)
 455        (when (valid-image-instantiator-format-p 'tab-control x)
 456          (cond ((eq emchat-status-gutter-orientation 'top)
 457                 (set-default-gutter-position 'top)
 458                 (set-specifier top-gutter-visible-p t emchat-frame x)
 459                 (set-specifier top-gutter-border-width 0 emchat-frame x)
 460                 (set-gutter-element top-gutter 'status-tab
 461                                     gutter-string emchat-frame x))
 462                ((eq emchat-status-gutter-orientation 'bottom)
 463                 (set-default-gutter-position 'bottom)
 464                 (set-specifier bottom-gutter-visible-p t emchat-frame x)
 465                 (set-specifier bottom-gutter-border-width 0 emchat-frame x)
 466                 (set-gutter-element bottom-gutter 'status-tab
 467                                     gutter-string emchat-frame x))
 468                ((eq emchat-status-gutter-orientation 'left)
 469                 (set-default-gutter-position 'left)
 470                 (set-specifier left-gutter-visible-p t emchat-frame x)
 471                 (set-specifier left-gutter-border-width 0 emchat-frame x)
 472                 (set-gutter-element left-gutter 'status-tab
 473                                     gutter-string emchat-frame x))
 474                ((eq emchat-status-gutter-orientation 'right)
 475                 (set-default-gutter-position 'right)
 476                 (set-specifier right-gutter-visible-p t emchat-frame x)
 477                 (set-specifier right-gutter-border-width 0 emchat-frame x)
 478                 (set-gutter-element right-gutter 'status-tab
 479                                     gutter-string emchat-frame x)))))
 480      (console-type-list))))
 481
 482 ;;; FIXME: When the gutter code in (S)XEmacs can put different faces
 483 ;;; on different buttons update this so that the status tabs have the
 484 ;;; right faces... emchat-face-{online,away,na,occ,dnd,ffc,invisible}.
 485 (defun emchat-update-tab-in-gutter ()
 486   "Update the tab control in the gutter area."
 487   (unless (or (window-dedicated-p (frame-selected-window emchat-frame))
 488               (frame-property emchat-frame 'popup))
 489     (emchat-add-tab-to-gutter)
 490     (when (valid-image-instantiator-format-p 'tab-control emchat-frame)
 491       (set-glyph-image
 492        emchat-status-gutter-tab
 493        (vector 'tab-control :descriptor "Status"
 494                :face 'bold
 495                :orientation emchat-status-gutter-orientation
 496                (if (or (eq emchat-status-gutter-orientation 'top)
 497                        (eq emchat-status-gutter-orientation 'bottom))
 498                    :pixel-width :pixel-height)
 499                (if (or (eq emchat-status-gutter-orientation 'top)
 500                        (eq emchat-status-gutter-orientation 'bottom))
 501                    '(gutter-pixel-width) '(gutter-pixel-height))
 502                :items (eval 'emchat-status-tabs))
 503        emchat-frame)
 504       ;; set-glyph-image will not make the gutter dirty
 505       (set-gutter-dirty-p emchat-status-gutter-orientation))))
 506
 507 (provide 'emchat-status)
 508
 509 ;;; emchat-status.el ends here