Emacs and the Status Notification Specification

[Tom Tromey]

The Status Notification Specification is a D-Bus spec for what are
sometimes called "systray icons".  It lets applications create systray
icons using just D-Bus, rather than the mix of different things required
by the older spec.

The spec itself is here:

    http://www.notmart.org/misc/statusnotifieritem/index.html

As far as I know, only KDE currently implements this spec.  However,
nothing prevents it from being implemented in other desktops.

Attached are 2 files to implement the spec for Emacs:

* status.el, the basic implementation
* erc-status.el, adding an icon for ERC.  The icon blinks when someone
  pings you, and clicking it switches to the appropriate buffer.

I'd like to check these in to Emacs.  However, I was uncertain where to
locate them, so I thought I would post here first.

I also have a similar file, emms-status.el, to add an icon for EMMS; and
a few bits of elisp to add something similar for the calendar (plus
calls to notifications.el for appointments...).  I can send those along
if anybody cares.

Tom

;;; status.el --- notification area support for Emacs.

;; Copyright (C) 2007, 2011 Tom Tromey <address@hidden>

;; Author: Tom Tromey <address@hidden>
;; Version: 0.3

;; This file is not (yet) part of GNU Emacs.
;; However, it is distributed under the same license.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;; Commentary:

;; This implements the client side of the Status Notifier Item
;; specification:

;; http://www.notmart.org/misc/statusnotifieritem/index.html

;; There are no user-visible features of this module, only features
;; for Emacs Lisp programs.  You may like to use erc-status.el, which
;; provides some nice notification area support for ERC.

(require 'dbus)
(eval-when-compile (require 'cl))

;; The next available status ID.  Internal.
(defvar status--id 0)

;; Structure representing a status icon.
;; For internal use only.
(defstruct (status (:conc-name status--))
  (service-name nil :read-only t)
  (icon "dialog-information")
  (attention-icon "dialog-warning")
  overlay-icon
  (tooltip-icon "dialog-information")
  (tooltip-title "")
  (tooltip-description "")
  (category :application :read-only t)
  (id nil :read-only t)
  (title "Emacs")
  (status :passive)
  activate-callback
  secondary-activate-callback)

;; Map category keywords to strings from the spec.
(defconst status--category-map
  '((:application . "ApplicationStatus")
    (:communication . "Communication")
    (:system . "SystemServices")
    (:hardware . "Hardware")))

;; Map status keywords to strings from the spec.
(defconst status--status-map
  '((:passive . "Passive")
    (:active . "Active")
    (:needs-attention . "NeedsAttention")))

;; Properties we don't currently expose to the user, together with
;; their values.  (We actually do expose "ToolTip", but it is handled
;; differently below.)
(defconst status--properties
  '(("AttentionIconPixmap" nil)
    ("IconPixmap" nil)
    ("OverlayIconPixmap" nil)
    ("ToolTip" nil)
    ("WindowId" 0)))

;; Properties we do expose to the user, together with the accessor to
;; use.
(defconst status--exposed-properties
  '(("AttentionIconName" status--attention-icon)
    ("IconName" status--icon)
    ("OverlayIconName" status--overlay-icon)
    ("Category" status--category)
    ("Id" status--id)
    ("Title" status--title)))

;; Called when the icon is activated; calls the user-specified
;; function.
(defun status--activate (status-icon x y)
  (let ((callback (status--activate-callback status-icon)))
    (if callback
        (funcall callback))
    :ignore))

;; Called when the icon gets a secondary activation event.  Calls the
;; user-specified function.
(defun status--secondary-activate (status-icon x y)
  (let ((callback (status--secondary-activate-callback status-icon)))
    (if callback
        (funcall callback))
    :ignore))

