| | 1 | ;; jabber-ahc-presence.el - provide remote control of presence -*- lexical-binding: t; -*- |
| | 2 | |
| | 3 | ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu |
| | 4 | ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net |
| | 5 | |
| | 6 | ;; This file is a part of jabber.el. |
| | 7 | |
| | 8 | ;; This program is free software; you can redistribute it and/or modify |
| | 9 | ;; it under the terms of the GNU General Public License as published by |
| | 10 | ;; the Free Software Foundation; either version 2 of the License, or |
| | 11 | ;; (at your option) any later version. |
| | 12 | |
| | 13 | ;; This program is distributed in the hope that it will be useful, |
| | 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| | 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| | 16 | ;; GNU General Public License for more details. |
| | 17 | |
| | 18 | ;; You should have received a copy of the GNU General Public License |
| | 19 | ;; along with this program; if not, write to the Free Software |
| | 20 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| | 21 | |
| | 22 | (require 'jabber-presence) |
| | 23 | (require 'jabber-ahc) |
| | 24 | (defvar *jabber-current-show*) |
| | 25 | (defvar *jabber-current-status*) |
| | 26 | (defvar *jabber-current-priority*) |
| | 27 | |
| | 28 | (defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status" |
| | 29 | "Node used by function `jabber-ahc-presence'.") |
| | 30 | |
| | 31 | (jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence |
| | 32 | 'jabber-my-jid-p) |
| | 33 | |
| | 34 | (defun jabber-ahc-presence (jc xml-data) |
| | 35 | "Process presence change command. |
| | 36 | |
| | 37 | JC is the Jabber connection. |
| | 38 | XML-DATA is the parsed tree data from the stream (stanzas) |
| | 39 | obtained from `xml-parse-region'." |
| | 40 | |
| | 41 | (let* ((query (jabber-iq-query xml-data)) |
| | 42 | (sessionid (jabber-xml-get-attribute query 'sessionid)) |
| | 43 | (action (jabber-xml-get-attribute query 'action))) |
| | 44 | ;; No session state is kept; instead, lack of session-id is used |
| | 45 | ;; as indication of first command. |
| | 46 | (cond |
| | 47 | ;; command cancelled |
| | 48 | ((string= action "cancel") |
| | 49 | `(command ((xmlns . "http://jabber.org/protocol/commands") |
| | 50 | (sessionid . ,sessionid) |
| | 51 | (node . ,jabber-ahc-presence-node) |
| | 52 | (status . "canceled")))) |
| | 53 | ;; return form |
| | 54 | ((null sessionid) |
| | 55 | `(command ((xmlns . "http://jabber.org/protocol/commands") |
| | 56 | (sessionid . "jabber-ahc-presence") |
| | 57 | (node . ,jabber-ahc-presence-node) |
| | 58 | (status . "executing")) |
| | 59 | (x ((xmlns . "jabber:x:data") |
| | 60 | (type . "form")) |
| | 61 | (title nil ,(format "Set presence of %s" (jabber-connection-jid jc))) |
| | 62 | (instructions nil "Select new presence status.") |
| | 63 | (field ((var . "FORM_TYPE") (type . "hidden")) |
| | 64 | (value nil "http://jabber.org/protocol/rc")) |
| | 65 | (field ((var . "status") |
| | 66 | (label . "Status") |
| | 67 | (type . "list-single")) |
| | 68 | (value nil ,(if (string= *jabber-current-show* "") |
| | 69 | "online" |
| | 70 | *jabber-current-show*)) |
| | 71 | (option ((label . "Online")) (value nil "online")) |
| | 72 | (option ((label . "Chatty")) (value nil "chat")) |
| | 73 | (option ((label . "Away")) (value nil "away")) |
| | 74 | (option ((label . "Extended away")) (value nil "xa")) |
| | 75 | (option ((label . "Do not disturb")) (value nil "dnd"))) |
| | 76 | (field ((var . "status-message") |
| | 77 | (label . "Message") |
| | 78 | (type . "text-single")) |
| | 79 | (value nil ,*jabber-current-status*)) |
| | 80 | (field ((var . "status-priority") |
| | 81 | (label . "Priority") |
| | 82 | (type . "text-single")) |
| | 83 | (value nil ,(int-to-string *jabber-current-priority*)))))) |
| | 84 | ;; process form |
| | 85 | (t |
| | 86 | (let* ((x (car (jabber-xml-get-children query 'x))) |
| | 87 | ;; we assume that the first <x/> is the jabber:x:data one |
| | 88 | (fields (jabber-xml-get-children x 'field)) |
| | 89 | (new-show *jabber-current-show*) |
| | 90 | (new-status *jabber-current-status*) |
| | 91 | (new-priority *jabber-current-priority*)) |
| | 92 | (dolist (field fields) |
| | 93 | (let ((var (jabber-xml-get-attribute field 'var)) |
| | 94 | ;; notice that multi-value fields won't be handled properly |
| | 95 | ;; by this |
| | 96 | (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) |
| | 97 | (cond |
| | 98 | ((string= var "status") |
| | 99 | (setq new-show (if (string= value "online") |
| | 100 | "" |
| | 101 | value))) |
| | 102 | ((string= var "status-message") |
| | 103 | (setq new-status value)) |
| | 104 | ((string= var "status-priority") |
| | 105 | (setq new-priority (string-to-number value)))))) |
| | 106 | (jabber-send-presence new-show new-status new-priority)) |
| | 107 | `(command ((xmlns . "http://jabber.org/protocol/commands") |
| | 108 | (sessionid . ,sessionid) |
| | 109 | (node . ,jabber-ahc-presence-node) |
| | 110 | (status . "completed")) |
| | 111 | (note ((type . "info")) "Presence has been changed.")))))) |
| | 112 | |
| | 113 | (provide 'jabber-ahc-presence) |
| | 114 | |
| | 115 | ;;; arch-tag: 4b8cbbe7-00a9-4d42-a4ac-b824ab914fba |
projects / config.git / blame_incremental