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

;; Copyright (C) 2007, 2011 Tom Tromey <tromey@redhat.com>

;; Author: Tom Tromey <tromey@redhat.com>
;; 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