;; Create the status notifier item via D-Bus.  See the specification
;; to understand most of this.
(defun status--setup-service (status-icon)
  (dolist (item status--properties)
    (dbus-register-property :session (status--service-name status-icon)
                            "/StatusNotifierItem"
                            "org.kde.StatusNotifierItem"
                            (car item)
                            :read (cadr item)
                            t t))
  (dolist (item status--exposed-properties)
    (dbus-register-property :session (status--service-name status-icon)
                            "/StatusNotifierItem"
                            "org.kde.StatusNotifierItem"
                            (car item)
                            :read (funcall (cadr item) status-icon)
                            t t))
  (dbus-register-property :session (status--service-name status-icon)
                          "/StatusNotifierItem"
                          "org.kde.StatusNotifierItem"
                          "Status"
                          :read (cdr (assq (status--status status-icon)
                                           status--status-map))
                          t t)
  (dbus-register-method :session (status--service-name status-icon)
                        "/StatusNotifierItem"
                        "org.kde.StatusNotifierItem"
                        "Activate"
                        `(lambda (&rest args) (apply
                                               #'status--activate
                                               ,status-icon
                                               args))
                        t)
  (dbus-register-method :session (status--service-name status-icon)
                        "/StatusNotifierItem"
                        "org.kde.StatusNotifierItem"
                        "SecondaryActivate"
                        `(lambda (&rest args) (apply
                                               #'status--secondary-activate
                                               ,status-icon
                                               args))
                        t)

  (dbus-register-service :session (status--service-name status-icon))

  ;; Register the item with the watcher.
  (dbus-call-method-asynchronously :session "org.kde.StatusNotifierWatcher"
                                   "/StatusNotifierWatcher"
                                   "org.kde.StatusNotifierWatcher"
                                   "RegisterStatusNotifierItem"
                                   nil
                                   (status--service-name status-icon)))

(defun status--update-dbus-property (icon property signal new-value
                                          &rest extra-args)
  (dbus-register-property :session (status--service-name icon)
                          "/StatusNotifierItem"
                          "org.kde.StatusNotifierItem"
                          property
                          :read new-value)
  (apply #'dbus-send-signal
         :session (status--service-name icon)
         "/StatusNotifierItem"
         "org.kde.StatusNotifierItem"
         signal
         extra-args))

(defun status-set-icon (icon new-value)
  "Set the icon displayed in the status area.
ICON is that status icon object.
NEW-VALUE is the Freedesktop-compliant name of the icon to display."
  (setf (status--icon icon) new-value)
  (status--update-dbus-property icon "IconName" "NewIcon" new-value))

(defun status-set-attention-icon (icon new-value)
  "Set the attention icon displayed in the status area.
ICON is that status attention icon object; the attention icon is
displayed when the status icon needs attention.  It defaults to the
ordinary icon.
NEW-VALUE is the Freedesktop-compliant name of the icon to display."
  (setf (status--attention-icon icon) new-value)
  (status--update-dbus-property icon "AttentionIconName" "NewAttentionIcon"
                                new-value))

(defun status-set-overlay-icon (icon new-value)
  "Set the overlay icon displayed in the status area.
ICON is that status overlay icon object; the overlay icon carries extra
information to displayed over the status icon.  It defaults to nil.
NEW-VALUE is the Freedesktop-compliant name of the icon to display."
  (setf (status--overlay-icon icon) new-value)
  (status--update-dbus-property icon "OverlayIconName" "NewOverlayIcon"
                                new-value))

(defun status-set-title (icon new-value)
  "Set the title of the status icon.
ICON is the status icon to modify.
NEW-VALUE is the new title."
  (setf (status--title icon) new-value)
  (status--update-dbus-property icon "Title" "NewTitle" new-value))

(defun status--compute-tooltip (icon)
  (list :struct
        (status--tooltip-icon icon)
        nil
        (status--tooltip-title icon)
        (status--tooltip-description icon)))

(defun status-set-tooltip-title (icon new-value)
  "Set the title of the status icon's tooltip.
ICON is the status icon to modify.
NEW-VALUE is the new tooltip title."
  (setf (status--tooltip-title icon) new-value)
  (status--update-dbus-property icon "ToolTip" "NewToolTip"
                                (status--compute-tooltip icon)))

(defun status-set-tooltip-icon (icon new-value)
  "Set the icon of the status icon's tooltip.
ICON is the status icon to modify.
NEW-VALUE is the new tooltip icon; it must be a Freedesktop-compliant
icon name."
  (setf (status--tooltip-icon icon) new-value)
  (status--update-dbus-property icon "ToolTip" "NewToolTip"
                                (status--compute-tooltip icon)))

(defun status-set-tooltip-description (icon new-value)
  "Set the description of the status icon's tooltip.
ICON is the status icon to modify.
NEW-VALUE is the new description.
The description may contain HTML markup."
  (setf (status--tooltip-description icon) new-value)
  (status--update-dbus-property icon "ToolTip" "NewToolTip"
                                (status--compute-tooltip icon)))

(defun status-set-status (icon new-value)
  "Set the status of the status icon.
ICON is the status icon to modify.
NEW-VALUE is the new status; it must be one of the keywords:
  :passive          The application is in a passive state.
  :active           The application is in an active state.
  :needs-attention  The application needs attention from the user."
  (let ((string-value (cdr (assq new-value status--status-map))))
    (unless string-value
      (error "Invalid status for status-icon"))
    (setf (status--status icon) new-value)
    (status--update-dbus-property icon "Status" "NewStatus"
                                  string-value string-value)))

(defun status-set-activate-callback (status-icon new-value)
  "Set the activation callback function for STATUS-ICON.
NEW-VALUE is a function which will be called when the icon is \"activated\"
\(usually this means clicked by the user).
If nil, no function will be called."
  (setf (status--activate-callback status-icon) new-value))

(defun status-set-secondary-activate-callback (status-icon new-value)
  "Set the activation callback function for STATUS-ICON.
NEW-VALUE is a function which will be called when the icon is
\"secondarily activated\" (usually this means middle-clicked by the user).
If nil, no function will be called."
  (setf (status--secondary-activate-callback status-icon) new-value))

;;;###autoload
(defun status-new (category id &rest args)
  "Create a new status icon and return it."
  (let* ((id status--id)
         (service-name (concat "org.kde.StatusNotifierItem-"
                               (int-to-string (emacs-pid))
                               "-"
                               (int-to-string id)))
         (result (apply #'make-status
                        :service-name service-name
                        :category (cdr (assq category
                                             status--category-map))
                        :id id
                        args)))
    (setq status--id (1+ status--id))
    (status--setup-service result)
    result))

(defun status-delete (status-icon)
  "Destroy the status icon."
  (dbus-unregister-service :session (status--service-name status-icon)))

(provide 'status)

;;; status.el ends here

;;; erc-status.el --- notification area support for ERC

;; Copyright (C) 2007, 2011 Tom Tromey <address@hidden>

;; Author: Tom Tromey <address@hidden>
;; Version: 0.2
;; Keywords: comm

;; This file is not (yet) part of GNU Emacs.
;; However, it is distributed under the same license.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This provides nice support for the notification area to ERC.  In
;; particular it:
;; * Will blink the icon when you get a private message or are paged
;;   in a channel.
;; * Left-click on the blinking icon will show the appropriate channel
;;   buffer in some frame (which is then raised).  If there are
;;   multiple pages at once, it will show one and you can click again
;;   to go to the next one.
;; * Will show a menu of all the channels on the right button menu.
;;   (Though... this doesn't work and I haven't debugged it.)
;; * Will pop up notification bubbles when you connect to or
;;   disconnect from a server.
;; This is regular erc module named 'status'; you can enable it as you
;; would any other module.

;;; Change log:

;; 2011-06-23  rewrite for status notifier spec
;; 2007-02-15  raise frame on left click
;; 2007-02-13  make sure priv message added after auto-query
;; 2007-02-08  turn into an ERC module
;; 2007-02-08  another try at private messages
;; 2007-01-29  try to make private messages work.  show buffer on click

;; TO DO:
;; - make tool tip show some kind of real status ...?
;; - use a nicer icon
;; - menu?  (tried but it isn't working yet)
;; - integrate with auto-query a bit better
;; - let left click use specified frame or make a new frame?

(require 'status)
(require 'erc)
(require 'notifications)

;; The status icon object.
(defvar erc-status-status-icon nil)

;; List of ERC buffers that caused the status icon to blink.
(defvar erc-status-buffer-list nil)

(defun erc-status-remove-buffer (buffer)
  ;; If the list is not empty, and removing an element makes the list
  ;; empty, stop blinking.
  (and erc-status-buffer-list
       (not (setq erc-status-buffer-list (delq buffer erc-status-buffer-list)))
       (status-set-state erc-status-status-icon :active)))

(defun erc-status-add-buffer (buffer)
  (unless (erc-buffer-visible buffer)
    (status-set-state erc-status-status-icon :needs-attention)
    (unless (memq buffer erc-status-buffer-list)
      (setq erc-status-buffer-list (cons buffer
                                         erc-status-buffer-list)))))

(defun erc-status-match-hook (match-type nick message)
  ;; Look for user's nick and make the icon blink.
  (if (eq match-type 'current-nick)
      (erc-status-add-buffer (current-buffer))))

(defun erc-status-buffer-killed ()
  ;; If one of our buffers was killed, remove it.
  (erc-status-remove-buffer (current-buffer)))

(defun erc-status-window-configuration-changed ()
  (let ((new-list))
    (dolist (buffer erc-status-buffer-list)
      (unless (erc-buffer-visible buffer)
        (setq new-list (cons buffer new-list))))
    (unless (setq erc-status-buffer-list new-list)
      (status-set-state erc-status-status-icon :active))))

(defun erc-status-disconnected (nick ip reason)
  (notifications-notify :title (concat "Disconnected: " reason)
                        :app-name "ERC"
                        :urgency 'normal))

(defun erc-status-after-connect (server nick)
  (notifications-notify :title (concat "Connected to " server " as " nick)
                        :app-name "ERC"
                        :urgency 'normal))

(defun erc-status-select-first-buffer ()
  "Switch to the first ERC buffer requiring your attention.
If there is no such buffer, do nothing."
  (when erc-status-buffer-list
    (switch-to-buffer (car erc-status-buffer-list))
    (raise-frame)))



;; From: http://www.emacswiki.org/cgi-bin/wiki/ErcPageMe
;; Then modified to suit.

(defun erc-status-PRIVMSG (proc parsed)
  (let* ((nick (car (erc-parse-user (erc-response.sender parsed))))
         (target (car (erc-response.command-args parsed)))
         (msg (erc-response.contents parsed))
         (query  (if (not erc-query-on-unjoined-chan-privmsg)
                     nick
                   (if (erc-current-nick-p target)
                       nick
                     target))))
    (when (and (erc-current-nick-p target)
               (not (erc-is-message-ctcp-and-not-action-p msg)))
      ;; Note: assumes you are using auto-query.
      (erc-status-add-buffer (erc-get-buffer query proc))))
  ;; Always return nil.
  nil)



(define-erc-module status nil
  "Notification area support for ERC."
  ;; Enable.
  ((unless erc-status-status-icon
     (setq erc-status-status-icon (status-new :communication "Emacs ERC"
                                              :icon "user-available"))
     ;; (status-set-tooltip erc-status-status-icon
     ;;                          "ERC - IRC client for Emacs")
     (status-set-activate-callback erc-status-status-icon
                                   'erc-status-select-first-buffer))
   (add-hook 'erc-text-matched-hook 'erc-status-match-hook)
   (add-hook 'kill-buffer-hook 'erc-status-buffer-killed)
   (add-hook 'window-configuration-change-hook
             'erc-status-window-configuration-changed)
   (add-hook 'erc-after-connect 'erc-status-after-connect)
   (add-hook 'erc-disconnected-hook 'erc-status-disconnected)
   ;; FIXME: Must come *after* erc-auto-query.  Some sort of
   ;; auto-query hook or the like would be good here.
   (add-hook 'erc-server-PRIVMSG-functions 'erc-status-PRIVMSG t))

  ;; Disable.
  ((when erc-status-status-icon
     (status-delete erc-status-status-icon)
     (setq erc-status-status-icon nil))
   (remove-hook 'erc-text-matched-hook 'erc-status-match-hook)
   (remove-hook 'kill-buffer-hook 'erc-status-buffer-killed)
   (remove-hook 'window-configuration-change-hook
                'erc-status-window-configuration-changed)
   (remove-hook 'erc-after-connect 'erc-status-after-connect)
   (remove-hook 'erc-disconnected-hook 'erc-status-disconnected)
   (remove-hook 'erc-server-PRIVMSG-functions 'erc-status-PRIVMSG)))

;;; erc-status.el ends here