9ahmed
/
boo-bee-macs
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

added stuff

This commit is contained in:
9ahmed 2021-04-18 02:21:02 +05:00
parent a3ea884b74
commit cb52adbbe8
136 changed files with 22677 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
elpa/fsm-0.2.1.signed Normal file
View File

@ -0,0 +1 @@
Good signature from 066DAFCB81E42C40 GNU ELPA Signing Agent (2019) <elpasign@elpa.gnu.org> (trust undefined) created at 2019-09-21T22:54:34+0500 using RSA

22
elpa/fsm-0.2.1/fsm-autoloads.el Normal file
View File

@ -0,0 +1,22 @@
;;; fsm-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "fsm" "fsm.el" (0 0 0 0))
;;; Generated autoloads from fsm.el
(register-definition-prefixes "fsm" '("fsm-"))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; fsm-autoloads.el ends here

2
elpa/fsm-0.2.1/fsm-pkg.el Normal file
View File

@ -0,0 +1,2 @@
;;; Generated package description from fsm.el -*- no-byte-compile: t -*-
(define-package "fsm" "0.2.1" "state machine library" '((emacs "24.1") (cl-lib "0.5")) :url "http://elpa.gnu.org/packages/fsm.html" :keywords '("extensions") :authors '(("Magnus Henoch" . "magnus.henoch@gmail.com")) :maintainer '("Thomas Fitzsimmons" . "fitzsim@fitzsim.org"))

503
elpa/fsm-0.2.1/fsm.el Normal file
View File

@ -0,0 +1,503 @@
;;; fsm.el --- state machine library -*- lexical-binding: t; -*-
;; Copyright (C) 2006, 2007, 2008, 2015 Free Software Foundation, Inc.
;; Author: Magnus Henoch <magnus.henoch@gmail.com>
;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Version: 0.2.1
;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
;; Keywords: extensions
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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:
;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of
;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp
;; easy and fun. By "asynchronous" I mean that long-lasting tasks
;; don't interfer with normal editing.
;; Some people say that it would be nice if Emacs Lisp had threads
;; and/or continuations. They are probably right, but there are few
;; things that can't be made to run in the background using facilities
;; already available: timers, filters and sentinels. As the code can
;; become a bit messy when using such means, with callbacks everywhere
;; and such things, it can be useful to structure the program as a
;; state machine.
;; In this model, a state machine passes between different "states",
;; which are actually only different event handler functions. The
;; state machine receives "events" (from timers, filters, user
;; requests, etc) and reacts to them, possibly entering another state,
;; possibly returning a value.
;; The essential macros/functions are:
;;
;; define-state-machine - create start-FOO function
;; define-state - event handler for each state (required)
;; define-enter-state - called when entering a state (optional)
;; define-fsm - encapsulates the above three (more sugar!)
;; fsm-send - send an event to a state machine
;; fsm-call - send an event and wait for reply
;; fsm.el is similar to but different from Distel:
;; <URL:http://fresh.homeunix.net/~luke/distel/>
;; Emacs' tq library is a similar idea.
;; Here is a simple (not using all the features of fsm.el) example:
;;
;; ;; -*- lexical-binding: t; -*-
;; (require 'fsm)
;; (cl-labels ((hey (n ev)
;; (message "%d (%s)\tp%sn%s!" n ev
;; (if (zerop (% n 4)) "o" "i")
;; (make-string (max 1 (abs n)) ?g))))
;; (cl-macrolet ((zow (next timeout)
;; `(progn (hey (cl-incf count) event)
;; (list ,next count ,timeout))))
;; (define-fsm pingpong
;; :start ((init) "Start a pingpong fsm."
;; (interactive "nInit (number, negative to auto-terminate): ")
;; (list :ping (ash (ash init -2) 2) ; 4 is death
;; (when (interactive-p) 0)))
;; :state-data-name count
;; :states
;; ((:ping
;; (:event (zow :pingg 0.1)))
;; (:pingg
;; (:event (zow :pinggg 0.1)))
;; (:pinggg
;; (:event (zow :pong 1)))
;; (:pong
;; (:event (zow :ping (if (= 0 count)
;; (fsm-goodbye-cruel-world 'pingpong)
;; 3))))))))
;; (fsm-send (start-pingpong -16) t)
;;
;; Copy into a buffer, uncomment, and type M-x eval-buffer RET.
;; Alternatively, you can replace the `fsm-goodbye-cruel-world'
;; form with `nil', eval just the `cl-labels' form and then type
;; M-x start-pingpong RET -16 RET.
;; Version 0.2:
;; -- Delete trailing whitespace.
;; -- Fix formatting.
;; -- Use lexical binding.
;; -- Port to cl-lib.
;; -- Remove unnecessary fsm-debug-output message.
;; -- Add FSM name to fsm-debug-output messages that were not including it.
;; -- Fix checkdoc errors.
;; -- Change FSMs from plists to uninterned symbols.
;; NOTE: This is version 0.1ttn4 of fsm.el, with the following
;; mods (an exercise in meta-meta-programming ;-) by ttn:
;; -- Refill for easy (traditional 80-column) perusal.
;; -- New var `fsm-debug-timestamp-format'.
;; -- Make variables satisfy `user-variable-p'.
;; -- Use `format' instead of `concat'.
;; -- New func `fsm-goodbye-cruel-world'.
;; -- Make start-function respect `interactive' spec.
;; -- Make enter-/event-functions anonymous.
;; -- New macro `define-fsm'.
;; -- Example usage in Commentary.
;;; Code:
;; We require cl-lib at runtime, since we insert `cl-destructuring-bind' into
;; modules that use fsm.el.
(require 'cl-lib)
(defvar fsm-debug "*fsm-debug*"
"*Name of buffer for fsm debug messages.
If nil, don't output debug messages.")
(defvar fsm-debug-timestamp-format nil
"*Timestamp format (a string) for `fsm-debug-output'.
Default format is whatever `current-time-string' returns
followed by a colon and a space.")
(defun fsm-debug-output (format &rest args)
"Append debug output to buffer named by the variable `fsm-debug'.
FORMAT and ARGS are passed to `format'."
(when fsm-debug
(with-current-buffer (get-buffer-create fsm-debug)
(save-excursion
(goto-char (point-max))
(insert (if fsm-debug-timestamp-format
(format-time-string fsm-debug-timestamp-format)
(concat (current-time-string) ": "))
(apply 'format format args) "\n")))))
(cl-defmacro define-state-machine (name &key start sleep)
"Define a state machine class called NAME.
A function called start-NAME is created, which uses the argument
list and body specified in the :start argument. BODY should
return a list of the form (STATE STATE-DATA [TIMEOUT]), where
STATE is the initial state (defined by `define-state'),
STATE-DATA is any object, and TIMEOUT is the number of seconds
before a :timeout event will be sent to the state machine. BODY
may refer to the instance being created through the dynamically
bound variable `fsm'.
SLEEP-FUNCTION, if provided, takes one argument, the number of
seconds to sleep while allowing events concerning this state
machine to happen. There is probably no reason to change the
default, which is accept-process-output with rearranged
arguments.
\(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])"
(declare (debug (&define name :name start
&rest
&or [":start"
(lambda-list
[&optional ("interactive" interactive)]
stringp def-body)]
[":sleep" function-form])))
(let ((start-name (intern (format "start-%s" name)))
interactive-spec)
(cl-destructuring-bind (arglist docstring &body body) start
(when (and (consp (car body)) (eq 'interactive (caar body)))
(setq interactive-spec (list (pop body))))
(unless (stringp docstring)
(error "Docstring is not a string"))
`(progn
(put ',name :fsm-enter (make-hash-table :size 11 :test 'eq))
(put ',name :fsm-event (make-hash-table :size 11 :test 'eq))
(defun ,start-name ,arglist
,docstring
,@interactive-spec
(fsm-debug-output "Starting %s" ',name)
(let ((fsm (cl-gensym (concat "fsm-" ,(symbol-name name) "-"))))
(cl-destructuring-bind (state state-data &optional timeout)
(progn ,@body)
(put fsm :name ',name)
(put fsm :state nil)
(put fsm :state-data nil)
(put fsm :sleep ,(or sleep '(lambda (secs)
(accept-process-output
nil secs))))
(put fsm :deferred nil)
(fsm-update fsm state state-data timeout)
fsm)))))))
(cl-defmacro define-state (fsm-name state-name arglist &body body)
"Define a state called STATE-NAME in the state machine FSM-NAME.
ARGLIST and BODY make a function that gets called when the state
machine receives an event in this state. The arguments are:
FSM the state machine instance (treat it as opaque)
STATE-DATA An object
EVENT The occurred event, an object.
CALLBACK A function of one argument that expects the response
to this event, if any (often `ignore' is used)
If the event should return a response, the state machine should
arrange to call CALLBACK at some point in the future (not necessarily
in this handler).
The function should return a list of the form (NEW-STATE
NEW-STATE-DATA TIMEOUT):
NEW-STATE The next state, a symbol
NEW-STATE-DATA An object
TIMEOUT A number: send timeout event after this many seconds
nil: cancel existing timer
:keep: let existing timer continue
Alternatively, the function may return the keyword :defer, in
which case the event will be resent when the state machine enters
another state."
(declare (debug (&define name name :name handler lambda-list def-body)))
`(setf (gethash ',state-name (get ',fsm-name :fsm-event))
(lambda ,arglist ,@body)))
(cl-defmacro define-enter-state (fsm-name state-name arglist &body body)
"Define a function to call when FSM-NAME enters the state STATE-NAME.
ARGLIST and BODY make a function that gets called when the state
machine enters this state. The arguments are:
FSM the state machine instance (treat it as opaque)
STATE-DATA An object
The function should return a list of the form (NEW-STATE-DATA
TIMEOUT):
NEW-STATE-DATA An object
TIMEOUT A number: send timeout event after this many seconds
nil: cancel existing timer
:keep: let existing timer continue"
(declare (debug (&define name name :name enter lambda-list def-body)))
`(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
(lambda ,arglist ,@body)))
(cl-defmacro define-fsm (name &key
start sleep states
(fsm-name 'fsm)
(state-data-name 'state-data)
(callback-name 'callback)
(event-name 'event))
"Define a state machine class called NAME, along with its STATES.
This macro is (further) syntatic sugar for `define-state-machine',
`define-state' and `define-enter-state' macros, q.v.
NAME is a symbol. Everything else is specified with a keyword arg.
START and SLEEP are the same as for `define-state-machine'.
STATES is a list, each element having the form (STATE-NAME . STATE-SPEC).
STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or
`:enter', and values a series of expressions representing the BODY of
a `define-state' or `define-enter-state' call, respectively.
FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols,
used to construct the state functions' arglists."
`(progn
(define-state-machine ,name :start ,start :sleep ,sleep)
,@(cl-loop for (state-name . spec) in states
if (assq :enter spec) collect
`(define-enter-state ,name ,state-name
(,fsm-name ,state-data-name)
,@(cdr it))
end
if (assq :event spec) collect
`(define-state ,name ,state-name
(,fsm-name ,state-data-name
,event-name
,callback-name)
,@(cdr it))
end)))
(defun fsm-goodbye-cruel-world (name)
"Unbind functions related to fsm NAME (a symbol).
Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE.
Functions are `fmakunbound', which will probably give (fatal) pause to
any state machines using them. Return nil."
(interactive "SUnbind function definitions for fsm named: ")
(fmakunbound (intern (format "start-%s" name)))
(let (ht)
(when (hash-table-p (setq ht (get name :fsm-event)))
(clrhash ht)
(cl-remprop name :fsm-event))
(when (hash-table-p (setq ht (get name :fsm-enter)))
(clrhash ht)
(cl-remprop name :fsm-enter)))
nil)
(defun fsm-start-timer (fsm secs)
"Send a timeout event to FSM after SECS seconds.
The timer is canceled if another event occurs before, unless the
event handler explicitly asks to keep the timer."
(fsm-stop-timer fsm)
(put fsm
:timeout (run-with-timer
secs nil
#'fsm-send-sync fsm :timeout)))
(defun fsm-stop-timer (fsm)
"Stop the timeout timer of FSM."
(let ((timer (get fsm :timeout)))
(when (timerp timer)
(cancel-timer timer)
(put fsm :timeout nil))))
(defun fsm-maybe-change-timer (fsm timeout)
"Change the timer of FSM according to TIMEOUT."
(cond
((numberp timeout)
(fsm-start-timer fsm timeout))
((null timeout)
(fsm-stop-timer fsm))
;; :keep needs no timer change
))
(defun fsm-send (fsm event &optional callback)
"Send EVENT to FSM asynchronously.
If the state machine generates a response, eventually call
CALLBACK with the response as only argument."
(run-with-timer 0 nil #'fsm-send-sync fsm event callback))
(defun fsm-update (fsm new-state new-state-data timeout)
"Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT."
(let ((fsm-name (get fsm :name))
(old-state (get fsm :state)))
(put fsm :state new-state)
(put fsm :state-data new-state-data)
(fsm-maybe-change-timer fsm timeout)
;; On state change, call enter function and send deferred events
;; again.
(unless (eq old-state new-state)
(fsm-debug-output "%s enters %s" fsm-name new-state)
(let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
(when (functionp enter-fn)
(fsm-debug-output "Found enter function for %s/%s" fsm-name new-state)
(condition-case e
(cl-destructuring-bind (newer-state-data newer-timeout)
(funcall enter-fn fsm new-state-data)
(put fsm :state-data newer-state-data)
(fsm-maybe-change-timer fsm newer-timeout))
((debug error)
(fsm-debug-output "%s/%s update didn't work: %S"
fsm-name new-state e)))))
(let ((deferred (nreverse (get fsm :deferred))))
(put fsm :deferred nil)
(dolist (event deferred)
(apply 'fsm-send-sync fsm event))))))
(defun fsm-send-sync (fsm event &optional callback)
"Send EVENT to FSM synchronously.
If the state machine generates a response, eventually call
CALLBACK with the response as only argument."
(save-match-data
(let* ((fsm-name (get fsm :name))
(state (get fsm :state))
(state-data (get fsm :state-data))
(state-fn (gethash state (get fsm-name :fsm-event))))
;; If the event is a list, output only the car, to avoid an
;; overflowing debug buffer.
(fsm-debug-output "Sent %S to %s in state %s"
(or (car-safe event) event) fsm-name state)
(let ((result (condition-case e
(funcall state-fn fsm state-data event
(or callback 'ignore))
((debug error) (cons :error-signaled e)))))
;; Special case for deferring an event until next state change.
(cond
((eq result :defer)
(let ((deferred (get fsm :deferred)))
(put fsm :deferred (cons (list event callback) deferred))))
((null result)
(fsm-debug-output "Warning: event %S ignored in state %s/%s"
event fsm-name state))
((eq (car-safe result) :error-signaled)
(fsm-debug-output "Error in %s/%s: %s"
fsm-name state
(error-message-string (cdr result))))
((and (listp result)
(<= 2 (length result))
(<= (length result) 3))
(cl-destructuring-bind (new-state new-state-data &optional timeout)
result
(fsm-update fsm new-state new-state-data timeout)))
(t
(fsm-debug-output "Incorrect return value in %s/%s: %S"
fsm-name state
result)))))))
(defun fsm-call (fsm event)
"Send EVENT to FSM synchronously, and wait for a reply.
Return the reply. `with-timeout' might be useful."
(let (reply)
(fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
(while (null reply)
(fsm-sleep fsm 1))
(car reply)))
(defun fsm-make-filter (fsm)
"Return a filter function that sends events to FSM.
Events sent are of the form (:filter PROCESS STRING)."
(let ((fsm fsm))
(lambda (process string)
(fsm-send-sync fsm (list :filter process string)))))
(defun fsm-make-sentinel (fsm)
"Return a sentinel function that sends events to FSM.
Events sent are of the form (:sentinel PROCESS STRING)."
(let ((fsm fsm))
(lambda (process string)
(fsm-send-sync fsm (list :sentinel process string)))))
(defun fsm-sleep (fsm secs)
"Sleep up to SECS seconds in a way that lets FSM receive events."
(funcall (get fsm :sleep) secs))
(defun fsm-get-state-data (fsm)
"Return the state data of FSM.
Note the absence of a set function. The fsm should manage its
state data itself; other code should just send messages to it."
(get fsm :state-data))
;;;; ChangeLog:
;; 2016-07-10 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; packages/fsm: Bump version to 0.2.1
;;
;; 2016-07-10 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; packages/fsm: Fix compilation error
;;
;; * packages/fsm/fsm.el (define-state-machine): Quote default :sleep
;; lambda (bug#23920).
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Revert some changes suggested by checkdoc
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Bump version to 0.2
;;
;; 2015-09-05 Magnus Henoch <magnus.henoch@gmail.com>
;;
;; fsm: Change FSMs from plists to uninterned symbols
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Fix copyright
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Add packaging fields
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Fix checkdoc errors
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Add FSM name to some fsm-debug-output messages
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Port to cl-lib
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Use lexical binding
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Fix formatting
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Delete trailing whitespace
;;
;; 2015-09-05 Thomas Fitzsimmons <fitzsim@fitzsim.org>
;;
;; fsm: Import fsm.el from emacs-jabber
;;
;; Import fsm.el from git://git.code.sf.net/p/emacs-jabber/git, commit
;; 1f858cc4f3cdabcd7380a7d08af273bcdd708c15.
;;
(provide 'fsm)
;;; fsm.el ends here

BIN
elpa/fsm-0.2.1/fsm.elc Normal file
View File

Binary file not shown.

33
elpa/gemini-mode-20210226.1419/gemini-mode-autoloads.el Normal file
View File

@ -0,0 +1,33 @@
;;; gemini-mode-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "gemini-mode" "gemini-mode.el" (0 0 0 0))
;;; Generated autoloads from gemini-mode.el
(autoload 'gemini-mode "gemini-mode" "\
Major mode for editing text/gemini 'geminimap' documents
\(fn)" t nil)
(add-to-list 'auto-mode-alist '("\\.gmi\\'" . gemini-mode))
(add-to-list 'auto-mode-alist '("\\.gemini\\'" . gemini-mode))
(add-to-list 'auto-mode-alist '("\\.geminimap\\'" . gemini-mode))
(register-definition-prefixes "gemini-mode" '("gemini-" "turn-on-visual-fill-column-mode"))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; gemini-mode-autoloads.el ends here

2
elpa/gemini-mode-20210226.1419/gemini-mode-pkg.el Normal file
View File

@ -0,0 +1,2 @@
;;; Generated package description from gemini-mode.el -*- no-byte-compile: t -*-
(define-package "gemini-mode" "20210226.1419" "A simple highlighting package for text/gemini" '((emacs "24.4")) :commit "0a227125a4112266c06ed7247de039090314b525" :authors '(("Jason McBrayer <jmcbray@carcosa.net>, tastytea <tastytea@tastytea.de>, Étienne Deparis" . "etienne@depar.is")) :maintainer '("Jason McBrayer <jmcbray@carcosa.net>, tastytea <tastytea@tastytea.de>, Étienne Deparis" . "etienne@depar.is") :keywords '("languages") :url "https://git.carcosa.net/jmcbray/gemini.el")

224
elpa/gemini-mode-20210226.1419/gemini-mode.el Normal file
View File

@ -0,0 +1,224 @@
;;; gemini-mode.el --- A simple highlighting package for text/gemini -*- lexical-binding: t; -*-
;; Copyright (C) 2020 Jason McBrayer
;; Author: Jason McBrayer <jmcbray@carcosa.net>, tastytea <tastytea@tastytea.de>, Étienne Deparis <etienne@depar.is>
;; Created: 20 May 2020
;; Version: 1.0.0
;; Package-Version: 20210226.1419
;; Package-Commit: 0a227125a4112266c06ed7247de039090314b525
;; Keywords: languages
;; Homepage: https://git.carcosa.net/jmcbray/gemini.el
;; Package-Requires: ((emacs "24.4"))
;;; Commentary:
;; This package provides a major mode for editing text/gemini files.
;; Currently, it only provides syntax-highlighting support.
;; This file is not part of GNU Emacs.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program 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 Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(eval-when-compile
(defvar font-lock-beg)
(defvar font-lock-end)
(defun elpher-go (_))
(defun visual-fill-column-mode (_)))
(defface gemini-heading-face-1
'((t :inherit bold :height 1.8))
"Face for Gemini headings level 1"
:group 'gemini-mode)
(defface gemini-heading-face-2
'((t :inherit bold :height 1.4))
"Face for Gemini headings level 2"
:group 'gemini-mode)
(defface gemini-heading-face-3
'((t :inherit bold :height 1.2))
"Face for Gemini headings level 3"
:group 'gemini-mode)
(defface gemini-heading-face-rest
'((t :inherit bold))
"Face for Gemini headings below level 3"
:group 'gemini-mode)
(defface gemini-quote-face
'((t :inherit italic))
"Face for quoted lines in Gemini"
:group 'gemini-mode)
(defface gemini-ulist-face
'((t :inherit font-lock-keyword-face))
"Face for unordered list items in Gemini"
:group 'gemini-mode)
(defcustom gemini-mode-hook 'turn-on-visual-line-mode
"Normal hook run when entering Gemini mode. Usually used to set line
wrapping"
:type 'hook
:options '(turn-on-visual-line-mode turn-on-visual-fill-column-mode)
:group 'gemini-mode)
;; See RFC 3986 (URI).
(defconst gemini-regex-uri
"\\([a-zA-z0-9+-.]+:[^]\t\n\r<>,;() ]+\\)"
"Regular expression for matching URIs.")
(defconst gemini-regex-link-line
"^=>[[:blank:]]?\\([^[:blank:]]+\\)\\([[:blank:]]?.*\\)?$"
"Regular expression for matching link lines.
Used by ‘font-lock-defaults’ and ‘gemini-link-at-point’.")
(defvar gemini-highlights
(let* ((gemini-preformatted-regexp "^```[^`]+```$")
(gemini-heading-rest-regexp "^####+[[:blank:]]*.*$")
(gemini-heading-3-regexp "^###[[:blank:]]*.*$")
(gemini-heading-2-regexp "^##[[:blank:]]*.*$")
(gemini-heading-1-regexp "^#[[:blank:]]*.*$")
(gemini-ulist-regexp "^\\* .*$")
(gemini-quote-regexp "^>[[:blank:]]*.*$"))
;; preformatted must be declared first has it must absolutely be set
;; before any other face (for exemple to avoid a title inside a
;; preformatted block to hijack it).
`((,gemini-preformatted-regexp . 'font-lock-builtin-face)
(,gemini-heading-rest-regexp . 'gemini-heading-face-rest)
(,gemini-heading-3-regexp . 'gemini-heading-face-3)
(,gemini-heading-2-regexp . 'gemini-heading-face-2)
(,gemini-heading-1-regexp . 'gemini-heading-face-1)
(,gemini-regex-link-line 1 'link)
(,gemini-ulist-regexp . 'gemini-ulist-face)
(,gemini-quote-regexp . 'gemini-quote-face)))
"Font lock keywords for `gemini-mode'.")
(defvar gemini-mode-map
(let ((map (make-keymap)))
(define-key map (kbd "C-c C-l") #'gemini-insert-link)
(define-key map (kbd "C-c C-o") #'gemini-open-link-at-point)
(define-key map (kbd "C-c RET") #'gemini-insert-list-item)
map)
"Keymap for `gemini-mode'.")
(defun gemini-get-used-uris ()
"Return a list of all used URIs in the buffer."
(save-excursion
(goto-char (point-min))
(let (uris)
(while (re-search-forward gemini-regex-uri nil t)
(push (match-string 1) uris))
uris)))
(defun gemini-insert-link ()
"Insert new link, with interactive prompts.
If there is an active region, use the text as the default URL, if
it seems to be a URL, or link text value otherwise."
(interactive)
(cl-multiple-value-bind (begin end text uri)
(if (use-region-p)
;; Use region as either link text or URL as appropriate.
(let ((region (buffer-substring-no-properties
(region-beginning) (region-end))))
(if (string-match gemini-regex-uri region)
;; Region contains a URL; use it as such.
(list (region-beginning) (region-end)
nil (match-string 1 region))
;; Region doesn't contain a URL, so use it as text.
(list (region-beginning) (region-end)
region nil))))
(let* ((used-uris (gemini-get-used-uris))
(uri (completing-read "URL: "
used-uris nil nil uri))
(text (completing-read "Link text (blank for plain URL): "
nil nil nil text)))
(when (and begin end)
(delete-region begin end))
(insert "=> " uri)
(unless (string= text "")
(insert " " text)))))
(defun gemini-insert-list-item ()
"Insert a new list item.
If at the beginning of a line, just insert it. Otherwise
go to the end of the current line, insert a newline, and
insert a list item."
(interactive)
(if (equal (line-beginning-position) (point))
(insert "* ")
(end-of-line)
(newline)
(insert "* ")))
(defun gemini-link-at-point ()
"Return the link present on the line at point."
(let ((line (thing-at-point 'line t)))
(when (string-match gemini-regex-link-line line)
(match-string 1 line))))
(defun gemini-open-link-at-point ()
"Open the link at point with elpher if it is installed."
(interactive)
(let ((link (gemini-link-at-point)))
(when link
(cond ((string-prefix-p "gemini://" link t)
(when (require 'elpher nil t)
(elpher-go link)))
((file-exists-p link)
(find-file link))
((string-match "https?://" link)
(browse-url link))
(t (error "Don't know what to do with %s" link))))))
(defun gemini-font-lock-extend-region-for-preformatted-blocks ()
"Extend the current font-lock focus to allow preformatted block discovering."
(save-excursion
(let (block-start block-end)
(goto-char font-lock-beg)
(end-of-line)
(when (re-search-backward "^```.*$" nil t)
(setq block-start (match-beginning 0))
(unless (eq block-start (point-min))
(setq block-start (1- block-start))))
(goto-char font-lock-end)
(beginning-of-line)
(when (re-search-forward "^```$" nil t)
(setq block-end (match-end 0))
(unless (eq block-end (point-max))
(setq block-end (1+ block-end))))
(when (and block-start block-end)
(setq font-lock-beg block-start
font-lock-end block-end)))))
(defun turn-on-visual-fill-column-mode nil
(require 'visual-fill-column)
(visual-fill-column-mode 1))
;;;###autoload
(define-derived-mode gemini-mode text-mode "gemini"
"Major mode for editing text/gemini 'geminimap' documents"
(setq font-lock-defaults '(gemini-highlights))
(add-hook 'font-lock-extend-region-functions
#'gemini-font-lock-extend-region-for-preformatted-blocks)
(visual-line-mode 1)
(run-hooks 'gemini-mode-hook))
;;;###autoload
(progn
(add-to-list 'auto-mode-alist '("\\.gmi\\'" . gemini-mode))
(add-to-list 'auto-mode-alist '("\\.gemini\\'" . gemini-mode))
(add-to-list 'auto-mode-alist '("\\.geminimap\\'" . gemini-mode)))
(provide 'gemini-mode)
;;; gemini-mode.el ends here

BIN
elpa/gemini-mode-20210226.1419/gemini-mode.elc Normal file
View File

Binary file not shown.

18
elpa/jabber-20180927.2325/dir Normal file
View File

@ -0,0 +1,18 @@
This is the file .../info/dir, which contains the
topmost node of the Info hierarchy, called (dir)Top.
The first time you invoke Info you start off looking at this node.

File: dir, Node: Top This is the top of the INFO tree
This (the Directory node) gives a menu of major topics.
Typing "q" exits, "H" lists all Info commands, "d" returns here,
"h" gives a primer for first-timers,
"mEmacs<Return>" visits the Emacs manual, etc.
In Emacs, you can click mouse button 2 on a menu item or cross reference
to select it.
* Menu:
Emacs
* jabber.el: (jabber). Emacs XMPP (Jabber) client

439
elpa/jabber-20180927.2325/jabber-activity.el Normal file
View File

@ -0,0 +1,439 @@
;;; jabber-activity.el --- show jabber activity in the mode line
;; Copyright (C) 2004 Carl Henrik Lunde - <chlunde+jabber+@ping.uio.no>
;; This file is a part of jabber.el
;; This program 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 2, 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Allows tracking messages from buddies using the global mode line
;; See (info "(jabber)Tracking activity")
;;; TODO:
;; - Make it possible to enable this mode using M-x customize
;; - When Emacs is on another desktop, (get-buffer-window buf 'visible)
;; returns nil. We need to know when the user selects the frame again
;; so we can remove the string from the mode line. (Or just run
;; jabber-activity-clean often).
;; - jabber-activity-switch-to needs a keybinding. In which map?
;; - Is there any need for having defcustom jabber-activity-make-string?
;; - When there's activity in a buffer it would be nice with a hook which
;; does the opposite of bury-buffer, so switch-to-buffer will show that
;; buffer first.
;;; Code:
(require 'jabber-core)
(require 'jabber-alert)
(require 'jabber-util)
(require 'jabber-muc-nick-completion) ;we need jabber-muc-looks-like-personal-p
(require 'cl)
(defgroup jabber-activity nil
"activity tracking options"
:group 'jabber)
;; All the (featurep 'jabber-activity) is so we don't call a function
;; with an autoloaded cookie while the file is loading, since that
;; would lead to endless load recursion.
(defcustom jabber-activity-make-string 'jabber-activity-make-string-default
"Function to call, for making the string to put in the mode
line. The default function returns the nick of the user."
:set #'(lambda (var val)
(custom-set-default var val)
(when (and (featurep 'jabber-activity)
(fboundp 'jabber-activity-make-name-alist))
(jabber-activity-make-name-alist)
(jabber-activity-mode-line-update)))
:type 'function
:group 'jabber-activity)
(defcustom jabber-activity-shorten-minimum 1
"All strings returned by `jabber-activity-make-strings-shorten' will be
at least this long, when possible."
:group 'jabber-activity
:type 'number)
(defcustom jabber-activity-make-strings 'jabber-activity-make-strings-default
"Function which should return an alist of JID -> string when given a list of
JIDs."
:set #'(lambda (var val)
(custom-set-default var val)
(when (and (featurep 'jabber-activity)
(fboundp 'jabber-activity-make-name-alist))
(jabber-activity-make-name-alist)
(jabber-activity-mode-line-update)))
:type '(choice (function-item :tag "Keep strings"
:value jabber-activity-make-strings-default)
(function-item :tag "Shorten strings"
:value jabber-activity-make-strings-shorten)
(function :tag "Other function"))
:group 'jabber-activity)
(defcustom jabber-activity-count-in-title nil
"If non-nil, display number of active JIDs in frame title."
:type 'boolean
:group 'jabber-activity
:set #'(lambda (var val)
(custom-set-default var val)
(when (and (featurep 'jabber-activity)
(bound-and-true-p jabber-activity-mode))
(jabber-activity-mode -1)
(jabber-activity-mode 1))))
(defcustom jabber-activity-count-in-title-format
'(jabber-activity-jids ("[" jabber-activity-count-string "] "))
"Format string used for displaying activity in frame titles.
Same syntax as `mode-line-format'."
:type 'sexp
:group 'jabber-activity
:set #'(lambda (var val)
(if (not (and (featurep 'jabber-activity) (bound-and-true-p jabber-activity-mode)))
(custom-set-default var val)
(jabber-activity-mode -1)
(custom-set-default var val)
(jabber-activity-mode 1))))
(defcustom jabber-activity-show-p 'jabber-activity-show-p-default
"Predicate function to call to check if the given JID should be
shown in the mode line or not."
:type 'function
:group 'jabber-activity)
(defcustom jabber-activity-query-unread t
"Query the user as to whether killing Emacs should be cancelled when
there are unread messages which otherwise would be lost."
:type 'boolean
:group 'jabber-activity)
(defcustom jabber-activity-banned nil
"List of regexps of banned JID"
:type '(repeat string)
:group 'jabber-activity)
(defface jabber-activity-face
'((t (:foreground "red" :weight bold)))
"The face for displaying jabber-activity-string in the mode line"
:group 'jabber-activity)
(defface jabber-activity-personal-face
'((t (:foreground "blue" :weight bold)))
"The face for displaying personal jabber-activity-string in the mode line"
:group 'jabber-activity)
(defvar jabber-activity-jids nil
"A list of JIDs which have caused activity")
(defvar jabber-activity-personal-jids nil
"Subset of `jabber-activity-jids' for JIDs with \"personal\" activity.")
(defvar jabber-activity-name-alist nil
"Alist of mode line names for bare JIDs")
(defvar jabber-activity-mode-string ""
"The mode string for jabber activity")
(defvar jabber-activity-count-string "0"
"Number of active JIDs as a string.")
(defvar jabber-activity-update-hook nil
"Hook called when `jabber-activity-jids' changes.
It is called after `jabber-activity-mode-string' and
`jabber-activity-count-string' are updated.")
;; Protect this variable from being set in Local variables etc.
(put 'jabber-activity-mode-string 'risky-local-variable t)
(put 'jabber-activity-count-string 'risky-local-variable t)
(defun jabber-activity-make-string-default (jid)
"Return the nick of the JID. If no nick is available, return
the user name part of the JID. In private MUC conversations,
return the user's nickname."
(if (jabber-muc-sender-p jid)
(jabber-jid-resource jid)
(let ((nick (jabber-jid-displayname jid))
(user (jabber-jid-user jid))
(username (jabber-jid-username jid)))
(if (and username (string= nick user))
username
nick))))
(defun jabber-activity-make-strings-default (jids)
"Apply `jabber-activity-make-string' on JIDS"
(mapcar #'(lambda (jid) (cons jid (funcall jabber-activity-make-string jid)))
jids))
(defun jabber-activity-common-prefix (s1 s2)
"Return length of common prefix string shared by S1 and S2"
(let ((len (min (length s1) (length s2))))
(or (dotimes (i len)
(when (not (eq (aref s1 i) (aref s2 i)))
(return i)))
;; Substrings, equal, nil, or empty ("")
len)))
(defun jabber-activity-make-strings-shorten (jids)
"Return an alist of JID -> names acquired by running
`jabber-activity-make-string' on JIDS, and then shortening the names
as much as possible such that all strings still are unique and at
least `jabber-activity-shorten-minimum' long."
(let ((alist
(sort (mapcar
#'(lambda (x) (cons x (funcall jabber-activity-make-string x)))
jids)
#'(lambda (x y) (string-lessp (cdr x) (cdr y))))))
(loop for ((prev-jid . prev) (cur-jid . cur) (next-jid . next))
on (cons nil alist)
until (null cur)
collect
(cons
cur-jid
(substring
cur
0 (min (length cur)
(max jabber-activity-shorten-minimum
(1+ (jabber-activity-common-prefix cur prev))
(1+ (jabber-activity-common-prefix cur next)))))))))
(defun jabber-activity-find-buffer-name (jid)
"Find the name of the buffer that messages from JID would use."
(or (and (jabber-jid-resource jid)
(get-buffer (jabber-muc-private-get-buffer
(jabber-jid-user jid)
(jabber-jid-resource jid))))
(get-buffer (jabber-chat-get-buffer jid))
(get-buffer (jabber-muc-get-buffer jid))))
(defun jabber-activity-show-p-default (jid)
"Returns t only if there is an invisible buffer for JID
and JID not in jabber-activity-banned"
(let ((buffer (jabber-activity-find-buffer-name jid)))
(and (buffer-live-p buffer)
(not (get-buffer-window buffer 'visible))
(not (dolist (entry jabber-activity-banned)
(when (string-match entry jid)
(return t)))))))
(defun jabber-activity-make-name-alist ()
"Rebuild `jabber-activity-name-alist' based on currently known JIDs"
(let ((jids (or (mapcar #'car jabber-activity-name-alist)
(mapcar #'symbol-name *jabber-roster*))))
(setq jabber-activity-name-alist
(funcall jabber-activity-make-strings jids))))
(defun jabber-activity-lookup-name (jid)
"Lookup name in `jabber-activity-name-alist', creates an entry
if needed, and returns a (jid . string) pair suitable for the mode line"
(let ((elm (assoc jid jabber-activity-name-alist)))
(if elm
elm
(progn
;; Remake alist with the new JID
(setq jabber-activity-name-alist
(funcall jabber-activity-make-strings
(cons jid (mapcar #'car jabber-activity-name-alist))))
(jabber-activity-lookup-name jid)))))
(defun jabber-activity-mode-line-update ()
"Update the string shown in the mode line using `jabber-activity-make-string'
on JIDs where `jabber-activity-show-p'. Optional not-nil GROUP mean that message come from MUC.
Optional TEXT used with one-to-one or MUC chats and may be used to identify personal MUC message.
Optional PRESENCE mean personal presence request or alert."
(setq jabber-activity-mode-string
(if jabber-activity-jids
(mapconcat
(lambda (x)
(let ((jump-to-jid (car x)))
(jabber-propertize
(cdr x)
'face (if (member jump-to-jid jabber-activity-personal-jids)
'jabber-activity-personal-face
'jabber-activity-face)
;; XXX: XEmacs doesn't have make-mode-line-mouse-map.
;; Is there another way to make this work?
'local-map (when (fboundp 'make-mode-line-mouse-map)
(make-mode-line-mouse-map
'mouse-1 `(lambda ()
(interactive "@")
(jabber-activity-switch-to
,(car x)))))
'help-echo (concat "Jump to "
(jabber-jid-displayname (car x))
"'s buffer"))))
(mapcar #'jabber-activity-lookup-name
jabber-activity-jids)
",")
""))
(setq jabber-activity-count-string
(number-to-string (length jabber-activity-jids)))
(force-mode-line-update 'all)
(run-hooks 'jabber-activity-update-hook))
;;; Hooks
(defun jabber-activity-clean ()
"Remove JIDs where `jabber-activity-show-p' no longer is true"
(setq jabber-activity-jids (delete-if-not jabber-activity-show-p
jabber-activity-jids))
(setq jabber-activity-personal-jids
(delete-if-not jabber-activity-show-p
jabber-activity-personal-jids))
(jabber-activity-mode-line-update))
(defun jabber-activity-add (from buffer text proposed-alert)
"Add a JID to mode line when `jabber-activity-show-p'"
(when (funcall jabber-activity-show-p from)
(add-to-list 'jabber-activity-jids from)
(add-to-list 'jabber-activity-personal-jids from)
(jabber-activity-mode-line-update)))
(defun jabber-activity-add-muc (nick group buffer text proposed-alert)
"Add a JID to mode line when `jabber-activity-show-p'"
(when (funcall jabber-activity-show-p group)
(add-to-list 'jabber-activity-jids group)
(when (jabber-muc-looks-like-personal-p text group)
(add-to-list 'jabber-activity-personal-jids group))
(jabber-activity-mode-line-update)))
(defun jabber-activity-presence (who oldstatus newstatus statustext proposed-alert)
"Add a JID to mode line on subscription requests."
(when (string= newstatus "subscribe")
(add-to-list 'jabber-activity-jids (symbol-name who))
(add-to-list 'jabber-activity-personal-jids (symbol-name who))
(jabber-activity-mode-line-update)))
(defun jabber-activity-kill-hook ()
"Query the user as to whether killing Emacs should be cancelled
when there are unread messages which otherwise would be lost, if
`jabber-activity-query-unread' is t"
(if (and jabber-activity-jids
jabber-activity-query-unread)
(or jabber-silent-mode (yes-or-no-p
"You have unread Jabber messages, are you sure you want to quit?"))
t))
;;; Interactive functions
(defvar jabber-activity-last-buffer nil
"Last non-Jabber buffer used.")
(defun jabber-activity-switch-to (&optional jid-param)
"If JID-PARAM is provided, switch to that buffer. If JID-PARAM is nil and
there has been activity in another buffer, switch to that buffer. If no such
buffer exists, switch back to the last non Jabber chat buffer used."
(interactive)
(if (or jid-param jabber-activity-jids)
(let ((jid (or jid-param (car jabber-activity-jids))))
(unless (eq major-mode 'jabber-chat-mode)
(setq jabber-activity-last-buffer (current-buffer)))
(switch-to-buffer (jabber-activity-find-buffer-name jid))
(jabber-activity-clean))
(if (eq major-mode 'jabber-chat-mode)
;; Switch back to the buffer used last
(when (buffer-live-p jabber-activity-last-buffer)
(switch-to-buffer jabber-activity-last-buffer))
(message "No new activity"))))
(defvar jabber-activity-idle-timer nil "Idle timer used for activity cleaning")
;;;###autoload
(define-minor-mode jabber-activity-mode
"Toggle display of activity in hidden jabber buffers in the mode line.
With a numeric arg, enable this display if arg is positive."
:global t
:group 'jabber-activity
:init-value t
(if jabber-activity-mode
(progn
;; XEmacs compatibilty hack from erc-track
(if (featurep 'xemacs)
(defadvice switch-to-buffer (after jabber-activity-update (&rest args) activate)
(jabber-activity-clean))
(add-hook 'window-configuration-change-hook
'jabber-activity-clean))
(add-hook 'jabber-message-hooks
'jabber-activity-add)
(add-hook 'jabber-muc-hooks
'jabber-activity-add-muc)
(add-hook 'jabber-presence-hooks
'jabber-activity-presence)
(setq jabber-activity-idle-timer (run-with-idle-timer 2 t 'jabber-activity-clean))
;; XXX: reactivate
;; (add-hook 'jabber-post-connect-hooks
;; 'jabber-activity-make-name-alist)
(add-to-list 'kill-emacs-query-functions
'jabber-activity-kill-hook)
(add-to-list 'global-mode-string
'(t jabber-activity-mode-string))
(when jabber-activity-count-in-title
;; Be careful not to override specific meanings of the
;; existing title format. In particular, if the car is
;; a symbol, we can't just add our stuff at the beginning.
;; If the car is "", we should be safe.
;;
;; In my experience, sometimes the activity count gets
;; included twice in the title. I'm not sure exactly why,
;; but it would be nice to replace the code below with
;; something cleaner.
(if (equal (car-safe frame-title-format) "")
(add-to-list 'frame-title-format
jabber-activity-count-in-title-format)
(setq frame-title-format (list ""
jabber-activity-count-in-title-format
frame-title-format)))
(if (equal (car-safe icon-title-format) "")
(add-to-list 'icon-title-format
jabber-activity-count-in-title-format)
(setq icon-title-format (list ""
jabber-activity-count-in-title-format
icon-title-format)))))
(progn
(if (featurep 'xemacs)
(ad-disable-advice 'switch-to-buffer 'after 'jabber-activity-update)
(remove-hook 'window-configuration-change-hook
'jabber-activity-remove-visible))
(remove-hook 'jabber-message-hooks
'jabber-activity-add)
(remove-hook 'jabber-muc-hooks
'jabber-activity-add-muc)
(remove-hook 'jabber-presence-hooks
'jabber-activity-presence)
(ignore-errors (cancel-timer jabber-activity-idle-timer))
;; XXX: reactivate
;; (remove-hook 'jabber-post-connect-hooks
;; 'jabber-activity-make-name-alist)
(setq global-mode-string (delete '(t jabber-activity-mode-string)
global-mode-string))
(when (listp frame-title-format)
(setq frame-title-format
(delete jabber-activity-count-in-title-format
frame-title-format)))
(when (listp icon-title-format)
(setq icon-title-format
(delete jabber-activity-count-in-title-format
icon-title-format))))))
;; XXX: define-minor-mode should probably do this for us, but it doesn't.
(if jabber-activity-mode (jabber-activity-mode 1))
(provide 'jabber-activity)
;; arch-tag: 127D7E42-356B-11D9-BE1E-000A95C2FCD0

107
elpa/jabber-20180927.2325/jabber-ahc-presence.el Normal file
View File

@ -0,0 +1,107 @@
;; jabber-ahc-presence.el - provide remote control of presence
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-ahc)
(defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status"
"Node used by jabber-ahc-presence")
(jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence
'jabber-my-jid-p)
(defun jabber-ahc-presence (jc xml-data)
"Process presence change command."
(let* ((query (jabber-iq-query xml-data))
(sessionid (jabber-xml-get-attribute query 'sessionid))
(action (jabber-xml-get-attribute query 'action)))
;; No session state is kept; instead, lack of session-id is used
;; as indication of first command.
(cond
;; command cancelled
((string= action "cancel")
`(command ((xmlns . "http://jabber.org/protocol/commands")
(sessionid . ,sessionid)
(node . ,jabber-ahc-presence-node)
(status . "canceled"))))
;; return form
((null sessionid)
`(command ((xmlns . "http://jabber.org/protocol/commands")
(sessionid . "jabber-ahc-presence")
(node . ,jabber-ahc-presence-node)
(status . "executing"))
(x ((xmlns . "jabber:x:data")
(type . "form"))
(title nil ,(format "Set presence of %s" (jabber-connection-jid jc)))
(instructions nil "Select new presence status.")
(field ((var . "FORM_TYPE") (type . "hidden"))
(value nil "http://jabber.org/protocol/rc"))
(field ((var . "status")
(label . "Status")
(type . "list-single"))
(value nil ,(if (string= *jabber-current-show* "")
"online"
*jabber-current-show*))
(option ((label . "Online")) (value nil "online"))
(option ((label . "Chatty")) (value nil "chat"))
(option ((label . "Away")) (value nil "away"))
(option ((label . "Extended away")) (value nil "xa"))
(option ((label . "Do not disturb")) (value nil "dnd")))
(field ((var . "status-message")
(label . "Message")
(type . "text-single"))
(value nil ,*jabber-current-status*))
(field ((var . "status-priority")
(label . "Priority")
(type . "text-single"))
(value nil ,(int-to-string *jabber-current-priority*))))))
;; process form
(t
(let* ((x (car (jabber-xml-get-children query 'x)))
;; we assume that the first <x/> is the jabber:x:data one
(fields (jabber-xml-get-children x 'field))
(new-show *jabber-current-show*)
(new-status *jabber-current-status*)
(new-priority *jabber-current-priority*))
(dolist (field fields)
(let ((var (jabber-xml-get-attribute field 'var))
;; notice that multi-value fields won't be handled properly
;; by this
(value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))
(cond
((string= var "status")
(setq new-show (if (string= value "online")
""
value)))
((string= var "status-message")
(setq new-status value))
((string= var "status-priority")
(setq new-priority (string-to-number value))))))
(jabber-send-presence new-show new-status new-priority))
`(command ((xmlns . "http://jabber.org/protocol/commands")
(sessionid . ,sessionid)
(node . ,jabber-ahc-presence-node)
(status . "completed"))
(note ((type . "info")) "Presence has been changed."))))))
(provide 'jabber-ahc-presence)
;;; arch-tag: 4b8cbbe7-00a9-4d42-a4ac-b824ab914fba

231
elpa/jabber-20180927.2325/jabber-ahc.el Normal file
View File

@ -0,0 +1,231 @@
;; jabber-ahc.el - Ad-Hoc Commands by JEP-0050
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-disco)
(require 'jabber-widget)
(defvar jabber-ahc-sessionid nil
"session id of Ad-Hoc Command session")
(defvar jabber-ahc-node nil
"node to send commands to")
(defvar jabber-ahc-commands nil
"Commands provided
This is an alist, where the keys are node names as strings (which
means that they must not conflict). The values are plists having
following properties:
acl - function taking connection object and JID of requester,
returning non-nil for access allowed. No function means
open for everyone.
name - name of command
func - function taking connection object and entire IQ stanza as
arguments and returning a <command/> node
Use the function `jabber-ahc-add' to add a command to this list.")
;;; SERVER
(add-to-list 'jabber-disco-info-nodes
(list "http://jabber.org/protocol/commands"
'((identity ((category . "automation")
(type . "command-list")
(name . "Ad-Hoc Command list")))
(feature ((var . "http://jabber.org/protocol/commands")))
(feature ((var . "http://jabber.org/protocol/disco#items")))
(feature
((var . "http://jabber.org/protocol/disco#info"))))))
(defun jabber-ahc-add (node name func acl)
"Add a command to internal lists.
NODE is the node name to be used. It must be unique.
NAME is the natural-language name of the command.
FUNC is a function taking the entire IQ stanza as single argument when
this command is invoked, and returns a <command/> node.
ACL is a function taking JID as single argument, returning non-nil for
access allowed. nil means open for everyone."
(add-to-list 'jabber-ahc-commands (cons node (list 'name name
'func func
'acl acl)))
(add-to-list 'jabber-disco-info-nodes
(list node `((identity ((category . "automation")
(type . "command-node")
(name . ,name)))
(feature ((var . "http://jabber.org/protocol/commands")))
(feature ((var . "http://jabber.org/protocol/disco#info")))
(feature ((var . "jabber:x:data")))))))
(jabber-disco-advertise-feature "http://jabber.org/protocol/commands")
(add-to-list 'jabber-disco-items-nodes
(list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil))
(defun jabber-ahc-disco-items (jc xml-data)
"Return commands in response to disco#items request"
(let ((jid (jabber-xml-get-attribute xml-data 'from)))
(mapcar (function
(lambda (command)
(let ((node (car command))
(plist (cdr command)))
(let ((acl (plist-get plist 'acl))
(name (plist-get plist 'name))
(func (plist-get plist 'func)))
(when (or (not (functionp acl))
(funcall acl jc jid))
`(item ((name . ,name)
(jid . ,(jabber-connection-jid jc))
(node . ,node))))))))
jabber-ahc-commands)))
(add-to-list 'jabber-iq-set-xmlns-alist
(cons "http://jabber.org/protocol/commands" 'jabber-ahc-process))
(defun jabber-ahc-process (jc xml-data)
(let ((to (jabber-xml-get-attribute xml-data 'from))
(id (jabber-xml-get-attribute xml-data 'id))
(node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)))
;; find command
(let* ((plist (cdr (assoc node jabber-ahc-commands)))
(acl (plist-get plist 'acl))
(func (plist-get plist 'func)))
(if plist
;; found
(if (or (not (functionp acl))
(funcall acl jc to))
;; access control passed
(jabber-send-iq jc to "result"
(funcall func jc xml-data)
nil nil nil nil id)
;; ...or failed
(jabber-signal-error "cancel" 'not-allowed))
;; No such node
(jabber-signal-error "cancel" 'item-not-found)))))
;;; CLIENT
(add-to-list 'jabber-jid-service-menu
(cons "Request command list" 'jabber-ahc-get-list))
(defun jabber-ahc-get-list (jc to)
"Request list of ad-hoc commands. (JEP-0050)"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Request command list from: " nil nil nil 'full t)))
(jabber-get-disco-items jc to "http://jabber.org/protocol/commands"))
(add-to-list 'jabber-jid-service-menu
(cons "Execute command" 'jabber-ahc-execute-command))
(defun jabber-ahc-execute-command (jc to node)
"Execute ad-hoc command. (JEP-0050)"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Execute command of: " nil nil nil 'full t)
(jabber-read-node "Node of command: ")))
(jabber-send-iq jc to
"set"
`(command ((xmlns . "http://jabber.org/protocol/commands")
(node . ,node)
(action . "execute")))
#'jabber-process-data #'jabber-ahc-display
#'jabber-process-data "Command execution failed"))
(defun jabber-ahc-display (jc xml-data)
(let* ((from (jabber-xml-get-attribute xml-data 'from))
(query (jabber-iq-query xml-data))
(node (jabber-xml-get-attribute query 'node))
(notes (jabber-xml-get-children query 'note))
(sessionid (jabber-xml-get-attribute query 'sessionid))
(status (jabber-xml-get-attribute query 'status))
(actions (car (jabber-xml-get-children query 'actions)))
xdata
(inhibit-read-only t))
(make-local-variable 'jabber-ahc-sessionid)
(setq jabber-ahc-sessionid sessionid)
(make-local-variable 'jabber-ahc-node)
(setq jabber-ahc-node node)
(make-local-variable 'jabber-buffer-connection)
(setq jabber-buffer-connection jc)
(dolist (x (jabber-xml-get-children query 'x))
(when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
(setq xdata x)))
(cond
((string= status "executing")
(insert "Executing command\n\n"))
((string= status "completed")
(insert "Command completed\n\n"))
((string= status "canceled")
(insert "Command canceled\n\n")))
(dolist (note notes)
(let ((note-type (jabber-xml-get-attribute note 'type)))
(cond
((string= note-type "warn")
(insert "Warning: "))
((string= note-type "error")
(insert "Error: ")))
(insert (car (jabber-xml-node-children note)) "\n")))
(insert "\n")
(when xdata
(jabber-init-widget-buffer from)
(let ((formtype (jabber-xml-get-attribute xdata 'type)))
(if (string= formtype "result")
(jabber-render-xdata-search-results xdata)
(jabber-render-xdata-form xdata)
(when (string= status "executing")
(let ((button-titles
(cond
((null actions)
'(complete cancel))
(t
(let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions)))
(default-action (jabber-xml-get-attribute actions 'execute)))
(if (or (null default-action) (memq (intern default-action) children))
children
(cons (intern default-action) children)))))))
(dolist (button-title button-titles)
(widget-create 'push-button :notify `(lambda (&rest ignore) (jabber-ahc-submit (quote ,button-title))) (symbol-name button-title))
(widget-insert "\t")))
(widget-insert "\n"))))
(widget-setup)
(widget-minor-mode 1))))
(defun jabber-ahc-submit (action)
"Submit Ad-Hoc Command."
(jabber-send-iq jabber-buffer-connection jabber-submit-to
"set"
`(command ((xmlns . "http://jabber.org/protocol/commands")
(sessionid . ,jabber-ahc-sessionid)
(node . ,jabber-ahc-node)
(action . ,(symbol-name action)))
,(if (and (not (eq action 'cancel))
(eq jabber-form-type 'xdata))
(jabber-parse-xdata-form)))
#'jabber-process-data #'jabber-ahc-display
#'jabber-process-data "Command execution failed"))
(provide 'jabber-ahc)
;;; arch-tag: c0d5ed8c-50cb-44e1-8e0f-4058b79ee353

514
elpa/jabber-20180927.2325/jabber-alert.el Normal file
View File

@ -0,0 +1,514 @@
;; jabber-alert.el - alert hooks
;; Copyright (C) 2003, 2004, 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-util)
(require 'cl)
(defgroup jabber-alerts nil "auditory and visual alerts for jabber events"
:group 'jabber)
(defcustom jabber-alert-message-hooks '(jabber-message-echo
jabber-message-scroll)
"Hooks run when a new message arrives.
Arguments are FROM, BUFFER, TEXT and TITLE. FROM is the JID of
the sender, BUFFER is the the buffer where the message can be
read, and TEXT is the text of the message. TITLE is the string
returned by `jabber-alert-message-function' for these arguments,
so that hooks do not have to call it themselves.
This hook is meant for user customization of message alerts. For
other uses, see `jabber-message-hooks'."
:type 'hook
:options '(jabber-message-beep
jabber-message-wave
jabber-message-echo
jabber-message-switch
jabber-message-display
jabber-message-scroll)
:group 'jabber-alerts)
(defvar jabber-message-hooks nil
"Internal hooks run when a new message arrives.
This hook works just like `jabber-alert-message-hooks', except that
it's not meant to be customized by the user.")
(defcustom jabber-alert-message-function
'jabber-message-default-message
"Function for constructing short message alert messages.
Arguments are FROM, BUFFER, and TEXT. This function should return a
string containing an appropriate text message, or nil if no message
should be displayed.
The provided hooks displaying a text message get it from this function,
and show no message if it returns nil. Other hooks do what they do
every time."
:type 'function
:group 'jabber-alerts)
(defcustom jabber-alert-muc-hooks '(jabber-muc-echo jabber-muc-scroll)
"Hooks run when a new MUC message arrives.
Arguments are NICK, GROUP, BUFFER, TEXT and TITLE. NICK is the
nickname of the sender. GROUP is the JID of the group. BUFFER
is the the buffer where the message can be read, and TEXT is the
text of the message. TITLE is the string returned by
`jabber-alert-muc-function' for these arguments, so that hooks do
not have to call it themselves."
:type 'hook
:options '(jabber-muc-beep
jabber-muc-wave
jabber-muc-echo
jabber-muc-switch
jabber-muc-display
jabber-muc-scroll)
:group 'jabber-alerts)
(defvar jabber-muc-hooks '()
"Internal hooks run when a new MUC message arrives.
This hook works just like `jabber-alert-muc-hooks', except that
it's not meant to be customized by the user.")
(defcustom jabber-alert-muc-function
'jabber-muc-default-message
"Function for constructing short message alert messages.
Arguments are NICK, GROUP, BUFFER, and TEXT. This function
should return a string containing an appropriate text message, or
nil if no message should be displayed.
The provided hooks displaying a text message get it from this function,
and show no message if it returns nil. Other hooks do what they do
every time."
:type 'function
:group 'jabber-alerts)
(defcustom jabber-alert-presence-hooks
'(jabber-presence-echo)
"Hooks run when a user's presence changes.
Arguments are WHO, OLDSTATUS, NEWSTATUS, STATUSTEXT and
PROPOSED-ALERT. WHO is a symbol whose text is the JID of the contact,
and which has various interesting properties. OLDSTATUS is the old
presence or nil if disconnected. NEWSTATUS is the new presence, or
one of \"subscribe\", \"unsubscribe\", \"subscribed\" and
\"unsubscribed\". TITLE is the string returned by
`jabber-alert-presence-message-function' for these arguments."
:type 'hook
:options '(jabber-presence-beep
jabber-presence-wave
jabber-presence-switch
jabber-presence-display
jabber-presence-echo)
:group 'jabber-alerts)
(defvar jabber-presence-hooks '(jabber-presence-watch)
"Internal hooks run when a user's presence changes.
This hook works just like `jabber-alert-presence-hooks', except that
it's not meant to be customized by the user.")
(defcustom jabber-alert-presence-message-function
'jabber-presence-default-message
"Function for constructing title of presence alert messages.
Arguments are WHO, OLDSTATUS, NEWSTATUS and STATUSTEXT. See
`jabber-alert-presence-hooks' for documentation. This function
should return a string containing an appropriate text message, or nil
if no message should be displayed.
The provided hooks displaying a text message get it from this function.
All hooks refrain from action if this function returns nil."
:type 'function
:group 'jabber-alerts)
(defcustom jabber-alert-info-message-hooks '(jabber-info-display jabber-info-echo)
"Hooks run when an info request is completed.
First argument is WHAT, a symbol telling the kind of info request completed.
That might be 'roster, for requested roster updates, and 'browse, for
browse requests. Second argument in BUFFER, a buffer containing the result.
Third argument is PROPOSED-ALERT, containing the string returned by
`jabber-alert-info-message-function' for these arguments."
:type 'hook
:options '(jabber-info-beep
jabber-info-wave
jabber-info-echo
jabber-info-switch
jabber-info-display)
:group 'jabber-alerts)
(defvar jabber-info-message-hooks '()
"Internal hooks run when an info request is completed.
This hook works just like `jabber-alert-info-message-hooks',
except that it's not meant to be customized by the user.")
(defcustom jabber-alert-info-message-function
'jabber-info-default-message
"Function for constructing info alert messages.
Arguments are WHAT, a symbol telling the kind of info request completed,
and BUFFER, a buffer containing the result."
:type 'function
:group 'jabber-alerts)
(defcustom jabber-info-message-alist
'((roster . "Roster display updated")
(browse . "Browse request completed"))
"Alist for info alert messages, used by `jabber-info-default-message'."
:type '(alist :key-type symbol :value-type string
:options (roster browse))
:group 'jabber-alerts)
(defcustom jabber-alert-message-wave ""
"A sound file to play when a message arrived.
See `jabber-alert-message-wave-alist' if you want other sounds
for specific contacts."
:type 'file
:group 'jabber-alerts)
(defcustom jabber-alert-message-wave-alist nil
"Specific sound files for messages from specific contacts.
The keys are regexps matching the JID, and the values are sound
files."
:type '(alist :key-type regexp :value-type file)
:group 'jabber-alerts)
(defcustom jabber-alert-muc-wave ""
"a sound file to play when a MUC message arrived"
:type 'file
:group 'jabber-alerts)
(defcustom jabber-alert-presence-wave ""
"a sound file to play when a presence arrived"
:type 'file
:group 'jabber-alerts)
(defcustom jabber-alert-presence-wave-alist nil
"Specific sound files for presence from specific contacts.
The keys are regexps matching the JID, and the values are sound
files."
:type '(alist :key-type regexp :value-type file)
:group 'jabber-alerts)
(defcustom jabber-alert-info-wave ""
"a sound file to play when an info query result arrived"
:type 'file
:group 'jabber-alerts)
(defcustom jabber-play-sound-file 'play-sound-file
"a function to call to play alert sound files"
:type 'function
:group 'jabber-alerts)
(defmacro define-jabber-alert (name docstring function)
"Define a new family of external alert hooks.
Use this macro when your hooks do nothing except displaying a string
in some new innovative way. You write a string display function, and
this macro does all the boring and repetitive work.
NAME is the name of the alert family. The resulting hooks will be
called jabber-{message,muc,presence,info}-NAME.
DOCSTRING is the docstring to use for those hooks.
FUNCTION is a function that takes one argument, a string,
and displays it in some meaningful way. It can be either a
lambda form or a quoted function name.
The created functions are inserted as options in Customize.
Examples:
\(define-jabber-alert foo \"Send foo alert\" 'foo-message)
\(define-jabber-alert bar \"Send bar alert\"
(lambda (msg) (bar msg 42)))"
(let ((sn (symbol-name name)))
(let ((msg (intern (format "jabber-message-%s" sn)))
(muc (intern (format "jabber-muc-%s" sn)))
(pres (intern (format "jabber-presence-%s" sn)))
(info (intern (format "jabber-info-%s" sn))))
`(progn
(defun ,msg (from buffer text title)
,docstring
(when title
(funcall ,function text title)))
(pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options))
(defun ,muc (nick group buffer text title)
,docstring
(when title
(funcall ,function text title)))
(pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options))
(defun ,pres (who oldstatus newstatus statustext title)
,docstring
(when title
(funcall ,function statustext title)))
(pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options))
(defun ,info (infotype buffer text)
,docstring
(when text
(funcall ,function text)))
(pushnew (quote ,info) (get 'jabber-alert-info-message-hooks 'custom-options))))))
;; Alert hooks
(define-jabber-alert echo "Show a message in the echo area"
(lambda (text &optional title) (message "%s" (or title text))))
(define-jabber-alert beep "Beep on event"
(lambda (&rest ignore) (beep)))
;; Message alert hooks
(defun jabber-message-default-message (from buffer text)
(when (or jabber-message-alert-same-buffer
(not (memq (selected-window) (get-buffer-window-list buffer))))
(if (jabber-muc-sender-p from)
(format "Private message from %s in %s"
(jabber-jid-resource from)
(jabber-jid-displayname (jabber-jid-user from)))
(format "Message from %s" (jabber-jid-displayname from)))))
(defcustom jabber-message-alert-same-buffer t
"If nil, don't display message alerts for the current buffer."
:type 'boolean
:group 'jabber-alerts)
(defcustom jabber-muc-alert-self nil
"If nil, don't display MUC alerts for your own messages."
:type 'boolean
:group 'jabber-alerts)
(defun jabber-message-wave (from buffer text title)
"Play the wave file specified in `jabber-alert-message-wave'"
(when title
(let* ((case-fold-search t)
(bare-jid (jabber-jid-user from))
(sound-file (or (dolist (entry jabber-alert-message-wave-alist)
(when (string-match (car entry) bare-jid)
(return (cdr entry))))
jabber-alert-message-wave)))
(unless (equal sound-file "")
(funcall jabber-play-sound-file sound-file)))))
(defun jabber-message-display (from buffer text title)
"Display the buffer where a new message has arrived."
(when title
(display-buffer buffer)))
(defun jabber-message-switch (from buffer text title)
"Switch to the buffer where a new message has arrived."
(when title
(switch-to-buffer buffer)))
(defun jabber-message-scroll (from buffer text title)
"Scroll all nonselected windows where the chat buffer is displayed."
;; jabber-chat-buffer-display will DTRT with point in the buffer.
;; But this change will not take effect in nonselected windows.
;; Therefore we do that manually here.
;;
;; There are three cases:
;; 1. The user started typing a message in this window. Point is
;; greater than jabber-point-insert. In that case, we don't
;; want to move point.
;; 2. Point was at the end of the buffer, but no message was being
;; typed. After displaying the message, point is now close to
;; the end of the buffer. We advance it to the end.
;; 3. The user was perusing history in this window. There is no
;; simple way to distinguish this from 2, so the user loses.
(let ((windows (get-buffer-window-list buffer nil t))
(new-point-max (with-current-buffer buffer (point-max))))
(dolist (w windows)
(unless (eq w (selected-window))
(set-window-point w new-point-max)))))
;; MUC alert hooks
(defun jabber-muc-default-message (nick group buffer text)
(when (or jabber-message-alert-same-buffer
(not (memq (selected-window) (get-buffer-window-list buffer))))
(if nick
(when (or jabber-muc-alert-self
(not (string= nick (cdr (assoc group *jabber-active-groupchats*)))))
(format "Message from %s in %s" nick (jabber-jid-displayname
group)))
(format "Message in %s" (jabber-jid-displayname group)))))
(defun jabber-muc-wave (nick group buffer text title)
"Play the wave file specified in `jabber-alert-muc-wave'"
(when title
(funcall jabber-play-sound-file jabber-alert-muc-wave)))
(defun jabber-muc-display (nick group buffer text title)
"Display the buffer where a new message has arrived."
(when title
(display-buffer buffer)))
(defun jabber-muc-switch (nick group buffer text title)
"Switch to the buffer where a new message has arrived."
(when title
(switch-to-buffer buffer)))
(defun jabber-muc-scroll (nick group buffer text title)
"Scroll buffer even if it is in an unselected window."
(jabber-message-scroll nil buffer nil nil))
;; Presence alert hooks
(defun jabber-presence-default-message (who oldstatus newstatus statustext)
"This function returns nil if OLDSTATUS and NEWSTATUS are equal, and in other
cases a string of the form \"'name' (jid) is now NEWSTATUS (STATUSTEXT)\".
This function is not called directly, but is the default for
`jabber-alert-presence-message-function'."
(cond
((equal oldstatus newstatus)
nil)
(t
(let ((formattedname
(if (> (length (get who 'name)) 0)
(get who 'name)
(symbol-name who)))
(formattedstatus
(or
(cdr (assoc newstatus
'(("subscribe" . " requests subscription to your presence")
("subscribed" . " has granted presence subscription to you")
("unsubscribe" . " no longer subscribes to your presence")
("unsubscribed" . " cancels your presence subscription"))))
(concat " is now "
(or
(cdr (assoc newstatus jabber-presence-strings))
newstatus)))))
(concat formattedname formattedstatus)))))
(defun jabber-presence-only-chat-open-message (who oldstatus newstatus statustext)
"This function returns the same as `jabber-presence-default-message' but only
if there is a chat buffer open for WHO, keeping the amount of presence messages
at a more manageable level when there are lots of users.
This function is not called directly, but can be used as the value for
`jabber-alert-presence-message-function'."
(when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))
(jabber-presence-default-message who oldstatus newstatus statustext)))
(defun jabber-presence-wave (who oldstatus newstatus statustext proposed-alert)
"Play the wave file specified in `jabber-alert-presence-wave'"
(when proposed-alert
(let* ((case-fold-search t)
(bare-jid (symbol-name who))
(sound-file (or (dolist (entry jabber-alert-presence-wave-alist)
(when (string-match (car entry) bare-jid)
(return (cdr entry))))
jabber-alert-presence-wave)))
(unless (equal sound-file "")
(funcall jabber-play-sound-file sound-file)))))
;; This is now defined in jabber-roster.el.
;; (defun jabber-presence-update-roster (who oldstatus newstatus statustext proposed-alert)
;; "Update the roster display by calling `jabber-display-roster'"
;; (jabber-display-roster))
(defun jabber-presence-display (who oldstatus newstatus statustext proposed-alert)
"Display the roster buffer"
(when proposed-alert
(display-buffer jabber-roster-buffer)))
(defun jabber-presence-switch (who oldstatus newstatus statustext proposed-alert)
"Switch to the roster buffer"
(when proposed-alert
(switch-to-buffer jabber-roster-buffer)))
;;; Info alert hooks
(defun jabber-info-default-message (infotype buffer)
"Function for constructing info alert messages.
The argument is INFOTYPE, a symbol telling the kind of info request completed.
This function uses `jabber-info-message-alist' to find a message."
(concat (cdr (assq infotype jabber-info-message-alist))
" (buffer "(buffer-name buffer) ")"))
(defun jabber-info-wave (infotype buffer proposed-alert)
"Play the wave file specified in `jabber-alert-info-wave'"
(if proposed-alert
(funcall jabber-play-sound-file jabber-alert-info-wave)))
(defun jabber-info-display (infotype buffer proposed-alert)
"Display buffer of completed request"
(when proposed-alert
(display-buffer buffer)))
(defun jabber-info-switch (infotype buffer proposed-alert)
"Switch to buffer of completed request"
(when proposed-alert
(switch-to-buffer buffer)))
;;; Personal alert hooks
(defmacro define-personal-jabber-alert (name)
"From ALERT function, make ALERT-personal function. Makes sence only for MUC."
(let ((sn (symbol-name name)))
(let ((func (intern (format "%s-personal" sn))))
`(progn
(defun ,func (nick group buffer text title)
(if (jabber-muc-looks-like-personal-p text group)
(,name nick group buffer text title)))
(pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options)))))
)
(define-personal-jabber-alert jabber-muc-beep)
(define-personal-jabber-alert jabber-muc-wave)
(define-personal-jabber-alert jabber-muc-echo)
(define-personal-jabber-alert jabber-muc-switch)
(define-personal-jabber-alert jabber-muc-display)
(defcustom jabber-autoanswer-alist nil
"Specific phrases to autoanswer on specific message.
The keys are regexps matching the incoming message text, and the values are
autoanswer phrase."
:type '(alist :key-type regexp :value-type string)
:group 'jabber-alerts)
(defun jabber-autoanswer-answer (from buffer text proposed-alert)
"Answer automaticaly when incoming text matches first element
of `jabber-autoanswer-alist'"
(when (and from buffer text proposed-alert jabber-autoanswer-alist)
(let ((message
(dolist (entry jabber-autoanswer-alist)
(when (string-match (car entry) text)
(return (cdr entry))))))
(if message
(jabber-chat-send jabber-buffer-connection message)))
))
(pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options))
(defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert)
"Answer automaticaly when incoming text matches first element
of `jabber-autoanswer-alist'"
(when (and nick group buffer text proposed-alert jabber-autoanswer-alist)
(let ((message
(dolist (entry jabber-autoanswer-alist)
(when (string-match (car entry) text)
(return (cdr entry))))))
(if message
(jabber-chat-send jabber-buffer-connection message)))
))
(pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options))
(provide 'jabber-alert)
;;; arch-tag: 725bd73e-c613-4fdc-a11d-3392a7598d4f

BIN
elpa/jabber-20180927.2325/jabber-alert.elc Normal file
View File

Binary file not shown.

211
elpa/jabber-20180927.2325/jabber-autoaway.el Normal file
View File

@ -0,0 +1,211 @@
;;; jabber-autoaway.el --- change status to away after idleness
;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru
;; Copyright (C) 2010 - Terechkov Evgenii - evg@altlinux.org
;; Copyright (C) 2006, 2008 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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.
(eval-when-compile (require 'cl))
(require 'time-date)
(defgroup jabber-autoaway nil
"Change status to away after idleness"
:group 'jabber)
(defcustom jabber-autoaway-methods
(if (fboundp 'jabber-autoaway-method)
(list jabber-autoaway-method)
(list 'jabber-current-idle-time
'jabber-xprintidle-get-idle-time
'jabber-termatime-get-idle-time))
"Methods used to keep track of idleness.
This is a list of functions that takes no arguments, and returns the
number of seconds since the user was active, or nil on error."
:group 'jabber-autoaway
:options '(jabber-current-idle-time
jabber-xprintidle-get-idle-time
jabber-termatime-get-idle-time))
(defcustom jabber-autoaway-timeout 5
"Minutes of inactivity before changing status to away"
:group 'jabber-autoaway
:type 'number)
(defcustom jabber-autoaway-xa-timeout 10
"Minutes of inactivity before changing status to xa. Set to 0 to disable."
:group 'jabber-autoaway
:type 'number)
(defcustom jabber-autoaway-status "Idle"
"Status string for autoaway"
:group 'jabber-autoaway
:type 'string)
(defcustom jabber-autoaway-xa-status "Extended away"
"Status string for autoaway in xa state"
:group 'jabber-autoaway
:type 'string)
(defcustom jabber-autoaway-priority nil
"Priority for autoaway.
If nil, don't change priority. See the manual for more
information about priority."
:group 'jabber-autoaway
:type '(choice (const :tag "Don't change")
(integer :tag "Priority"))
:link '(info-link "(jabber)Presence"))
(defcustom jabber-autoaway-xa-priority nil
"Priority for autoaway in xa state.
If nil, don't change priority. See the manual for more
information about priority."
:group 'jabber-autoaway
:type '(choice (const :tag "Don't change")
(integer :tag "Priority"))
:link '(info-link "(jabber)Presence"))
(defcustom jabber-xprintidle-program (executable-find "xprintidle")
"Name of the xprintidle program"
:group 'jabber-autoaway
:type 'string)
(defcustom jabber-autoaway-verbose nil
"If nil, don't print autoaway status messages."
:group 'jabber-autoaway
:type 'boolean)
(defvar jabber-autoaway-timer nil)
(defvar jabber-autoaway-last-idle-time nil
"Seconds of idle time the last time we checked.
This is used to detect whether the user has become unidle.")
(defun jabber-autoaway-message (&rest args)
(when jabber-autoaway-verbose
(apply #'message args)))
;;;###autoload
(defun jabber-autoaway-start (&optional ignored)
"Start autoaway timer.
The IGNORED argument is there so you can put this function in
`jabber-post-connect-hooks'."
(interactive)
(unless jabber-autoaway-timer
(setq jabber-autoaway-timer
(run-with-timer (* jabber-autoaway-timeout 60) nil #'jabber-autoaway-timer))
(jabber-autoaway-message "Autoaway timer started")))
(defun jabber-autoaway-stop ()
"Stop autoaway timer."
(interactive)
(when jabber-autoaway-timer
(jabber-cancel-timer jabber-autoaway-timer)
(setq jabber-autoaway-timer nil)
(jabber-autoaway-message "Autoaway timer stopped")))
(defun jabber-autoaway-get-idle-time ()
"Get idle time in seconds according to jabber-autoaway-methods.
Return nil on error."
(car (sort (mapcar 'funcall jabber-autoaway-methods) (lambda (a b) (if a (if b (< a b) t) nil)))))
(defun jabber-autoaway-timer ()
;; We use one-time timers, so reset the variable.
(setq jabber-autoaway-timer nil)
(let ((idle-time (jabber-autoaway-get-idle-time)))
(when (numberp idle-time)
;; Has "idle timeout" passed?
(if (> idle-time (* 60 jabber-autoaway-timeout))
;; If so, mark ourselves idle.
(jabber-autoaway-set-idle)
;; Else, start a timer for the remaining amount.
(setq jabber-autoaway-timer
(run-with-timer (- (* 60 jabber-autoaway-timeout) idle-time)
nil #'jabber-autoaway-timer))))))
(defun jabber-autoaway-set-idle (&optional xa)
(jabber-autoaway-message "Autoaway triggered")
;; Send presence, unless the user has set a custom presence
(unless (member *jabber-current-show* '("xa" "dnd"))
(jabber-send-presence
(if xa "xa" "away")
(if (or (string= *jabber-current-status* jabber-default-status) (string= *jabber-current-status* jabber-autoaway-status)) (if xa jabber-autoaway-xa-status jabber-autoaway-status) *jabber-current-status*)
(or (if xa jabber-autoaway-priority jabber-autoaway-xa-priority) *jabber-current-priority*)))
(setq jabber-autoaway-last-idle-time (jabber-autoaway-get-idle-time))
;; Run unidle timer every 10 seconds (if xa specified, timer already running)
(unless xa
(setq jabber-autoaway-timer (run-with-timer 10 10
#'jabber-autoaway-maybe-unidle))))
(defun jabber-autoaway-maybe-unidle ()
(let ((idle-time (jabber-autoaway-get-idle-time)))
(jabber-autoaway-message "Idle for %d seconds" idle-time)
(if (member *jabber-current-show* '("xa" "away"))
;; As long as idle time increases monotonically, stay idle.
(if (> idle-time jabber-autoaway-last-idle-time)
(progn
;; Has "Xa timeout" passed?
(if (and (> jabber-autoaway-xa-timeout 0) (> idle-time (* 60 jabber-autoaway-xa-timeout)))
;; iIf so, mark ourselves xa.
(jabber-autoaway-set-idle t))
(setq jabber-autoaway-last-idle-time idle-time))
;; But if it doesn't, go back to unidle state.
(jabber-autoaway-message "Back to unidle")
;; But don't mess with the user's custom presence.
(if (or (string= *jabber-current-status* jabber-autoaway-status) (string= *jabber-current-status* jabber-autoaway-xa-status))
(jabber-send-default-presence)
(progn
(jabber-send-presence jabber-default-show *jabber-current-status* jabber-default-priority)
(jabber-autoaway-message "%S /= %S - not resetting presence" *jabber-current-status* jabber-autoaway-status)))
(jabber-autoaway-stop)
(jabber-autoaway-start)))))
(defun jabber-xprintidle-get-idle-time ()
"Get idle time through the xprintidle program."
(when jabber-xprintidle-program
(with-temp-buffer
(when (zerop (call-process jabber-xprintidle-program
nil t))
(/ (string-to-number (buffer-string)) 1000.0)))))
(defun jabber-termatime-get-idle-time ()
"Get idle time through atime of terminal.
The method for finding the terminal only works on GNU/Linux."
(let ((terminal (cond
((file-exists-p "/proc/self/fd/0")
"/proc/self/fd/0")
(t
nil))))
(when terminal
(let* ((atime-of-tty (nth 4 (file-attributes terminal)))
(diff (time-to-seconds (time-since atime-of-tty))))
(when (> diff 0)
diff)))))
(defun jabber-current-idle-time ()
"Get idle time through `current-idle-time'.
`current-idle-time' was introduced in Emacs 22."
(if (fboundp 'current-idle-time)
(let ((idle-time (current-idle-time)))
(if (null idle-time)
0
(float-time idle-time)))))
(provide 'jabber-autoaway)
;; arch-tag: 5bcea14c-842d-11da-a120-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-autoaway.elc Normal file
View File

Binary file not shown.

852
elpa/jabber-20180927.2325/jabber-autoloads.el Normal file
View File

@ -0,0 +1,852 @@
;;; jabber-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "jabber" "jabber.el" (0 0 0 0))
;;; Generated autoloads from jabber.el
(defvar jabber-account-list nil "\
List of Jabber accounts.
Each element of the list is a cons cell describing a Jabber account,
where the car is a JID and the CDR is an alist.
JID is a full Jabber ID string (e.g. foo@bar.tld). You can also
specify the resource (e.g. foo@bar.tld/emacs).
The following keys can be present in the alist:
:password is a string to authenticate ourself against the server.
It can be empty. If you don't want to store your password in your
Emacs configuration, try auth-source (info node `(auth)Top').
:network-server is a string identifying the address to connect to,
if it's different from the server part of the JID.
:port is the port to use (default depends on connection type).
:connection-type is a symbol. Valid symbols are `starttls',
`network' and `ssl'.
Only JID is mandatory. The rest can be guessed at run-time.
Examples:
Two accounts without any special configuration:
\((\"foo@example.com\") (\"bar@example.net\"))
One disabled account with a non-standard port:
\((\"romeo@montague.net\" (:port . 5242) (:disabled . t)))
If you don't have SRV and STARTTLS capabilities in your Emacs,
configure a Google Talk account like this:
\((\"username@gmail.com\"
(:network-server . \"talk.google.com\")
(:connection-type . ssl)))")
(custom-autoload 'jabber-account-list "jabber" t)
(defvar *jabber-current-status* nil "\
the users current presence status")
(defvar *jabber-current-show* nil "\
the users current presence show")
(defvar *jabber-current-priority* nil "\
the user's current priority")
(defconst jabber-presence-faces '(("" . jabber-roster-user-online) ("away" . jabber-roster-user-away) ("xa" . jabber-roster-user-xa) ("dnd" . jabber-roster-user-dnd) ("chat" . jabber-roster-user-chatty) ("error" . jabber-roster-user-error) (nil . jabber-roster-user-offline)) "\
Mapping from presence types to faces")
(autoload 'jabber-customize "jabber" "\
customize jabber options" t nil)
(autoload 'jabber-info "jabber" "\
open jabber.el manual" t nil)
(register-definition-prefixes "jabber" '("*jabber-status-history*" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-activity" "jabber-activity.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-activity.el
(defvar jabber-activity-mode t "\
Non-nil if Jabber-Activity mode is enabled.
See the `jabber-activity-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `jabber-activity-mode'.")
(custom-autoload 'jabber-activity-mode "jabber-activity" nil)
(autoload 'jabber-activity-mode "jabber-activity" "\
Toggle display of activity in hidden jabber buffers in the mode line.
With a numeric arg, enable this display if arg is positive.
\(fn &optional ARG)" t nil)
(register-definition-prefixes "jabber-activity" '("jabber-activity-"))
;;;***
;;;### (autoloads nil "jabber-ahc" "jabber-ahc.el" (0 0 0 0))
;;; Generated autoloads from jabber-ahc.el
(register-definition-prefixes "jabber-ahc" '("jabber-ahc-"))
;;;***
;;;### (autoloads nil "jabber-ahc-presence" "jabber-ahc-presence.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-ahc-presence.el
(register-definition-prefixes "jabber-ahc-presence" '("jabber-ahc-presence"))
;;;***
;;;### (autoloads nil "jabber-alert" "jabber-alert.el" (0 0 0 0))
;;; Generated autoloads from jabber-alert.el
(register-definition-prefixes "jabber-alert" '("beep" "define-" "echo" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-autoaway" "jabber-autoaway.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-autoaway.el
(autoload 'jabber-autoaway-start "jabber-autoaway" "\
Start autoaway timer.
The IGNORED argument is there so you can put this function in
`jabber-post-connect-hooks'.
\(fn &optional IGNORED)" t nil)
(register-definition-prefixes "jabber-autoaway" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-avatar" "jabber-avatar.el" (0 0 0 0))
;;; Generated autoloads from jabber-avatar.el
(register-definition-prefixes "jabber-avatar" '("avatar" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-awesome" "jabber-awesome.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-awesome.el
(register-definition-prefixes "jabber-awesome" '("awesome" "jabber-awesome-"))
;;;***
;;;### (autoloads nil "jabber-bookmarks" "jabber-bookmarks.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-bookmarks.el
(autoload 'jabber-get-conference-data "jabber-bookmarks" "\
Get bookmark data for CONFERENCE-JID.
KEY may be nil or one of :name, :autojoin, :nick and :password.
If KEY is nil, a plist containing the above keys is returned.
CONT is called when the result is available, with JC and the
result as arguments. If CONT is nil, return the requested data
immediately, and return nil if it is not in the cache.
\(fn JC CONFERENCE-JID CONT &optional KEY)" nil nil)
(autoload 'jabber-parse-conference-bookmark "jabber-bookmarks" "\
Convert a <conference/> tag into a plist.
The plist may contain the keys :jid, :name, :autojoin,
:nick and :password.
\(fn NODE)" nil nil)
(autoload 'jabber-get-bookmarks "jabber-bookmarks" "\
Retrieve bookmarks (if needed) and call CONT.
Arguments to CONT are JC and the bookmark list. CONT will be
called as the result of a filter function or a timer.
If REFRESH is non-nil, always fetch bookmarks.
\(fn JC CONT &optional REFRESH)" nil nil)
(autoload 'jabber-get-bookmarks-from-cache "jabber-bookmarks" "\
Return cached bookmarks for JC.
If bookmarks have not yet been fetched by `jabber-get-bookmarks',
return nil.
\(fn JC)" nil nil)
(autoload 'jabber-edit-bookmarks "jabber-bookmarks" "\
Create a buffer for editing bookmarks interactively.
\(fn JC)" t nil)
(register-definition-prefixes "jabber-bookmarks" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-browse" "jabber-browse.el" (0 0 0 0))
;;; Generated autoloads from jabber-browse.el
(register-definition-prefixes "jabber-browse" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-chat" "jabber-chat.el" (0 0 0 0))
;;; Generated autoloads from jabber-chat.el
(defvar jabber-chatting-with nil "\
JID of the person you are chatting with")
(autoload 'jabber-chat-get-buffer "jabber-chat" "\
Return the chat buffer for chatting with CHAT-WITH (bare or full JID).
Either a string or a buffer is returned, so use `get-buffer' or
`get-buffer-create'.
\(fn CHAT-WITH)" nil nil)
(register-definition-prefixes "jabber-chat" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-chatbuffer" "jabber-chatbuffer.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-chatbuffer.el
(defvar jabber-buffer-connection nil "\
The connection used by this buffer.")
(make-variable-buffer-local 'jabber-buffer-connection)
(register-definition-prefixes "jabber-chatbuffer" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-chatstates" "jabber-chatstates.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-chatstates.el
(register-definition-prefixes "jabber-chatstates" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-compose" "jabber-compose.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-compose.el
(autoload 'jabber-compose "jabber-compose" "\
Create a buffer for composing a Jabber message.
\(fn JC &optional RECIPIENT)" t nil)
(register-definition-prefixes "jabber-compose" '("jabber-compose-send"))
;;;***
;;;### (autoloads nil "jabber-conn" "jabber-conn.el" (0 0 0 0))
;;; Generated autoloads from jabber-conn.el
(register-definition-prefixes "jabber-conn" '("*jabber-virtual-server-function*" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-console" "jabber-console.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-console.el
(autoload 'jabber-process-console "jabber-console" "\
Log XML-DATA i/o as XML in \"*-jabber-console-JID-*\" buffer
\(fn JC DIRECTION XML-DATA)" nil nil)
(register-definition-prefixes "jabber-console" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-core" "jabber-core.el" (0 0 0 0))
;;; Generated autoloads from jabber-core.el
(autoload 'jabber-connect-all "jabber" "Connect to all configured Jabber accounts.\nSee `jabber-account-list'.\nIf no accounts are configured (or ARG supplied), call `jabber-connect' interactively." t)
(autoload 'jabber-connect "jabber" "Connect to the Jabber server and start a Jabber XML stream.\nWith prefix argument, register a new account.\nWith double prefix argument, specify more connection details." t)
(register-definition-prefixes "jabber-core" '("*jabber-" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-disco" "jabber-disco.el" (0 0 0 0))
;;; Generated autoloads from jabber-disco.el
(eval-after-load "jabber-core" '(add-to-list 'jabber-presence-chain #'jabber-process-caps))
(autoload 'jabber-process-caps "jabber-disco" "\
Look for entity capabilities in presence stanzas.
\(fn JC XML-DATA)" nil nil)
(autoload 'jabber-disco-advertise-feature "jabber-disco" "\
\(fn FEATURE)" nil nil)
(autoload 'jabber-caps-presence-element "jabber-disco" "\
\(fn JC)" nil nil)
(eval-after-load "jabber-presence" '(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element))
(register-definition-prefixes "jabber-disco" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-events" "jabber-events.el" (0 0 0 0))
;;; Generated autoloads from jabber-events.el
(register-definition-prefixes "jabber-events" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-export" "jabber-export.el" (0 0 0 0))
;;; Generated autoloads from jabber-export.el
(autoload 'jabber-export-roster "jabber-export" "\
Export roster for connection JC.
\(fn JC)" t nil)
(autoload 'jabber-import-roster "jabber-export" "\
Create buffer for roster import for connection JC from FILE.
\(fn JC FILE)" t nil)
(register-definition-prefixes "jabber-export" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-feature-neg" "jabber-feature-neg.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-feature-neg.el
(register-definition-prefixes "jabber-feature-neg" '("jabber-fn-"))
;;;***
;;;### (autoloads nil "jabber-ft-client" "jabber-ft-client.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-ft-client.el
(register-definition-prefixes "jabber-ft-client" '("jabber-ft-"))
;;;***
;;;### (autoloads nil "jabber-ft-common" "jabber-ft-common.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-ft-common.el
(register-definition-prefixes "jabber-ft-common" '("jabber-ft-"))
;;;***
;;;### (autoloads nil "jabber-ft-server" "jabber-ft-server.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-ft-server.el
(register-definition-prefixes "jabber-ft-server" '("jabber-ft-"))
;;;***
;;;### (autoloads nil "jabber-gmail" "jabber-gmail.el" (0 0 0 0))
;;; Generated autoloads from jabber-gmail.el
(autoload 'jabber-gmail-subscribe "jabber-gmail" "\
Subscribe to gmail notifications.
See http://code.google.com/apis/talk/jep_extensions/usersettings.html#4
\(fn JC)" t nil)
(autoload 'jabber-gmail-query "jabber-gmail" "\
Request mail information from the Google Talk server (a.k.a. one shot query).
See http://code.google.com/apis/talk/jep_extensions/gmail.html#requestmail
\(fn JC)" t nil)
(register-definition-prefixes "jabber-gmail" '("jabber-gmail-"))
;;;***
;;;### (autoloads nil "jabber-history" "jabber-history.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-history.el
(register-definition-prefixes "jabber-history" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-iq" "jabber-iq.el" (0 0 0 0))
;;; Generated autoloads from jabber-iq.el
(register-definition-prefixes "jabber-iq" '("*jabber-open-info-queries*" "jabber-"))
;;;***
;;;### (autoloads nil "jabber-keepalive" "jabber-keepalive.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-keepalive.el
(let ((loads (get 'jabber-keepalive 'custom-loads))) (if (member '"jabber-keepalive" loads) nil (put 'jabber-keepalive 'custom-loads (cons '"jabber-keepalive" loads))))
(autoload 'jabber-keepalive-start "jabber-keepalive" "\
Activate keepalive.
That is, regularly send a ping request to the server, and
disconnect if it doesn't answer. See `jabber-keepalive-interval'
and `jabber-keepalive-timeout'.
The JC argument makes it possible to add this function to
`jabber-post-connect-hooks'; it is ignored. Keepalive is activated
for all accounts regardless of the argument.
\(fn &optional JC)" t nil)
(autoload 'jabber-whitespace-ping-start "jabber-keepalive" "\
Start sending whitespace pings at regular intervals.
See `jabber-whitespace-ping-interval'.
The JC argument is ignored; whitespace pings are enabled for all
accounts.
\(fn &optional JC)" t nil)
(register-definition-prefixes "jabber-keepalive" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-keymap" "jabber-keymap.el" (0 0 0 0))
;;; Generated autoloads from jabber-keymap.el
(defvar jabber-global-keymap (let ((map (make-sparse-keymap))) (define-key map "\3" 'jabber-connect-all) (define-key map "\4" 'jabber-disconnect) (define-key map "\22" 'jabber-switch-to-roster-buffer) (define-key map "\n" 'jabber-chat-with) (define-key map "\f" 'jabber-activity-switch-to) (define-key map "\1" 'jabber-send-away-presence) (define-key map "\17" 'jabber-send-default-presence) (define-key map "\30" 'jabber-send-xa-presence) (define-key map "\20" 'jabber-send-presence) map) "\
Global Jabber keymap (usually under C-x C-j)")
(define-key ctl-x-map "\n" jabber-global-keymap)
(register-definition-prefixes "jabber-keymap" '("jabber-common-keymap"))
;;;***
;;;### (autoloads nil "jabber-libnotify" "jabber-libnotify.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-libnotify.el
(register-definition-prefixes "jabber-libnotify" '("jabber-libnotify-" "libnotify"))
;;;***
;;;### (autoloads nil "jabber-logon" "jabber-logon.el" (0 0 0 0))
;;; Generated autoloads from jabber-logon.el
(register-definition-prefixes "jabber-logon" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-menu" "jabber-menu.el" (0 0 0 0))
;;; Generated autoloads from jabber-menu.el
(defvar jabber-menu (let ((map (make-sparse-keymap "jabber-menu"))) (define-key-after map [jabber-menu-connect] '("Connect" . jabber-connect-all)) (define-key-after map [jabber-menu-disconnect] '(menu-item "Disconnect" jabber-disconnect :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-status] `(menu-item "Set Status" ,(make-sparse-keymap "set-status") :enable (bound-and-true-p jabber-connections))) (define-key map [jabber-menu-status jabber-menu-status-chat] '(menu-item "Chatty" (lambda nil (interactive) (jabber-send-presence "chat" (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) *jabber-current-priority*)) :button (:radio and (boundp '*jabber-current-show*) (equal *jabber-current-show* "chat")))) (define-key map [jabber-menu-status jabber-menu-status-dnd] '(menu-item "Do not Disturb" (lambda nil (interactive) (jabber-send-presence "dnd" (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) *jabber-current-priority*)) :button (:radio and (boundp '*jabber-current-show*) (equal *jabber-current-show* "dnd")))) (define-key map [jabber-menu-status jabber-menu-status-xa] '(menu-item "Extended Away" jabber-send-xa-presence :button (:radio and (boundp '*jabber-current-show*) (equal *jabber-current-show* "xa")))) (define-key map [jabber-menu-status jabber-menu-status-away] '(menu-item "Away" jabber-send-away-presence :button (:radio and (boundp '*jabber-current-show*) (equal *jabber-current-show* "away")))) (define-key map [jabber-menu-status jabber-menu-status-online] '(menu-item "Online" jabber-send-default-presence :button (:radio and (boundp '*jabber-current-show*) (equal *jabber-current-show* "")))) (define-key-after map [separator] '(menu-item "--")) (define-key-after map [jabber-menu-chat-with] '(menu-item "Chat with..." jabber-chat-with :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-nextmsg] '(menu-item "Next unread message" jabber-activity-switch-to :enable (bound-and-true-p jabber-activity-jids))) (define-key-after map [jabber-menu-send-subscription-request] '(menu-item "Send subscription request" jabber-send-subscription-request :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-roster] '("Switch to roster" . jabber-switch-to-roster-buffer)) (define-key-after map [separator2] '(menu-item "--")) (define-key-after map [jabber-menu-customize] '("Customize" . jabber-customize)) (define-key-after map [jabber-menu-info] '("Help" . jabber-info)) map))
(defvar jabber-display-menu 'maybe "\
Decide whether the \"Jabber\" menu is displayed in the menu bar.
If t, always display.
If nil, never display.
If maybe, display if jabber.el is installed under `package-user-dir', or
if any of `jabber-account-list' or `jabber-connections' is non-nil.")
(custom-autoload 'jabber-display-menu "jabber-menu" t)
(define-key-after (lookup-key global-map [menu-bar]) [jabber-menu] (list 'menu-item "Jabber" jabber-menu :visible '(or (eq jabber-display-menu t) (and (eq jabber-display-menu 'maybe) (or (bound-and-true-p jabber-account-list) (bound-and-true-p jabber-connections))))))
(register-definition-prefixes "jabber-menu" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-modeline" "jabber-modeline.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-modeline.el
(register-definition-prefixes "jabber-modeline" '("jabber-mode-line-"))
;;;***
;;;### (autoloads nil "jabber-muc" "jabber-muc.el" (0 0 0 0))
;;; Generated autoloads from jabber-muc.el
(defvar *jabber-active-groupchats* nil "\
alist of groupchats and nicknames
Keys are strings, the bare JID of the room.
Values are strings.")
(defvar jabber-muc-printers 'nil "\
List of functions that may be able to print part of a MUC message.
This gets prepended to `jabber-chat-printers', which see.")
(autoload 'jabber-muc-get-buffer "jabber-muc" "\
Return the chat buffer for chatroom GROUP.
Either a string or a buffer is returned, so use `get-buffer' or
`get-buffer-create'.
\(fn GROUP)" nil nil)
(autoload 'jabber-muc-private-get-buffer "jabber-muc" "\
Return the chat buffer for private chat with NICKNAME in GROUP.
Either a string or a buffer is returned, so use `get-buffer' or
`get-buffer-create'.
\(fn GROUP NICKNAME)" nil nil)
(autoload 'jabber-muc-vcard-get "jabber-muc" "\
Request vcard from chat with NICKNAME in GROUP.
\(fn JC GROUP NICKNAME)" t nil)
(autoload 'jabber-muc-message-p "jabber-muc" "\
Return non-nil if MESSAGE is a groupchat message.
That does not include private messages in a groupchat, but does
include groupchat invites.
\(fn MESSAGE)" nil nil)
(autoload 'jabber-muc-sender-p "jabber-muc" "\
Return non-nil if JID is a full JID of an MUC participant.
\(fn JID)" nil nil)
(autoload 'jabber-muc-private-message-p "jabber-muc" "\
Return non-nil if MESSAGE is a private message in a groupchat.
\(fn MESSAGE)" nil nil)
(register-definition-prefixes "jabber-muc" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-muc-nick-coloring" "jabber-muc-nick-coloring.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-muc-nick-coloring.el
(register-definition-prefixes "jabber-muc-nick-coloring" '("jabber-muc-"))
;;;***
;;;### (autoloads nil "jabber-muc-nick-completion" "jabber-muc-nick-completion.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-muc-nick-completion.el
(autoload 'jabber-muc-looks-like-personal-p "jabber-muc-nick-completion" "\
Return non-nil if jabber MESSAGE is addresed to me.
Optional argument GROUP to look.
\(fn MESSAGE &optional GROUP)" nil nil)
(register-definition-prefixes "jabber-muc-nick-completion" '("*jabber-muc-participant-last-speaking*" "jabber-" "try-expand-jabber-muc"))
;;;***
;;;### (autoloads nil "jabber-ourversion" "jabber-ourversion.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-ourversion.el
(register-definition-prefixes "jabber-ourversion" '("jabber-version"))
;;;***
;;;### (autoloads nil "jabber-ping" "jabber-ping.el" (0 0 0 0))
;;; Generated autoloads from jabber-ping.el
(register-definition-prefixes "jabber-ping" '("jabber-p"))
;;;***
;;;### (autoloads nil "jabber-presence" "jabber-presence.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-presence.el
(autoload 'jabber-send-presence "jabber-presence" "\
Set presence for all accounts.
\(fn SHOW STATUS PRIORITY)" t nil)
(autoload 'jabber-send-default-presence "jabber-presence" "\
Send default presence.
Default presence is specified by `jabber-default-show',
`jabber-default-status', and `jabber-default-priority'.
\(fn &optional IGNORE)" t nil)
(register-definition-prefixes "jabber-presence" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-private" "jabber-private.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-private.el
(autoload 'jabber-private-get "jabber-private" "\
Retrieve an item from private XML storage.
The item to retrieve is identified by NODE-NAME (a symbol) and
NAMESPACE (a string).
On success, SUCCESS-CALLBACK is called with JC and the retrieved
XML fragment.
On error, ERROR-CALLBACK is called with JC and the entire IQ
result.
\(fn JC NODE-NAME NAMESPACE SUCCESS-CALLBACK ERROR-CALLBACK)" nil nil)
(autoload 'jabber-private-set "jabber-private" "\
Store FRAGMENT in private XML storage.
SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and
ERROR-CLOSURE-DATA are used as in `jabber-send-iq'.
\(fn JC FRAGMENT &optional SUCCESS-CALLBACK SUCCESS-CLOSURE-DATA ERROR-CALLBACK ERROR-CLOSURE-DATA)" nil nil)
(register-definition-prefixes "jabber-private" '("jabber-private-get-1"))
;;;***
;;;### (autoloads nil "jabber-ratpoison" "jabber-ratpoison.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-ratpoison.el
(register-definition-prefixes "jabber-ratpoison" '("jabber-ratpoison-message" "ratpoison"))
;;;***
;;;### (autoloads nil "jabber-register" "jabber-register.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-register.el
(register-definition-prefixes "jabber-register" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-roster" "jabber-roster.el" (0 0 0 0))
;;; Generated autoloads from jabber-roster.el
(autoload 'jabber-switch-to-roster-buffer "jabber-roster" "\
Switch to roster buffer.
Optional JC argument is ignored; it's there so this function can
be used in `jabber-post-connection-hooks'.
\(fn &optional JC)" t nil)
(autoload 'jabber-roster-update "jabber-roster" "\
Update roster, in memory and on display.
Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
three being lists of JID symbols.
\(fn JC NEW-ITEMS CHANGED-ITEMS DELETED-ITEMS)" nil nil)
(register-definition-prefixes "jabber-roster" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-rtt" "jabber-rtt.el" (0 0 0 0))
;;; Generated autoloads from jabber-rtt.el
(eval-after-load "jabber-disco" '(jabber-disco-advertise-feature "urn:xmpp:rtt:0"))
(eval-after-load "jabber-core" '(add-to-list 'jabber-message-chain #'jabber-rtt-handle-message t))
(autoload 'jabber-rtt-handle-message "jabber-rtt" "\
\(fn JC XML-DATA)" nil nil)
(autoload 'jabber-rtt-send-mode "jabber-rtt" "\
Show text to recipient as it is being typed.
This lets the recipient see every change made to the message up
until it's sent. The recipient's client needs to implement
XEP-0301, In-Band Real Time Text.
If called interactively, toggle `Jabber-Rtt-Send mode'. If the
prefix argument is positive, enable the mode, and if it is zero
or negative, disable the mode.
If called from Lisp, toggle the mode if ARG is `toggle'. Enable
the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
The mode's hook is called both when the mode is enabled and when
it is disabled.
\(fn &optional ARG)" t nil)
(register-definition-prefixes "jabber-rtt" '("jabber-rtt-"))
;;;***
;;;### (autoloads nil "jabber-sasl" "jabber-sasl.el" (0 0 0 0))
;;; Generated autoloads from jabber-sasl.el
(register-definition-prefixes "jabber-sasl" '("jabber-sasl-"))
;;;***
;;;### (autoloads nil "jabber-sawfish" "jabber-sawfish.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-sawfish.el
(register-definition-prefixes "jabber-sawfish" '("jabber-sawfish-display-" "sawfish"))
;;;***
;;;### (autoloads nil "jabber-screen" "jabber-screen.el" (0 0 0 0))
;;; Generated autoloads from jabber-screen.el
(register-definition-prefixes "jabber-screen" '("jabber-screen-message" "screen"))
;;;***
;;;### (autoloads nil "jabber-search" "jabber-search.el" (0 0 0 0))
;;; Generated autoloads from jabber-search.el
(register-definition-prefixes "jabber-search" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-si-client" "jabber-si-client.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-si-client.el
(register-definition-prefixes "jabber-si-client" '("jabber-si-initiate"))
;;;***
;;;### (autoloads nil "jabber-si-common" "jabber-si-common.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-si-common.el
(register-definition-prefixes "jabber-si-common" '("jabber-si-stream-methods"))
;;;***
;;;### (autoloads nil "jabber-si-server" "jabber-si-server.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from jabber-si-server.el
(register-definition-prefixes "jabber-si-server" '("jabber-si-pro"))
;;;***
;;;### (autoloads nil "jabber-socks5" "jabber-socks5.el" (0 0 0 0))
;;; Generated autoloads from jabber-socks5.el
(register-definition-prefixes "jabber-socks5" '("jabber-socks5"))
;;;***
;;;### (autoloads nil "jabber-time" "jabber-time.el" (0 0 0 0))
;;; Generated autoloads from jabber-time.el
(register-definition-prefixes "jabber-time" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-tmux" "jabber-tmux.el" (0 0 0 0))
;;; Generated autoloads from jabber-tmux.el
(register-definition-prefixes "jabber-tmux" '("jabber-tmux-message" "tmux"))
;;;***
;;;### (autoloads nil "jabber-truncate" "jabber-truncate.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-truncate.el
(register-definition-prefixes "jabber-truncate" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-util" "jabber-util.el" (0 0 0 0))
;;; Generated autoloads from jabber-util.el
(register-definition-prefixes "jabber-util" '("jabber-" "string>-numerical" "url-xmpp"))
;;;***
;;;### (autoloads nil "jabber-vcard" "jabber-vcard.el" (0 0 0 0))
;;; Generated autoloads from jabber-vcard.el
(register-definition-prefixes "jabber-vcard" '("jabber-vcard-"))
;;;***
;;;### (autoloads nil "jabber-vcard-avatars" "jabber-vcard-avatars.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from jabber-vcard-avatars.el
(register-definition-prefixes "jabber-vcard-avatars" '("jabber-vcard-avatars-"))
;;;***
;;;### (autoloads nil "jabber-version" "jabber-version.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from jabber-version.el
(register-definition-prefixes "jabber-version" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-watch" "jabber-watch.el" (0 0 0 0))
;;; Generated autoloads from jabber-watch.el
(register-definition-prefixes "jabber-watch" '("jabber-"))
;;;***
;;;### (autoloads nil "jabber-widget" "jabber-widget.el" (0 0 0 0))
;;; Generated autoloads from jabber-widget.el
(register-definition-prefixes "jabber-widget" '("jabber-" "jid-complete"))
;;;***
;;;### (autoloads nil "jabber-wmii" "jabber-wmii.el" (0 0 0 0))
;;; Generated autoloads from jabber-wmii.el
(register-definition-prefixes "jabber-wmii" '("jabber-wmii-" "wmii"))
;;;***
;;;### (autoloads nil "jabber-xmessage" "jabber-xmessage.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from jabber-xmessage.el
(register-definition-prefixes "jabber-xmessage" '("jabber-xmessage-" "xmessage"))
;;;***
;;;### (autoloads nil "jabber-xml" "jabber-xml.el" (0 0 0 0))
;;; Generated autoloads from jabber-xml.el
(register-definition-prefixes "jabber-xml" '("jabber-"))
;;;***
;;;### (autoloads nil nil ("jabber-festival.el" "jabber-notifications.el"
;;;;;; "jabber-osd.el" "jabber-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; jabber-autoloads.el ends here

234
elpa/jabber-20180927.2325/jabber-avatar.el Normal file
View File

@ -0,0 +1,234 @@
;;; jabber-avatar.el --- generic functions for avatars
;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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:
;; There are several methods for transporting avatars in Jabber
;; (JEP-0008, JEP-0084, JEP-0153). They all have in common that they
;; identify avatars by their SHA1 checksum, and (at least partially)
;; use Base64-encoded image data. Thus this library of support
;; functions for interpreting and caching avatars.
;; A contact with an avatar has the image in the avatar property of
;; the JID symbol. Use `jabber-avatar-set' to set it.
;;; Code:
(require 'mailcap)
(eval-when-compile (require 'cl))
;;;; Variables
(defgroup jabber-avatar nil
"Avatar related settings"
:group 'jabber)
(defcustom jabber-avatar-cache-directory
(locate-user-emacs-file "jabber-avatar-cache" ".jabber-avatars")
"Directory to use for cached avatars"
:group 'jabber-avatar
:type 'directory)
(defcustom jabber-avatar-verbose nil
"Display messages about irregularities with other people's avatars."
:group 'jabber-avatar
:type 'boolean)
(defcustom jabber-avatar-max-width 96
"Maximum width of avatars."
:group 'jabber-avatar
:type 'integer)
(defcustom jabber-avatar-max-height 96
"Maximum height of avatars."
:group 'jabber-avatar
:type 'integer)
;;;; Avatar data handling
(defstruct avatar sha1-sum mime-type url base64-data height width bytes)
(defun jabber-avatar-from-url (url)
"Construct an avatar structure from the given URL.
Retrieves the image to find info about it."
(with-current-buffer (let ((coding-system-for-read 'binary))
(url-retrieve-synchronously url))
(let* ((case-fold-search t)
(mime-type (ignore-errors
(search-forward-regexp "^content-type:[ \t]*\\(.*\\)$")
(match-string 1)))
(data (progn
(search-forward "\n\n")
(buffer-substring (point) (point-max)))))
(prog1
(jabber-avatar-from-data data nil mime-type)
(kill-buffer nil)))))
(defun jabber-avatar-from-file (filename)
"Construct an avatar structure from FILENAME."
(require 'mailcap)
(let ((data (with-temp-buffer
(insert-file-contents-literally filename)
(buffer-string)))
(mime-type (when (string-match "\\.[^.]+$" filename)
(mailcap-extension-to-mime (match-string 0 filename)))))
(jabber-avatar-from-data data nil mime-type)))
(defun jabber-avatar-from-base64-string (base64-string &optional mime-type)
"Construct an avatar stucture from BASE64-STRING.
If MIME-TYPE is not specified, try to find it from the image data."
(jabber-avatar-from-data nil base64-string mime-type))
(defun jabber-avatar-from-data (raw-data base64-string &optional mime-type)
"Construct an avatar structure from RAW-DATA and/or BASE64-STRING.
If either is not provided, it is computed.
If MIME-TYPE is not specified, try to find it from the image data."
(let* ((data (or raw-data (base64-decode-string base64-string)))
(bytes (length data))
(sha1-sum (sha1 data))
(base64-data (or base64-string (base64-encode-string raw-data)))
(type (or mime-type
(cdr (assq (get :type (cdr (condition-case nil
(jabber-create-image data nil t)
(error nil))))
'((png "image/png")
(jpeg "image/jpeg")
(gif "image/gif")))))))
(jabber-avatar-compute-size
(make-avatar :mime-type mime-type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))))
;; XXX: This function is based on an outdated version of JEP-0084.
;; (defun jabber-avatar-from-data-node (data-node)
;; "Construct an avatar structure from the given <data/> node."
;; (jabber-xml-let-attributes
;; (content-type id bytes height width) data-node
;; (let ((base64-data (car (jabber-xml-node-children data-node))))
;; (make-avatar :mime-type content-type :sha1-sum id :bytes bytes
;; :height height :width width :base64-data base64-data))))
(defun jabber-avatar-image (avatar)
"Create an image from AVATAR.
Return nil if images of this type are not supported."
(condition-case nil
(jabber-create-image (with-temp-buffer
(set-buffer-multibyte nil)
(insert (avatar-base64-data avatar))
(base64-decode-region (point-min) (point-max))
(buffer-string))
nil
t)
(error nil)))
(defun jabber-avatar-compute-size (avatar)
"Compute and set the width and height fields of AVATAR.
Return AVATAR."
;; image-size only works when there is a window system.
;; But display-graphic-p doesn't exist on XEmacs...
(let ((size (and (fboundp 'display-graphic-p)
(display-graphic-p)
(let ((image (jabber-avatar-image avatar)))
(and image
(image-size image t))))))
(when size
(setf (avatar-width avatar) (car size))
(setf (avatar-height avatar) (cdr size)))
avatar))
;;;; Avatar cache
(defun jabber-avatar-find-cached (sha1-sum)
"Return file name of cached image for avatar identified by SHA1-SUM.
If there is no cached image, return nil."
(let ((filename (expand-file-name sha1-sum jabber-avatar-cache-directory)))
(if (file-exists-p filename)
filename
nil)))
(defun jabber-avatar-cache (avatar)
"Cache the AVATAR."
(let* ((id (avatar-sha1-sum avatar))
(base64-data (avatar-base64-data avatar))
(mime-type (avatar-mime-type avatar))
(filename (expand-file-name id jabber-avatar-cache-directory)))
(unless (file-directory-p jabber-avatar-cache-directory)
(make-directory jabber-avatar-cache-directory t))
(if (file-exists-p filename)
(when jabber-avatar-verbose
(message "Caching avatar, but %s already exists" filename))
(with-temp-buffer
(let ((require-final-newline nil)
(coding-system-for-write 'binary))
(if (fboundp 'set-buffer-multibyte)
(set-buffer-multibyte nil))
(insert base64-data)
(base64-decode-region (point-min) (point-max))
(write-region (point-min) (point-max) filename nil 'silent))))))
;;;; Set avatar for contact
(defun jabber-avatar-set (jid avatar)
"Set the avatar of JID to be AVATAR.
JID is a string containing a bare JID.
AVATAR may be one of:
* An avatar structure.
* The SHA1 sum of a cached avatar.
* nil, meaning no avatar."
;; We want to optimize for the case of same avatar.
;; Loading an image is expensive, so do it lazily.
(let ((jid-symbol (jabber-jid-symbol jid))
image hash)
(cond
((avatar-p avatar)
(setq hash (avatar-sha1-sum avatar))
(setq image (lambda () (jabber-avatar-image avatar))))
((stringp avatar)
(setq hash avatar)
(setq image (lambda ()
(condition-case nil
(jabber-create-image (jabber-avatar-find-cached avatar))
(error nil)))))
(t
(setq hash nil)
(setq image #'ignore)))
(unless (string= hash (get jid-symbol 'avatar-hash))
(put jid-symbol 'avatar (funcall image))
(put jid-symbol 'avatar-hash hash)
(jabber-presence-update-roster jid-symbol))))
(defun jabber-create-image (file-or-data &optional type data-p)
"Create image, scaled down to jabber-avatar-max-width/height,
if width/height exceeds either of those, and ImageMagick is
available."
(let* ((image (create-image file-or-data type data-p))
(size (image-size image t))
(spec (cdr image)))
(when (and (functionp 'imagemagick-types)
(or (> (car size) jabber-avatar-max-width)
(> (cdr size) jabber-avatar-max-height)))
(plist-put spec :type 'imagemagick)
(plist-put spec :width jabber-avatar-max-width)
(plist-put spec :height jabber-avatar-max-height))
image))
(provide 'jabber-avatar)
;; arch-tag: 2405c3f8-8eaa-11da-826c-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-avatar.elc Normal file
View File

Binary file not shown.

42
elpa/jabber-20180927.2325/jabber-awesome.el Normal file
View File

@ -0,0 +1,42 @@
;; jabber-awesome.el - emacs-jabber interface to awesome and naughty
;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(eval-when-compile (require 'jabber-alert))
(defcustom jabber-awesome-args ", timeout=5"
"Additional args to naughty."
:type 'string
:group 'jabber-alerts)
(defun jabber-awesome-message (text &optional title)
"Show MSG in Awesome"
;; Possible errors include not finding the awesome binary.
(condition-case e
(let ((process-connection-type))
(shell-command-to-string (format "echo 'naughty.notify({text = \"%s\" %s})' | awesome-client -"
(or title text) jabber-awesome-args))
)
(error nil)))
(define-jabber-alert awesome "Show a message through the Awesome window manager"
'jabber-awesome-message)
(define-personal-jabber-alert jabber-muc-awesome)
(provide 'jabber-awesome)

BIN
elpa/jabber-20180927.2325/jabber-awesome.elc Normal file
View File

Binary file not shown.

248
elpa/jabber-20180927.2325/jabber-bookmarks.el Normal file
View File

@ -0,0 +1,248 @@
;; jabber-bookmarks.el - bookmarks according to XEP-0048
;; Copyright (C) 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-private)
(require 'jabber-widget)
(require 'cl)
(defvar jabber-bookmarks (make-hash-table :test 'equal)
"Mapping from full JIDs to bookmarks.
Bookmarks are what has been retrieved from the server, as list of
XML elements. This is nil if bookmarks have not been retrieved,
and t if no bookmarks where found.")
;;;###autoload
(defun jabber-get-conference-data (jc conference-jid cont &optional key)
"Get bookmark data for CONFERENCE-JID.
KEY may be nil or one of :name, :autojoin, :nick and :password.
If KEY is nil, a plist containing the above keys is returned.
CONT is called when the result is available, with JC and the
result as arguments. If CONT is nil, return the requested data
immediately, and return nil if it is not in the cache."
(if (null cont)
(let ((cache (jabber-get-bookmarks-from-cache jc)))
(if (and cache (listp cache))
(jabber-get-conference-data-internal
cache conference-jid key)))
(jabber-get-bookmarks
jc
(lexical-let ((conference-jid conference-jid)
(key key)
(cont cont))
(lambda (jc result)
(let ((entry (jabber-get-conference-data-internal result conference-jid key)))
(funcall cont jc entry)))))))
(defun jabber-get-conference-data-internal (result conference-jid key)
(let ((entry (dolist (node result)
(when (and (eq (jabber-xml-node-name node) 'conference)
(string= (jabber-xml-get-attribute node 'jid) conference-jid))
(return (jabber-parse-conference-bookmark node))))))
(if key
(plist-get entry key)
entry)))
;;;###autoload
(defun jabber-parse-conference-bookmark (node)
"Convert a <conference/> tag into a plist.
The plist may contain the keys :jid, :name, :autojoin,
:nick and :password."
(when (eq (jabber-xml-node-name node) 'conference)
(list :jid (jabber-xml-get-attribute node 'jid)
:name (jabber-xml-get-attribute node 'name)
:autojoin (member (jabber-xml-get-attribute node 'autojoin)
'("true" "1"))
:nick (car (jabber-xml-node-children
(car (jabber-xml-get-children node 'nick))))
:password (car (jabber-xml-node-children
(car (jabber-xml-get-children node 'password)))))))
;;;###autoload
(defun jabber-get-bookmarks (jc cont &optional refresh)
"Retrieve bookmarks (if needed) and call CONT.
Arguments to CONT are JC and the bookmark list. CONT will be
called as the result of a filter function or a timer.
If REFRESH is non-nil, always fetch bookmarks."
(let ((bookmarks (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)))
(if (and (not refresh) bookmarks)
(run-with-timer 0 nil cont jc (when (listp bookmarks) bookmarks))
(lexical-let* ((cont cont)
(callback (lambda (jc result) (jabber-get-bookmarks-1 jc result cont))))
(jabber-private-get jc 'storage "storage:bookmarks"
callback callback)))))
(defun jabber-get-bookmarks-1 (jc result cont)
(let ((my-jid (jabber-connection-bare-jid jc))
(value
(if (eq (jabber-xml-node-name result) 'storage)
(or (jabber-xml-node-children result) t)
t)))
(puthash my-jid value jabber-bookmarks)
(funcall cont jc (when (listp value) value))))
;;;###autoload
(defun jabber-get-bookmarks-from-cache (jc)
"Return cached bookmarks for JC.
If bookmarks have not yet been fetched by `jabber-get-bookmarks',
return nil."
(gethash (jabber-connection-bare-jid jc) jabber-bookmarks))
(defun jabber-set-bookmarks (jc bookmarks &optional callback)
"Set bookmarks to BOOKMARKS, which is a list of XML elements.
If CALLBACK is non-nil, call it with JC and t or nil as arguments
on success or failure, respectively."
(unless callback
(setq callback #'ignore))
(jabber-private-set
jc
`(storage ((xmlns . "storage:bookmarks"))
,@bookmarks)
callback t
callback nil))
;;;###autoload
(defun jabber-edit-bookmarks (jc)
"Create a buffer for editing bookmarks interactively."
(interactive (list (jabber-read-account)))
(jabber-get-bookmarks jc 'jabber-edit-bookmarks-1 t))
(defun jabber-edit-bookmarks-1 (jc bookmarks)
(setq bookmarks
(mapcar
(lambda (e)
(case (jabber-xml-node-name e)
(url
(list 'url (or (jabber-xml-get-attribute e 'url) "")
(or (jabber-xml-get-attribute e 'name) "")))
(conference
(list 'conference
(or (jabber-xml-get-attribute e 'jid) "")
(or (jabber-xml-get-attribute e 'name) "")
(not (not (member (jabber-xml-get-attribute e 'autojoin)
'("true" "1"))))
(or (jabber-xml-path e '(nick "")) "")
(or (jabber-xml-path e '(password "")) "")))))
bookmarks))
(setq bookmarks (delq nil bookmarks))
(with-current-buffer (get-buffer-create "Edit bookmarks")
(jabber-init-widget-buffer nil)
(setq jabber-buffer-connection jc)
(widget-insert (jabber-propertize (concat "Edit bookmarks for "
(jabber-connection-bare-jid jc))
'face 'jabber-title-large)
"\n\n")
(when (or (bound-and-true-p jabber-muc-autojoin)
(bound-and-true-p jabber-muc-default-nicknames))
(widget-insert "The variables `jabber-muc-autojoin' and/or `jabber-muc-default-nicknames'\n"
"contain values. They are only available to jabber.el on this machine.\n"
"You may want to import them into your bookmarks, to make them available\n"
"to any client on any machine.\n")
(widget-create 'push-button :notify 'jabber-bookmarks-import "Import values from variables")
(widget-insert "\n\n"))
(push (cons 'bookmarks
(widget-create
'(repeat
:tag "Bookmarks"
(choice
(list :tag "Conference"
(const :format "" conference)
(string :tag "JID") ;XXX: jid widget type?
(string :tag "Name")
(checkbox :tag "Autojoin" :format "%[%v%] Autojoin?\n")
(string :tag "Nick") ;or nil?
(string :tag "Password") ;or nil?
)
(list :tag "URL"
(const :format "" url)
(string :tag "URL")
(string :tag "Name"))))
:value bookmarks))
jabber-widget-alist)
(widget-insert "\n")
(widget-create 'push-button :notify 'jabber-bookmarks-submit "Submit")
(widget-setup)
(widget-minor-mode 1)
(switch-to-buffer (current-buffer))
(goto-char (point-min))))
(defun jabber-bookmarks-submit (&rest ignore)
(let ((bookmarks (widget-value (cdr (assq 'bookmarks jabber-widget-alist)))))
(setq bookmarks
(mapcar
(lambda (entry)
(case (car entry)
(url
(destructuring-bind (symbol url name) entry
`(url ((url . ,url)
(name . ,name)))))
(conference
(destructuring-bind (symbol jid name autojoin nick password)
entry
`(conference ((jid . ,jid)
(name . ,name)
(autojoin . ,(if autojoin
"1"
"0")))
,@(unless (zerop (length nick))
`((nick () ,nick)))
,@(unless (zerop (length password))
`((password () ,password))))))))
bookmarks))
(remhash (jabber-connection-bare-jid jabber-buffer-connection) jabber-bookmarks)
(jabber-private-set
jabber-buffer-connection
`(storage ((xmlns . "storage:bookmarks"))
,@bookmarks)
'jabber-report-success "Storing bookmarks"
'jabber-report-success "Storing bookmarks")))
(defun jabber-bookmarks-import (&rest ignore)
(let* ((value (widget-value (cdr (assq 'bookmarks jabber-widget-alist))))
(conferences (mapcar
'cdr
(remove-if-not
(lambda (entry)
(eq (car entry) 'conference))
value))))
(dolist (default-nickname jabber-muc-default-nicknames)
(destructuring-bind (muc-jid . nick) default-nickname
(let ((entry (assoc muc-jid conferences)))
(if entry
(setf (fourth entry) nick)
(setq entry (list muc-jid "" nil nick ""))
(push entry conferences)
(push (cons 'conference entry) value)))))
(dolist (autojoin jabber-muc-autojoin)
(let ((entry (assoc autojoin conferences)))
(if entry
(setf (third entry) t)
(setq entry (list autojoin "" t "" ""))
(push (cons 'conference entry) value))))
(widget-value-set (cdr (assq 'bookmarks jabber-widget-alist)) value)
(widget-setup)))
(provide 'jabber-bookmarks)
;; arch-tag: a7d6f862-bac0-11db-831f-000a95c2fcd0

100
elpa/jabber-20180927.2325/jabber-browse.el Normal file
View File

@ -0,0 +1,100 @@
;; jabber-browse.el - jabber browsing by JEP-0011
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-xml)
(require 'jabber-util)
;; jabber.el can perform browse requests, but will not answer them.
(add-to-list 'jabber-jid-info-menu
(cons "Send browse query" 'jabber-get-browse))
(defun jabber-get-browse (jc to)
"send a browse infoquery request to someone"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "browse: " nil nil nil nil t)))
(jabber-send-iq jc to
"get"
'(query ((xmlns . "jabber:iq:browse")))
#'jabber-process-data #'jabber-process-browse
#'jabber-process-data "Browse failed"))
;; called from jabber-process-data
(defun jabber-process-browse (jc xml-data)
"Handle results from jabber:iq:browse requests."
(dolist (item (jabber-xml-node-children xml-data))
(when (and (listp item)
(not (eq (jabber-xml-node-name item) 'ns)))
(let ((jid (jabber-xml-get-attribute item 'jid))
(beginning (point)))
(cond
((or
(eq (jabber-xml-node-name item) 'user)
(string= (jabber-xml-get-attribute item 'category) "user"))
(insert (jabber-propertize "$ USER"
'face 'jabber-title-medium)
"\n\n"))
((or
(eq (jabber-xml-node-name item) 'service)
(string= (jabber-xml-get-attribute item 'category) "service"))
(insert (jabber-propertize "* SERVICE"
'face 'jabber-title-medium)
"\n\n"))
((or
(eq (jabber-xml-node-name item) 'conference)
(string= (jabber-xml-get-attribute item 'category) "conference"))
(insert (jabber-propertize "@ CONFERENCE"
'face 'jabber-title-medium)
"\n\n"))
(t
;; So far I've seen "server" and "directory", both in the node-name.
;; Those are actually service disco categories, but jabberd 2 seems
;; to use them for browse results as well. It's not right (as in
;; JEP-0011), but it's reasonable.
(let ((category (jabber-xml-get-attribute item 'category)))
(if (= (length category) 0)
(setq category (jabber-xml-node-name item)))
(insert (jabber-propertize (format "! OTHER: %s" category)
'face 'jabber-title-medium)
"\n\n"))))
(dolist (attr '((type . "Type:\t\t")
(jid . "JID:\t\t")
(name . "Name:\t\t")
(version . "Version:\t")))
(let ((data (jabber-xml-get-attribute item (car attr))))
(if (> (length data) 0)
(insert (cdr attr) data "\n"))))
(dolist (ns (jabber-xml-get-children item 'ns))
(if (stringp (car (jabber-xml-node-children ns)))
(insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n")))
(insert "\n")
(put-text-property beginning (point) 'jabber-jid jid)
(put-text-property beginning (point) 'jabber-account jc)
;; XXX: Is this kind of recursion really needed?
(if (listp (car (jabber-xml-node-children item)))
(jabber-process-browse jc item))))))
(provide 'jabber-browse)
;;; arch-tag: be01ab34-96eb-4fcb-aa35-a0d3e6c446c3

BIN
elpa/jabber-20180927.2325/jabber-browse.elc Normal file
View File

Binary file not shown.

683
elpa/jabber-20180927.2325/jabber-chat.el Normal file
View File

@ -0,0 +1,683 @@
;; jabber-chat.el - one-to-one chats
;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-core)
(require 'jabber-chatbuffer)
(require 'jabber-history)
(require 'jabber-menu) ;we need jabber-jid-chat-menu
(require 'ewoc)
(eval-when-compile (require 'cl))
(defgroup jabber-chat nil "chat display options"
:group 'jabber)
(defcustom jabber-chat-buffer-format "*-jabber-chat-%n-*"
"The format specification for the name of chat buffers.
These fields are available (all are about the person you are chatting
with):
%n Nickname, or JID if no nickname set
%j Bare JID (without resource)
%r Resource"
:type 'string
:group 'jabber-chat)
(defcustom jabber-chat-header-line-format
'("" (jabber-chat-buffer-show-avatar
(:eval
(let ((buddy (jabber-jid-symbol jabber-chatting-with)))
(jabber-propertize " "
'display (get buddy 'avatar)))))
(:eval (jabber-jid-displayname jabber-chatting-with))
"\t" (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with)))
(propertize
(or
(cdr (assoc (get buddy 'show) jabber-presence-strings))
(get buddy 'show))
'face
(or (cdr (assoc (get buddy 'show) jabber-presence-faces))
'jabber-roster-user-online))))
"\t" (:eval (jabber-fix-status (get (jabber-jid-symbol jabber-chatting-with) 'status)))
"\t" jabber-events-message ;see jabber-events.el
"\t" jabber-chatstates-message) ;see jabber-chatstates.el
"The specification for the header line of chat buffers.
The format is that of `mode-line-format' and `header-line-format'."
:type 'sexp
:group 'jabber-chat)
(defcustom jabber-chat-buffer-show-avatar t
"Show avatars in header line of chat buffer?
This variable might not take effect if you have changed
`jabber-chat-header-line-format'."
:type 'boolean
:group 'jabber-chat)
(defcustom jabber-chat-time-format "%H:%M"
"The format specification for instant messages in the chat buffer.
See also `jabber-chat-delayed-time-format'.
See `format-time-string' for valid values."
:type 'string
:group 'jabber-chat)
(defcustom jabber-chat-delayed-time-format "%Y-%m-%d %H:%M"
"The format specification for delayed messages in the chat buffer.
See also `jabber-chat-time-format'.
See `format-time-string' for valid values."
:type 'string
:group 'jabber-chat)
(defcustom jabber-print-rare-time t
"Non-nil means to print \"rare time\" indications in chat buffers.
The default settings tell every new hour."
:type 'boolean
:group 'jabber-chat)
(defcustom jabber-rare-time-format "%a %e %b %Y %H:00"
"The format specification for the rare time information.
Rare time information will be printed whenever the current time,
formatted according to this string, is different to the last
rare time printed."
:type 'string
:group 'jabber-chat)
(defface jabber-rare-time-face
'((t (:foreground "darkgreen" :underline t)))
"face for displaying the rare time info"
:group 'jabber-chat)
(defcustom jabber-chat-local-prompt-format "[%t] %n> "
"The format specification for lines you type in the chat buffer.
These fields are available:
%t Time, formatted according to `jabber-chat-time-format'
or `jabber-chat-delayed-time-format'
%u Username
%n Nickname (obsolete, same as username)
%r Resource
%j Bare JID (without resource)"
:type 'string
:group 'jabber-chat)
(defcustom jabber-chat-foreign-prompt-format "[%t] %n> "
"The format specification for lines others type in the chat buffer.
These fields are available:
%t Time, formatted according to `jabber-chat-time-format'
or `jabber-chat-delayed-time-format'
%n Nickname, or JID if no nickname set
%u Username
%r Resource
%j Bare JID (without resource)"
:type 'string
:group 'jabber-chat)
(defcustom jabber-chat-system-prompt-format "[%t] *** "
"The format specification for lines from the system or that are special in the chat buffer."
:type 'string
:group 'jabber-chat)
(defface jabber-chat-prompt-local
'((t (:foreground "blue" :weight bold)))
"face for displaying the chat prompt for what you type in"
:group 'jabber-chat)
(defface jabber-chat-prompt-foreign
'((t (:foreground "red" :weight bold)))
"face for displaying the chat prompt for what they send"
:group 'jabber-chat)
(defface jabber-chat-prompt-system
'((t (:foreground "green" :weight bold)))
"face used for system and special messages"
:group 'jabber-chat)
(defface jabber-chat-text-local '((t ()))
"Face used for text you write"
:group 'jabber-chat)
(defface jabber-chat-text-foreign '((t ()))
"Face used for text others write"
:group 'jabber-chat)
(defface jabber-chat-error
'((t (:foreground "red" :weight bold)))
"Face used for error messages"
:group 'jabber-chat)
;;;###autoload
(defvar jabber-chatting-with nil
"JID of the person you are chatting with")
(defvar jabber-chat-printers '(jabber-chat-print-subject
jabber-chat-print-body
jabber-chat-print-url
jabber-chat-goto-address)
"List of functions that may be able to print part of a message.
Each function receives these arguments:
XML-DATA The entire message stanza
WHO :local or :foreign, for sent or received stanza, respectively
MODE :insert or :printp. For :insert, insert text at point.
For :printp, return non-nil if function would insert text.")
(defvar jabber-body-printers '(jabber-chat-normal-body)
"List of functions that may be able to print a body for a message.
Each function receives these arguments:
XML-DATA The entire message stanza
WHO :local, :foreign or :error
MODE :insert or :printp. For :insert, insert text at point.
For :printp, return non-nil if function would insert text.
These functions are called in order, until one of them returns
non-nil.
Add a function to the beginning of this list if the tag it handles
replaces the contents of the <body/> tag.")
(defvar jabber-chat-send-hooks nil
"List of functions called when a chat message is sent.
The arguments are the text to send, and the id attribute of the
message.
The functions should return a list of XML nodes they want to be
added to the outgoing message.")
(defvar jabber-chat-earliest-backlog nil
"Float-time of earliest backlog entry inserted into buffer.
nil if no backlog has been inserted.")
;;;###autoload
(defun jabber-chat-get-buffer (chat-with)
"Return the chat buffer for chatting with CHAT-WITH (bare or full JID).
Either a string or a buffer is returned, so use `get-buffer' or
`get-buffer-create'."
(format-spec jabber-chat-buffer-format
(list
(cons ?n (jabber-jid-displayname chat-with))
(cons ?j (jabber-jid-user chat-with))
(cons ?r (or (jabber-jid-resource chat-with) "")))))
(defun jabber-chat-create-buffer (jc chat-with)
"Prepare a buffer for chatting with CHAT-WITH.
This function is idempotent."
(with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with))
(unless (eq major-mode 'jabber-chat-mode)
(jabber-chat-mode jc #'jabber-chat-pp)
(make-local-variable 'jabber-chatting-with)
(setq jabber-chatting-with chat-with)
(setq jabber-send-function 'jabber-chat-send)
(setq header-line-format jabber-chat-header-line-format)
(make-local-variable 'jabber-chat-earliest-backlog)
;; insert backlog
(when (null jabber-chat-earliest-backlog)
(let ((backlog-entries (jabber-history-backlog chat-with)))
(if (null backlog-entries)
(setq jabber-chat-earliest-backlog (jabber-float-time))
(setq jabber-chat-earliest-backlog
(jabber-float-time (jabber-parse-time
(aref (car backlog-entries) 0))))
(mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
;; Make sure the connection variable is up to date.
(setq jabber-buffer-connection jc)
(current-buffer)))
(defun jabber-chat-insert-backlog-entry (msg)
"Insert backlog entry MSG at beginning of buffer."
;; Rare timestamps are especially important in backlog. We risk
;; having superfluous timestamps if we just add before each backlog
;; entry.
(let* ((message-time (jabber-parse-time (aref msg 0)))
(fake-stanza `(message ((from . ,(aref msg 2)))
(body nil ,(aref msg 4))
(x ((xmlns . "jabber:x:delay")
(stamp . ,(jabber-encode-legacy-time message-time))))))
(node-data (list (if (string= (aref msg 1) "in") :foreign :local)
fake-stanza :delayed t)))
;; Insert after existing rare timestamp?
(if (and jabber-print-rare-time
(ewoc-nth jabber-chat-ewoc 0)
(eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time)
(not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0))))))
(ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data)
;; Insert first.
(ewoc-enter-first jabber-chat-ewoc node-data)
(when jabber-print-rare-time
(ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time))))))
(add-to-list 'jabber-jid-chat-menu
(cons "Display more context" 'jabber-chat-display-more-backlog))
(defun jabber-chat-display-more-backlog (how-many)
"Display more context. HOW-MANY is number of messages. Specify 0 to display all messages."
(interactive "nHow many more messages (Specify 0 to display all)? ")
(let* ((inhibit-read-only t)
(jabber-backlog-days nil)
(jabber-backlog-number (if (= how-many 0) t how-many))
(backlog-entries (jabber-history-backlog
jabber-chatting-with jabber-chat-earliest-backlog)))
(when backlog-entries
(setq jabber-chat-earliest-backlog
(jabber-float-time (jabber-parse-time
(aref (car backlog-entries) 0))))
(save-excursion
(goto-char (point-min))
(mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
(add-to-list 'jabber-message-chain 'jabber-process-chat)
(defun jabber-process-chat (jc xml-data)
"If XML-DATA is a one-to-one chat message, handle it as such."
;; For now, everything that is not a public MUC message is
;; potentially a 1to1 chat message.
(when (not (jabber-muc-message-p xml-data))
;; Note that we handle private MUC messages here.
(let ((from (jabber-xml-get-attribute xml-data 'from))
(error-p (jabber-xml-get-children xml-data 'error))
(body-text (car (jabber-xml-node-children
(car (jabber-xml-get-children
xml-data 'body))))))
;; First check if we would output anything for this stanza.
(when (or error-p
(run-hook-with-args-until-success 'jabber-chat-printers xml-data :foreign :printp))
;; If so, create chat buffer, if necessary...
(with-current-buffer (if (jabber-muc-sender-p from)
(jabber-muc-private-create-buffer
jc
(jabber-jid-user from)
(jabber-jid-resource from))
(jabber-chat-create-buffer jc from))
;; ...add the message to the ewoc...
(let ((node
(ewoc-enter-last jabber-chat-ewoc (list (if error-p :error :foreign) xml-data :time (current-time)))))
(jabber-maybe-print-rare-time node))
;; ...and call alert hooks.
(dolist (hook '(jabber-message-hooks jabber-alert-message-hooks))
(run-hook-with-args hook
from (current-buffer) body-text
(funcall jabber-alert-message-function
from (current-buffer) body-text))))))))
(defun jabber-chat-send (jc body)
"Send BODY through connection JC, and display it in chat buffer."
;; Build the stanza...
(let* ((id (apply 'format "emacs-msg-%d.%d.%d" (current-time)))
(stanza-to-send `(message
((to . ,jabber-chatting-with)
(type . "chat")
(id . ,id))
(body () ,body))))
;; ...add additional elements...
;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead.
;; That way we don't need to eliminate the "local hook" functionality
;; here.
(dolist (hook jabber-chat-send-hooks)
(if (eq hook t)
;; Local hook referring to global...
(when (local-variable-p 'jabber-chat-send-hooks)
(dolist (global-hook (default-value 'jabber-chat-send-hooks))
(nconc stanza-to-send (funcall global-hook body id))))
(nconc stanza-to-send (funcall hook body id))))
;; ...display it, if it would be displayed.
(when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp)
(jabber-maybe-print-rare-time
(ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time)))))
;; ...and send it...
(jabber-send-sexp jc stanza-to-send)))
(defun jabber-chat-pp (data)
"Pretty-print a <message/> stanza.
\(car data) is either :local, :foreign, :error or :notice.
\(cadr data) is the <message/> stanza.
This function is used as an ewoc prettyprinter."
(let* ((beg (point))
(original-timestamp (when (listp (cadr data))
(jabber-message-timestamp (cadr data))))
(internal-time
(plist-get (cddr data) :time))
(body (ignore-errors (car
(jabber-xml-node-children
(car
(jabber-xml-get-children (cadr data) 'body))))))
(/me-p
(and (> (length body) 4)
(string= (substring body 0 4) "/me "))))
;; Print prompt...
(let ((delayed (or original-timestamp (plist-get (cddr data) :delayed)))
(prompt-start (point)))
(case (car data)
(:local
(jabber-chat-self-prompt (or original-timestamp internal-time)
delayed
/me-p))
(:foreign
(if (and (listp (cadr data))
(jabber-muc-private-message-p (cadr data)))
(jabber-muc-private-print-prompt (cadr data))
;; For :error and :notice, this might be a string... beware
(jabber-chat-print-prompt (when (listp (cadr data)) (cadr data))
(or original-timestamp internal-time)
delayed
/me-p)))
((:error :notice :subscription-request)
(jabber-chat-system-prompt (or original-timestamp internal-time)))
(:muc-local
(jabber-muc-print-prompt (cadr data) t /me-p))
(:muc-foreign
(jabber-muc-print-prompt (cadr data) nil /me-p))
((:muc-notice :muc-error)
(jabber-muc-system-prompt)))
(put-text-property prompt-start (point) 'field 'jabber-prompt))
;; ...and body
(case (car data)
((:local :foreign)
(run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert))
((:muc-local :muc-foreign)
(let ((printers (append jabber-muc-printers jabber-chat-printers)))
(run-hook-with-args 'printers (cadr data) (car data) :insert)))
((:error :muc-error)
(if (stringp (cadr data))
(insert (jabber-propertize (cadr data) 'face 'jabber-chat-error))
(jabber-chat-print-error (cadr data))))
((:notice :muc-notice)
(insert (cadr data)))
(:rare-time
(insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data))
'face 'jabber-rare-time-face)))
(:subscription-request
(insert "This user requests subscription to your presence.\n")
(when (and (stringp (cadr data)) (not (zerop (length (cadr data)))))
(insert "Message: " (cadr data) "\n"))
(insert "Accept?\n\n")
(flet ((button
(text action)
(if (fboundp 'insert-button)
(insert-button text 'action action)
;; simple button replacement
(let ((keymap (make-keymap)))
(define-key keymap "\r" action)
(insert (jabber-propertize text 'keymap keymap 'face 'highlight))))
(insert "\t")))
(button "Mutual" 'jabber-subscription-accept-mutual)
(button "One-way" 'jabber-subscription-accept-one-way)
(button "Decline" 'jabber-subscription-decline))))
(when jabber-chat-fill-long-lines
(save-restriction
(narrow-to-region beg (point))
(jabber-chat-buffer-fill-long-lines)))
(put-text-property beg (point) 'read-only t)
(put-text-property beg (point) 'front-sticky t)
(put-text-property beg (point) 'rear-nonsticky t)))
(defun jabber-rare-time-needed (time1 time2)
"Return non-nil if a timestamp should be printed between TIME1 and TIME2."
(not (string= (format-time-string jabber-rare-time-format time1)
(format-time-string jabber-rare-time-format time2))))
(defun jabber-maybe-print-rare-time (node)
"Print rare time before NODE, if appropriate."
(let* ((prev (ewoc-prev jabber-chat-ewoc node))
(data (ewoc-data node))
(prev-data (when prev (ewoc-data prev))))
(flet ((entry-time (entry)
(or (when (listp (cadr entry))
(jabber-message-timestamp (cadr entry)))
(plist-get (cddr entry) :time))))
(when (and jabber-print-rare-time
(or (null prev)
(jabber-rare-time-needed (entry-time prev-data)
(entry-time data))))
(ewoc-enter-before jabber-chat-ewoc node
(list :rare-time (entry-time data)))))))
(defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p)
"Print prompt for received message in XML-DATA.
TIMESTAMP is the timestamp to print, or nil to get it
from a jabber:x:delay element.
If DELAYED is true, print long timestamp
\(`jabber-chat-delayed-time-format' as opposed to
`jabber-chat-time-format').
If DONT-PRINT-NICK-P is true, don't include nickname."
(let ((from (jabber-xml-get-attribute xml-data 'from))
(timestamp (or timestamp (jabber-message-timestamp xml-data))))
(insert (jabber-propertize
(format-spec jabber-chat-foreign-prompt-format
(list
(cons ?t (format-time-string
(if delayed
jabber-chat-delayed-time-format
jabber-chat-time-format)
timestamp))
(cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from)))
(cons ?u (or (jabber-jid-username from) from))
(cons ?r (jabber-jid-resource from))
(cons ?j (jabber-jid-user from))))
'face 'jabber-chat-prompt-foreign
'help-echo
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from)))))
(defun jabber-chat-system-prompt (timestamp)
(insert (jabber-propertize
(format-spec jabber-chat-foreign-prompt-format
(list
(cons ?t (format-time-string jabber-chat-time-format
timestamp))
(cons ?n "")
(cons ?u "")
(cons ?r "")
(cons ?j "")))
'face 'jabber-chat-prompt-system
'help-echo
(concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp)))))
(defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p)
"Print prompt for sent message.
TIMESTAMP is the timestamp to print, or nil for now.
If DELAYED is true, print long timestamp
\(`jabber-chat-delayed-time-format' as opposed to
`jabber-chat-time-format').
If DONT-PRINT-NICK-P is true, don't include nickname."
(let* ((state-data (fsm-get-state-data jabber-buffer-connection))
(username (plist-get state-data :username))
(server (plist-get state-data :server))
(resource (plist-get state-data :resource))
(nickname username))
(insert (jabber-propertize
(format-spec jabber-chat-local-prompt-format
(list
(cons ?t (format-time-string
(if delayed
jabber-chat-delayed-time-format
jabber-chat-time-format)
timestamp))
(cons ?n (if dont-print-nick-p "" nickname))
(cons ?u username)
(cons ?r resource)
(cons ?j (concat username "@" server))))
'face 'jabber-chat-prompt-local
'help-echo
(concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you")))))
(defun jabber-chat-print-error (xml-data)
"Print error in given <message/> in a readable way."
(let ((the-error (car (jabber-xml-get-children xml-data 'error))))
(insert
(jabber-propertize
(concat "Error: " (jabber-parse-error the-error))
'face 'jabber-chat-error))))
(defun jabber-chat-print-subject (xml-data who mode)
"Print subject of given <message/>, if any."
(let ((subject (car
(jabber-xml-node-children
(car
(jabber-xml-get-children xml-data 'subject))))))
(when (not (zerop (length subject)))
(case mode
(:printp
t)
(:insert
(insert (jabber-propertize
"Subject: " 'face 'jabber-chat-prompt-system)
(jabber-propertize
subject
'face 'jabber-chat-text-foreign)
"\n"))))))
(defun jabber-chat-print-body (xml-data who mode)
(run-hook-with-args-until-success 'jabber-body-printers xml-data who mode))
(defun jabber-chat-normal-body (xml-data who mode)
"Print body for received message in XML-DATA."
(let ((body (car
(jabber-xml-node-children
(car
(jabber-xml-get-children xml-data 'body))))))
(when body
(when (eql mode :insert)
(if (and (> (length body) 4)
(string= (substring body 0 4) "/me "))
(let ((action (substring body 4))
(nick (cond
((eq who :local)
(plist-get (fsm-get-state-data jabber-buffer-connection) :username))
((or (jabber-muc-message-p xml-data)
(jabber-muc-private-message-p xml-data))
(jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
(t
(jabber-jid-displayname (jabber-xml-get-attribute xml-data 'from))))))
(insert (jabber-propertize
(concat nick
" "
action)
'face 'jabber-chat-prompt-system)))
(insert (jabber-propertize
body
'face (case who
((:foreign :muc-foreign) 'jabber-chat-text-foreign)
((:local :muc-local) 'jabber-chat-text-local))))))
t)))
(defun jabber-chat-print-url (xml-data who mode)
"Print URLs provided in jabber:x:oob namespace."
(let ((foundp nil))
(dolist (x (jabber-xml-node-children xml-data))
(when (and (listp x) (eq (jabber-xml-node-name x) 'x)
(string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob"))
(setq foundp t)
(when (eql mode :insert)
(let ((url (car (jabber-xml-node-children
(car (jabber-xml-get-children x 'url)))))
(desc (car (jabber-xml-node-children
(car (jabber-xml-get-children x 'desc))))))
(insert "\n"
(jabber-propertize
"URL: " 'face 'jabber-chat-prompt-system)
(format "%s <%s>" desc url))))))
foundp))
(defun jabber-chat-goto-address (xml-data who mode)
"Call `goto-address' on the newly written text."
(when (eq mode :insert)
(ignore-errors
;; `goto-address' is autoloaded, but `goto-address-fontify' is not.
(require 'goto-addr)
(let ((end (point))
(limit (max (- (point) 1000) (1+ (point-min)))))
;; We only need to fontify the text written since the last
;; prompt. The prompt has a field property, so we can find it
;; using `field-beginning'.
(goto-address-fontify (field-beginning nil nil limit) end)))))
;; jabber-compose is autoloaded in jabber.el
(add-to-list 'jabber-jid-chat-menu
(cons "Compose message" 'jabber-compose))
(defun jabber-send-message (jc to subject body type)
"send a message tag to the server"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "to: ")
(jabber-read-with-input-method "subject: ")
(jabber-read-with-input-method "body: ")
(read-string "type: ")))
(jabber-send-sexp jc
`(message ((to . ,to)
,(if (> (length type) 0)
`(type . ,type)))
,(if (> (length subject) 0)
`(subject () ,subject))
,(if (> (length body) 0)
`(body () ,body))))
(if (and jabber-history-enabled (not (string= type "groupchat")))
(jabber-history-log-message "out" nil to body (current-time))))
(add-to-list 'jabber-jid-chat-menu
(cons "Start chat" 'jabber-chat-with))
(defun jabber-chat-with (jc jid &optional other-window)
"Open an empty chat window for chatting with JID.
With a prefix argument, open buffer in other window.
Returns the chat buffer."
(interactive (let* ((jid
(jabber-read-jid-completing "chat with:"))
(account
(jabber-read-account nil jid)))
(list
account jid current-prefix-arg)))
(let ((buffer (jabber-chat-create-buffer jc jid)))
(if other-window
(switch-to-buffer-other-window buffer)
(switch-to-buffer buffer))))
(defun jabber-chat-with-jid-at-point (&optional other-window)
"Start chat with JID at point.
Signal an error if there is no JID at point.
With a prefix argument, open buffer in other window."
(interactive "P")
(let ((jid-at-point (get-text-property (point)
'jabber-jid))
(account (get-text-property (point)
'jabber-account)))
(if (and jid-at-point account)
(jabber-chat-with account jid-at-point other-window)
(error "No contact at point"))))
(provide 'jabber-chat)
;; arch-tag: f423eb92-aa87-475b-b590-48c93ccba9be

137
elpa/jabber-20180927.2325/jabber-chatbuffer.el Normal file
View File

@ -0,0 +1,137 @@
;; jabber-chatbuffer.el - functions common to all chat buffers
;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-keymap)
(defvar jabber-point-insert nil
"Position where the message being composed starts")
(defvar jabber-send-function nil
"Function for sending a message from a chat buffer.")
(defvar jabber-chat-mode-hook nil
"Hook called at the end of `jabber-chat-mode'.
Note that functions in this hook have no way of knowing
what kind of chat buffer is being created.")
(defcustom jabber-chat-fill-long-lines t
"If non-nil, fill long lines in chat buffers.
Lines are broken at word boundaries at the width of the
window or at `fill-column', whichever is shorter."
:group 'jabber-chat
:type 'boolean)
(defvar jabber-chat-ewoc nil
"The ewoc showing the messages of this chat buffer.")
;;;###autoload
(defvar jabber-buffer-connection nil
"The connection used by this buffer.")
;;;###autoload
(make-variable-buffer-local 'jabber-buffer-connection)
(defun jabber-chat-mode (jc ewoc-pp)
"\\{jabber-chat-mode-map}"
(kill-all-local-variables)
;; Make sure to set this variable somewhere
(make-local-variable 'jabber-send-function)
(make-local-variable 'scroll-conservatively)
(make-local-variable 'jabber-point-insert)
(make-local-variable 'jabber-chat-ewoc)
(make-local-variable 'buffer-undo-list)
(setq jabber-buffer-connection jc
scroll-conservatively 5
buffer-undo-list t) ;dont keep undo list for chatbuffer
(unless jabber-chat-ewoc
(setq jabber-chat-ewoc
(ewoc-create ewoc-pp nil "---"))
(goto-char (point-max))
(put-text-property (point-min) (point) 'read-only t)
(let ((inhibit-read-only t))
(put-text-property (point-min) (point) 'front-sticky t)
(put-text-property (point-min) (point) 'rear-nonsticky t))
(setq jabber-point-insert (point-marker)))
;;(setq header-line-format jabber-chat-header-line-format)
(setq major-mode 'jabber-chat-mode
mode-name "jabber-chat")
(use-local-map jabber-chat-mode-map)
(if (fboundp 'run-mode-hooks)
(run-mode-hooks 'jabber-chat-mode-hook)
(run-hooks 'jabber-chat-mode-hook)))
(put 'jabber-chat-mode 'mode-class 'special)
;; Spell check only what you're currently writing
(defun jabber-chat-mode-flyspell-verify ()
(>= (point) jabber-point-insert))
(put 'jabber-chat-mode 'flyspell-mode-predicate
'jabber-chat-mode-flyspell-verify)
(defvar jabber-chat-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map jabber-common-keymap)
(define-key map "\r" 'jabber-chat-buffer-send)
map))
(defun jabber-chat-buffer-send ()
(interactive)
;; If user accidentally hits RET without writing anything, just
;; ignore it.
(when (plusp (- (point-max) jabber-point-insert))
;; If connection was lost...
(unless (memq jabber-buffer-connection jabber-connections)
;; ...maybe there is a new connection to the same account.
(let ((new-jc (jabber-find-active-connection jabber-buffer-connection)))
(if new-jc
;; If so, just use it.
(setq jabber-buffer-connection new-jc)
;; Otherwise, ask for a new account.
(setq jabber-buffer-connection (jabber-read-account t)))))
(let ((body (delete-and-extract-region jabber-point-insert (point-max))))
(funcall jabber-send-function jabber-buffer-connection body))))
(defun jabber-chat-buffer-fill-long-lines ()
"Fill lines that are wider than the window width."
;; This was mostly stolen from article-fill-long-lines
(interactive)
(save-excursion
(let ((inhibit-read-only t)
(width (window-width (get-buffer-window (current-buffer)))))
(goto-char (point-min))
(let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
(save-restriction
(narrow-to-region (min (1+ (point)) (point-max))
(point-at-bol))
(let ((goback (point-marker)))
(fill-paragraph nil)
(goto-char (marker-position goback)))))
(forward-line 1))))))
(provide 'jabber-chatbuffer)
;; arch-tag: 917e5b60-5894-4c49-b3bc-12e1f97ffdc6

BIN
elpa/jabber-20180927.2325/jabber-chatbuffer.elc Normal file
View File

Binary file not shown.

177
elpa/jabber-20180927.2325/jabber-chatstates.el Normal file
View File

@ -0,0 +1,177 @@
;;; jabber-chatstate.el --- Chat state notification (XEP-0085) implementation
;; Author: Ami Fischman <ami@fischman.org>
;; (based entirely on jabber-events.el by Magnus Henoch <mange@freemail.hu>)
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; TODO
;; - Currently only active/composing notifications are /sent/ though all 5
;; notifications are handled on receipt.
(require 'cl)
(defgroup jabber-chatstates nil
"Chat state notifications."
:group 'jabber)
(defconst jabber-chatstates-xmlns "http://jabber.org/protocol/chatstates"
"XML namespace for the chatstates feature.")
(defcustom jabber-chatstates-confirm t
"Send notifications about chat states?"
:group 'jabber-chatstates
:type 'boolean)
(defvar jabber-chatstates-requested 'first-time
"Whether or not chat states notification was requested.
This is one of the following:
first-time - send state in first stanza, then switch to nil
t - send states
nil - don't send states")
(make-variable-buffer-local 'jabber-chatstates-requested)
(defvar jabber-chatstates-last-state nil
"The last seen chat state.")
(make-variable-buffer-local 'jabber-chatstates-last-state)
(defvar jabber-chatstates-message ""
"Human-readable presentation of chat state information")
(make-variable-buffer-local 'jabber-chatstates-message)
;;; INCOMING
;;; Code for requesting chat state notifications from others and handling
;;; them.
(defun jabber-chatstates-update-message ()
(setq jabber-chatstates-message
(if (and jabber-chatstates-last-state
(not (eq 'active jabber-chatstates-last-state)))
(format " (%s)" (symbol-name jabber-chatstates-last-state))
"")))
(add-hook 'jabber-chat-send-hooks 'jabber-chatstates-when-sending)
(defun jabber-chatstates-when-sending (text id)
(jabber-chatstates-update-message)
(jabber-chatstates-stop-timer)
(when (and jabber-chatstates-confirm jabber-chatstates-requested)
(when (eq jabber-chatstates-requested 'first-time)
;; don't send more notifications until we know that the other
;; side wants them.
(setq jabber-chatstates-requested nil))
(setq jabber-chatstates-composing-sent nil)
`((active ((xmlns . ,jabber-chatstates-xmlns))))))
;;; OUTGOING
;;; Code for handling requests for chat state notifications and providing
;;; them, modulo user preferences.
(defvar jabber-chatstates-composing-sent nil
"Has composing notification been sent?
It can be sent and cancelled several times.")
(make-variable-buffer-local 'jabber-chatstates-composing-sent)
(defvar jabber-chatstates-paused-timer nil
"Timer that counts down from 'composing state to 'paused.")
(make-variable-buffer-local 'jabber-chatstates-paused-timer)
(defun jabber-chatstates-stop-timer ()
"Stop the 'paused timer."
(when jabber-chatstates-paused-timer
(cancel-timer jabber-chatstates-paused-timer)))
(defun jabber-chatstates-kick-timer ()
"Start (or restart) the 'paused timer as approriate."
(jabber-chatstates-stop-timer)
(setq jabber-chatstates-paused-timer
(run-with-timer 5 nil 'jabber-chatstates-send-paused)))
(defun jabber-chatstates-send-paused ()
"Send an 'paused state notification."
(when (and jabber-chatstates-requested jabber-chatting-with)
(setq jabber-chatstates-composing-sent nil)
(jabber-send-sexp-if-connected
jabber-buffer-connection
`(message
((to . ,jabber-chatting-with)
(type . "chat"))
(paused ((xmlns . ,jabber-chatstates-xmlns)))))))
(defun jabber-chatstates-after-change ()
(let* ((composing-now (not (= (point-max) jabber-point-insert)))
(state (if composing-now 'composing 'active)))
(when (and jabber-chatstates-confirm
jabber-chatting-with
jabber-chatstates-requested
(not (eq composing-now jabber-chatstates-composing-sent)))
(jabber-send-sexp-if-connected
jabber-buffer-connection
`(message
((to . ,jabber-chatting-with)
(type . "chat"))
(,state ((xmlns . ,jabber-chatstates-xmlns)))))
(when (setq jabber-chatstates-composing-sent composing-now)
(jabber-chatstates-kick-timer)))))
;;; COMMON
(defun jabber-handle-incoming-message-chatstates (jc xml-data)
(when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))
(with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
(cond
;; If we get an error message, we shouldn't report any
;; events, as the requests are mirrored from us.
((string= (jabber-xml-get-attribute xml-data 'type) "error")
(remove-hook 'post-command-hook 'jabber-chatstates-after-change t)
(setq jabber-chatstates-requested nil))
(t
(let ((state
(or
(let ((node
(find jabber-chatstates-xmlns
(jabber-xml-node-children xml-data)
:key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns))
:test #'string=)))
(jabber-xml-node-name node))
(let ((node
;; XXX: this is how we interoperate with
;; Google Talk. We should really use a
;; namespace-aware XML parser.
(find jabber-chatstates-xmlns
(jabber-xml-node-children xml-data)
:key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns:cha))
:test #'string=)))
(when node
;; Strip the "cha:" prefix
(let ((name (symbol-name (jabber-xml-node-name node))))
(when (> (length name) 4)
(intern (substring name 4)))))))))
;; Set up hooks for composition notification
(when (and jabber-chatstates-confirm state)
(setq jabber-chatstates-requested t)
(add-hook 'post-command-hook 'jabber-chatstates-after-change nil t))
(setq jabber-chatstates-last-state state)
(jabber-chatstates-update-message)))))))
;; Add function last in chain, so a chat buffer is already created.
(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-chatstates t)
(jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates")
(provide 'jabber-chatstates)
;; arch-tag: d879de90-51e1-11dc-909d-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-chatstates.elc Normal file
View File

Binary file not shown.

82
elpa/jabber-20180927.2325/jabber-compose.el Normal file
View File

@ -0,0 +1,82 @@
;;; jabber-compose.el --- compose a Jabber message in a buffer
;; Copyright (C) 2006, 2007 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; Keywords:
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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.
;;; Code:
;;;###autoload
(defun jabber-compose (jc &optional recipient)
"Create a buffer for composing a Jabber message."
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "To whom? ")))
(with-current-buffer (get-buffer-create
(generate-new-buffer-name
(concat
"Jabber-Compose"
(when recipient
(format "-%s" (jabber-jid-displayname recipient))))))
(set (make-local-variable 'jabber-widget-alist) nil)
(setq jabber-buffer-connection jc)
(use-local-map widget-keymap)
(insert (jabber-propertize "Compose Jabber message\n" 'face 'jabber-title-large))
(insert (substitute-command-keys "\\<widget-field-keymap>Completion available with \\[widget-complete].\n"))
(push (cons :recipients
(widget-create '(repeat :tag "Recipients" jid)
:value (when recipient
(list recipient))))
jabber-widget-alist)
(insert "\nSubject: ")
(push (cons :subject
(widget-create 'editable-field :value ""))
jabber-widget-alist)
(insert "\nText:\n")
(push (cons :text
(widget-create 'text :value ""))
jabber-widget-alist)
(insert "\n")
(widget-create 'push-button :notify #'jabber-compose-send "Send")
(widget-setup)
(switch-to-buffer (current-buffer))
(goto-char (point-min))))
(defun jabber-compose-send (&rest ignore)
(let ((recipients (widget-value (cdr (assq :recipients jabber-widget-alist))))
(subject (widget-value (cdr (assq :subject jabber-widget-alist))))
(text (widget-value (cdr (assq :text jabber-widget-alist)))))
(when (null recipients)
(error "No recipients specified"))
(dolist (to recipients)
(jabber-send-message jabber-buffer-connection to subject text nil))
(bury-buffer)
(message "Message sent")))
(provide 'jabber-compose)
;; arch-tag: 59032c00-994d-11da-8d97-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-compose.elc Normal file
View File

Binary file not shown.

405
elpa/jabber-20180927.2325/jabber-conn.el Normal file
View File

@ -0,0 +1,405 @@
;; jabber-conn.el - Network transport functions
;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni
;; mostly inspired by Gnus.
;; Copyright (C) 2005 - Carl Henrik Lunde - chlunde+jabber+@ping.uio.no
;; (starttls)
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; A collection of functions, that hide the details of transmitting to
;; and fro a Jabber Server
(eval-when-compile (require 'cl))
;; Emacs 24 can be linked with GnuTLS
(ignore-errors (require 'gnutls))
;; Try two different TLS/SSL libraries, but don't fail if none available.
(or (ignore-errors (require 'tls))
(ignore-errors (require 'ssl)))
(ignore-errors (require 'starttls))
(eval-and-compile
(or (ignore-errors (require 'srv))
(ignore-errors
(let ((load-path (cons (expand-file-name
"jabber-fallback-lib"
(file-name-directory (locate-library "jabber")))
load-path)))
(require 'srv)))
(error
"srv not found in `load-path' or jabber-fallback-lib/ directory.")))
(defgroup jabber-conn nil "Jabber Connection Settings"
:group 'jabber)
(defun jabber-have-starttls ()
"Return true if we can use STARTTLS."
(or (and (fboundp 'gnutls-available-p)
(gnutls-available-p))
(and (featurep 'starttls)
(or (and (bound-and-true-p starttls-gnutls-program)
(executable-find starttls-gnutls-program))
(and (bound-and-true-p starttls-program)
(executable-find starttls-program))))))
(defconst jabber-default-connection-type
(cond
;; Use STARTTLS if we can...
((jabber-have-starttls)
'starttls)
;; ...else default to unencrypted connection.
(t
'network))
"Default connection type.
See `jabber-connect-methods'.")
(defcustom jabber-connection-ssl-program nil
"Program used for SSL/TLS connections.
nil means prefer gnutls but fall back to openssl.
'gnutls' means use gnutls (through `open-tls-stream').
'openssl means use openssl (through `open-ssl-stream')."
:type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil)
(const :tag "Use gnutls" gnutls)
(const :tag "Use openssl" openssl))
:group 'jabber-conn)
(defcustom jabber-invalid-certificate-servers ()
"Jabber servers for which we accept invalid TLS certificates.
This is a list of server names, each matching the hostname part
of your JID.
This option has effect only when using native GnuTLS in Emacs 24
or later."
:type '(repeat string)
:group 'jabber-conn)
(defvar jabber-connect-methods
`((network jabber-network-connect jabber-network-send)
(starttls
,(if (and (fboundp 'gnutls-available-p)
(gnutls-available-p))
;; With "native" TLS, we can use a normal connection.
'jabber-network-connect
'jabber-starttls-connect)
jabber-network-send)
(ssl jabber-ssl-connect jabber-ssl-send)
(virtual jabber-virtual-connect jabber-virtual-send))
"Alist of connection methods and functions.
First item is the symbol naming the method.
Second item is the connect function.
Third item is the send function.")
(defun jabber-get-connect-function (type)
"Get the connect function associated with TYPE.
TYPE is a symbol; see `jabber-connection-type'."
(let ((entry (assq type jabber-connect-methods)))
(nth 1 entry)))
(defun jabber-get-send-function (type)
"Get the send function associated with TYPE.
TYPE is a symbol; see `jabber-connection-type'."
(let ((entry (assq type jabber-connect-methods)))
(nth 2 entry)))
(defun jabber-srv-targets (server network-server port)
"Find host and port to connect to.
If NETWORK-SERVER and/or PORT are specified, use them.
If we can't find SRV records, use standard defaults."
;; If the user has specified a host or a port, obey that.
(if (or network-server port)
(list (cons (or network-server server)
(or port 5222)))
(or (condition-case nil
(srv-lookup (concat "_xmpp-client._tcp." server))
(error nil))
(list (cons server 5222)))))
;; Plain TCP/IP connection
(defun jabber-network-connect (fsm server network-server port)
"Connect to a Jabber server with a plain network connection.
Send a message of the form (:connected CONNECTION) to FSM if
connection succeeds. Send a message (:connection-failed ERRORS) if
connection fails."
(cond
((featurep 'make-network-process '(:nowait t))
;; We can connect asynchronously!
(jabber-network-connect-async fsm server network-server port))
(t
;; Connecting to the server will block Emacs.
(jabber-network-connect-sync fsm server network-server port))))
(defun jabber-network-connect-async (fsm server network-server port)
;; Get all potential targets...
(lexical-let ((targets (jabber-srv-targets server network-server port))
errors
(fsm fsm))
;; ...and connect to them one after another, asynchronously, until
;; connection succeeds.
(labels
((connect
(target remaining-targets)
(lexical-let ((target target) (remaining-targets remaining-targets))
(labels ((connection-successful
(c)
;; This mustn't be `fsm-send-sync', because the FSM
;; needs to change the sentinel, which cannot be done
;; from inside the sentinel.
(fsm-send fsm (list :connected c)))
(connection-failed
(c status)
(when (and (> (length status) 0)
(eq (aref status (1- (length status))) ?\n))
(setq status (substring status 0 -1)))
(let ((err
(format "Couldn't connect to %s:%s: %s"
(car target) (cdr target) status)))
(message "%s" err)
(push err errors))
(when c (delete-process c))
(if remaining-targets
(progn
(message
"Connecting to %s:%s..."
(caar remaining-targets) (cdar remaining-targets))
(connect (car remaining-targets) (cdr remaining-targets)))
(fsm-send fsm (list :connection-failed (nreverse errors))))))
(condition-case e
(make-network-process
:name "jabber"
:buffer (generate-new-buffer jabber-process-buffer)
:host (car target) :service (cdr target)
:coding 'utf-8
:nowait t
:sentinel
(lexical-let ((target target) (remaining-targets remaining-targets))
(lambda (connection status)
(cond
((string-match "^open" status)
(connection-successful connection))
((string-match "^failed" status)
(connection-failed connection status))
((string-match "^deleted" status)
;; This happens when we delete a process in the
;; "failed" case above.
nil)
(t
(message "Unknown sentinel status `%s'" status))))))
(file-error
;; A file-error has the error message in the third list
;; element.
(connection-failed nil (car (cddr e))))
(error
;; Not sure if we ever get anything but file-errors,
;; but let's make sure we report them:
(connection-failed nil (error-message-string e))))))))
(message "Connecting to %s:%s..." (caar targets) (cdar targets))
(connect (car targets) (cdr targets)))))
(defun jabber-network-connect-sync (fsm server network-server port)
;; This code will AFAIK only be used on Windows. Apologies in
;; advance for any bit rot...
(let ((coding-system-for-read 'utf-8)
(coding-system-for-write 'utf-8)
(targets (jabber-srv-targets server network-server port))
errors)
(catch 'connected
(dolist (target targets)
(condition-case e
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
connection)
(unwind-protect
(setq connection (open-network-stream
"jabber"
process-buffer
(car target)
(cdr target)))
(unless (or connection jabber-debug-keep-process-buffers)
(kill-buffer process-buffer)))
(when connection
(fsm-send fsm (list :connected connection))
(throw 'connected connection)))
(file-error
;; A file-error has the error message in the third list
;; element.
(let ((err (format "Couldn't connect to %s:%s: %s"
(car target) (cdr target)
(car (cddr e)))))
(message "%s" err)
(push err errors)))
(error
;; Not sure if we ever get anything but file-errors,
;; but let's make sure we report them:
(let ((err (format "Couldn't connect to %s:%s: %s"
(car target) (cdr target)
(error-message-string e))))
(message "%s" err)
(push err errors)))))
(fsm-send fsm (list :connection-failed (nreverse errors))))))
(defun jabber-network-send (connection string)
"Send a string via a plain TCP/IP connection to the Jabber Server."
(process-send-string connection string))
;; SSL connection, we use openssl's s_client function for encryption
;; of the link
;; TODO: make this configurable
(defun jabber-ssl-connect (fsm server network-server port)
"connect via OpenSSL or GnuTLS to a Jabber Server
Send a message of the form (:connected CONNECTION) to FSM if
connection succeeds. Send a message (:connection-failed ERRORS) if
connection fails."
(let ((coding-system-for-read 'utf-8)
(coding-system-for-write 'utf-8)
(connect-function
(cond
((and (memq jabber-connection-ssl-program '(nil gnutls))
(fboundp 'open-tls-stream))
'open-tls-stream)
((and (memq jabber-connection-ssl-program '(nil openssl))
(fboundp 'open-ssl-stream))
'open-ssl-stream)
(t
(error "Neither TLS nor SSL connect functions available"))))
error-msg)
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
connection)
(setq network-server (or network-server server))
(setq port (or port 5223))
(condition-case e
(setq connection (funcall connect-function
"jabber"
process-buffer
network-server
port))
(error
(setq error-msg
(format "Couldn't connect to %s:%d: %s" network-server port
(error-message-string e)))
(message "%s" error-msg)))
(unless (or connection jabber-debug-keep-process-buffers)
(kill-buffer process-buffer))
(if connection
(fsm-send fsm (list :connected connection))
(fsm-send fsm (list :connection-failed
(when error-msg (list error-msg))))))))
(defun jabber-ssl-send (connection string)
"Send a string via an SSL-encrypted connection to the Jabber Server."
;; It seems we need to send a linefeed afterwards.
(process-send-string connection string)
(process-send-string connection "\n"))
(defun jabber-starttls-connect (fsm server network-server port)
"Connect via an external GnuTLS process to a Jabber Server.
Send a message of the form (:connected CONNECTION) to FSM if
connection succeeds. Send a message (:connection-failed ERRORS) if
connection fails."
(let ((coding-system-for-read 'utf-8)
(coding-system-for-write 'utf-8)
(targets (jabber-srv-targets server network-server port))
errors)
(unless (fboundp 'starttls-open-stream)
(error "starttls.el not available"))
(catch 'connected
(dolist (target targets)
(condition-case e
(let ((process-buffer (generate-new-buffer jabber-process-buffer))
connection)
(unwind-protect
(setq connection
(starttls-open-stream
"jabber"
process-buffer
(car target)
(cdr target)))
(unless (or connection jabber-debug-keep-process-buffers)
(kill-buffer process-buffer)))
(if (null connection)
;; It seems we don't actually get an error if we
;; can't connect. Let's try to convey some useful
;; information to the user at least.
(let ((err (format "Couldn't connect to %s:%s"
(car target) (cdr target))))
(message "%s" err)
(push err errors))
(fsm-send fsm (list :connected connection))
(throw 'connected connection)))
(error
(let ((err (format "Couldn't connect to %s: %s" target
(error-message-string e))))
(message "%s" err)
(push err errors)))))
(fsm-send fsm (list :connection-failed (nreverse errors))))))
(defun jabber-starttls-initiate (fsm)
"Initiate a starttls connection"
(jabber-send-sexp fsm
'(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls")))))
(defun jabber-starttls-process-input (fsm xml-data)
"Process result of starttls request.
On failure, signal error."
(cond
((eq (car xml-data) 'proceed)
(let* ((state-data (fsm-get-state-data fsm))
(connection (plist-get state-data :connection)))
;; Did we use open-network-stream or starttls-open-stream? We
;; can tell by process-type.
(case (process-type connection)
(network
(let* ((hostname (plist-get state-data :server))
(verifyp (not (member hostname jabber-invalid-certificate-servers))))
;; gnutls-negotiate might signal an error, which is caught
;; by our caller
(gnutls-negotiate
:process connection
;; This is the hostname that the certificate should be valid for:
:hostname hostname
:verify-hostname-error verifyp
:verify-error verifyp)))
(real
(or
(starttls-negotiate connection)
(error "Negotiation failure"))))))
((eq (car xml-data) 'failure)
(error "Command rejected by server"))))
(defvar *jabber-virtual-server-function* nil
"Function to use for sending stanzas on a virtual connection.
The function should accept two arguments, the connection object
and a string that the connection wants to send.")
(defun jabber-virtual-connect (fsm server network-server port)
"Connect to a virtual \"server\".
Use `*jabber-virtual-server-function*' as send function."
(unless (functionp *jabber-virtual-server-function*)
(error "No virtual server function specified"))
;; We pass the fsm itself as "connection object", as that is what a
;; virtual server needs to send stanzas.
(fsm-send fsm (list :connected fsm)))
(defun jabber-virtual-send (connection string)
(funcall *jabber-virtual-server-function* connection string))
(provide 'jabber-conn)
;; arch-tag: f95ec240-8cd3-11d9-9dbf-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-conn.elc Normal file
View File

Binary file not shown.

143
elpa/jabber-20180927.2325/jabber-console.el Normal file
View File

@ -0,0 +1,143 @@
;; jabber-console.el - XML Console mode
;; Copyright (C) 2009, 2010 - Demyan Rogozhin <demyan.rogozhin@gmail.com>
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Commentary:
;; Use *-jabber-console-* for sending custom XMPP code. Be careful!
;;; Code:
(require 'jabber-keymap)
(require 'jabber-util)
(require 'ewoc)
(require 'sgml-mode) ;we base on this mode to hightlight XML
(defcustom jabber-console-name-format "*-jabber-console-%s-*"
"Format for console buffer name. %s mean connection jid."
:type 'string
:group 'jabber-debug)
(defcustom jabber-console-truncate-lines 3000
"Maximum number of lines in console buffer.
Not truncate if set to 0"
:type 'integer
:group 'jabber-debug)
(defvar jabber-point-insert nil
"Position where the message being composed starts")
(defvar jabber-send-function nil
"Function for sending a message from a chat buffer.")
(defvar jabber-console-mode-hook nil
"Hook called at the end of `jabber-console-mode'.
Note that functions in this hook have no way of knowing
what kind of chat buffer is being created.")
(defvar jabber-console-ewoc nil
"The ewoc showing the XML elements of this stream buffer.")
(defvar jabber-console-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map jabber-common-keymap)
(define-key map "\r" 'jabber-chat-buffer-send)
map))
(defun jabber-console-create-buffer (jc)
(with-current-buffer
(get-buffer-create (format jabber-console-name-format (jabber-connection-bare-jid jc)))
(unless (eq major-mode 'jabber-console-mode)
(jabber-console-mode))
;; Make sure the connection variable is up to date.
(setq jabber-buffer-connection jc)
(current-buffer)))
(defun jabber-console-send (jc data)
;; Put manual string into buffers ewoc
(jabber-process-console jc "raw" data)
;; ...than sent it to server
(jabber-send-string jc data))
(defun jabber-console-comment (str)
"Insert comment into console buffer."
(let ((string (concat
comment-start str "@" (jabber-encode-time (current-time)) ":"
comment-end "\n")))
(when (stringp jabber-debug-log-xml)
(jabber-append-string-to-file string jabber-debug-log-xml))
(insert string)))
(defun jabber-console-pp (data)
"Pretty Printer for XML-sexp and raw data"
(let ((direction (car data))
(xml-list (cdr data))
(raw (cadr data)))
(jabber-console-comment direction)
(if (stringp raw)
;; raw code input
(progn
(insert raw)
(when (stringp jabber-debug-log-xml)
(jabber-append-string-to-file raw jabber-debug-log-xml)))
;; receive/sending
(progn
(xml-print xml-list)
(when (stringp jabber-debug-log-xml)
(jabber-append-string-to-file
"\n" jabber-debug-log-xml 'xml-print xml-list))))))
(define-derived-mode jabber-console-mode sgml-mode "Jabber Console"
"Major mode for debug XMPP protocol"
;; Make sure to set this variable somewhere
(make-local-variable 'jabber-send-function)
(make-local-variable 'jabber-point-insert)
(make-local-variable 'jabber-console-ewoc)
(setq jabber-send-function 'jabber-console-send)
(unless jabber-console-ewoc
(setq jabber-console-ewoc
(ewoc-create #'jabber-console-pp nil "<!-- + -->"))
(goto-char (point-max))
(put-text-property (point-min) (point) 'read-only t)
(let ((inhibit-read-only t))
(put-text-property (point-min) (point) 'front-sticky t)
(put-text-property (point-min) (point) 'rear-nonsticky t))
(setq jabber-point-insert (point-marker))))
(put 'jabber-console-mode 'mode-class 'special)
(defun jabber-console-sanitize (xml-data)
"Sanitize XML-DATA for jabber-process-console"
(if (listp xml-data)
(jabber-tree-map (lambda (x) (if (numberp x) (format "%s" x) x)) xml-data)
xml-data))
;;;###autoload
(defun jabber-process-console (jc direction xml-data)
"Log XML-DATA i/o as XML in \"*-jabber-console-JID-*\" buffer"
(let ((buffer (get-buffer-create (jabber-console-create-buffer jc))))
(with-current-buffer buffer
(progn
(ewoc-enter-last jabber-console-ewoc (list direction (jabber-console-sanitize xml-data)))
(when (< 1 jabber-console-truncate-lines)
(let ((jabber-log-lines-to-keep jabber-console-truncate-lines))
(jabber-truncate-top buffer jabber-console-ewoc)))))))
(provide 'jabber-console)
;;; jabber-console.el ends here

BIN
elpa/jabber-20180927.2325/jabber-console.elc Normal file
View File

Binary file not shown.

1006
elpa/jabber-20180927.2325/jabber-core.el Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/jabber-20180927.2325/jabber-core.elc Normal file
View File

Binary file not shown.

652
elpa/jabber-20180927.2325/jabber-disco.el Normal file
View File

@ -0,0 +1,652 @@
;; jabber-disco.el - service discovery functions
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-xml)
(require 'jabber-menu)
;;; Respond to disco requests
(defvar jabber-advertised-features
(list "http://jabber.org/protocol/disco#info")
"Features advertised on service discovery requests
Don't add your feature to this list directly. Instead, call
`jabber-disco-advertise-feature'.")
(defvar jabber-disco-items-nodes
(list
(list "" nil nil))
"Alist of node names and information about returning disco item data.
Key is node name as a string, or \"\" for no node specified. Value is
a list of two items.
First item is data to return. If it is a function, that function is
called and its return value is used; if it is a list, that list is
used. The list should be the XML data to be returned inside the
<query/> element, like this:
\((item ((name . \"Name of first item\")
(jid . \"first.item\")
(node . \"node\"))))
Second item is access control function. That function is passed the
JID, and returns non-nil if access is granted. If the second item is
nil, access is always granted.")
(defvar jabber-disco-info-nodes
(list
(list "" #'jabber-disco-return-client-info nil))
"Alist of node names and information returning disco info data.
Key is node name as a string, or \"\" for no node specified. Value is
a list of two items.
First item is data to return. If it is a function, that function is
called and its return value is used; if it is a list, that list is
used. The list should be the XML data to be returned inside the
<query/> element, like this:
\((identity ((category . \"client\")
(type . \"pc\")
(name . \"Jabber client\")))
(feature ((var . \"some-feature\"))))
Second item is access control function. That function is passed the
JID, and returns non-nil if access is granted. If the second item is
nil, access is always granted.")
(add-to-list 'jabber-iq-get-xmlns-alist
(cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info))
(add-to-list 'jabber-iq-get-xmlns-alist
(cons "http://jabber.org/protocol/disco#items" 'jabber-return-disco-info))
(defun jabber-return-disco-info (jc xml-data)
"Respond to a service discovery request.
See JEP-0030."
(let* ((to (jabber-xml-get-attribute xml-data 'from))
(id (jabber-xml-get-attribute xml-data 'id))
(xmlns (jabber-iq-xmlns xml-data))
(which-alist (eval (cdr (assoc xmlns
(list
(cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes)
(cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes))))))
(node (or
(jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)
""))
(return-list (cdr (assoc node which-alist)))
(func (nth 0 return-list))
(access-control (nth 1 return-list)))
(if return-list
(if (and (functionp access-control)
(not (funcall access-control jc to)))
(jabber-signal-error "cancel" 'not-allowed)
;; Access control passed
(let ((result (if (functionp func)
(funcall func jc xml-data)
func)))
(jabber-send-iq jc to "result"
`(query ((xmlns . ,xmlns)
,@(when node
(list (cons 'node node))))
,@result)
nil nil nil nil id)))
;; No such node
(jabber-signal-error "cancel" 'item-not-found))))
(defun jabber-disco-return-client-info (&optional jc xml-data)
`(
;; If running under a window system, this is
;; a GUI client. If not, it is a console client.
(identity ((category . "client")
(name . "Emacs Jabber client")
(type . ,(if (memq window-system
'(x w32 mac ns))
"pc"
"console"))))
,@(mapcar
#'(lambda (featurename)
`(feature ((var . ,featurename))))
jabber-advertised-features)))
;;; Interactive disco requests
(add-to-list 'jabber-jid-info-menu
(cons "Send items disco query" 'jabber-get-disco-items))
(defun jabber-get-disco-items (jc to &optional node)
"Send a service discovery request for items"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t)
(jabber-read-node "Node (or leave empty): ")))
(jabber-send-iq jc to
"get"
(list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items"))
(if (> (length node) 0)
(list (cons 'node node)))))
#'jabber-process-data #'jabber-process-disco-items
#'jabber-process-data "Item discovery failed"))
(add-to-list 'jabber-jid-info-menu
(cons "Send info disco query" 'jabber-get-disco-info))
(defun jabber-get-disco-info (jc to &optional node)
"Send a service discovery request for info"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t)
(jabber-read-node "Node (or leave empty): ")))
(jabber-send-iq jc to
"get"
(list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info"))
(if (> (length node) 0)
(list (cons 'node node)))))
#'jabber-process-data #'jabber-process-disco-info
#'jabber-process-data "Info discovery failed"))
(defun jabber-process-disco-info (jc xml-data)
"Handle results from info disco requests."
(let ((beginning (point)))
(dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
(cond
((eq (jabber-xml-node-name x) 'identity)
(let ((name (jabber-xml-get-attribute x 'name))
(category (jabber-xml-get-attribute x 'category))
(type (jabber-xml-get-attribute x 'type)))
(insert (jabber-propertize (if name
name
"Unnamed")
'face 'jabber-title-medium)
"\n\nCategory:\t" category "\n")
(if type
(insert "Type:\t\t" type "\n"))
(insert "\n")))
((eq (jabber-xml-node-name x) 'feature)
(let ((var (jabber-xml-get-attribute x 'var)))
(insert "Feature:\t" var "\n")))))
(put-text-property beginning (point)
'jabber-jid (jabber-xml-get-attribute xml-data 'from))
(put-text-property beginning (point)
'jabber-account jc)))
(defun jabber-process-disco-items (jc xml-data)
"Handle results from items disco requests."
(let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
(if items
(dolist (item items)
(let ((jid (jabber-xml-get-attribute item 'jid))
(name (jabber-xml-get-attribute item 'name))
(node (jabber-xml-get-attribute item 'node)))
(insert
(jabber-propertize
(concat
(jabber-propertize
(concat jid "\n" (if node (format "Node: %s\n" node)))
'face 'jabber-title-medium)
name "\n\n")
'jabber-jid jid
'jabber-account jc
'jabber-node node))))
(insert "No items found.\n"))))
;;; Caching API for disco requests
;; Keys are ("jid" . "node"), where "node" is nil if appropriate.
;; Values are (identities features), where each identity is ["name"
;; "category" "type"], and each feature is a string.
(defvar jabber-disco-info-cache (make-hash-table :test 'equal))
;; Keys are ("jid" . "node"). Values are (items), where each
;; item is ["name" "jid" "node"] (some values may be nil).
(defvar jabber-disco-items-cache (make-hash-table :test 'equal))
(defun jabber-disco-get-info (jc jid node callback closure-data &optional force)
"Get disco info for JID and NODE, using connection JC.
Call CALLBACK with JC and CLOSURE-DATA as first and second
arguments and result as third argument when result is available.
On success, result is (IDENTITIES FEATURES), where each identity is [\"name\"
\"category\" \"type\"], and each feature is a string.
On error, result is the error node, recognizable by (eq (car result) 'error).
If CALLBACK is nil, just fetch data. If FORCE is non-nil,
invalidate cache and get fresh data."
(when force
(remhash (cons jid node) jabber-disco-info-cache))
(let ((result (unless force (jabber-disco-get-info-immediately jid node))))
(if result
(and callback (run-with-timer 0 nil callback jc closure-data result))
(jabber-send-iq jc jid
"get"
`(query ((xmlns . "http://jabber.org/protocol/disco#info")
,@(when node `((node . ,node)))))
#'jabber-disco-got-info (cons callback closure-data)
(lambda (jc xml-data callback-data)
(when (car callback-data)
(funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
(cons callback closure-data)))))
(defun jabber-disco-got-info (jc xml-data callback-data)
(let ((jid (jabber-xml-get-attribute xml-data 'from))
(node (jabber-xml-get-attribute (jabber-iq-query xml-data)
'node))
(result (jabber-disco-parse-info xml-data)))
(puthash (cons jid node) result jabber-disco-info-cache)
(when (car callback-data)
(funcall (car callback-data) jc (cdr callback-data) result))))
(defun jabber-disco-parse-info (xml-data)
"Extract data from an <iq/> stanza containing a disco#info result.
See `jabber-disco-get-info' for a description of the return value."
(list
(mapcar
#'(lambda (id)
(vector (jabber-xml-get-attribute id 'name)
(jabber-xml-get-attribute id 'category)
(jabber-xml-get-attribute id 'type)))
(jabber-xml-get-children (jabber-iq-query xml-data) 'identity))
(mapcar
#'(lambda (feature)
(jabber-xml-get-attribute feature 'var))
(jabber-xml-get-children (jabber-iq-query xml-data) 'feature))))
(defun jabber-disco-get-info-immediately (jid node)
"Get cached disco info for JID and NODE.
Return nil if no info available.
Fill the cache with `jabber-disco-get-info'."
(or
;; Check "normal" cache...
(gethash (cons jid node) jabber-disco-info-cache)
;; And then check Entity Capabilities.
(and (null node) (jabber-caps-get-cached jid))))
(defun jabber-disco-get-items (jc jid node callback closure-data &optional force)
"Get disco items for JID and NODE, using connection JC.
Call CALLBACK with JC and CLOSURE-DATA as first and second
arguments and items result as third argument when result is
available.
On success, result is a list of items, where each
item is [\"name\" \"jid\" \"node\"] (some values may be nil).
On error, result is the error node, recognizable by (eq (car result) 'error).
If CALLBACK is nil, just fetch data. If FORCE is non-nil,
invalidate cache and get fresh data."
(when force
(remhash (cons jid node) jabber-disco-items-cache))
(let ((result (gethash (cons jid node) jabber-disco-items-cache)))
(if result
(and callback (run-with-timer 0 nil callback jc closure-data result))
(jabber-send-iq jc jid
"get"
`(query ((xmlns . "http://jabber.org/protocol/disco#items")
,@(when node `((node . ,node)))))
#'jabber-disco-got-items (cons callback closure-data)
(lambda (jc xml-data callback-data)
(when (car callback-data)
(funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
(cons callback closure-data)))))
(defun jabber-disco-got-items (jc xml-data callback-data)
(let ((jid (jabber-xml-get-attribute xml-data 'from))
(node (jabber-xml-get-attribute (jabber-iq-query xml-data)
'node))
(result
(mapcar
#'(lambda (item)
(vector
(jabber-xml-get-attribute item 'name)
(jabber-xml-get-attribute item 'jid)
(jabber-xml-get-attribute item 'node)))
(jabber-xml-get-children (jabber-iq-query xml-data) 'item))))
(puthash (cons jid node) result jabber-disco-items-cache)
(when (car callback-data)
(funcall (car callback-data) jc (cdr callback-data) result))))
(defun jabber-disco-get-items-immediately (jid node)
(gethash (cons jid node) jabber-disco-items-cache))
;;; Publish
(defun jabber-disco-publish (jc node item-name item-jid item-node)
"Publish the given item under disco node NODE."
(jabber-send-iq jc nil
"set"
`(query ((xmlns . "http://jabber.org/protocol/disco#items")
,@(when node `((node . ,node))))
(item ((action . "update")
(jid . ,item-jid)
,@(when item-name
`((name . ,item-name)))
,@(when item-node
`((node . ,item-node))))))
'jabber-report-success "Disco publish"
'jabber-report-success "Disco publish"))
(defun jabber-disco-publish-remove (jc node item-jid item-node)
"Remove the given item from published disco items."
(jabber-send-iq jc nil
"set"
`(query ((xmlns . "http://jabber.org/protocol/disco#items")
,@(when node `((node . ,node))))
(item ((action . "remove")
(jid . ,item-jid)
,@(when item-node
`((node . ,item-node))))))
'jabber-report-success "Disco removal"
'jabber-report-success "Disco removal"))
;;; Entity Capabilities (XEP-0115)
;;;###autoload
(eval-after-load "jabber-core"
'(add-to-list 'jabber-presence-chain #'jabber-process-caps))
(defvar jabber-caps-cache (make-hash-table :test 'equal))
(defconst jabber-caps-hash-names
(if (fboundp 'secure-hash)
'(("sha-1" . sha1)
("sha-224" . sha224)
("sha-256" . sha256)
("sha-384" . sha384)
("sha-512" . sha512))
;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
;; back to the `sha1' function, handled specially in
;; `jabber-caps--secure-hash'.
'(("sha-1" . sha1)))
"Hash function name map.
Maps names defined in http://www.iana.org/assignments/hash-function-text-names
to symbols accepted by `secure-hash'.
XEP-0115 currently recommends SHA-1, but let's be future-proof.")
(defun jabber-caps-get-cached (jid)
"Get disco info from Entity Capabilities cache.
JID should be a string containing a full JID.
Return (IDENTITIES FEATURES), or nil if not in cache."
(let* ((symbol (jabber-jid-symbol jid))
(resource (or (jabber-jid-resource jid) ""))
(resource-plist (cdr (assoc resource (get symbol 'resources))))
(key (plist-get resource-plist 'caps)))
(when key
(let ((cache-entry (gethash key jabber-caps-cache)))
(when (and (consp cache-entry) (not (floatp (car cache-entry))))
cache-entry)))))
;;;###autoload
(defun jabber-process-caps (jc xml-data)
"Look for entity capabilities in presence stanzas."
(let* ((from (jabber-xml-get-attribute xml-data 'from))
(type (jabber-xml-get-attribute xml-data 'type))
(c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
(when (and (null type) c)
(jabber-xml-let-attributes
(ext hash node ver) c
(cond
(hash
;; If the <c/> element has a hash attribute, it follows the
;; "modern" version of XEP-0115.
(jabber-process-caps-modern jc from hash node ver))
(t
;; No hash attribute. Use legacy version of XEP-0115.
;; TODO: do something clever here.
))))))
(defun jabber-process-caps-modern (jc jid hash node ver)
(when (assoc hash jabber-caps-hash-names)
;; We support the hash function used.
(let* ((key (cons hash ver))
(cache-entry (gethash key jabber-caps-cache)))
;; Remember the hash in the JID symbol.
(let* ((symbol (jabber-jid-symbol jid))
(resource (or (jabber-jid-resource jid) ""))
(resource-entry (assoc resource (get symbol 'resources)))
(new-resource-plist (plist-put (cdr resource-entry) 'caps key)))
(if resource-entry
(setf (cdr resource-entry) new-resource-plist)
(push (cons resource new-resource-plist) (get symbol 'resources))))
(flet ((request-disco-info
()
(jabber-send-iq
jc jid
"get"
`(query ((xmlns . "http://jabber.org/protocol/disco#info")
(node . ,(concat node "#" ver))))
#'jabber-process-caps-info-result (list hash node ver)
#'jabber-process-caps-info-error (list hash node ver))))
(cond
((and (consp cache-entry)
(floatp (car cache-entry)))
;; We have a record of asking someone about this hash.
(if (< (- (float-time) (car cache-entry)) 10.0)
;; We asked someone about this hash less than 10 seconds ago.
;; Let's add the new JID to the entry, just in case that
;; doesn't work out.
(pushnew jid (cdr cache-entry) :test #'string=)
;; We asked someone about it more than 10 seconds ago.
;; They're probably not going to answer. Let's ask
;; this contact about it instead.
(setf (car cache-entry) (float-time))
(request-disco-info)))
((null cache-entry)
;; We know nothing about this hash. Let's note the
;; fact that we tried to get information about it.
(puthash key (list (float-time)) jabber-caps-cache)
(request-disco-info))
(t
;; We already know what this hash represents, so we
;; can cache info for this contact.
(puthash (cons jid nil) cache-entry jabber-disco-info-cache)))))))
(defun jabber-process-caps-info-result (jc xml-data closure-data)
(destructuring-bind (hash node ver) closure-data
(let* ((key (cons hash ver))
(query (jabber-iq-query xml-data))
(verification-string (jabber-caps-ver-string query hash)))
(if (string= ver verification-string)
;; The hash is correct; save info.
(puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache)
;; The hash is incorrect.
(jabber-caps-try-next jc hash node ver)))))
(defun jabber-process-caps-info-error (jc xml-data closure-data)
(destructuring-bind (hash node ver) closure-data
(jabber-caps-try-next jc hash node ver)))
(defun jabber-caps-try-next (jc hash node ver)
(let* ((key (cons hash ver))
(cache-entry (gethash key jabber-caps-cache)))
(when (floatp (car-safe cache-entry))
(let ((next-jid (pop (cdr cache-entry))))
;; Do we know someone else we could ask about this hash?
(if next-jid
(progn
(setf (car cache-entry) (float-time))
(jabber-send-iq
jc next-jid
"get"
`(query ((xmlns . "http://jabber.org/protocol/disco#info")
(node . ,(concat node "#" ver))))
#'jabber-process-caps-info-result (list hash node ver)
#'jabber-process-caps-info-error (list hash node ver)))
;; No, forget about it for now.
(remhash key jabber-caps-cache))))))
;;; Entity Capabilities utility functions
(defun jabber-caps-ver-string (query hash)
;; XEP-0115, section 5.1
;; 1. Initialize an empty string S.
(with-temp-buffer
(let* ((identities (jabber-xml-get-children query 'identity))
(disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var))
(jabber-xml-get-children query 'feature)))
(maybe-forms (jabber-xml-get-children query 'x))
(forms (remove-if-not
(lambda (x)
;; Keep elements that are forms and have a FORM_TYPE,
;; according to XEP-0128.
(and (string= (jabber-xml-get-xmlns x) "jabber:x:data")
(jabber-xdata-formtype x)))
maybe-forms)))
;; 2. Sort the service discovery identities [15] by category
;; and then by type and then by xml:lang (if it exists),
;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/'
;; [NAME]. [16] Note that each slash is included even if the
;; LANG or NAME is not included (in accordance with XEP-0030,
;; the category and type MUST be included.
(setq identities (sort identities #'jabber-caps-identity-<))
;; 3. For each identity, append the 'category/type/lang/name' to
;; S, followed by the '<' character.
(dolist (identity identities)
(jabber-xml-let-attributes (category type xml:lang name) identity
;; Use `concat' here instead of passing everything to
;; `insert', since `concat' tolerates nil values.
(insert (concat category "/" type "/" xml:lang "/" name "<"))))
;; 4. Sort the supported service discovery features. [17]
(setq disco-features (sort disco-features #'string<))
;; 5. For each feature, append the feature to S, followed by the
;; '<' character.
(dolist (f disco-features)
(insert f "<"))
;; 6. If the service discovery information response includes
;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e.,
;; by the XML character data of the <value/> element).
(setq forms (sort forms (lambda (a b)
(string< (jabber-xdata-formtype a)
(jabber-xdata-formtype b)))))
;; 7. For each extended service discovery information form:
(dolist (form forms)
;; Append the XML character data of the FORM_TYPE field's
;; <value/> element, followed by the '<' character.
(insert (jabber-xdata-formtype form) "<")
;; Sort the fields by the value of the "var" attribute.
(let ((fields (sort (jabber-xml-get-children form 'field)
(lambda (a b)
(string< (jabber-xml-get-attribute a 'var)
(jabber-xml-get-attribute b 'var))))))
(dolist (field fields)
;; For each field other than FORM_TYPE:
(unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
;; Append the value of the "var" attribute, followed by the '<' character.
(insert (jabber-xml-get-attribute field 'var) "<")
;; Sort values by the XML character data of the <value/> element.
(let ((values (sort (mapcar (lambda (value)
(car (jabber-xml-node-children value)))
(jabber-xml-get-children field 'value))
#'string<)))
;; For each <value/> element, append the XML character
;; data, followed by the '<' character.
(dolist (value values)
(insert value "<"))))))))
;; 8. Ensure that S is encoded according to the UTF-8 encoding
;; (RFC 3269 [18]).
(let ((s (encode-coding-string (buffer-string) 'utf-8 t))
(algorithm (cdr (assoc hash jabber-caps-hash-names))))
;; 9. Compute the verification string by hashing S using the
;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as
;; defined in RFC 3174 [19]). The hashed data MUST be generated
;; with binary output and encoded using Base64 as specified in
;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT
;; include whitespace and MUST set padding bits to zero). [21]
(base64-encode-string (jabber-caps--secure-hash algorithm s) t))))
(defun jabber-caps--secure-hash (algorithm string)
(cond
;; `secure-hash' was introduced in Emacs 24
((fboundp 'secure-hash)
(secure-hash algorithm string nil nil t))
((eq algorithm 'sha1)
;; For SHA-1, we can use the `sha1' function.
(sha1 string nil nil t))
(t
(error "Cannot use hash algorithm %s!" algorithm))))
(defun jabber-caps-identity-< (a b)
(let ((a-category (jabber-xml-get-attribute a 'category))
(b-category (jabber-xml-get-attribute b 'category)))
(or (string< a-category b-category)
(and (string= a-category b-category)
(let ((a-type (jabber-xml-get-attribute a 'type))
(b-type (jabber-xml-get-attribute b 'type)))
(or (string< a-type b-type)
(and (string= a-type b-type)
(let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang))
(b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
(string< a-xml:lang b-xml:lang)))))))))
;;; Sending Entity Capabilities
(defvar jabber-caps-default-hash-function "sha-1"
"Hash function to use when sending caps in presence stanzas.
The value should be a key in `jabber-caps-hash-names'.")
(defvar jabber-caps-current-hash nil
"The current disco hash we're sending out in presence stanzas.")
(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
;;;###autoload
(defun jabber-disco-advertise-feature (feature)
(unless (member feature jabber-advertised-features)
(push feature jabber-advertised-features)
(when jabber-caps-current-hash
(jabber-caps-recalculate-hash)
;; If we're already connected, we need to send updated presence
;; for the new feature.
(mapc #'jabber-send-current-presence jabber-connections))))
(defun jabber-caps-recalculate-hash ()
"Update `jabber-caps-current-hash' for feature list change.
Also update `jabber-disco-info-nodes', so we return results for
the right node."
(let* ((old-hash jabber-caps-current-hash)
(old-node (and old-hash (concat jabber-caps-node "#" old-hash)))
(new-hash
(jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info))
jabber-caps-default-hash-function))
(new-node (concat jabber-caps-node "#" new-hash)))
(when old-node
(let ((old-entry (assoc old-node jabber-disco-info-nodes)))
(when old-entry
(setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes)))))
(push (list new-node #'jabber-disco-return-client-info nil)
jabber-disco-info-nodes)
(setq jabber-caps-current-hash new-hash)))
;;;###autoload
(defun jabber-caps-presence-element (_jc)
(unless jabber-caps-current-hash
(jabber-caps-recalculate-hash))
(list
`(c ((xmlns . "http://jabber.org/protocol/caps")
(hash . ,jabber-caps-default-hash-function)
(node . ,jabber-caps-node)
(ver . ,jabber-caps-current-hash)))))
;;;###autoload
(eval-after-load "jabber-presence"
'(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element))
(provide 'jabber-disco)
;;; arch-tag: 71f5c76f-2956-4ed2-b871-9f5fe198092d

245
elpa/jabber-20180927.2325/jabber-events.el Normal file
View File

@ -0,0 +1,245 @@
;;; jabber-events.el --- Message events (JEP-0022) implementation
;; Copyright (C) 2005, 2008 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
(require 'cl)
(defgroup jabber-events nil
"Message events and notifications."
:group 'jabber)
;;; INCOMING
;;; Code for requesting event notifications from others and handling
;;; them.
(defcustom jabber-events-request-these '(offline
delivered
displayed
composing)
"Request these kinds of event notifications from others."
:type '(set (const :tag "Delivered to offline storage" offline)
(const :tag "Delivered to user's client" delivered)
(const :tag "Displayed to user" displayed)
(const :tag "User is typing a reply" composing))
:group 'jabber-events)
(defvar jabber-events-composing-p nil
"Is the other person composing a message?")
(make-variable-buffer-local 'jabber-events-composing-p)
(defvar jabber-events-arrived nil
"In what way has the message reached the recipient?
Possible values are nil (no information available), offline
\(queued for delivery when recipient is online), delivered
\(message has reached the client) and displayed (user is
probably reading the message).")
(make-variable-buffer-local 'jabber-events-arrived)
(defvar jabber-events-message ""
"Human-readable presentation of event information")
(make-variable-buffer-local 'jabber-events-message)
(defun jabber-events-update-message ()
(setq jabber-events-message
(concat (cdr (assq jabber-events-arrived
'((offline . "In offline storage")
(delivered . "Delivered")
(displayed . "Displayed"))))
(when jabber-events-composing-p
" (typing a message)"))))
(add-hook 'jabber-chat-send-hooks 'jabber-events-when-sending)
(defun jabber-events-when-sending (text id)
(setq jabber-events-arrived nil)
(jabber-events-update-message)
`((x ((xmlns . "jabber:x:event"))
,@(mapcar #'list jabber-events-request-these))))
;;; OUTGOING
;;; Code for handling requests for event notifications and providing
;;; them, modulo user preferences.
(defcustom jabber-events-confirm-delivered t
"Send delivery confirmation if requested?"
:group 'jabber-events
:type 'boolean)
(defcustom jabber-events-confirm-displayed t
"Send display confirmation if requested?"
:group 'jabber-events
:type 'boolean)
(defcustom jabber-events-confirm-composing t
"Send notifications about typing a reply?"
:group 'jabber-events
:type 'boolean)
(defvar jabber-events-requested ()
"List of events requested")
(make-variable-buffer-local 'jabber-events-requested)
(defvar jabber-events-last-id nil
"Id of last message received, or nil if none.")
(make-variable-buffer-local 'jabber-events-last-id)
(defvar jabber-events-delivery-confirmed nil
"Has delivery confirmation been sent?")
(make-variable-buffer-local 'jabber-events-delivery-confirmed)
(defvar jabber-events-display-confirmed nil
"Has display confirmation been sent?")
(make-variable-buffer-local 'jabber-events-display-confirmed)
(defvar jabber-events-composing-sent nil
"Has composing notification been sent?
It can be sent and cancelled several times.")
(add-hook 'window-configuration-change-hook
'jabber-events-confirm-display)
(defun jabber-events-confirm-display ()
"Send display confirmation if appropriate.
That is, if user allows it, if the other user requested it,
and it hasn't been sent before."
(walk-windows #'jabber-events-confirm-display-in-window))
(defun jabber-events-confirm-display-in-window (window)
(with-current-buffer (window-buffer window)
(when (and jabber-events-confirm-displayed
(not jabber-events-display-confirmed)
(memq 'displayed jabber-events-requested)
;; XXX: if jabber-events-requested is non-nil, how can
;; jabber-chatting-with be nil? See
;; http://sourceforge.net/tracker/index.php?func=detail&aid=1872560&group_id=88346&atid=586350
jabber-chatting-with
;; don't send to bare jids
(jabber-jid-resource jabber-chatting-with))
(jabber-send-sexp
jabber-buffer-connection
`(message
((to . ,jabber-chatting-with))
(x ((xmlns . "jabber:x:event"))
(displayed)
(id () ,jabber-events-last-id))))
(setq jabber-events-display-confirmed t))))
(defun jabber-events-after-change ()
(let ((composing-now (not (= (point-max) jabber-point-insert))))
(when (and jabber-events-confirm-composing
jabber-chatting-with
(not (eq composing-now jabber-events-composing-sent)))
(jabber-send-sexp
jabber-buffer-connection
`(message
((to . ,jabber-chatting-with))
(x ((xmlns . "jabber:x:event"))
,@(if composing-now '((composing)) nil)
(id () ,jabber-events-last-id))))
(setq jabber-events-composing-sent composing-now))))
;;; COMMON
;; Add function last in chain, so a chat buffer is already created.
(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-events t)
(defun jabber-handle-incoming-message-events (jc xml-data)
(when (and (not (jabber-muc-message-p xml-data))
(get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))))
(with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
(let ((x (find "jabber:x:event"
(jabber-xml-get-children xml-data 'x)
:key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns))
:test #'string=)))
(cond
;; If we get an error message, we shouldn't report any
;; events, as the requests are mirrored from us.
((string= (jabber-xml-get-attribute xml-data 'type) "error")
(remove-hook 'post-command-hook 'jabber-events-after-change t)
(setq jabber-events-requested nil))
;; If there's a body, it's not an incoming message event.
((jabber-xml-get-children xml-data 'body)
;; User is done composing, obviously.
(setq jabber-events-composing-p nil)
(jabber-events-update-message)
;; Reset variables
(setq jabber-events-display-confirmed nil)
(setq jabber-events-delivery-confirmed nil)
;; User requests message events
(setq jabber-events-requested
;; There might be empty strings in the XML data,
;; which car chokes on. Having nil values in
;; the list won't hurt, therefore car-safe.
(mapcar #'car-safe
(jabber-xml-node-children x)))
(setq jabber-events-last-id (jabber-xml-get-attribute
xml-data 'id))
;; Send notifications we already know about
(flet ((send-notification
(type)
(jabber-send-sexp
jc
`(message
((to . ,(jabber-xml-get-attribute xml-data 'from)))
(x ((xmlns . "jabber:x:event"))
(,type)
(id () ,jabber-events-last-id))))))
;; Send delivery confirmation if appropriate
(when (and jabber-events-confirm-delivered
(memq 'delivered jabber-events-requested))
(send-notification 'delivered)
(setq jabber-events-delivery-confirmed t))
;; Send display confirmation if appropriate
(when (and jabber-events-confirm-displayed
(get-buffer-window (current-buffer) 'visible)
(memq 'displayed jabber-events-requested))
(send-notification 'displayed)
(setq jabber-events-display-confirmed t))
;; Set up hooks for composition notification
(when (and jabber-events-confirm-composing
(memq 'composing jabber-events-requested))
(add-hook 'post-command-hook 'jabber-events-after-change
nil t))))
(t
;; So it has no body. If it's a message event,
;; the <x/> node should be the only child of the
;; message, and it should contain an <id/> node.
;; We check the latter.
(when (and x (jabber-xml-get-children x 'id))
;; Currently we don't care about the <id/> node.
;; There's only one node except for the id.
(unless
(dolist (possible-node '(offline delivered displayed))
(when (jabber-xml-get-children x possible-node)
(setq jabber-events-arrived possible-node)
(jabber-events-update-message)
(return t)))
;; Or maybe even zero, which is a negative composing node.
(setq jabber-events-composing-p
(not (null (jabber-xml-get-children x 'composing))))
(jabber-events-update-message)))))))))
(provide 'jabber-events)
;; arch-tag: 7b6e61fe-a9b3-11d9-afca-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-events.elc Normal file
View File

Binary file not shown.

251
elpa/jabber-20180927.2325/jabber-export.el Normal file
View File

@ -0,0 +1,251 @@
;;; jabber-export.el --- export Jabber roster to file
;; Copyright (C) 2005, 2007 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
(require 'cl)
(defvar jabber-export-roster-widget nil)
(defvar jabber-import-subscription-p-widget nil)
;;;###autoload
(defun jabber-export-roster (jc)
"Export roster for connection JC."
(interactive (list (jabber-read-account)))
(let ((state-data (fsm-get-state-data jc)))
(jabber-export-roster-do-it
(jabber-roster-to-sexp (plist-get state-data :roster)))))
(defun jabber-export-roster-do-it (roster)
"Create buffer from which ROSTER can be exported to a file."
(interactive)
(with-current-buffer (get-buffer-create "Export roster")
(jabber-init-widget-buffer nil)
(widget-insert (jabber-propertize "Export roster\n"
'face 'jabber-title-large))
(widget-insert "You are about to save your roster to a file. Here
you can edit it before saving. Changes done here will
not affect your actual roster.
")
(widget-create 'push-button :notify #'jabber-export-save "Save to file")
(widget-insert " ")
(widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
(widget-insert "\n\n")
(make-local-variable 'jabber-export-roster-widget)
(jabber-export-display roster)
(widget-setup)
(widget-minor-mode 1)
(goto-char (point-min))
(switch-to-buffer (current-buffer))))
;;;###autoload
(defun jabber-import-roster (jc file)
"Create buffer for roster import for connection JC from FILE."
(interactive (list (jabber-read-account)
(read-file-name "Import roster from file: ")))
(let ((roster
(with-temp-buffer
(let ((coding-system-for-read 'utf-8))
(jabber-roster-xml-to-sexp
(car (xml-parse-file file)))))))
(with-current-buffer (get-buffer-create "Import roster")
(setq jabber-buffer-connection jc)
(jabber-init-widget-buffer nil)
(widget-insert (jabber-propertize "Import roster\n"
'face 'jabber-title-large))
(widget-insert "You are about to import the contacts below to your roster.
")
(make-local-variable 'jabber-import-subscription-p-widget)
(setq jabber-import-subscription-p-widget
(widget-create 'checkbox))
(widget-insert " Adjust subscriptions\n")
(widget-create 'push-button :notify #'jabber-import-doit "Import to roster")
(widget-insert " ")
(widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
(widget-insert "\n\n")
(make-local-variable 'jabber-export-roster-widget)
(jabber-export-display roster)
(widget-setup)
(widget-minor-mode 1)
(goto-char (point-min))
(switch-to-buffer (current-buffer)))))
(defun jabber-export-remove-regexp (&rest ignore)
(let* ((value (widget-value jabber-export-roster-widget))
(length-before (length value))
(regexp (read-string "Remove JIDs matching regexp: ")))
(setq value (delete-if
#'(lambda (a)
(string-match regexp (nth 0 a)))
value))
(widget-value-set jabber-export-roster-widget value)
(widget-setup)
(message "%d items removed" (- length-before (length value)))))
(defun jabber-export-save (&rest ignore)
"Export roster to file."
(let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget)))
(coding-system-for-write 'utf-8))
(with-temp-file (read-file-name "Export roster to file: ")
(insert "<iq xmlns='jabber:client'><query xmlns='jabber:iq:roster'>\n")
(dolist (item items)
(insert (jabber-sexp2xml item) "\n"))
(insert "</query></iq>\n"))
(message "Roster saved")))
(defun jabber-import-doit (&rest ignore)
"Import roster being edited in widget."
(let* ((state-data (fsm-get-state-data jabber-buffer-connection))
(jabber-roster (plist-get state-data :roster))
roster-delta)
(dolist (n (widget-value jabber-export-roster-widget))
(let* ((jid (nth 0 n))
(name (and (not (zerop (length (nth 1 n))))
(nth 1 n)))
(subscription (nth 2 n))
(groups (nth 3 n))
(jid-symbol (jabber-jid-symbol jid))
(in-roster-p (memq jid-symbol jabber-roster))
(jid-name (and in-roster-p (get jid-symbol 'name)))
(jid-subscription (and in-roster-p (get jid-symbol 'subscription)))
(jid-groups (and in-roster-p (get jid-symbol 'groups))))
;; Do we need to change the roster?
(when (or
;; If the contact is not in the roster already,
(not in-roster-p)
;; or if the import introduces a name,
(and name (not jid-name))
;; or changes a name,
(and name jid-name (not (string= name jid-name)))
;; or introduces new groups.
(set-difference groups jid-groups :test #'string=))
(push (jabber-roster-sexp-to-xml
(list jid (or name jid-name) nil (union groups jid-groups :test #'string=))
t)
roster-delta))
;; And adujst subscription.
(when (widget-value jabber-import-subscription-p-widget)
(let ((want-to (member subscription '("to" "both")))
(want-from (member subscription '("from" "both")))
(have-to (member jid-subscription '("to" "both")))
(have-from (member jid-subscription '("from" "both"))))
(flet ((request-subscription
(type)
(jabber-send-sexp jabber-buffer-connection
`(presence ((to . ,jid)
(type . ,type))))))
(cond
((and want-to (not have-to))
(request-subscription "subscribe"))
((and have-to (not want-to))
(request-subscription "unsubscribe")))
(cond
((and want-from (not have-from))
;; not much to do here
)
((and have-from (not want-from))
(request-subscription "unsubscribed"))))))))
(when roster-delta
(jabber-send-iq jabber-buffer-connection
nil "set"
`(query ((xmlns . "jabber:iq:roster")) ,@roster-delta)
#'jabber-report-success "Roster import"
#'jabber-report-success "Roster import"))))
(defun jabber-roster-to-sexp (roster)
"Convert ROSTER to simpler sexp format.
Return a list, where each item is a vector:
\[jid name subscription groups]
where groups is a list of strings."
(mapcar
#'(lambda (n)
(list
(symbol-name n)
(or (get n 'name) "")
(get n 'subscription)
(get n 'groups)))
roster))
(defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription)
"Convert SEXP to XML format.
Return an XML node."
`(item ((jid . ,(nth 0 sexp))
,@(let ((name (nth 1 sexp)))
(unless (zerop (length name))
`((name . ,name))))
,@(unless omit-subscription
`((subscription . ,(nth 2 sexp)))))
,@(mapcar
#'(lambda (g)
(list 'group nil g))
(nth 3 sexp))))
(defun jabber-roster-xml-to-sexp (xml-data)
"Convert XML-DATA to simpler sexp format.
XML-DATA is an <iq> node with a <query xmlns='jabber:iq:roster'> child.
See `jabber-roster-to-sexp' for description of output format."
(assert (eq (jabber-xml-node-name xml-data) 'iq))
(let ((query (car (jabber-xml-get-children xml-data 'query))))
(assert query)
(mapcar
#'(lambda (n)
(list
(jabber-xml-get-attribute n 'jid)
(or (jabber-xml-get-attribute n 'name) "")
(jabber-xml-get-attribute n 'subscription)
(mapcar
#'(lambda (g)
(car (jabber-xml-node-children g)))
(jabber-xml-get-children n 'group))))
(jabber-xml-get-children query 'item))))
(defun jabber-export-display (roster)
(setq jabber-export-roster-widget
(widget-create
'(repeat
:tag "Roster"
(list :format "%v"
(string :tag "JID")
(string :tag "Name")
(choice :tag "Subscription"
(const "none")
(const "both")
(const "to")
(const "from"))
(repeat :tag "Groups"
(string :tag "Group"))))
:value roster)))
(provide 'jabber-export)
;;; arch-tag: 9c6b94a9-290a-4c0f-9286-72bd9c1fb8a3

BIN
elpa/jabber-20180927.2325/jabber-export.elc Normal file
View File

Binary file not shown.

731
elpa/jabber-20180927.2325/jabber-fallback-lib/hexrgb.el Normal file
View File

@ -0,0 +1,731 @@
;;; hexrgb.el --- Functions to manipulate colors, including RGB hex strings.
;;
;; Filename: hexrgb.el
;; Description: Functions to manipulate colors, including RGB hex strings.
;; Author: Drew Adams
;; Maintainer: Drew Adams
;; Copyright (C) 2004-2009, Drew Adams, all rights reserved.
;; Created: Mon Sep 20 22:58:45 2004
;; Version: 21.0
;; Last-Updated: Sat Nov 14 15:55:15 2009 (-0800)
;; By: dradams
;; Update #: 732
;; URL: http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el
;; Keywords: number, hex, rgb, color, background, frames, display
;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x
;;
;; Features that might be required by this library:
;;
;; None
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Functions to manipulate colors, including RGB hex strings.
;;
;; This library provides functions for converting between RGB (red,
;; green, blue) color components and HSV (hue, saturation, value)
;; color components. It helps you convert among Emacs color values
;; (whole numbers from 0 through 65535), RGB and HSV floating-point
;; components (0.0 through 1.0), Emacs color-name strings (such as
;; "blue"), and hex RGB color strings (such as "#FC43A7912").
;;
;; An RGB hex string, such as used as a frame `background-color'
;; property, is a string of 1 + (3 * n) characters, the first of
;; which is "#". The other characters are hexadecimal digits, in
;; three groups representing (from the left): red, green, and blue
;; hex codes.
;;
;; Constants defined here:
;;
;; `hexrgb-defined-colors', `hexrgb-defined-colors-alist',
;; `hexrgb-defined-colors-no-dups',
;; `hexrgb-defined-colors-no-dups-alist'.
;;
;; Options defined here:
;;
;; `hexrgb-canonicalize-defined-colors-flag'.
;;
;; Commands defined here:
;;
;; `hexrgb-blue', `hexrgb-complement', `hexrgb-green',
;; `hexrgb-hue', `hexrgb-read-color', `hexrgb-red',
;; `hexrgb-saturation', `hexrgb-value'.
;;
;; Non-interactive functions defined here:
;;
;; `hexrgb-approx-equal', `hexrgb-canonicalize-defined-colors',
;; `hexrgb-color-name-to-hex', `hexrgb-color-values-to-hex',
;; `hexrgb-color-value-to-float', `hexrgb-defined-colors',
;; `hexrgb-defined-colors-alist',
;; `hexrgb-delete-whitespace-from-string',
;; `hexrgb-float-to-color-value', `hexrgb-hex-char-to-integer',
;; `hexrgb-hex-to-color-values', `hexrgb-hex-to-hsv',
;; `hexrgb-hex-to-rgb', `hexrgb-hsv-to-hex', `hexrgb-hex-to-int',
;; `hexrgb-hsv-to-rgb', `hexrgb-increment-blue',
;; `hexrgb-increment-equal-rgb', `hexrgb-increment-green',
;; `hexrgb-increment-hex', `hexrgb-increment-red',
;; `hexrgb-int-to-hex', `hexrgb-rgb-hex-string-p',
;; `hexrgb-rgb-to-hex', `hexrgb-rgb-to-hsv'.
;;
;;
;; Add this to your initialization file (~/.emacs or ~/_emacs):
;;
;; (require 'hexrgb)
;;
;; Do not try to use this library without a window manager.
;; That is, do not use this with `emacs -nw'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;; 2009/11/14 dadams
;; hexrgb-rgb-to-hsv: Corrected hue when > 1.0. Use strict inequality for hue limit tests.
;; hexrgb-approx-equal: Convert RFUZZ and AFUZZ to their absolute values.
;; 2009/11/03 dadams
;; Added: hexrgb-delete-whitespace-from-string, hexrgb-canonicalize-defined-colors,
;; hexrgb-defined-colors(-no-dups)(-alist), hexrgb-canonicalize-defined-colors-flag.
;; hexrgb-read-color: Use function hexrgb-defined-colors-alist, not the constant.
;; 2008/12/25 dadams
;; hexrgb-rgb-to-hsv:
;; Replace (not (equal 0.0e+NaN saturation)) by standard test (= saturation saturation).
;; Thx to Michael Heerdegen for the bug report.
;; 2008-10-17 dadams
;; hexrgb-defined-colors(-alist): Prevent load-time error if user tries to use emacs -nw.
;; 2007/12/30 dadams
;; Added: hexrgb-hex-to-color-values.
;; 2007/10/20 dadams
;; hexrgb-read-color: Treat pseudo colors too (e.g. *point foreground*).
;; 2007/01/21 dadams
;; hexrgb-read-color: Error if empty string (and not allow-empty-name-p).
;; 2006/06/06 dadams
;; Added: hexrgb-defined-colors(-alist). Use instead of (x-defined-colors).
;; hexrgb-(red|green|blue): Added interactive specs.
;; 2006/06/04 dadams
;; hexrgb-read-color: Added optional arg allow-empty-name-p.
;; 2006/06/02 dadams
;; Added: hexrgb-rgb-hex-string-p. Used it.
;; 2006/05/30 dadams
;; Added: hexrgb-hex-to-(hsv|rgb), hexrgb-hsv-to-hex, hexrgb-color-name-to-hex,
;; hexrgb-complement, hexrgb-read-color, hexrgb-hue, hexrgb-saturation,
;; hexrgb-value, hexrgb-red, hexrgb-blue, hexrgb-green.
;; approx-equal: Add optional fuzz factor arguments. Changed the algorithm.
;; Renamed: approx-equal to hexrgb-approx-equal.
;; hexrgb-rgb-to-hsv: Changed test from < to <=: (when (<= hue 0.0)...).
;; hexrgb-hsv-to-rgb: Treat hue = 0.0 (int 0) the same as hue = 1.0 (int 6).
;; hexrgb-rgb-to-hex, hexrgb-increment-hex: Corrected doc strings.
;; 2006/05/22 dadams
;; Added: hexrgb-hsv-to-hex, hexrgb-rgb-to-hex. Require cl.el when byte-compile.
;; 2005/08/09 dadams
;; hexrgb-rgb-to-hsv: Side-stepped Emacs-20 bug in comparing NaN.
;; hexrgb-increment-*: Added optional arg wrap-p.
;; hexrgb-increment-hex: Prevent wrap if not wrap-p.
;; 2005/08/02 dadams
;; hexrgb-rgb-to-hes: Bug fix: If delta is zero, then so are hue and saturation.
;; 2005/06/24 dadams
;; hexrgb-rgb-to-hsv: Bug fix: test for NaN (e.g. on divide by zero).
;; 2005/02/08 dadams
;; hexrgb-hsv-to-rgb: Bug fix (typo: p, q -> pp, qq; added ww).
;; 2005/01/09 dadams
;; hexrgb-int-to-hex: Fixed bug in hexrgb-int-to-hex: nb-digits not respected.
;; Added: hexrgb-hsv-to-rgb, hexrgb-rgb-to-hsv, approx-equal.
;; Renamed old hexrgb-increment-value to hexrgb-increment-equal-rgb.
;; 2005/01/05 dadams
;; hexrgb-int-to-hex: Used a suggestion from Juri Linkov.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program 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 2, or (at your option)
;; any later version.
;; This program 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 this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(eval-when-compile (require 'cl)) ;; case; plus, for Emacs < 20: when, unless
;; Unless you first load `hexrgb.el', then either `palette.el' or `eyedropper.el', you will get
;; warnings about variables and functions with prefix `eyedrop-' when you byte-compile
;; `hexrgb.el'. You can ignore these warnings.
(defvar eyedrop-picked-foreground)
(defvar eyedrop-picked-background)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(eval-and-compile
(defun hexrgb-canonicalize-defined-colors (list)
"Copy of LIST with color names canonicalized.
LIST is a list of color names (strings).
Canonical names are lowercase, with no whitespace.
There are no duplicate names."
(let ((tail list)
this new)
(while tail
(setq this (car tail)
this (hexrgb-delete-whitespace-from-string (downcase this) 0 (length this)))
(unless (member this new) (push this new))
(pop tail))
(nreverse new)))
(defun hexrgb-delete-whitespace-from-string (string &optional from to)
"Remove whitespace from substring of STRING from FROM to TO.
If FROM is nil, then start at the beginning of STRING (FROM = 0).
If TO is nil, then end at the end of STRING (TO = length of STRING).
FROM and TO are zero-based indexes into STRING.
Character FROM is affected (possibly deleted). Character TO is not."
(setq from (or from 0)
to (or to (length string)))
(with-temp-buffer
(insert string)
(goto-char (+ from (point-min)))
(let ((count from)
char)
(while (and (not (eobp)) (< count to))
(setq char (char-after))
(if (memq char '(?\ ?\t ?\n)) (delete-char 1) (forward-char 1))
(setq count (1+ count)))
(buffer-string)))))
;;;###autoload
(defconst hexrgb-defined-colors (eval-when-compile (and window-system (x-defined-colors)))
"List of all supported colors.")
;;;###autoload
(defconst hexrgb-defined-colors-no-dups
(eval-when-compile
(and window-system (hexrgb-canonicalize-defined-colors (x-defined-colors))))
"List of all supported color names, with no duplicates.
Names are all lowercase, without any spaces.")
;;;###autoload
(defconst hexrgb-defined-colors-alist
(eval-when-compile (and window-system (mapcar #'list (x-defined-colors))))
"Alist of all supported color names, for use in completion.
See also `hexrgb-defined-colors-no-dups-alist', which is the same
thing, but without any duplicates, such as \"light blue\" and
\"LightBlue\".")
;;;###autoload
(defconst hexrgb-defined-colors-no-dups-alist
(eval-when-compile
(and window-system
(mapcar #'list (hexrgb-canonicalize-defined-colors (x-defined-colors)))))
"Alist of all supported color names, with no duplicates, for completion.
Names are all lowercase, without any spaces.")
;;;###autoload
(defcustom hexrgb-canonicalize-defined-colors-flag t
"*Non-nil means remove duplicate color names.
Names are considered duplicates if they are the same when abstracting
from whitespace and letter case."
:type 'boolean
:group 'Icicles :group 'doremi-frame-commands :group 'faces :group 'convenience)
;; You should use these two functions, not the constants, so users can change
;; the behavior by customizing `hexrgb-canonicalize-defined-colors-flag'.
(defun hexrgb-defined-colors ()
"List of supported color names.
If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names
are lowercased, whitespace is removed, and there are no duplicates."
(if hexrgb-canonicalize-defined-colors-flag
hexrgb-defined-colors-no-dups
hexrgb-defined-colors))
(defun hexrgb-defined-colors-alist ()
"Alist of supported color names. Usable for completion.
If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names
are lowercased, whitespace is removed, and there are no duplicates."
(if hexrgb-canonicalize-defined-colors-flag
hexrgb-defined-colors-no-dups-alist
hexrgb-defined-colors-alist))
;; RMS added this function to Emacs (23) as `read-color', with some feature loss.
;;;###autoload
(defun hexrgb-read-color (&optional convert-to-RGB-p allow-empty-name-p prompt)
"Read a color name or RGB hex value: #RRRRGGGGBBBB.
Completion is available for color names, but not for RGB hex strings.
If you input an RGB hex string, it must have the form #XXXXXXXXXXXX or
XXXXXXXXXXXX, where each X is a hex digit. The number of Xs must be a
multiple of 3, with the same number of Xs for each of red, green, and
blue. The order is red, green, blue.
Color names that are normally considered equivalent are canonicalized:
They are lowercased, whitespace is removed, and duplicates are
eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced
by \"lightblue\". If you do not want this behavior, but want to
choose names that might contain whitespace or uppercase letters, then
customize option `hexrgb-canonicalize-defined-colors-flag' to nil.
In addition to standard color names and RGB hex values, the following
are available as color candidates. In each case, the corresponding
color is used.
* `*copied foreground*' - last copied foreground, if available
* `*copied background*' - last copied background, if available
* `*mouse-2 foreground*' - foreground where you click `mouse-2'
* `*mouse-2 background*' - background where you click `mouse-2'
* `*point foreground*' - foreground under the cursor
* `*point background*' - background under the cursor
\(You can copy a color using eyedropper commands such as
`eyedrop-pick-foreground-at-mouse'.)
Checks input to be sure it represents a valid color. If not, raises
an error (but see exception for empty input with non-nil
ALLOW-EMPTY-NAME-P).
Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts
an input color name to an RGB hex string. Returns the RGB hex string.
Optional arg ALLOW-EMPTY-NAME-P controls what happens if you enter an
empty color name (that is, you just hit `RET'). If non-nil, then
`hexrgb-read-color' returns an empty color name, \"\". If nil, then
it raises an error. Programs must test for \"\" if ALLOW-EMPTY-NAME-P
is non-nil. They can then perform an appropriate action in case of
empty input.
Optional arg PROMPT is the prompt. Nil means use a default prompt."
(interactive "p") ; Always convert to RGB interactively.
(let* ((completion-ignore-case t)
;; Free variables here: `eyedrop-picked-foreground', `eyedrop-picked-background'.
;; They are defined in library `palette.el' or library `eyedropper.el'.
(colors (if (fboundp 'eyedrop-foreground-at-point)
(append (and eyedrop-picked-foreground
'(("*copied foreground*")))
(and eyedrop-picked-background
'(("*copied background*")))
'(("*mouse-2 foreground*")
("*mouse-2 background*")
("*point foreground*") ("*point background*"))
(hexrgb-defined-colors-alist))
(hexrgb-defined-colors-alist)))
(color (completing-read (or prompt "Color (name or #R+G+B+): ")
colors))
hex-string)
(when (fboundp 'eyedrop-foreground-at-point)
(cond ((string= "*copied foreground*" color) (setq color eyedrop-picked-foreground))
((string= "*copied background*" color) (setq color eyedrop-picked-background))
((string= "*point foreground*" color) (setq color (eyedrop-foreground-at-point)))
((string= "*point background*" color) (setq color (eyedrop-background-at-point)))
((string= "*mouse-2 foreground*" color)
(setq color (prog1 (eyedrop-foreground-at-mouse
(read-event "Click `mouse-2' to choose foreground color - "))
(read-event)))) ; Discard mouse up event.
((string= "*mouse-2 background*" color)
(setq color (prog1 (eyedrop-background-at-mouse
(read-event "Click `mouse-2' to choose background color - "))
(read-event)))))) ; Discard mouse up event.
(setq hex-string (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
(and (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
t)))
(if (and allow-empty-name-p (string= "" color))
""
(when (and hex-string (not (eq 0 hex-string)))
(setq color (concat "#" color))) ; No #; add it.
(unless hex-string
(when (or (string= "" color)
(not (if (fboundp 'test-completion) ; Not defined in Emacs 20.
(test-completion color colors)
(try-completion color colors))))
(error "No such color: %S" color))
(when convert-to-RGB-p (setq color (hexrgb-color-name-to-hex color))))
(when (interactive-p) (message "Color: `%s'" color))
color)))
;;;###autoload
(defun hexrgb-rgb-hex-string-p (color &optional laxp)
"Non-nil if COLOR is an RGB string #XXXXXXXXXXXX.
Each X is a hex digit. The number of Xs must be a multiple of 3, with
the same number of Xs for each of red, green, and blue.
Non-nil optional arg LAXP means that the initial `#' is optional. In
that case, for a valid string of hex digits: when # is present 0 is
returned; otherwise, t is returned."
(or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
(and laxp (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t)))
;;;###autoload
(defun hexrgb-complement (color)
"Return the color that is the complement of COLOR."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(let ((red (hexrgb-red color))
(green (hexrgb-green color))
(blue (hexrgb-blue color)))
(setq color (hexrgb-rgb-to-hex (- 1.0 red) (- 1.0 green) (- 1.0 blue))))
(when (interactive-p) (message "Complement: `%s'" color))
color)
;;;###autoload
(defun hexrgb-hue (color)
"Return the hue component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(car (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
;;;###autoload
(defun hexrgb-saturation (color)
"Return the saturation component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(cadr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
;;;###autoload
(defun hexrgb-value (color)
"Return the value component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(caddr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
;;;###autoload
(defun hexrgb-red (color)
"Return the red component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(/ (hexrgb-hex-to-int (substring color 1 (1+ (/ (1- (length color)) 3))))
(expt 16.0 (/ (1- (length color)) 3.0))))
;;;###autoload
(defun hexrgb-green (color)
"Return the green component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(let* ((len (/ (1- (length color)) 3))
(start (1+ len)))
(/ (hexrgb-hex-to-int (substring color start (+ start len)))
(expt 16.0 (/ (1- (length color)) 3.0)))))
;;;###autoload
(defun hexrgb-blue (color)
"Return the blue component of COLOR, in range 0 to 1 inclusive.
COLOR is a color name or hex RGB string that starts with \"#\"."
(interactive (list (hexrgb-read-color)))
(setq color (hexrgb-color-name-to-hex color))
(let* ((len (/ (1- (length color)) 3))
(start (+ 1 len len)))
(/ (hexrgb-hex-to-int (substring color start (+ start len)))
(expt 16.0 (/ (1- (length color)) 3.0)))))
;;;###autoload
(defun hexrgb-rgb-to-hsv (red green blue)
"Convert RED, GREEN, BLUE components to HSV (hue, saturation, value).
Each input component is 0.0 to 1.0, inclusive.
Returns a list of HSV components of value 0.0 to 1.0, inclusive."
(let* ((min (min red green blue))
(max (max red green blue))
(value max)
(delta (- max min))
hue saturation)
(if (hexrgb-approx-equal 0.0 delta)
(setq hue 0.0
saturation 0.0) ; Gray scale - no color; only value.
(if (and (condition-case nil
(setq saturation (/ delta max))
(arith-error nil))
;; Must be a number, not a NaN. The standard test for a NaN is (not (= N N)),
;; but an Emacs 20 bug makes (= N N) return t for a NaN also.
(or (< emacs-major-version 21) (= saturation saturation)))
(if (hexrgb-approx-equal 0.0 saturation)
(setq hue 0.0
saturation 0.0) ; Again, no color; only value.
;; Color
(setq hue (if (hexrgb-approx-equal red max)
(/ (- green blue) delta) ; Between yellow & magenta.
(if (hexrgb-approx-equal green max)
(+ 2.0 (/ (- blue red) delta)) ; Between cyan & yellow.
(+ 4.0 (/ (- red green) delta)))) ; Between magenta & cyan.
hue (/ hue 6.0))
;; (when (<= hue 0.0) (setq hue (+ hue 1.0))) ; $$$$$$
;; (when (>= hue 1.0) (setq hue (- hue 1.0)))) ; $$$$$$
(when (< hue 0.0) (setq hue (+ hue 1.0)))
(when (> hue 1.0) (setq hue (- hue 1.0))))
(setq hue 0.0 ; Div by zero (max=0): H:=0, S:=0. (Hue undefined.)
saturation 0.0)))
(list hue saturation value)))
;;;###autoload
(defun hexrgb-hsv-to-rgb (hue saturation value)
"Convert HUE, SATURATION, VALUE components to RGB (red, green, blue).
Each input component is 0.0 to 1.0, inclusive.
Returns a list of RGB components of value 0.0 to 1.0, inclusive."
(let (red green blue int-hue fract pp qq tt ww)
(if (hexrgb-approx-equal 0.0 saturation)
(setq red value
green value
blue value) ; Gray
(setq hue (* hue 6.0) ; Sectors: 0 to 5
int-hue (floor hue)
fract (- hue int-hue)
pp (* value (- 1 saturation))
qq (* value (- 1 (* saturation fract)))
ww (* value (- 1 (* saturation (- 1 (- hue int-hue))))))
(case int-hue
((0 6) (setq red value
green ww
blue pp))
(1 (setq red qq
green value
blue pp))
(2 (setq red pp
green value
blue ww))
(3 (setq red pp
green qq
blue value))
(4 (setq red ww
green pp
blue value))
(otherwise (setq red value
green pp
blue qq))))
(list red green blue)))
;;;###autoload
(defun hexrgb-hsv-to-hex (hue saturation value)
"Return the hex RBG color string for inputs HUE, SATURATION, VALUE.
The inputs are each in the range 0 to 1.
The output string is of the form \"#RRRRGGGGBBBB\"."
(hexrgb-color-values-to-hex
(mapcar (lambda (x) (floor (* x 65535.0))) (hexrgb-hsv-to-rgb hue saturation value))))
;;;###autoload
(defun hexrgb-rgb-to-hex (red green blue)
"Return the hex RBG color string for inputs RED, GREEN, BLUE.
The inputs are each in the range 0 to 1.
The output string is of the form \"#RRRRGGGGBBBB\"."
(hexrgb-color-values-to-hex
(mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue))))
;;;###autoload
(defun hexrgb-hex-to-hsv (color)
"Return a list of HSV (hue, saturation, value) color components.
Each component is a value from 0.0 to 1.0, inclusive.
COLOR is a color name or a hex RGB string that starts with \"#\" and
is followed by an equal number of hex digits for red, green, and blue
components."
(let ((rgb-components (hexrgb-hex-to-rgb color)))
(apply #'hexrgb-rgb-to-hsv rgb-components)))
;;;###autoload
(defun hexrgb-hex-to-rgb (color)
"Return a list of RGB (red, green, blue) color components.
Each component is a value from 0.0 to 1.0, inclusive.
COLOR is a color name or a hex RGB string that starts with \"#\" and
is followed by an equal number of hex digits for red, green, and blue
components."
(unless (hexrgb-rgb-hex-string-p color) (setq color (hexrgb-color-name-to-hex color)))
(let ((len (/ (1- (length color)) 3)))
(list (/ (hexrgb-hex-to-int (substring color 1 (1+ len))) 65535.0)
(/ (hexrgb-hex-to-int (substring color (1+ len) (+ 1 len len))) 65535.0)
(/ (hexrgb-hex-to-int (substring color (+ 1 len len))) 65535.0))))
;;;###autoload
(defun hexrgb-color-name-to-hex (color)
"Return the RGB hex string for the COLOR name, starting with \"#\".
If COLOR is already a string starting with \"#\", then just return it."
(let ((components (x-color-values color)))
(unless components (error "No such color: %S" color))
(unless (hexrgb-rgb-hex-string-p color)
(setq color (hexrgb-color-values-to-hex components))))
color)
;; Just hard-code 4 as the number of hex digits, since `x-color-values'
;; seems to produce appropriate integer values for this value.
;;
;; Color "components" would be better in the name than color "value"
;; but this name follows the Emacs tradition (e.g. `x-color-values',
;; 'ps-color-values', `ps-e-x-color-values').
;;;###autoload
(defun hexrgb-color-values-to-hex (values)
"Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
Each X in the string is a hexadecimal digit.
Input VALUES is as for the output of `x-color-values'."
(concat "#" (hexrgb-int-to-hex (nth 0 values) 4) ; red
(hexrgb-int-to-hex (nth 1 values) 4) ; green
(hexrgb-int-to-hex (nth 2 values) 4))) ; blue
;;;###autoload
(defun hexrgb-hex-to-color-values (color)
"Convert hex COLOR to a list of rgb color values.
COLOR is a hex rgb color string, #XXXXXXXXXXXX
Each X in the string is a hexadecimal digit. There are 3N X's, N > 0.
The output list is as for `x-color-values'."
(let* ((hex-strgp (string-match
"^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$"
color))
(ndigits (/ (if (eq (match-beginning 1) (match-end 1))
(length color)
(1- (length color)))
3))
red green blue)
(unless hex-strgp (error "Invalid RGB color string: %s" color))
(setq color (substring color (match-beginning 2) (match-end 2))
red (hexrgb-hex-to-int (substring color 0 ndigits))
green (hexrgb-hex-to-int (substring color ndigits (* 2 ndigits)))
blue (hexrgb-hex-to-int (substring color ndigits (* 3 ndigits))))
(list red green blue)))
;;;###autoload
(defun hexrgb-increment-red (hex nb-digits increment &optional wrap-p)
"Increment red value of rgb string HEX by INCREMENT.
String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
If optional arg WRAP-P is non-nil, then the result wraps around zero.
For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap
around to \"#000000000\"."
(concat "#"
(hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p)
(substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
(substring hex (1+ (* nb-digits 2)))))
;;;###autoload
(defun hexrgb-increment-green (hex nb-digits increment &optional wrap-p)
"Increment green value of rgb string HEX by INCREMENT.
String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap
around to \"#000000000\"."
(concat
"#" (substring hex 1 (1+ nb-digits))
(hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
increment
nb-digits
wrap-p)
(substring hex (1+ (* nb-digits 2)))))
;;;###autoload
(defun hexrgb-increment-blue (hex nb-digits increment &optional wrap-p)
"Increment blue value of rgb string HEX by INCREMENT.
String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap
around to \"#000000000\"."
(concat "#" (substring hex 1 (1+ (* nb-digits 2)))
(hexrgb-increment-hex (substring hex (1+ (* nb-digits 2)))
increment
nb-digits
wrap-p)))
;;;###autoload
(defun hexrgb-increment-equal-rgb (hex nb-digits increment &optional wrap-p)
"Increment each color value (r,g,b) of rgb string HEX by INCREMENT.
String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap
around to \"#000000000\"."
(concat
"#" (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p)
(hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
increment
nb-digits
wrap-p)
(hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) increment nb-digits wrap-p)))
;;;###autoload
(defun hexrgb-increment-hex (hex increment nb-digits &optional wrap-p)
"Increment HEX number (a string NB-DIGITS long) by INCREMENT.
For example, incrementing \"FFFFFFFFF\" by 1 will cause it to wrap
around to \"000000000\"."
(let* ((int (hexrgb-hex-to-int hex))
(new-int (+ increment int)))
(if (or wrap-p
(and (>= int 0) ; Not too large for the machine.
(>= new-int 0) ; For the case where increment < 0.
(<= (length (format (concat "%X") new-int)) nb-digits))) ; Not too long.
(hexrgb-int-to-hex new-int nb-digits) ; Use incremented number.
hex))) ; Don't increment.
;;;###autoload
(defun hexrgb-hex-to-int (hex)
"Convert HEX string argument to an integer.
The characters of HEX must be hex characters."
(let* ((factor 1)
(len (length hex))
(indx (1- len))
(int 0))
(while (>= indx 0)
(setq int (+ int (* factor (hexrgb-hex-char-to-integer (aref hex indx))))
indx (1- indx)
factor (* 16 factor)))
int))
;; From `hexl.el'. This is the same as `hexl-hex-char-to-integer' defined there.
;;;###autoload
(defun hexrgb-hex-char-to-integer (character)
"Take a CHARACTER and return its value as if it were a hex digit."
(if (and (>= character ?0) (<= character ?9))
(- character ?0)
(let ((ch (logior character 32)))
(if (and (>= ch ?a) (<= ch ?f))
(- ch (- ?a 10))
(error "Invalid hex digit `%c'" ch)))))
;; Originally, I used the code from `int-to-hex-string' in `float.el'.
;; This version is thanks to Juri Linkov <juri@jurta.org>.
;;
;;;###autoload
(defun hexrgb-int-to-hex (int &optional nb-digits)
"Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
Each X in the output string is a hexadecimal digit.
NB-DIGITS is the number of hex digits. If INT is too large to be
represented with NB-DIGITS, then the result is truncated from the
left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
the hex equivalent of 256 decimal is 100, which is more than 2 digits."
(setq nb-digits (or nb-digits 4))
(substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
;; Inspired by Elisp Info manual, node "Comparison of Numbers".
;;;###autoload
(defun hexrgb-approx-equal (x y &optional rfuzz afuzz)
"Return non-nil if numbers X and Y are approximately equal.
RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor.
RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10).
RFUZZ and AFUZZ are converted to their absolute values.
The algorithm is:
(< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))."
(setq rfuzz (or rfuzz 1.0e-8)
rfuzz (abs rfuzz)
afuzz (or afuzz (/ rfuzz 10))
afuzz (abs afuzz))
(< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y))))))
;;;###autoload
(defun hexrgb-color-value-to-float (n)
"Return the floating-point equivalent of color value N.
N must be an integer between 0 and 65535, or else an error is raised."
(unless (and (wholenump n) (<= n 65535))
(error "Not a whole number less than 65536"))
(/ (float n) 65535.0))
;;;###autoload
(defun hexrgb-float-to-color-value (x)
"Return the color value equivalent of floating-point number X.
X must be between 0.0 and 1.0, or else an error is raised."
(unless (and (numberp x) (<= 0.0 x) (<= x 1.0))
(error "Not a floating-point number between 0.0 and 1.0"))
(floor (* x 65535.0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'hexrgb)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; hexrgb.el ends here

BIN
elpa/jabber-20180927.2325/jabber-fallback-lib/hexrgb.elc Normal file
View File

Binary file not shown.

125
elpa/jabber-20180927.2325/jabber-feature-neg.el Normal file
View File

@ -0,0 +1,125 @@
;; jabber-feature-neg.el - Feature Negotiation by JEP-0020
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-disco)
(require 'cl)
(jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg")
(defun jabber-fn-parse (xml-data type)
"Parse a Feature Negotiation request, return alist representation.
XML-DATA should have one child element, <x/>, in the jabber:x:data
namespace.
TYPE is either 'request or 'response.
Returned alist has field name as key, and value is a list of offered
alternatives."
(let ((x (car (jabber-xml-get-children xml-data 'x))))
(unless (and x
(string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data"))
(jabber-signal-error "modify" 'bad-request "Malformed Feature Negotiation"))
(let (alist
(fields (jabber-xml-get-children x 'field)))
(dolist (field fields)
(let ((var (jabber-xml-get-attribute field 'var))
(value (car (jabber-xml-get-children field 'value)))
(options (jabber-xml-get-children field 'option)))
(setq alist (cons
(cons var
(cond
((eq type 'request)
(mapcar #'(lambda (option)
(car (jabber-xml-node-children
(car (jabber-xml-get-children
option 'value)))))
options))
((eq type 'response)
(jabber-xml-node-children value))
(t
(error "Incorrect Feature Negotiation type: %s" type))))
alist))))
;; return alist
alist)))
(defun jabber-fn-encode (alist type)
"Transform a feature alist into an <x/> node int the jabber:x:data namespace.
Note that this is not the reverse of `jabber-fn-parse'.
TYPE is either 'request or 'response."
(let ((requestp (eq type 'request)))
`(x ((xmlns . "jabber:x:data")
(type . ,(if requestp "form" "submit")))
,@(mapcar #'(lambda (field)
`(field
((type . "list-single")
(var . ,(car field)))
,@(if requestp
(mapcar
#'(lambda (option)
`(option nil (value nil ,option)))
(cdr field))
(list `(value nil ,(cadr field))))))
alist))))
(defun jabber-fn-intersection (mine theirs)
"Find values acceptable to both parties.
MINE and THEIRS are alists, as returned by `jabber-fn-parse'.
An alist is returned, where the keys are the negotiated variables,
and the values are lists containing the preferred option. If
negotiation is impossible, an error is signalled. The errors are as
specified in JEP-0020, and not necessarily the ones of higher-level
protocols."
(let ((vars (mapcar #'car mine))
(their-vars (mapcar #'car theirs)))
;; are the same variables being negotiated?
(sort vars 'string-lessp)
(sort their-vars 'string-lessp)
(let ((mine-but-not-theirs (set-difference vars their-vars :test 'string=))
(theirs-but-not-mine (set-difference their-vars vars :test 'string=)))
(when mine-but-not-theirs
(jabber-signal-error "modify" 'not-acceptable (car mine-but-not-theirs)))
(when theirs-but-not-mine
(jabber-signal-error "cancel" 'feature-not-implemented (car theirs-but-not-mine))))
(let (alist)
(dolist (var vars)
(let ((my-options (cdr (assoc var mine)))
(their-options (cdr (assoc var theirs))))
(let ((common-options (intersection my-options their-options :test 'string=)))
(if common-options
;; we have a match; but which one to use?
;; the first one will probably work
(setq alist
(cons (list var (car common-options))
alist))
;; no match
(jabber-signal-error "modify" 'not-acceptable var)))))
alist)))
(provide 'jabber-feature-neg)
;;; arch-tag: 65b2cdcc-7a5f-476b-a613-84ec8e590186

35
elpa/jabber-20180927.2325/jabber-festival.el Normal file
View File

@ -0,0 +1,35 @@
;;; jabber-festival.el --- Festival alert hooks
;; Copyright (C) 2005 Magnus Henoch
;; This file is a part of jabber.el.
;; This program 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 2, or (at your option)
;; any later version.
;; This program 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
(eval-when-compile (require 'jabber-alert))
(condition-case e
(progn
;; Most people don't have Festival, so this will often fail
(require 'festival)
(define-jabber-alert festival "Voice messages through Festival"
(lambda (text &optional title) (festival-say-string (or title text)))))
(error nil))
(provide 'jabber-festival)
;; arch-tag: 8922D096-5D07-11D9-B4C2-000A95C2FCD0

BIN
elpa/jabber-20180927.2325/jabber-festival.elc Normal file
View File

Binary file not shown.

68
elpa/jabber-20180927.2325/jabber-ft-client.el Normal file
View File

@ -0,0 +1,68 @@
;; jabber-ft-client.el - send file transfer requests, by JEP-0096
;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(eval-when-compile (require 'cl))
(require 'jabber-si-client)
(require 'jabber-util)
(require 'jabber-ft-common)
(defun jabber-ft-send (jc jid filename desc)
"Attempt to send FILENAME to JID."
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Send file to: " nil nil nil 'full t)
(read-file-name "Send which file: " nil nil t)
(jabber-read-with-input-method "Description (optional): ")))
(if (zerop (length desc)) (setq desc nil))
(setq filename (expand-file-name filename))
(access-file filename "Couldn't open file")
(let* ((attributes (file-attributes filename))
(size (nth 7 attributes))
(date (nth 5 attributes))
(hash (jabber-ft-get-md5 filename)))
(jabber-si-initiate jc jid "http://jabber.org/protocol/si/profile/file-transfer"
`(file ((xmlns . "http://jabber.org/protocol/si/profile/file-transfer")
(name . ,(file-name-nondirectory filename))
(size . ,size)
(date . ,(jabber-encode-time date))
,@(when hash
(list (cons 'hash hash))))
(desc () ,desc))
(lexical-let ((filename filename))
(lambda (jc jid sid send-data-function)
(jabber-ft-do-send
jid sid send-data-function filename))))))
(defun jabber-ft-do-send (jid sid send-data-function filename)
(if (stringp send-data-function)
(message "File sending failed: %s" send-data-function)
(with-temp-buffer
(insert-file-contents-literally filename)
;; Ever heard of buffering?
(funcall send-data-function (buffer-string))
(message "File transfer completed")))
;; File transfer is monodirectional, so ignore received data.
#'ignore)
(provide 'jabber-ft-client)
;;; arch-tag: fba686d5-37b5-4165-86c5-49b76fa0ea6e

46
elpa/jabber-20180927.2325/jabber-ft-common.el Normal file
View File

@ -0,0 +1,46 @@
;;; jabber-ft-common.el --- Common functions for sending and receiving files (JEP-0096)
;; Copyright (C) 2006, 2008 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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.
(defcustom jabber-ft-md5sum-program (or (when (executable-find "md5")
(list (executable-find "md5") "-n"))
(when (executable-find "md5sum")
(list (executable-find "md5sum"))))
"The program to use to calculate MD5 sums of files.
The first item should be the name of the program, and the remaing
items the arguments. The file name is appended as the last
argument."
:type '(repeat string)
:group 'jabber)
(defun jabber-ft-get-md5 (file-name)
"Get MD5 sum of FILE-NAME, and return as hex string.
Return nil if no MD5 summing program is available."
(when jabber-ft-md5sum-program
(with-temp-buffer
(apply 'call-process (car jabber-ft-md5sum-program) nil t nil
(append (cdr jabber-ft-md5sum-program) (list file-name)))
;; Output is "hexsum filename"
(goto-char (point-min))
(forward-word 1)
(buffer-substring (point-min) (point)))))
(provide 'jabber-ft-common)
;; arch-tag: 1ce4cce0-8360-11da-a5ba-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-ft-common.elc Normal file
View File

Binary file not shown.

131
elpa/jabber-20180927.2325/jabber-ft-server.el Normal file
View File

@ -0,0 +1,131 @@
;; jabber-ft-server.el - handle incoming file transfers, by JEP-0096
;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-si-server)
(require 'jabber-util)
(defvar jabber-ft-sessions nil
"Alist, where keys are (sid jid), and values are buffers of the files.")
(defvar jabber-ft-size nil
"Size of the file that is being downloaded")
(defvar jabber-ft-md5-hash nil
"MD5 hash of the file that is being downloaded")
(jabber-disco-advertise-feature "http://jabber.org/protocol/si/profile/file-transfer")
(add-to-list 'jabber-si-profiles
(list "http://jabber.org/protocol/si/profile/file-transfer"
'jabber-ft-accept
'jabber-ft-server-connected))
(defun jabber-ft-accept (jc xml-data)
"Receive IQ stanza containing file transfer request, ask user"
(let* ((from (jabber-xml-get-attribute xml-data 'from))
(query (jabber-iq-query xml-data))
(si-id (jabber-xml-get-attribute query 'id))
;; TODO: check namespace
(file (car (jabber-xml-get-children query 'file)))
(name (jabber-xml-get-attribute file 'name))
(size (jabber-xml-get-attribute file 'size))
(date (jabber-xml-get-attribute file 'date))
(md5-hash (jabber-xml-get-attribute file 'hash))
(desc (car (jabber-xml-node-children
(car (jabber-xml-get-children file 'desc)))))
(range (car (jabber-xml-get-children file 'range))))
(unless (and name size)
;; both name and size must be present
(jabber-signal-error "modify" 'bad-request))
(let ((question (format
"%s is sending you the file %s (%s bytes).%s Accept? "
(jabber-jid-displayname from)
name
size
(if (not (zerop (length desc)))
(concat " Description: '" desc "'")
""))))
(unless (yes-or-no-p question)
(jabber-signal-error "cancel" 'forbidden)))
;; default is to save with given name, in current directory.
;; maybe that's bad; maybe should be customizable.
(let* ((file-name (read-file-name "Download to: " nil nil nil name))
(buffer (create-file-buffer file-name)))
(message "Starting download of %s..." (file-name-nondirectory file-name))
(with-current-buffer buffer
(kill-all-local-variables)
(setq buffer-file-coding-system 'binary)
;; For Emacs, switch buffer to unibyte _before_ anything goes into it,
;; otherwise binary files are corrupted. For XEmacs, it isn't needed,
;; and it also doesn't have set-buffer-multibyte.
(if (fboundp 'set-buffer-multibyte)
(set-buffer-multibyte nil))
(set-visited-file-name file-name t)
(set (make-local-variable 'jabber-ft-size)
(string-to-number size))
(set (make-local-variable 'jabber-ft-md5-hash)
md5-hash))
(add-to-list 'jabber-ft-sessions
(cons (list si-id from) buffer)))
;; to support range, return something sensible here
nil))
(defun jabber-ft-server-connected (jc jid sid send-data-function)
;; We don't really care about the send-data-function. But if it's
;; a string, it means that we have no connection.
(if (stringp send-data-function)
(message "File receiving failed: %s" send-data-function)
;; On success, we just return our data receiving function.
'jabber-ft-data))
(defun jabber-ft-data (jc jid sid data)
"Receive chunk of transferred file."
(let ((buffer (cdr (assoc (list sid jid) jabber-ft-sessions))))
(with-current-buffer buffer
;; If data is nil, there is no more data.
;; But maybe the remote entity doesn't close the stream -
;; then we have to keep track of file size to know when to stop.
;; Return value is whether to keep connection open.
(when data
(insert data))
(if (and data (< (buffer-size) jabber-ft-size))
t
(basic-save-buffer)
(if (and jabber-ft-md5-hash
(let ((file-hash (jabber-ft-get-md5 buffer-file-name)))
(and file-hash
(not (string= file-hash jabber-ft-md5-hash)))))
;; hash mismatch!
(progn
(message "%s downloaded - CHECKSUM MISMATCH!"
(file-name-nondirectory buffer-file-name))
(sleep-for 5))
;; all is fine
(message "%s downloaded" (file-name-nondirectory buffer-file-name)))
(kill-buffer buffer)
nil))))
(provide 'jabber-ft-server)
;;; arch-tag: 334adcff-6210-496e-8382-8f49ae0248a1

98
elpa/jabber-20180927.2325/jabber-gmail.el Normal file
View File

@ -0,0 +1,98 @@
;;; jabber-gmail.el --- Gmail notifications via emacs-jabber
;; Copyright (C) 2008 Magnus Henoch <mange@freemail.hu>
;; Copyright (C) 2007 Valery V. Vorotyntsev <valery.vv@gmail.com>
;; This program 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 2
;; of the License, or (at your option) any later version.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Usage:
;; Add the following line to your ~/.emacs:
;;
;; (require 'jabber-gmail)
;;
;; If you prefer on demand loading
;; [http://a-nickels-worth.blogspot.com/2007/11/effective-emacs.html]:
;;
;; (autoload 'jabber-gmail-query "jabber-gmail")
;; (autoload 'jabber-gmail-subscribe "jabber-gmail")
;; (add-hook 'jabber-post-connect-hook 'jabber-gmail-subscribe)
;;
;; You may wish to bind a shortcut for `jabber-gmail-query'
;;
;; (global-set-key (kbd "<f9> g") 'jabber-gmail-query)
;;
;; or to customize `jabber-gmail-dothreads'
;;
;; (defun jabber-gmail-dothreads (ts)
;; (let ((msg (format "%d new messages in gmail inbox" (length ts))))
;; (message msg)
;; (jabber-screen-message msg)))
;;;###autoload
(defun jabber-gmail-subscribe (jc)
"Subscribe to gmail notifications.
See http://code.google.com/apis/talk/jep_extensions/usersettings.html#4"
(interactive (list (jabber-read-account)))
(jabber-send-iq jc (jabber-connection-bare-jid jc) "set"
'(usersetting ((xmlns . "google:setting"))
(mailnotifications ((value . "true"))))
#'jabber-report-success "Gmail subscription"
#'jabber-process-data "Gmail subscription")
;; Looks like "one shot" request is still needed to activate
;; notifications machinery.
(jabber-gmail-query jc))
(add-to-list 'jabber-iq-set-xmlns-alist
(cons "google:mail:notify" #'jabber-gmail-process-new-mail))
(defun jabber-gmail-process-new-mail (jc xml-sexp)
"Process new gmail notification.
See http://code.google.com/apis/talk/jep_extensions/gmail.html#notifications"
(let ((from (jabber-xml-get-attribute xml-sexp 'from))
(id (jabber-xml-get-attribute xml-sexp 'id)))
;; respond to server
(jabber-send-iq jc from "result" nil
nil nil nil nil
id))
(jabber-gmail-query jc))
;;;###autoload
(defun jabber-gmail-query (jc)
"Request mail information from the Google Talk server (a.k.a. one shot query).
See http://code.google.com/apis/talk/jep_extensions/gmail.html#requestmail"
(interactive (list (jabber-read-account)))
(jabber-send-iq jc (jabber-connection-bare-jid jc) "get"
'(query ((xmlns . "google:mail:notify")))
#'jabber-gmail-process-mailbox nil
#'jabber-process-data "Gmail query" "gmail-query"))
(defun jabber-gmail-process-mailbox (jc xml-sexp &rest ignore)
"Process gmail query response.
See http://code.google.com/apis/talk/jep_extensions/gmail.html#response"
(let ((ts (jabber-xml-node-children
(car (jabber-xml-get-children xml-sexp 'mailbox)))))
(when ts (jabber-gmail-dothreads ts))))
(defun jabber-gmail-dothreads (threads)
"Process <mail-thread-info/> elements.
THREADS is a list of XML sexps, corresponding to <mail-thread-info/> elements.
See http://code.google.com/apis/talk/jep_extensions/gmail.html#response"
(message "%d new messages in gmail inbox" (length threads)))
(provide 'jabber-gmail)
;; arch-tag: 102bc8e4-e08f-11dc-ab66-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-gmail.elc Normal file
View File

Binary file not shown.

337
elpa/jabber-20180927.2325/jabber-history.el Normal file
View File

@ -0,0 +1,337 @@
;; jabber-history.el - recording message history
;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2004 - Mathias Dahl
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Log format:
;; Each message is on one separate line, represented as a vector with
;; five elements. The first element is time encoded according to
;; JEP-0082. The second element is direction, "in" or "out".
;; The third element is the sender, "me" or a JID. The fourth
;; element is the recipient. The fifth element is the text
;; of the message.
;; FIXME: when rotation is enabled, jabber-history-query won't look
;; for older history files if the current history file doesn't contain
;; enough backlog entries.
(require 'jabber-core)
(require 'jabber-util)
(defgroup jabber-history nil "Customization options for Emacs
Jabber history files."
:group 'jabber)
(defcustom jabber-history-enabled nil
"Non-nil means message logging is enabled."
:type 'boolean
:group 'jabber-history)
(defcustom jabber-history-muc-enabled nil
"Non-nil means MUC logging is enabled.
Default is nil, cause MUC logging may be i/o-intensive."
:type 'boolean
:group 'jabber-history)
(defcustom jabber-history-dir
(locate-user-emacs-file "jabber-history" ".emacs-jabber")
"Base directory where per-contact history files are stored.
Used only when `jabber-use-global-history' is nil."
:type 'directory
:group 'jabber-history)
(defcustom jabber-global-history-filename
(locate-user-emacs-file "jabber-global-message-log" ".jabber_global_message_log")
"Global file where all messages are logged.
Used when `jabber-use-global-history' is non-nil."
:type 'file
:group 'jabber-history)
(defcustom jabber-use-global-history
;; Using a global history file by default was a bad idea. Let's
;; default to per-user files unless the global history file already
;; exists, to avoid breaking existing installations.
(file-exists-p jabber-global-history-filename)
"Whether to use a global file for message history.
If non-nil, `jabber-global-history-filename' is used, otherwise,
messages are stored in per-user files under the
`jabber-history-dir' directory."
:type 'boolean
:group 'jabber-history)
(defcustom jabber-history-enable-rotation nil
"Whether history files should be renamed when reach
`jabber-history-size-limit' kilobytes. If nil, history files
will grow indefinitely, otherwise they'll be renamed to
<history-file>-<number>, where <number> is 1 or the smallest
number after the last rotation."
:type 'boolean
:group 'jabber-history)
(defcustom jabber-history-size-limit 1024
"Maximum history file size in kilobytes.
When history file reaches this limit, it is renamed to
<history-file>-<number>, where <number> is 1 or the smallest
number after the last rotation."
:type 'integer
:group 'jabber-history)
(defvar jabber-history-inhibit-received-message-functions nil
"Functions determining whether to log an incoming message stanza.
The functions in this list are called with two arguments,
the connection and the full message stanza.
If any of the functions returns non-nil, the stanza is not logged
in the message history.")
(defun jabber-rotate-history-p (history-file)
"Return true if HISTORY-FILE should be rotated."
(when (and jabber-history-enable-rotation
(file-exists-p history-file))
(> (/ (nth 7 (file-attributes history-file)) 1024)
jabber-history-size-limit)))
(defun jabber-history-rotate (history-file &optional try)
"Rename HISTORY-FILE to HISTORY-FILE-TRY."
(let ((suffix (number-to-string (or try 1))))
(if (file-exists-p (concat history-file "-" suffix))
(jabber-history-rotate history-file (if try (1+ try) 1))
(rename-file history-file (concat history-file "-" suffix)))))
(add-to-list 'jabber-message-chain 'jabber-message-history)
(defun jabber-message-history (jc xml-data)
"Log message to log file."
(when (and (not jabber-use-global-history)
(not (file-directory-p jabber-history-dir)))
(make-directory jabber-history-dir))
(let ((is-muc (jabber-muc-message-p xml-data)))
(when (and jabber-history-enabled
(or
(not is-muc) ;chat message or private MUC message
(and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active
(unless (run-hook-with-args-until-success
'jabber-history-inhibit-received-message-functions
jc xml-data)
(let ((from (jabber-xml-get-attribute xml-data 'from))
(text (car (jabber-xml-node-children
(car (jabber-xml-get-children xml-data 'body)))))
(timestamp (jabber-message-timestamp xml-data)))
(when (and from text)
(jabber-history-log-message "in" from nil text timestamp)))))))
(add-hook 'jabber-chat-send-hooks 'jabber-history-send-hook)
(defun jabber-history-send-hook (body id)
"Log outgoing message to log file."
(when (and (not jabber-use-global-history)
(not (file-directory-p jabber-history-dir)))
(make-directory jabber-history-dir))
;; This function is called from a chat buffer, so jabber-chatting-with
;; contains the desired value.
(if jabber-history-enabled
(jabber-history-log-message "out" nil jabber-chatting-with body (current-time))))
(defun jabber-history-filename (contact)
"Return a history filename for CONTACT if the per-user file
loggin strategy is used or the global history filename."
(if jabber-use-global-history
jabber-global-history-filename
;; jabber-jid-symbol is the best canonicalization we have.
(concat jabber-history-dir
"/" (symbol-name (jabber-jid-symbol contact)))))
(defun jabber-history-log-message (direction from to body timestamp)
"Log a message"
(with-temp-buffer
;; Remove properties
(set-text-properties 0 (length body) nil body)
;; Encode text as Lisp string - get decoding for free
(setq body (prin1-to-string body))
;; Encode LF and CR
(while (string-match "\n" body)
(setq body (replace-match "\\n" nil t body nil)))
(while (string-match "\r" body)
(setq body (replace-match "\\r" nil t body nil)))
(insert (format "[\"%s\" \"%s\" %s %s %s]\n"
(jabber-encode-time (or timestamp (current-time)))
(or direction
"in")
(or (when from
(prin1-to-string from))
"\"me\"")
(or (when to
(prin1-to-string to))
"\"me\"")
body))
(let ((coding-system-for-write 'utf-8)
(history-file (jabber-history-filename (or from to))))
(when (and (not jabber-use-global-history)
(not (file-directory-p jabber-history-dir)))
(make-directory jabber-history-dir))
(when (jabber-rotate-history-p history-file)
(jabber-history-rotate history-file))
(condition-case e
(write-region (point-min) (point-max) history-file t 'quiet)
(error
(message "Unable to write history: %s" (error-message-string e)))))))
(defun jabber-history-query (start-time
end-time
number
direction
jid-regexp
history-file)
"Return a list of vectors, one for each message matching the criteria.
START-TIME and END-TIME are floats as obtained from `float-time'.
Either or both may be nil, meaning no restriction.
NUMBER is the maximum number of messages to return, or t for
unlimited.
DIRECTION is either \"in\" or \"out\", or t for no limit on direction.
JID-REGEXP is a regexp which must match the JID.
HISTORY-FILE is the file in which to search.
Currently jabber-history-query performs a linear search from the end
of the log file."
(when (file-readable-p history-file)
(with-temp-buffer
(let ((coding-system-for-read 'utf-8))
(if jabber-use-global-history
(insert-file-contents history-file)
(let* ((lines-collected nil)
(matched-files
(directory-files jabber-history-dir t
(concat "^"
(regexp-quote (file-name-nondirectory
history-file)))))
(matched-files
(cons (car matched-files)
(sort (cdr matched-files) 'string>-numerical))))
(while (not lines-collected)
(if (null matched-files)
(setq lines-collected t)
(let ((file (pop matched-files)))
(progn
(insert-file-contents file)
(when (numberp number)
(if (>= (count-lines (point-min) (point-max)) number)
(setq lines-collected t))))))))))
(let (collected current-line)
(goto-char (point-max))
(catch 'beginning-of-file
(while (progn
(backward-sexp)
(setq current-line (car (read-from-string
(buffer-substring
(point)
(save-excursion
(forward-sexp)
(point))))))
(and (or (null start-time)
(> (jabber-float-time (jabber-parse-time
(aref current-line 0)))
start-time))
(or (eq number t)
(< (length collected) number))))
(if (and (or (eq direction t)
(string= direction (aref current-line 1)))
(or (null end-time)
(> end-time (jabber-float-time (jabber-parse-time
(aref current-line 0)))))
(string-match
jid-regexp
(car
(remove "me"
(list (aref current-line 2)
(aref current-line 3))))))
(push current-line collected))
(when (bobp)
(throw 'beginning-of-file nil))))
collected))))
(defcustom jabber-backlog-days 3.0
"Age limit on messages in chat buffer backlog, in days"
:group 'jabber
:type '(choice (number :tag "Number of days")
(const :tag "No limit" nil)))
(defcustom jabber-backlog-number 10
"Maximum number of messages in chat buffer backlog"
:group 'jabber
:type 'integer)
(defun jabber-history-backlog (jid &optional before)
"Fetch context from previous chats with JID.
Return a list of history entries (vectors), limited by
`jabber-backlog-days' and `jabber-backlog-number'.
If BEFORE is non-nil, it should be a float-time after which
no entries will be fetched. `jabber-backlog-days' still
applies, though."
(jabber-history-query
(and jabber-backlog-days
(- (jabber-float-time) (* jabber-backlog-days 86400.0)))
before
jabber-backlog-number
t ; both incoming and outgoing
(concat "^" (regexp-quote (jabber-jid-user jid)) "\\(/.*\\)?$")
(jabber-history-filename jid)))
(defun jabber-history-move-to-per-user ()
"Migrate global history to per-user files."
(interactive)
(when (file-directory-p jabber-history-dir)
(error "Per-user history directory already exists"))
(make-directory jabber-history-dir)
(let ((jabber-use-global-history nil))
(with-temp-buffer
(let ((coding-system-for-read 'utf-8))
(insert-file-contents jabber-global-history-filename))
(let ((progress-reporter
(when (fboundp 'make-progress-reporter)
(make-progress-reporter "Migrating history..."
(point-min) (point-max))))
;;(file-table (make-hash-table :test 'equal))
;; Keep track of blocks of entries pertaining to the same JID.
current-jid jid-start)
(while (not (eobp))
(let* ((start (point))
(end (progn (forward-line) (point)))
(line (buffer-substring start end))
(parsed (car (read-from-string line)))
(jid (if (string= (aref parsed 2) "me")
(aref parsed 3)
(aref parsed 2))))
;; Whenever there is a change in JID...
(when (not (equal jid current-jid))
(when current-jid
;; ...save data for previous JID...
(let ((history-file (jabber-history-filename current-jid)))
(write-region jid-start start history-file t 'quiet)))
;; ...and switch to new JID.
(setq current-jid jid)
(setq jid-start start))
(when (fboundp 'progress-reporter-update)
(progress-reporter-update progress-reporter (point)))))
;; Finally, save the last block, if any.
(when current-jid
(let ((history-file (jabber-history-filename current-jid)))
(write-region jid-start (point-max) history-file t 'quiet))))))
(message "Done. Please change `jabber-use-global-history' now."))
(provide 'jabber-history)
;; arch-tag: 0AA0C235-3FC0-11D9-9FE7-000A95C2FCD0

BIN
elpa/jabber-20180927.2325/jabber-history.elc Normal file
View File

Binary file not shown.

213
elpa/jabber-20180927.2325/jabber-iq.el Normal file
View File

@ -0,0 +1,213 @@
;; jabber-iq.el - infoquery functions
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-core)
(require 'jabber-util)
(require 'jabber-keymap)
(defvar *jabber-open-info-queries* nil
"an alist of open query id and their callback functions")
(defvar jabber-iq-get-xmlns-alist nil
"Mapping from XML namespace to handler for IQ GET requests.")
(defvar jabber-iq-set-xmlns-alist nil
"Mapping from XML namespace to handler for IQ SET requests.")
(defvar jabber-browse-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map jabber-common-keymap)
(define-key map [mouse-2] 'jabber-popup-combined-menu)
map))
(defcustom jabber-browse-mode-hook nil
"Hook run when entering Browse mode."
:group 'jabber
:type 'hook)
(defgroup jabber-browse nil "browse display options"
:group 'jabber)
(defcustom jabber-browse-buffer-format "*-jabber-browse:-%n-*"
"The format specification for the name of browse buffers.
These fields are available at this moment:
%n JID to browse"
:type 'string
:group 'jabber-browse)
(defun jabber-browse-mode ()
"\\{jabber-browse-mode-map}"
(kill-all-local-variables)
(setq major-mode 'jabber-browse-mode
mode-name "jabber-browse")
(use-local-map jabber-browse-mode-map)
(setq buffer-read-only t)
(if (fboundp 'run-mode-hooks)
(run-mode-hooks 'jabber-browse-mode-hook)
(run-hooks 'jabber-browse-mode-hook)))
(put 'jabber-browse-mode 'mode-class 'special)
(add-to-list 'jabber-iq-chain 'jabber-process-iq)
(defun jabber-process-iq (jc xml-data)
"process an incoming iq stanza"
(let* ((id (jabber-xml-get-attribute xml-data 'id))
(type (jabber-xml-get-attribute xml-data 'type))
(from (jabber-xml-get-attribute xml-data 'from))
(query (jabber-iq-query xml-data))
(callback (assoc id *jabber-open-info-queries*)))
(cond
;; if type is "result" or "error", this is a response to a query we sent.
((or (string= type "result")
(string= type "error"))
(let ((callback-cons (nth (cdr (assoc type '(("result" . 0)
("error" . 1)))) (cdr callback))))
(if (consp callback-cons)
(funcall (car callback-cons) jc xml-data (cdr callback-cons))))
(setq *jabber-open-info-queries* (delq callback *jabber-open-info-queries*)))
;; if type is "get" or "set", correct action depends on namespace of request.
((and (listp query)
(or (string= type "get")
(string= type "set")))
(let* ((which-alist (eval (cdr (assoc type
(list
(cons "get" 'jabber-iq-get-xmlns-alist)
(cons "set" 'jabber-iq-set-xmlns-alist))))))
(handler (cdr (assoc (jabber-xml-get-attribute query 'xmlns) which-alist))))
(if handler
(condition-case error-var
(funcall handler jc xml-data)
(jabber-error
(apply 'jabber-send-iq-error jc from id query (cdr error-var)))
(error (jabber-send-iq-error jc from id query "wait" 'internal-server-error (error-message-string error-var))))
(jabber-send-iq-error jc from id query "cancel" 'feature-not-implemented)))))))
(defun jabber-send-iq (jc to type query success-callback success-closure-data
error-callback error-closure-data &optional result-id)
"Send an iq stanza to the specified entity, and optionally set up a callback.
JC is the Jabber connection.
TO is the addressee.
TYPE is one of \"get\", \"set\", \"result\" or \"error\".
QUERY is a list containing the child of the iq node in the format `jabber-sexp2xml'
accepts.
SUCCESS-CALLBACK is the function to be called when a successful result arrives.
SUCCESS-CLOSURE-DATA is an extra argument to SUCCESS-CALLBACK.
ERROR-CALLBACK is the function to be called when an error arrives.
ERROR-CLOSURE-DATA is an extra argument to ERROR-CALLBACK.
RESULT-ID is the id to be used for a response to a received iq message.
`jabber-report-success' and `jabber-process-data' are common callbacks.
The callback functions are called like this:
\(funcall CALLBACK JC XML-DATA CLOSURE-DATA)
with XML-DATA being the IQ stanza received in response. "
(let ((id (or result-id (apply 'format "emacs-iq-%d.%d.%d" (current-time)))))
(if (or success-callback error-callback)
(setq *jabber-open-info-queries* (cons (list id
(cons success-callback success-closure-data)
(cons error-callback error-closure-data))
*jabber-open-info-queries*)))
(jabber-send-sexp jc
(list 'iq (append
(if to (list (cons 'to to)))
(list (cons 'type type))
(list (cons 'id id)))
query))))
(defun jabber-send-iq-error (jc to id original-query error-type condition
&optional text app-specific)
"Send an error iq stanza to the specified entity in response to a
previously sent iq stanza.
TO is the addressee.
ID is the id of the iq stanza that caused the error.
ORIGINAL-QUERY is the original query, which should be included in the
error, or nil.
ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\"
and \"wait\".
CONDITION is a symbol denoting a defined XMPP condition.
TEXT is a string to be sent in the error message, or nil for no text.
APP-SPECIFIC is a list of extra XML tags.
See section 9.3 of XMPP Core."
(jabber-send-sexp
jc
`(iq (,@(when to `((to . ,to)))
(type . "error")
(id . ,(or id "")))
,original-query
(error ((type . ,error-type))
(,condition ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))
,(if text
`(text ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))
,text))
,@app-specific))))
(defun jabber-process-data (jc xml-data closure-data)
"Process random results from various requests."
(let ((from (or (jabber-xml-get-attribute xml-data 'from) (plist-get (fsm-get-state-data jc) :server)))
(xmlns (jabber-iq-xmlns xml-data))
(type (jabber-xml-get-attribute xml-data 'type)))
(with-current-buffer (get-buffer-create (format-spec jabber-browse-buffer-format
(list (cons ?n from))))
(if (not (eq major-mode 'jabber-browse-mode))
(jabber-browse-mode))
(setq buffer-read-only nil)
(goto-char (point-max))
(insert (jabber-propertize from
'face 'jabber-title-large) "\n\n")
;; Put point at beginning of data
(save-excursion
;; If closure-data is a function, call it. If it is a string,
;; output it along with a description of the error. For other
;; values (e.g. nil), just dump the XML.
(cond
((functionp closure-data)
(funcall closure-data jc xml-data))
((stringp closure-data)
(insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n"))
(t
(insert (format "%S\n\n" xml-data))))
(dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
(run-hook-with-args hook 'browse (current-buffer) (funcall jabber-alert-info-message-function 'browse (current-buffer))))))))
(defun jabber-silent-process-data (jc xml-data closure-data)
"Process random results from various requests to only alert hooks."
(let ((text (cond
((functionp closure-data)
(funcall closure-data jc xml-data))
((stringp closure-data)
(concat closure-data ": " (jabber-parse-error (jabber-iq-error xml-data))))
(t
(format "%S" xml-data)))))
(dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
(run-hook-with-args hook 'browse (current-buffer)
text))))
(provide 'jabber-iq)
;;; arch-tag: 5585dfa3-b59a-42ee-9292-803652c85e26

BIN
elpa/jabber-20180927.2325/jabber-iq.elc Normal file
View File

Binary file not shown.

176
elpa/jabber-20180927.2325/jabber-keepalive.el Normal file
View File

@ -0,0 +1,176 @@
;; jabber-keepalive.el - try to detect lost connection
;; Copyright (C) 2004, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2007 - Detlev Zundel - dzu@gnu.org
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Keepalive - send something to the server and see if it answers
;;;
;;; These keepalive functions send a urn:xmpp:ping request to the
;;; server every X minutes, and considers the connection broken if
;;; they get no answer within Y seconds.
(require 'jabber-ping)
;;;###autoload
(defgroup jabber-keepalive nil
"Keepalive functions try to detect lost connection"
:group 'jabber)
(defcustom jabber-keepalive-interval 600
"Interval in seconds between connection checks."
:type 'integer
:group 'jabber-keepalive)
(defcustom jabber-keepalive-timeout 20
"Seconds to wait for response from server."
:type 'integer
:group 'jabber-keepalive)
(defvar jabber-keepalive-timer nil
"Timer object for keepalive function")
(defvar jabber-keepalive-timeout-timer nil
"Timer object for keepalive timeout function")
(defvar jabber-keepalive-pending nil
"List of outstanding keepalive connections")
(defvar jabber-keepalive-debug nil
"Log keepalive traffic when non-nil")
;;;###autoload
(defun jabber-keepalive-start (&optional jc)
"Activate keepalive.
That is, regularly send a ping request to the server, and
disconnect if it doesn't answer. See `jabber-keepalive-interval'
and `jabber-keepalive-timeout'.
The JC argument makes it possible to add this function to
`jabber-post-connect-hooks'; it is ignored. Keepalive is activated
for all accounts regardless of the argument."
(interactive)
(when jabber-keepalive-timer
(jabber-keepalive-stop))
(setq jabber-keepalive-timer
(run-with-timer 5
jabber-keepalive-interval
'jabber-keepalive-do))
(add-hook 'jabber-post-disconnect-hook 'jabber-keepalive-stop))
(defun jabber-keepalive-stop ()
"Deactivate keepalive"
(interactive)
(when jabber-keepalive-timer
(jabber-cancel-timer jabber-keepalive-timer)
(setq jabber-keepalive-timer nil)))
(defun jabber-keepalive-do ()
(when jabber-keepalive-debug
(message "%s: sending keepalive packet(s)" (current-time-string)))
(setq jabber-keepalive-timeout-timer
(run-with-timer jabber-keepalive-timeout
nil
'jabber-keepalive-timeout))
(setq jabber-keepalive-pending jabber-connections)
(dolist (c jabber-connections)
;; Whether we get an error or not is not interesting.
;; Getting a response at all is.
(jabber-ping-send c nil 'jabber-keepalive-got-response nil nil)))
(defun jabber-keepalive-got-response (jc &rest args)
(when jabber-keepalive-debug
(message "%s: got keepalive response from %s"
(current-time-string)
(plist-get (fsm-get-state-data jc) :server)))
(setq jabber-keepalive-pending (remq jc jabber-keepalive-pending))
(when (and (null jabber-keepalive-pending) (timerp jabber-keepalive-timeout-timer))
(jabber-cancel-timer jabber-keepalive-timeout-timer)
(setq jabber-keepalive-timeout-timer nil)))
(defun jabber-keepalive-timeout ()
(jabber-cancel-timer jabber-keepalive-timer)
(setq jabber-keepalive-timer nil)
(dolist (c jabber-keepalive-pending)
(message "%s: keepalive timeout, connection to %s considered lost"
(current-time-string)
(plist-get (fsm-get-state-data c) :server))
(run-hook-with-args 'jabber-lost-connection-hooks c)
(jabber-disconnect-one c nil)))
;;;; Whitespace pings - less traffic, no error checking on our side
;;;
;;; Openfire needs something like this, but I couldn't bring myself to
;;; enable keepalive by default... Whitespace pings are light and
;;; unobtrusive.
(defcustom jabber-whitespace-ping-interval 30
"Send a space character to the server with this interval, in seconds.
This is a traditional remedy for a number of problems: to keep NAT
boxes from considering the connection dead, to have the OS discover
earlier that the connection is lost, and to placate servers which rely
on the client doing this, e.g. Openfire.
If you want to verify that the server is able to answer, see
`jabber-keepalive-start' for another mechanism."
:type '(integer :tag "Interval in seconds")
:group 'jabber-core)
(defvar jabber-whitespace-ping-timer nil
"Timer object for whitespace pings")
;;;###autoload
(defun jabber-whitespace-ping-start (&optional jc)
"Start sending whitespace pings at regular intervals.
See `jabber-whitespace-ping-interval'.
The JC argument is ignored; whitespace pings are enabled for all
accounts."
(interactive)
(when jabber-whitespace-ping-timer
(jabber-whitespace-ping-stop))
(setq jabber-whitespace-ping-timer
(run-with-timer 5
jabber-whitespace-ping-interval
'jabber-whitespace-ping-do))
(add-hook 'jabber-post-disconnect-hook 'jabber-whitespace-ping-stop))
(defun jabber-whitespace-ping-stop ()
"Deactivate whitespace pings"
(interactive)
(when jabber-whitespace-ping-timer
(jabber-cancel-timer jabber-whitespace-ping-timer)
(setq jabber-whitespace-ping-timer nil)))
(defun jabber-whitespace-ping-do ()
(dolist (c jabber-connections)
(ignore-errors (jabber-send-string c " "))))
(provide 'jabber-keepalive)
;;; arch-tag: d19ca743-75a1-475f-9217-83bd18012146

62
elpa/jabber-20180927.2325/jabber-keymap.el Normal file
View File

@ -0,0 +1,62 @@
;; jabber-keymap.el - common keymap for many modes
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; button.el was introduced in Emacs 22
(condition-case e
(require 'button)
(error nil))
(defvar jabber-common-keymap
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-c" 'jabber-popup-chat-menu)
(define-key map "\C-c\C-r" 'jabber-popup-roster-menu)
(define-key map "\C-c\C-i" 'jabber-popup-info-menu)
(define-key map "\C-c\C-m" 'jabber-popup-muc-menu)
(define-key map "\C-c\C-s" 'jabber-popup-service-menu)
;; note that {forward,backward}-button are not autoloaded.
;; thus the `require' above.
(when (fboundp 'forward-button)
(define-key map [?\t] 'forward-button)
(define-key map [backtab] 'backward-button))
map))
;;;###autoload
(defvar jabber-global-keymap
(let ((map (make-sparse-keymap)))
(define-key map "\C-c" 'jabber-connect-all)
(define-key map "\C-d" 'jabber-disconnect)
(define-key map "\C-r" 'jabber-switch-to-roster-buffer)
(define-key map "\C-j" 'jabber-chat-with)
(define-key map "\C-l" 'jabber-activity-switch-to)
(define-key map "\C-a" 'jabber-send-away-presence)
(define-key map "\C-o" 'jabber-send-default-presence)
(define-key map "\C-x" 'jabber-send-xa-presence)
(define-key map "\C-p" 'jabber-send-presence)
map)
"Global Jabber keymap (usually under C-x C-j)")
;;;###autoload
(define-key ctl-x-map "\C-j" jabber-global-keymap)
(provide 'jabber-keymap)
;;; arch-tag: 22a9993d-a4a7-40ef-a025-7cff6c3f5587

BIN
elpa/jabber-20180927.2325/jabber-keymap.elc Normal file
View File

Binary file not shown.

103
elpa/jabber-20180927.2325/jabber-libnotify.el Normal file
View File

@ -0,0 +1,103 @@
;; jabber-libnotify.el - emacs-jabber interface to libnotify
;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru
;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'dbus nil t)
(eval-when-compile (require 'jabber-alert))
(defcustom jabber-libnotify-icon ""
"Icon to be used on the notification pop-up. Default is empty"
:type '(file :must-match t)
:group 'jabber-alerts)
(defcustom jabber-libnotify-timeout 2500
"Specifies the timeout of the pop up window in millisecond"
:type 'integer
:group 'jabber-alerts)
(defcustom jabber-libnotify-message-header "Jabber message"
"Defines the header of the pop up."
:type 'string
:group 'jabber-alerts)
(defcustom jabber-libnotify-app "Emacs Jabber"
"Defines the app of the pop up."
:type 'string
:group 'jabber-alerts)
(defcustom jabber-libnotify-urgency "low"
"Urgency of libnotify message"
:type '(choice (const :tag "Low" "low")
(const :tag "Normal" "normal")
(const :tag "Critical" "critical"))
:group 'jabber-alerts)
(defcustom jabber-libnotify-method (if (featurep 'dbus) 'dbus 'shell)
"Specifies the method for libnotify call. Dbus is more faster but require emacs23+"
:type '(choice (const :tag "Shell" shell)
(const :tag "D-Bus" dbus))
:group 'jabber-alerts)
(defvar jabber-libnotify-id 0)
(defun jabber-libnotify-next-id ()
"Return the next notification id."
(setq jabber-libnotify-id (+ jabber-libnotify-id 1)))
(defun jabber-libnotify-message (text &optional title)
"Show MSG using libnotify"
(let
((body (or (jabber-escape-xml text) " "))
(head (jabber-escape-xml
(or title
(or jabber-libnotify-message-header " ")
text))))
;; Possible errors include not finding the notify-send binary.
(condition-case e
(cond
((eq jabber-libnotify-method 'shell)
(let ((process-connection-type nil))
(start-process "notification" nil "notify-send"
"-t" (format "%s" jabber-libnotify-timeout)
"-i" (or jabber-libnotify-icon "\"\"")
"-u" jabber-libnotify-urgency
head body)))
((eq jabber-libnotify-method 'dbus)
(dbus-call-method
:session ; use the session (not system) bus
"org.freedesktop.Notifications" ; service name
"/org/freedesktop/Notifications" ; path name
"org.freedesktop.Notifications" "Notify" ; Method
jabber-libnotify-app
(jabber-libnotify-next-id)
jabber-libnotify-icon
':string (encode-coding-string head 'utf-8)
':string (encode-coding-string body 'utf-8)
'(:array)
'(:array :signature "{sv}")
':int32 jabber-libnotify-timeout)))
(error nil))))
(define-jabber-alert libnotify "Show a message through the libnotify interface"
'jabber-libnotify-message)
(define-personal-jabber-alert jabber-muc-libnotify)
(provide 'jabber-libnotify)
;; arch-tag: e9c4c210-8245-11dd-bddf-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-libnotify.elc Normal file
View File

Binary file not shown.

83
elpa/jabber-20180927.2325/jabber-logon.el Normal file
View File

@ -0,0 +1,83 @@
;; jabber-logon.el - logon functions
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-xml)
(require 'jabber-util)
;; In Emacs 24, sha1 is built in, so this require is only needed for
;; earlier versions. It's supposed to be a noop in Emacs 24, but
;; sometimes, for some people, it isn't, and fails with
;; (file-error "Cannot open load file" "sha1").
(unless (fboundp 'sha1)
(require 'sha1))
(defun jabber-get-auth (jc to session-id)
"Send IQ get request in namespace \"jabber:iq:auth\"."
(jabber-send-iq jc to
"get"
`(query ((xmlns . "jabber:iq:auth"))
(username () ,(plist-get (fsm-get-state-data jc) :username)))
#'jabber-do-logon session-id
#'jabber-report-success "Impossible error - auth field request"))
(defun jabber-do-logon (jc xml-data session-id)
"send username and password in logon attempt"
(let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest))
(passwd (when
(or digest-allowed
(plist-get (fsm-get-state-data jc) :encrypted)
(yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? "))
(or (plist-get (fsm-get-state-data jc) :password)
(jabber-read-password (jabber-connection-bare-jid jc)))))
auth)
(if (null passwd)
(fsm-send jc :authentication-failure)
(if digest-allowed
(setq auth `(digest () ,(sha1 (concat session-id passwd))))
(setq auth `(password () ,passwd)))
;; For legacy authentication we must specify a resource.
(unless (plist-get (fsm-get-state-data jc) :resource)
;; Yes, this is ugly. Where is my encapsulation?
(plist-put (fsm-get-state-data jc) :resource "emacs-jabber"))
(jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server)
"set"
`(query ((xmlns . "jabber:iq:auth"))
(username () ,(plist-get (fsm-get-state-data jc) :username))
,auth
(resource () ,(plist-get (fsm-get-state-data jc) :resource)))
#'jabber-process-logon passwd
#'jabber-process-logon nil))))
(defun jabber-process-logon (jc xml-data closure-data)
"receive login success or failure, and request roster.
CLOSURE-DATA should be the password on success and nil on failure."
(if closure-data
;; Logon success
(fsm-send jc (cons :authentication-success closure-data))
;; Logon failure
(jabber-report-success jc xml-data "Logon")
(fsm-send jc :authentication-failure)))
(provide 'jabber-logon)
;;; arch-tag: f24ebe5e-3420-44bb-af81-d4de21f378b0

BIN
elpa/jabber-20180927.2325/jabber-logon.elc Normal file
View File

Binary file not shown.

207
elpa/jabber-20180927.2325/jabber-menu.el Normal file
View File

@ -0,0 +1,207 @@
;; jabber-menu.el - menu definitions
;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-util)
(eval-when-compile (require 'cl))
;;;###autoload
(defvar jabber-menu
(let ((map (make-sparse-keymap "jabber-menu")))
(define-key-after map
[jabber-menu-connect]
'("Connect" . jabber-connect-all))
(define-key-after map
[jabber-menu-disconnect]
'(menu-item "Disconnect" jabber-disconnect
:enable (bound-and-true-p jabber-connections)))
(define-key-after map
[jabber-menu-status]
`(menu-item "Set Status" ,(make-sparse-keymap "set-status")
:enable (bound-and-true-p jabber-connections)))
(define-key map
[jabber-menu-status jabber-menu-status-chat]
'(menu-item
"Chatty"
(lambda ()
(interactive)
(jabber-send-presence "chat"
(jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)
*jabber-current-priority*))
:button (:radio . (and (boundp '*jabber-current-show*)
(equal *jabber-current-show* "chat")))))
(define-key map
[jabber-menu-status jabber-menu-status-dnd]
'(menu-item
"Do not Disturb"
(lambda ()
(interactive)
(jabber-send-presence "dnd"
(jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)
*jabber-current-priority*))
:button (:radio . (and (boundp '*jabber-current-show*)
(equal *jabber-current-show* "dnd")))))
(define-key map
[jabber-menu-status jabber-menu-status-xa]
'(menu-item "Extended Away" jabber-send-xa-presence
:button (:radio . (and (boundp '*jabber-current-show*)
(equal *jabber-current-show* "xa")))))
(define-key map
[jabber-menu-status jabber-menu-status-away]
'(menu-item "Away" jabber-send-away-presence
:button (:radio . (and (boundp '*jabber-current-show*)
(equal *jabber-current-show* "away")))))
(define-key map
[jabber-menu-status jabber-menu-status-online]
'(menu-item "Online" jabber-send-default-presence
:button (:radio . (and (boundp '*jabber-current-show*)
(equal *jabber-current-show* "")))))
(define-key-after map
[separator]
'(menu-item "--"))
(define-key-after map
[jabber-menu-chat-with]
'(menu-item "Chat with..." jabber-chat-with
:enable (bound-and-true-p jabber-connections)))
(define-key-after map
[jabber-menu-nextmsg]
'(menu-item "Next unread message" jabber-activity-switch-to
:enable (bound-and-true-p jabber-activity-jids)))
(define-key-after map
[jabber-menu-send-subscription-request]
'(menu-item "Send subscription request" jabber-send-subscription-request
:enable (bound-and-true-p jabber-connections)))
(define-key-after map
[jabber-menu-roster]
'("Switch to roster" . jabber-switch-to-roster-buffer))
(define-key-after map
[separator2]
'(menu-item "--"))
(define-key-after map
[jabber-menu-customize]
'("Customize" . jabber-customize))
(define-key-after map
[jabber-menu-info]
'("Help" . jabber-info))
map))
;;;###autoload
(defcustom jabber-display-menu 'maybe
"Decide whether the \"Jabber\" menu is displayed in the menu bar.
If t, always display.
If nil, never display.
If maybe, display if jabber.el is installed under `package-user-dir', or
if any of `jabber-account-list' or `jabber-connections' is non-nil."
:group 'jabber
:type '(choice (const :tag "Never" nil)
(const :tag "Always" t)
(const :tag "When installed by user, or when any accounts have been configured or connected" maybe)))
(defun jabber-menu (&optional remove)
"Put \"Jabber\" menu on menubar.
With prefix argument, remove it."
(interactive "P")
(setq jabber-display-menu (if remove nil t))
(force-mode-line-update))
(make-obsolete 'jabber-menu "set the variable `jabber-display-menu' instead.")
;; This used to be:
;; (define-key-after global-map [menu-bar jabber-menu] ...)
;; but that doesn't work in Emacs 21.
;;;###autoload
(define-key-after (lookup-key global-map [menu-bar])
[jabber-menu]
(list 'menu-item "Jabber" jabber-menu
:visible
'(or (eq jabber-display-menu t)
(and (eq jabber-display-menu 'maybe)
(or (bound-and-true-p jabber-account-list)
(bound-and-true-p jabber-connections))))))
(defvar jabber-jid-chat-menu nil
"Menu items for chat menu")
(defvar jabber-jid-info-menu nil
"Menu item for info menu")
(defvar jabber-jid-roster-menu nil
"Menu items for roster menu")
(defvar jabber-jid-muc-menu nil
"Menu items for MUC menu")
(defvar jabber-jid-service-menu nil
"Menu items for service menu")
(defun jabber-popup-menu (which-menu)
"Popup specified menu"
(let* ((mouse-event (and (listp last-input-event) last-input-event))
(choice (widget-choose "Actions" which-menu mouse-event)))
(if mouse-event
(mouse-set-point mouse-event))
(if choice
(call-interactively choice))))
(defun jabber-popup-chat-menu ()
"Popup chat menu"
(interactive)
(jabber-popup-menu jabber-jid-chat-menu))
(defun jabber-popup-info-menu ()
"Popup info menu"
(interactive)
(jabber-popup-menu jabber-jid-info-menu))
(defun jabber-popup-roster-menu ()
"Popup roster menu"
(interactive)
(jabber-popup-menu jabber-jid-roster-menu))
(defun jabber-popup-muc-menu ()
"Popup MUC menu"
(interactive)
(jabber-popup-menu jabber-jid-muc-menu))
(defun jabber-popup-service-menu ()
"Popup service menu"
(interactive)
(jabber-popup-menu jabber-jid-service-menu))
(defun jabber-popup-combined-menu ()
"Popup combined menu"
(interactive)
(jabber-popup-menu (append jabber-jid-chat-menu jabber-jid-info-menu jabber-jid-roster-menu jabber-jid-muc-menu)))
(provide 'jabber-menu)
;;; arch-tag: 5147f52f-de47-4348-86ff-b799d7a75e3f

98
elpa/jabber-20180927.2325/jabber-modeline.el Normal file
View File

@ -0,0 +1,98 @@
;; jabber-modeline.el - display jabber status in modeline
;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-presence)
(require 'jabber-alert)
(eval-when-compile (require 'cl))
(defgroup jabber-mode-line nil
"Display Jabber status in mode line"
:group 'jabber)
(defcustom jabber-mode-line-compact t
"Count contacts in fewer categories for compact view"
:group 'jabber-mode-line
:type 'boolean)
(defvar jabber-mode-line-string nil)
(defvar jabber-mode-line-presence nil)
(defvar jabber-mode-line-contacts nil)
(defadvice jabber-send-presence (after jsp-update-mode-line
(show status priority))
(jabber-mode-line-presence-update))
(defun jabber-mode-line-presence-update ()
(setq jabber-mode-line-presence (if (and jabber-connections (not *jabber-disconnecting*))
(cdr (assoc *jabber-current-show* jabber-presence-strings))
"Offline")))
(defun jabber-mode-line-count-contacts (&rest ignore)
(let ((count (list (cons "chat" 0)
(cons "" 0)
(cons "away" 0)
(cons "xa" 0)
(cons "dnd" 0)
(cons nil 0))))
(dolist (jc jabber-connections)
(dolist (buddy (plist-get (fsm-get-state-data jc) :roster))
(when (assoc (get buddy 'show) count)
(incf (cdr (assoc (get buddy 'show) count))))))
(setq jabber-mode-line-contacts
(if jabber-mode-line-compact
(format "(%d/%d/%d)"
(+ (cdr (assoc "chat" count))
(cdr (assoc "" count)))
(+ (cdr (assoc "away" count))
(cdr (assoc "xa" count))
(cdr (assoc "dnd" count)))
(cdr (assoc nil count)))
(apply 'format "(%d/%d/%d/%d/%d/%d)"
(mapcar 'cdr count))))))
(define-minor-mode jabber-mode-line-mode
"Toggle display of Jabber status in mode lines.
Display consists of your own status, and six numbers
meaning the number of chatty, online, away, xa, dnd
and offline contacts, respectively."
:global t :group 'jabber-mode-line
(setq jabber-mode-line-string "")
(or global-mode-string (setq global-mode-string '("")))
(if jabber-mode-line-mode
(progn
(add-to-list 'global-mode-string 'jabber-mode-line-string t)
(setq jabber-mode-line-string (list " "
'jabber-mode-line-presence
" "
'jabber-mode-line-contacts))
(put 'jabber-mode-line-string 'risky-local-variable t)
(put 'jabber-mode-line-presence 'risky-local-variable t)
(jabber-mode-line-presence-update)
(jabber-mode-line-count-contacts)
(ad-activate 'jabber-send-presence)
(add-hook 'jabber-post-disconnect-hook
'jabber-mode-line-presence-update)
(add-hook 'jabber-presence-hooks
'jabber-mode-line-count-contacts))))
(provide 'jabber-modeline)
;;; arch-tag: c03a7d3b-8811-49d4-b0e0-7ffd661d7925

85
elpa/jabber-20180927.2325/jabber-muc-nick-coloring.el Normal file
View File

@ -0,0 +1,85 @@
;;; jabber-muc-nick-coloring.el --- Add nick coloring abilyty to emacs-jabber
;; Copyright 2009, 2010, 2012, 2013 Terechkov Evgenii - evg@altlinux.org
;; This program 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 2, or (at your option)
;; any later version.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl)) ;for ignore-errors
;; we need hexrgb-hsv-to-hex:
(eval-and-compile
(or (ignore-errors (require 'hexrgb))
;; jabber-fallback-lib/ from jabber/lisp/jabber-fallback-lib
(ignore-errors
(let ((load-path (cons (expand-file-name
"jabber-fallback-lib"
(file-name-directory (locate-library "jabber")))
load-path)))
(require 'hexrgb)))
(error
"hexrgb not found in `load-path' or jabber-fallback-lib/ directory.")))
;;;;##########################################################################
;;;; User Options, Variables
;;;;##########################################################################
(defcustom jabber-muc-participant-colors nil
"Alist of used colors. Format is (nick . color). Color may be
in #RGB or textual (like red or blue) notation. Colors will be
added in #RGB notation for unknown nicks."
:type '(alist :key-type string :value-type color)
:group 'jabber-chat)
(defcustom jabber-muc-colorize-local nil
"Colorize MUC messages from you."
:type 'boolean
:group 'jabber-chat)
(defcustom jabber-muc-colorize-foreign nil
"Colorize MUC messages not from you."
:type 'boolean
:group 'jabber-chat)
(defcustom jabber-muc-nick-saturation 1.0
"Default saturation for nick coloring."
:type 'float
:group 'jabber-chat)
(defcustom jabber-muc-nick-value 1.0
"Default value for nick coloring."
:type 'float
:group 'jabber-chat)
(defun jabber-muc-nick-gen-color (nick)
"Return good enough color from available pool"
(let ((hue (/ (mod (string-to-number (substring (md5 nick) 0 6) 16) 360) 360.0)))
(hexrgb-hsv-to-hex hue jabber-muc-nick-saturation jabber-muc-nick-value)))
(defun jabber-muc-nick-get-color (nick)
"Get NICKs color"
(let ((color (cdr (assoc nick jabber-muc-participant-colors))))
(if color
color
(progn
(unless jabber-muc-participant-colors )
(push (cons nick (jabber-muc-nick-gen-color nick)) jabber-muc-participant-colors)
(cdr (assoc nick jabber-muc-participant-colors))))))
(provide 'jabber-muc-nick-coloring)
;;; jabber-muc-nick-coloring.el ends here

BIN
elpa/jabber-20180927.2325/jabber-muc-nick-coloring.elc Normal file
View File

Binary file not shown.

188
elpa/jabber-20180927.2325/jabber-muc-nick-completion.el Normal file
View File

@ -0,0 +1,188 @@
;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber
;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org
;; Copyright (C) 2007, 2008, 2010 - Kirill A. Korinskiy - catap@catap.ru
;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; User customizations here:
(defcustom jabber-muc-completion-delimiter ": "
"String to add to end of completion line."
:type 'string
:group 'jabber-chat)
(defcustom jabber-muc-looks-personaling-symbols '("," ":" ">")
"Symbols for personaling messages"
:type '(repeat string)
:group 'jabber-chat)
(defcustom jabber-muc-personal-message-bonus (* 60 20)
"Bonus for personal message, in seconds."
:type 'integer
:group 'jabber-chat)
(defcustom jabber-muc-all-string "all"
"String meaning all conference members (to insert in completion). Note that \":\" or alike not needed (it appended in other string)"
:type 'string
:group 'jabber-chat)
;;; History:
;;
;;; Code:
(require 'cl)
(require 'jabber-muc)
(require 'hippie-exp)
(defvar *jabber-muc-participant-last-speaking* nil
"Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")
(defun jabber-my-nick (&optional group)
"Return my jabber nick in GROUP."
(let ((room (or group jabber-group)))
(cdr (or (assoc room *jabber-active-groupchats*)
(assoc room jabber-muc-default-nicknames)))
))
;;;###autoload
(defun jabber-muc-looks-like-personal-p (message &optional group)
"Return non-nil if jabber MESSAGE is addresed to me.
Optional argument GROUP to look."
(if message (string-match (concat
"^"
(jabber-my-nick group)
(regexp-opt jabber-muc-looks-personaling-symbols))
message)
nil))
(defun jabber-muc-nicknames ()
"List of conference participants, excluding self, or nil if we not in conference."
(delete-if '(lambda (nick)
(string= nick (jabber-my-nick)))
(append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string))))
(defun jabber-muc-participant-update-activity (group nick time)
"Updates NICK's time of last speaking in GROUP to TIME."
(let* ((room (assoc group *jabber-muc-participant-last-speaking*))
(room-activity (cdr room))
(entry (assoc nick room-activity))
(old-time (or (cdr entry) 0)))
(when (> time old-time)
;; don't use put-alist for speed
(progn
(if entry (setcdr entry time)
(setq room-activity
(cons (cons nick time) room-activity)))
(if room (setcdr room room-activity)
(setq *jabber-muc-participant-last-speaking*
(cons (cons group room-activity)
*jabber-muc-participant-last-speaking*)))))))
(defun jabber-muc-track-message-time (nick group buffer text &optional title)
"Tracks time of NICK's last speaking in GROUP."
(when nick
(let ((time (float-time)))
(jabber-muc-participant-update-activity
group
nick
(if (jabber-muc-looks-like-personal-p text group)
(+ time jabber-muc-personal-message-bonus)
time)))))
(defun jabber-sort-nicks (nicks group)
"Return list of NICKS in GROUP, sorted."
(let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))))
(flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0)))
(cmp (nt1 nt2)
(let ((t1 (cdr nt1))
(t2 (cdr nt2)))
(if (and (zerop t1) (zerop t2))
(string<
(car nt1)
(car nt2))
(> t1 t2)))))
(mapcar 'car (sort (mapcar 'fetch-time nicks)
'cmp)))))
(defun jabber-muc-beginning-of-line ()
"Return position of line begining."
(save-excursion
(if (looking-back jabber-muc-completion-delimiter)
(backward-char (+ (length jabber-muc-completion-delimiter) 1)))
(skip-syntax-backward "^-")
(point)))
;;; One big hack:
(defun jabber-muc-completion-delete-last-tried ()
"Delete last tried competion variand from line."
(let ((last-tried (car he-tried-table)))
(when last-tried
(goto-char he-string-beg)
(delete-char (length last-tried))
(ignore-errors (delete-char (length jabber-muc-completion-delimiter)))
)))
(defun try-expand-jabber-muc (old)
"Try to expand target nick in MUC according to last speaking time.
OLD is last tried nickname."
(unless jabber-chatting-with
(unless old
(let ((nicknames (jabber-muc-nicknames)))
(he-init-string (jabber-muc-beginning-of-line) (point))
(setq he-expand-list (jabber-sort-nicks (all-completions he-search-string (mapcar 'list nicknames)) jabber-group))))
(setq he-expand-list
(delete-if '(lambda (x)
(he-string-member x he-tried-table))
he-expand-list))
(if (null he-expand-list)
(progn
(when old
;; here and later : its hack to workaround
;; he-substitute-string work which cant substitute empty
;; lines
(if (string= he-search-string "")
(jabber-muc-completion-delete-last-tried)
(he-reset-string)))
())
(let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line))
(concat (car he-expand-list) jabber-muc-completion-delimiter)
(car he-expand-list))))
(if (not (string= he-search-string ""))
(he-substitute-string subst)
(jabber-muc-completion-delete-last-tried)
(progn
(insert subst)
(if (looking-back (concat "^" (regexp-quote (car he-expand-list))))
(unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter))
(insert jabber-muc-completion-delimiter)))
)
))
(setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table)))
(setq he-expand-list (cdr he-expand-list))
t)))
(add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time)
(fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc)))
(define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion)
(provide 'jabber-muc-nick-completion)
;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0
;;; jabber-muc-completion.el ends here

1171
elpa/jabber-20180927.2325/jabber-muc.el Normal file
View File

File diff suppressed because it is too large Load Diff

91
elpa/jabber-20180927.2325/jabber-notifications.el Normal file
View File

@ -0,0 +1,91 @@
;; jabber-notifications.el - emacs-jabber interface to notifications.el
;; Copyright (C) 2014 - Adam Sjøgren - asjo@koldfront.dk
;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru
;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Built on jabber-libnotify.el.
(eval-when-compile (require 'jabber-alert))
(unless (string< emacs-version "24.1") ;notifications.el preset since Emacs 24.1
(require 'notifications)
(defcustom jabber-notifications-icon ""
"Icon to be used on the notification pop-up. Default is empty"
:type '(file :must-match t)
:group 'jabber-alerts)
(defcustom jabber-notifications-timeout nil
"Specifies the timeout of the pop up window in millisecond"
:type 'integer
:group 'jabber-alerts)
(defcustom jabber-notifications-message-header "Jabber message"
"Defines the header of the pop up."
:type 'string
:group 'jabber-alerts)
(defcustom jabber-notifications-app "Emacs Jabber"
"Defines the app of the pop up."
:type 'string
:group 'jabber-alerts)
(defcustom jabber-notifications-urgency "low"
"Urgency of message"
:type '(choice (const :tag "Low" "low")
(const :tag "Normal" "normal")
(const :tag "Critical" "critical"))
:group 'jabber-alerts)
(defun jabber-message-notifications (from buffer text title)
"Show a message through the notifications.el interface"
(let
((body (or (jabber-escape-xml text) " "))
(head (jabber-escape-xml
(or title
(or jabber-notifications-message-header " ")
text)))
(avatar-hash (get (jabber-jid-symbol from) 'avatar-hash)))
(notifications-notify
:title title
:body body
:app-icon (or (and avatar-hash (jabber-avatar-find-cached avatar-hash))
jabber-notifications-icon)
:app-name jabber-notifications-app
:category "jabber.message"
:timeout jabber-notifications-timeout)))
(defun jabber-muc-notifications (nick group buffer text title)
"Show MUC message through the notifications.el interface"
(jabber-message-notifications group buffer (if nick (format "%s: %s" nick text) text) title)
)
(defun jabber-muc-notifications-personal (nick group buffer text title)
"Show personal MUC message through the notifications.el interface"
(if (jabber-muc-looks-like-personal-p text group)
(jabber-muc-notifications nick group buffer text title))
)
;; jabber-*-notifications* requires "from" argument, so we cant use
;; define-jabber-alert/define-personal-jabber-alert here and do the
;; work by hand:
(pushnew 'jabber-message-notifications (get 'jabber-alert-message-hooks 'custom-options))
(pushnew 'jabber-muc-notifications (get 'jabber-alert-muc-hooks 'custom-options))
(pushnew 'jabber-muc-notifications-personal (get 'jabber-alert-muc-hooks 'custom-options))
)
(provide 'jabber-notifications)

BIN
elpa/jabber-20180927.2325/jabber-notifications.elc Normal file
View File

Binary file not shown.

35
elpa/jabber-20180927.2325/jabber-osd.el Normal file
View File

@ -0,0 +1,35 @@
;;; jabber-osd.el --- OSD support for jabber.el
;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org
;; This file is a part of jabber.el.
;; This program 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 2, or (at your option)
;; any later version.
;; This program 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
(eval-when-compile (require 'jabber-alert))
(condition-case e
(progn
;; Most people don't have osd.el, so this will often fail
(require 'osd)
(define-jabber-alert osd "Display a message in osd"
(lambda (text &optional title) (osd-show-string (or title text))))
(define-personal-jabber-alert jabber-muc-osd))
(error nil))
(provide 'jabber-osd)
;; arch-tag: 3eb8d55a-dd86-11dc-b2c6-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-osd.elc Normal file
View File

Binary file not shown.

8
elpa/jabber-20180927.2325/jabber-ourversion.el Normal file
View File

@ -0,0 +1,8 @@
;; jabber-ourversion.el. Holds the version number in a format that
;; configure.ac can read.
;; On the following line, only change the part between double quotes:
(defconst jabber-version "0.8.92"
"version returned to those who query us")
(provide 'jabber-ourversion)

BIN
elpa/jabber-20180927.2325/jabber-ourversion.elc Normal file
View File

Binary file not shown.

61
elpa/jabber-20180927.2325/jabber-ping.el Normal file
View File

@ -0,0 +1,61 @@
;; jabber-ping.el - XMPP "Ping" by XEP-0199
;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-util)
(require 'jabber-menu)
(require 'jabber-disco)
(add-to-list 'jabber-jid-info-menu
(cons "Ping" 'jabber-ping))
(defun jabber-ping-send (jc to process-func on-success on-error)
"Send XEP-0199 ping IQ stanza. JC is connection to use, TO is
full JID, PROCESS-FUNC is fucntion to call to process result,
ON-SUCCESS and ON-ERROR is arg for this function depending on
result."
(jabber-send-iq jc to "get"
'(ping ((xmlns . "urn:xmpp:ping")))
process-func on-success
process-func on-error))
(defun jabber-ping (to)
"Ping XMPP entity. TO is full JID. All connected JIDs is used."
(interactive (list (jabber-read-jid-completing "Send ping to: " nil nil nil 'full)))
(dolist (jc jabber-connections)
(jabber-ping-send jc to 'jabber-silent-process-data 'jabber-process-ping "Ping is unsupported")))
;; called by jabber-process-data
(defun jabber-process-ping (jc xml-data)
"Handle results from ping requests."
(let ((to (jabber-xml-get-attribute xml-data 'from)))
(format "%s is alive" to)))
(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:ping" 'jabber-pong))
(jabber-disco-advertise-feature "urn:xmpp:ping")
(defun jabber-pong (jc xml-data)
"Return pong as defined in XEP-0199. Sender and Id are
determined from the incoming packet passed in XML-DATA."
(let ((to (jabber-xml-get-attribute xml-data 'from))
(id (jabber-xml-get-attribute xml-data 'id)))
(jabber-send-iq jc to "result" nil nil nil nil nil id)))
(provide 'jabber-ping)

7
elpa/jabber-20180927.2325/jabber-pkg.el Normal file
View File

@ -0,0 +1,7 @@
(define-package "jabber" "20180927.2325" "A Jabber client for Emacs."
'((fsm "0.2")
(srv "0.2"))
:commit "fff33826f42e040dad7ef64ea312d85215d3b0a1")
;; Local Variables:
;; no-byte-compile: t
;; End:

565
elpa/jabber-20180927.2325/jabber-presence.el Normal file
View File

@ -0,0 +1,565 @@
;; jabber-presence.el - roster and presence bookkeeping
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-core)
(require 'jabber-iq)
(require 'jabber-alert)
(require 'jabber-util)
(require 'jabber-menu)
(require 'jabber-muc)
(defvar jabber-presence-element-functions nil
"List of functions returning extra elements for <presence/> stanzas.
Each function takes one argument, the connection, and returns a
possibly empty list of extra child element of the <presence/>
stanza.")
(defvar jabber-presence-history ()
"Keeps track of previously used presence status types")
(add-to-list 'jabber-iq-set-xmlns-alist
(cons "jabber:iq:roster" (function (lambda (jc x) (jabber-process-roster jc x nil)))))
(defun jabber-process-roster (jc xml-data closure-data)
"process an incoming roster infoquery result
CLOSURE-DATA should be 'initial if initial roster push, nil otherwise."
(let ((roster (plist-get (fsm-get-state-data jc) :roster))
(from (jabber-xml-get-attribute xml-data 'from))
(type (jabber-xml-get-attribute xml-data 'type))
(id (jabber-xml-get-attribute xml-data 'id))
(username (plist-get (fsm-get-state-data jc) :username))
(server (plist-get (fsm-get-state-data jc) :server))
(resource (plist-get (fsm-get-state-data jc) :resource))
new-items changed-items deleted-items)
;; Perform sanity check on "from" attribute: it should be either absent
;; match our own JID, or match the server's JID (the latter is what
;; Facebook does).
(if (not (or (null from)
(string= from server)
(string= from (concat username "@" server))
(string= from (concat username "@" server "/" resource))))
(message "Roster push with invalid \"from\": \"%s\" (expected \"%s\", \"%s@%s\" or \"%s@%s/%s\")"
from
server username server username server resource)
(dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item))
(let (roster-item
(jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid))))
;; If subscripton="remove", contact is to be removed from roster
(if (string= (jabber-xml-get-attribute item 'subscription) "remove")
(progn
(if (jabber-jid-rostername jid)
(message "%s (%s) removed from roster" (jabber-jid-rostername jid) jid)
(message "%s removed from roster" jid))
(push jid deleted-items))
;; Find contact if already in roster
(setq roster-item (car (memq jid roster)))
(if roster-item
(push roster-item changed-items)
;; If not found, create a new roster item.
(unless (eq closure-data 'initial)
(if (jabber-xml-get-attribute item 'name)
(message "%s (%s) added to roster" (jabber-xml-get-attribute item 'name) jid)
(message "%s added to roster" jid)))
(setq roster-item jid)
(push roster-item new-items))
;; If this is an initial push, we want to forget
;; everything we knew about this contact before - e.g. if
;; the contact was online when we disconnected and offline
;; when we reconnect, we don't want to see stale presence
;; information. This assumes that no contacts are shared
;; between accounts.
(when (eq closure-data 'initial)
(setplist roster-item nil))
;; Now, get all data associated with the contact.
(put roster-item 'name (jabber-xml-get-attribute item 'name))
(put roster-item 'subscription (jabber-xml-get-attribute item 'subscription))
(put roster-item 'ask (jabber-xml-get-attribute item 'ask))
;; Since roster items can't be changed incrementally, we
;; save the original XML to be able to modify it, instead of
;; having to reproduce it. This is for forwards
;; compatibility.
(put roster-item 'xml item)
(put roster-item 'groups
(mapcar (lambda (foo) (nth 2 foo))
(jabber-xml-get-children item 'group)))))))
;; This is the function that does the actual updating and
;; redrawing of the roster.
(jabber-roster-update jc new-items changed-items deleted-items)
(if (and id (string= type "set"))
(jabber-send-iq jc nil "result" nil
nil nil nil nil id)))
;; After initial roster push, run jabber-post-connect-hooks. We do
;; it here and not before since we want to have the entire roster
;; before we receive any presence stanzas.
(when (eq closure-data 'initial)
(run-hook-with-args 'jabber-post-connect-hooks jc)))
(defun jabber-initial-roster-failure (jc xml-data _closure-data)
;; If the initial roster request fails, let's report it, but run
;; jabber-post-connect-hooks anyway. According to the spec, there
;; is nothing exceptional about the server not returning a roster.
(jabber-report-success jc xml-data "Initial roster retrieval")
(run-hook-with-args 'jabber-post-connect-hooks jc))
(add-to-list 'jabber-presence-chain 'jabber-process-presence)
(defun jabber-process-presence (jc xml-data)
"process incoming presence tags"
;; XXX: use JC argument
(let ((roster (plist-get (fsm-get-state-data jc) :roster))
(from (jabber-xml-get-attribute xml-data 'from))
(to (jabber-xml-get-attribute xml-data 'to))
(type (jabber-xml-get-attribute xml-data 'type))
(presence-show (car (jabber-xml-node-children
(car (jabber-xml-get-children xml-data 'show)))))
(presence-status (car (jabber-xml-node-children
(car (jabber-xml-get-children xml-data 'status)))))
(error (car (jabber-xml-get-children xml-data 'error)))
(priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'priority))))
"0"))))
(cond
((string= type "subscribe")
(run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from presence-status))
((jabber-muc-presence-p xml-data)
(jabber-muc-process-presence jc xml-data))
(t
;; XXX: Think about what to do about out-of-roster presences.
(let ((buddy (jabber-jid-symbol from)))
(if (memq buddy roster)
(let* ((oldstatus (get buddy 'show))
(resource (or (jabber-jid-resource from) ""))
(resource-plist (cdr (assoc resource
(get buddy 'resources))))
newstatus)
(cond
((and (string= resource "") (member type '("unavailable" "error")))
;; 'unavailable' or 'error' from bare JID means that all resources
;; are offline.
(setq resource-plist nil)
(setq newstatus (if (string= type "error") "error" nil))
(let ((new-message (if error
(jabber-parse-error error)
presence-status)))
;; erase any previous information
(put buddy 'resources nil)
(put buddy 'connected nil)
(put buddy 'show newstatus)
(put buddy 'status new-message)))
((string= type "unavailable")
(setq resource-plist
(plist-put resource-plist 'connected nil))
(setq resource-plist
(plist-put resource-plist 'show nil))
(setq resource-plist
(plist-put resource-plist 'status
presence-status)))
((string= type "error")
(setq newstatus "error")
(setq resource-plist
(plist-put resource-plist 'connected nil))
(setq resource-plist
(plist-put resource-plist 'show "error"))
(setq resource-plist
(plist-put resource-plist 'status
(if error
(jabber-parse-error error)
presence-status))))
((or
(string= type "unsubscribe")
(string= type "subscribed")
(string= type "unsubscribed"))
;; Do nothing, except letting the user know. The Jabber protocol
;; places all this complexity on the server.
(setq newstatus type))
(t
(setq resource-plist
(plist-put resource-plist 'connected t))
(setq resource-plist
(plist-put resource-plist 'show (or presence-show "")))
(setq resource-plist
(plist-put resource-plist 'status
presence-status))
(setq resource-plist
(plist-put resource-plist 'priority priority))
(setq newstatus (or presence-show ""))))
(when resource-plist
;; this is for `assoc-set!' in guile
(if (assoc resource (get buddy 'resources))
(setcdr (assoc resource (get buddy 'resources)) resource-plist)
(put buddy 'resources (cons (cons resource resource-plist) (get buddy 'resources))))
(jabber-prioritize-resources buddy))
(fsm-send jc (cons :roster-update buddy))
(dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks))
(run-hook-with-args hook
buddy
oldstatus
newstatus
(plist-get resource-plist 'status)
(funcall jabber-alert-presence-message-function
buddy
oldstatus
newstatus
(plist-get resource-plist 'status)))))))))))
(defun jabber-process-subscription-request (jc from presence-status)
"process an incoming subscription request"
(with-current-buffer (jabber-chat-create-buffer jc from)
(ewoc-enter-last jabber-chat-ewoc (list :subscription-request presence-status :time (current-time)))
(dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks))
(run-hook-with-args hook (jabber-jid-symbol from) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from) nil "subscribe" presence-status)))))
(defun jabber-subscription-accept-mutual (&rest ignored)
(message "Subscription accepted; reciprocal subscription request sent")
(jabber-subscription-reply "subscribed" "subscribe"))
(defun jabber-subscription-accept-one-way (&rest ignored)
(message "Subscription accepted")
(jabber-subscription-reply "subscribed"))
(defun jabber-subscription-decline (&rest ignored)
(message "Subscription declined")
(jabber-subscription-reply "unsubscribed"))
(defun jabber-subscription-reply (&rest types)
(let ((to (jabber-jid-user jabber-chatting-with)))
(dolist (type types)
(jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type)))))))
(defun jabber-prioritize-resources (buddy)
"Set connected, show and status properties for BUDDY from highest-priority resource."
(let ((resource-alist (get buddy 'resources))
(highest-priority nil))
;; Reset to nil at first, for cases (a) resource-alist is nil
;; and (b) all resources are disconnected.
(put buddy 'connected nil)
(put buddy 'show nil)
(put buddy 'status nil)
(mapc #'(lambda (resource)
(let* ((resource-plist (cdr resource))
(priority (plist-get resource-plist 'priority)))
(if (plist-get resource-plist 'connected)
(when (or (null highest-priority)
(and priority
(> priority highest-priority)))
;; if no priority specified, interpret as zero
(setq highest-priority (or priority 0))
(put buddy 'connected (plist-get resource-plist 'connected))
(put buddy 'show (plist-get resource-plist 'show))
(put buddy 'status (plist-get resource-plist 'status))
(put buddy 'resource (car resource)))
;; if we have not found a connected resource yet, but this
;; disconnected resource has a status message, display it.
(when (not (get buddy 'connected))
(if (plist-get resource-plist 'status)
(put buddy 'status (plist-get resource-plist 'status)))
(if (plist-get resource-plist 'show)
(put buddy 'show (plist-get resource-plist 'show)))))))
resource-alist)))
(defun jabber-count-connected-resources (buddy)
"Return the number of connected resources for BUDDY."
(let ((resource-alist (get buddy 'resources))
(count 0))
(dolist (resource resource-alist)
(if (plist-get (cdr resource) 'connected)
(setq count (1+ count))))
count))
;;;###autoload
(defun jabber-send-presence (show status priority)
"Set presence for all accounts."
(interactive
(list
(completing-read "show: " '("" "away" "xa" "dnd" "chat")
nil t nil 'jabber-presence-history)
(jabber-read-with-input-method "status message: " *jabber-current-status*
'*jabber-status-history*)
(read-string "priority: " (int-to-string (if *jabber-current-priority*
*jabber-current-priority*
jabber-default-priority)))))
(setq *jabber-current-show* show *jabber-current-status* status)
(setq *jabber-current-priority*
(if (numberp priority) priority (string-to-number priority)))
(let (subelements-map)
;; For each connection, we use a different set of subelements. We
;; cache them, to only generate them once.
;; Ordinary presence, with no specified recipient
(dolist (jc jabber-connections)
(let ((subelements (jabber-presence-children jc)))
(push (cons jc subelements) subelements-map)
(jabber-send-sexp-if-connected jc `(presence () ,@subelements))))
;; Then send presence to groupchats
(dolist (gc *jabber-active-groupchats*)
(let* ((buffer (get-buffer (jabber-muc-get-buffer (car gc))))
(jc (when buffer
(buffer-local-value 'jabber-buffer-connection buffer)))
(subelements (cdr (assq jc subelements-map))))
(when jc
(jabber-send-sexp-if-connected
jc `(presence ((to . ,(concat (car gc) "/" (cdr gc))))
,@subelements))))))
(jabber-display-roster))
(defun jabber-presence-children (jc)
"Return the children for a <presence/> stanza."
`(,(when (> (length *jabber-current-status*) 0)
`(status () ,*jabber-current-status*))
,(when (> (length *jabber-current-show*) 0)
`(show () ,*jabber-current-show*))
,(when *jabber-current-priority*
`(priority () ,(number-to-string *jabber-current-priority*)))
,@(apply 'append (mapcar (lambda (f)
(funcall f jc))
jabber-presence-element-functions))))
(defun jabber-send-directed-presence (jc jid type)
"Send a directed presence stanza to JID.
TYPE is one of:
\"online\", \"away\", \"xa\", \"dnd\", \"chatty\":
Appear as present with the given status.
\"unavailable\":
Appear as offline.
\"probe\":
Ask the contact's server for updated presence.
\"subscribe\":
Ask for subscription to contact's presence.
(see also `jabber-send-subscription-request')
\"unsubscribe\":
Cancel your subscription to contact's presence.
\"subscribed\":
Accept contact's request for presence subscription.
(this is usually done within a chat buffer)
\"unsubscribed\":
Cancel contact's subscription to your presence."
(interactive
(list (jabber-read-account)
(jabber-read-jid-completing "Send directed presence to: ")
(completing-read "Type (default is online): "
'(("online")
("away")
("xa")
("dnd")
("chatty")
("probe")
("unavailable")
("subscribe")
("unsubscribe")
("subscribed")
("unsubscribed"))
nil t nil 'jabber-presence-history "online")))
(cond
((member type '("probe" "unavailable"
"subscribe" "unsubscribe"
"subscribed" "unsubscribed"))
(jabber-send-sexp jc `(presence ((to . ,jid)
(type . ,type)))))
(t
(let ((*jabber-current-show*
(if (string= type "online")
""
type))
(*jabber-current-status* nil))
(jabber-send-sexp jc `(presence ((to . ,jid))
,@(jabber-presence-children jc)))))))
(defun jabber-send-away-presence (&optional status)
"Set status to away.
With prefix argument, ask for status message."
(interactive
(list
(when current-prefix-arg
(jabber-read-with-input-method
"status message: " *jabber-current-status* '*jabber-status-history*))))
(jabber-send-presence "away" (if status status *jabber-current-status*)
*jabber-current-priority*))
;; XXX code duplication!
(defun jabber-send-xa-presence (&optional status)
"Send extended away presence.
With prefix argument, ask for status message."
(interactive
(list
(when current-prefix-arg
(jabber-read-with-input-method
"status message: " *jabber-current-status* '*jabber-status-history*))))
(jabber-send-presence "xa" (if status status *jabber-current-status*)
*jabber-current-priority*))
;;;###autoload
(defun jabber-send-default-presence (&optional ignore)
"Send default presence.
Default presence is specified by `jabber-default-show',
`jabber-default-status', and `jabber-default-priority'."
(interactive)
(jabber-send-presence
jabber-default-show jabber-default-status jabber-default-priority))
(defun jabber-send-current-presence (&optional ignore)
"(Re-)send current presence.
That is, if presence has already been sent, use current settings,
otherwise send defaults (see `jabber-send-default-presence')."
(interactive)
(if *jabber-current-show*
(jabber-send-presence *jabber-current-show* *jabber-current-status*
*jabber-current-priority*)
(jabber-send-default-presence)))
(add-to-list 'jabber-jid-roster-menu (cons "Send subscription request"
'jabber-send-subscription-request))
(defun jabber-send-subscription-request (jc to &optional request)
"send a subscription request to jid, showing him your request
text, if specified"
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "to: ")
(jabber-read-with-input-method "request: ")))
(jabber-send-sexp jc
`(presence
((to . ,to)
(type . "subscribe"))
,@(when (and request (> (length request) 0))
(list `(status () ,request))))))
(defvar jabber-roster-group-history nil
"History of entered roster groups")
(add-to-list 'jabber-jid-roster-menu
(cons "Add/modify roster entry" 'jabber-roster-change))
(defun jabber-roster-change (jc jid name groups)
"Add or change a roster item."
(interactive (let* ((jid (jabber-jid-symbol
(jabber-read-jid-completing "Add/change JID: ")))
(account (jabber-read-account))
(name (get jid 'name))
(groups (get jid 'groups))
(all-groups
(apply #'append
(mapcar
(lambda (j) (get j 'groups))
(plist-get (fsm-get-state-data account) :roster)))))
(when (string< emacs-version "22")
;; Older emacsen want the completion table to be an alist...
(setq all-groups (mapcar #'list all-groups)))
(list account
jid (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name)
(delete ""
(completing-read-multiple
(format
"Groups, comma-separated: (default %s) "
(if groups
(mapconcat #'identity groups ",")
"none"))
all-groups
nil nil nil
'jabber-roster-group-history
(mapconcat #'identity groups ",")
t)))))
;; If new fields are added to the roster XML structure in a future standard,
;; they will be clobbered by this function.
;; XXX: specify account
(jabber-send-iq jc nil "set"
(list 'query (list (cons 'xmlns "jabber:iq:roster"))
(append
(list 'item (append
(list (cons 'jid (symbol-name jid)))
(if (and name (> (length name) 0))
(list (cons 'name name)))))
(mapcar #'(lambda (x) `(group () ,x))
groups)))
#'jabber-report-success "Roster item change"
#'jabber-report-success "Roster item change"))
(add-to-list 'jabber-jid-roster-menu
(cons "Delete roster entry" 'jabber-roster-delete))
(defun jabber-roster-delete (jc jid)
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Delete from roster: ")))
(jabber-send-iq jc nil "set"
`(query ((xmlns . "jabber:iq:roster"))
(item ((jid . ,jid)
(subscription . "remove"))))
#'jabber-report-success "Roster item removal"
#'jabber-report-success "Roster item removal"))
(defun jabber-roster-delete-jid-at-point ()
"Delete JID at point from roster.
Signal an error if there is no JID at point."
(interactive)
(let ((jid-at-point (get-text-property (point)
'jabber-jid))
(account (get-text-property (point) 'jabber-account)))
(if (and jid-at-point account
(or jabber-silent-mode (yes-or-no-p (format "Really delete %s from roster? " jid-at-point))))
(jabber-roster-delete account jid-at-point)
(error "No contact at point"))))
(defun jabber-roster-delete-group-from-jids (jc jids group)
"Delete group `group' from all JIDs"
(interactive)
(dolist (jid jids)
(jabber-roster-change
jc jid (get jid 'name)
(remove-if-not (lambda (g) (not (string= g group)))
(get jid 'groups)))))
(defun jabber-roster-edit-group-from-jids (jc jids group)
"Edit group `group' from all JIDs"
(interactive)
(let ((new-group
(jabber-read-with-input-method
(format "New group: (default `%s') " group) nil nil group)))
(dolist (jid jids)
(jabber-roster-change
jc jid (get jid 'name)
(remove-duplicates
(mapcar
(lambda (g) (if (string= g group)
new-group
g))
(get jid 'groups))
:test 'string=)))))
(provide 'jabber-presence)
;;; arch-tag: b8616d4c-dde8-423e-86c7-da7b4928afc3

61
elpa/jabber-20180927.2325/jabber-private.el Normal file
View File

@ -0,0 +1,61 @@
;;; jabber-private.el --- jabber:iq:private API by JEP-0049
;; Copyright (C) 2005 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;;###autoload
(defun jabber-private-get (jc node-name namespace success-callback error-callback)
"Retrieve an item from private XML storage.
The item to retrieve is identified by NODE-NAME (a symbol) and
NAMESPACE (a string).
On success, SUCCESS-CALLBACK is called with JC and the retrieved
XML fragment.
On error, ERROR-CALLBACK is called with JC and the entire IQ
result."
(jabber-send-iq jc nil "get"
`(query ((xmlns . "jabber:iq:private"))
(,node-name ((xmlns . ,namespace))))
#'jabber-private-get-1 success-callback
#'(lambda (jc xml-data error-callback)
(funcall error-callback jc xml-data))
error-callback))
(defun jabber-private-get-1 (jc xml-data success-callback)
(funcall success-callback jc
(car (jabber-xml-node-children
(jabber-iq-query xml-data)))))
;;;###autoload
(defun jabber-private-set (jc fragment &optional
success-callback success-closure-data
error-callback error-closure-data)
"Store FRAGMENT in private XML storage.
SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and
ERROR-CLOSURE-DATA are used as in `jabber-send-iq'."
(jabber-send-iq jc nil "set"
`(query ((xmlns . "jabber:iq:private"))
,fragment)
success-callback success-closure-data
error-callback error-closure-data))
(provide 'jabber-private)
;; arch-tag: 065bd03e-40fa-11da-ab48-000a95c2fcd0

BIN
elpa/jabber-20180927.2325/jabber-private.elc Normal file
View File

Binary file not shown.

35
elpa/jabber-20180927.2325/jabber-ratpoison.el Normal file
View File

@ -0,0 +1,35 @@
;; jabber-ratpoison.el - emacs-jabber interface to ratpoison
;; Copyright (C) 2005, 2008 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(eval-when-compile (require 'jabber-alert))
(defun jabber-ratpoison-message (text &optional title)
"Show MSG in Ratpoison"
;; Possible errors include not finding the ratpoison binary.
(condition-case e
(let ((process-connection-type))
(call-process "ratpoison" nil 0 nil "-c" (concat "echo " (or title text))))
(error nil)))
(define-jabber-alert ratpoison "Show a message through the Ratpoison window manager"
'jabber-ratpoison-message)
(provide 'jabber-ratpoison)
;; arch-tag: 19650075-5D05-11D9-B80F-000A95C2FCD0

BIN
elpa/jabber-20180927.2325/jabber-ratpoison.elc Normal file
View File

Binary file not shown.

144
elpa/jabber-20180927.2325/jabber-register.el Normal file
View File

@ -0,0 +1,144 @@
;; jabber-register.el - registration according to JEP-0077
;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-widget)
(add-to-list 'jabber-jid-service-menu
(cons "Register with service" 'jabber-get-register))
(defun jabber-get-register (jc to)
"Send IQ get request in namespace \"jabber:iq:register\"."
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Register with: ")))
(jabber-send-iq jc to
"get"
'(query ((xmlns . "jabber:iq:register")))
#'jabber-process-data #'jabber-process-register-or-search
#'jabber-report-success "Registration"))
(defun jabber-process-register-or-search (jc xml-data)
"Display results from jabber:iq:{register,search} query as a form."
(let ((query (jabber-iq-query xml-data))
(have-xdata nil)
(type (cond
((string= (jabber-iq-xmlns xml-data) "jabber:iq:register")
'register)
((string= (jabber-iq-xmlns xml-data) "jabber:iq:search")
'search)
(t
(error "Namespace %s not handled by jabber-process-register-or-search" (jabber-iq-xmlns xml-data)))))
(register-account
(plist-get (fsm-get-state-data jc) :registerp))
(username
(plist-get (fsm-get-state-data jc) :username))
(server
(plist-get (fsm-get-state-data jc) :server)))
(cond
((eq type 'register)
;; If there is no `from' attribute, we are registering with the server
(jabber-init-widget-buffer (or (jabber-xml-get-attribute xml-data 'from)
server)))
((eq type 'search)
;; no such thing here
(jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from))))
(setq jabber-buffer-connection jc)
(widget-insert (if (eq type 'register) "Register with " "Search ") jabber-submit-to "\n\n")
(dolist (x (jabber-xml-get-children query 'x))
(when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
(setq have-xdata t)
;; If the registration form obeys JEP-0068, we know
;; for sure how to put a default username in it.
(jabber-render-xdata-form x
(if (and register-account
(string= (jabber-xdata-formtype x) "jabber:iq:register"))
(list (cons "username" username))
nil))))
(if (not have-xdata)
(jabber-render-register-form query
(when register-account
username)))
(widget-create 'push-button :notify (if (eq type 'register)
#'jabber-submit-register
#'jabber-submit-search) "Submit")
(when (eq type 'register)
(widget-insert "\t")
(widget-create 'push-button :notify #'jabber-remove-register "Cancel registration"))
(widget-insert "\n")
(widget-setup)
(widget-minor-mode 1)))
(defun jabber-submit-register (&rest ignore)
"Submit registration input. See `jabber-process-register-or-search'."
(let* ((registerp (plist-get (fsm-get-state-data jabber-buffer-connection) :registerp))
(handler (if registerp
#'jabber-process-register-secondtime
#'jabber-report-success))
(text (concat "Registration with " jabber-submit-to)))
(jabber-send-iq jabber-buffer-connection jabber-submit-to
"set"
(cond
((eq jabber-form-type 'register)
`(query ((xmlns . "jabber:iq:register"))
,@(jabber-parse-register-form)))
((eq jabber-form-type 'xdata)
`(query ((xmlns . "jabber:iq:register"))
,(jabber-parse-xdata-form)))
(t
(error "Unknown form type: %s" jabber-form-type)))
handler (if registerp 'success text)
handler (if registerp 'failure text)))
(message "Registration sent"))
(defun jabber-process-register-secondtime (jc xml-data closure-data)
"Receive registration success or failure.
CLOSURE-DATA is either 'success or 'error."
(cond
((eq closure-data 'success)
(message "Registration successful. You may now connect to the server."))
(t
(jabber-report-success jc xml-data "Account registration")))
(sit-for 3)
(jabber-disconnect-one jc))
(defun jabber-remove-register (&rest ignore)
"Cancel registration. See `jabber-process-register-or-search'."
(if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-submit-to "? ")))
(jabber-send-iq jabber-buffer-connection jabber-submit-to
"set"
'(query ((xmlns . "jabber:iq:register"))
(remove))
#'jabber-report-success "Unregistration"
#'jabber-report-success "Unregistration")))
(provide 'jabber-register)
;;; arch-tag: e6b349d6-b1ad-4d19-a412-74459dfae239

893
elpa/jabber-20180927.2325/jabber-roster.el Normal file
View File

@ -0,0 +1,893 @@
;; jabber-roster.el - displaying the roster -*- coding: utf-8; -*-
;; Copyright (C) 2009 - Kirill A. Korinskiy - catap@catap.ru
;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-presence)
(require 'jabber-util)
(require 'jabber-alert)
(require 'jabber-keymap)
(require 'format-spec)
(require 'cl) ;for `find'
(require 'jabber-private)
(defgroup jabber-roster nil "roster display options"
:group 'jabber)
(defcustom jabber-roster-line-format " %a %c %-25n %u %-8s %S"
"The format specification of the lines in the roster display.
These fields are available:
%a Avatar, if any
%c \"*\" if the contact is connected, or \" \" if not
%u sUbscription state - see below
%n Nickname of contact, or JID if no nickname
%j Bare JID of contact (without resource)
%r Highest-priority resource of contact
%s Availability of contact as string (\"Online\", \"Away\" etc)
%S Status string specified by contact
%u is replaced by one of the strings given by
`jabber-roster-subscription-display'."
:type 'string
:group 'jabber-roster)
(defcustom jabber-roster-subscription-display '(("none" . " ")
("from" . "< ")
("to" . " >")
("both" . "<->"))
"Strings used for indicating subscription status of contacts.
\"none\" means that there is no subscription between you and the
contact.
\"from\" means that the contact has a subscription to you, but you
have no subscription to the contact.
\"to\" means that you have a subscription to the contact, but the
contact has no subscription to you.
\"both\" means a mutual subscription.
Having a \"presence subscription\" means being able to see the
other person's presence.
Some fancy arrows you might want to use, if your system can
display them: ← → ⇄ ↔"
:type '(list (cons :format "%v" (const :format "" "none") (string :tag "None"))
(cons :format "%v" (const :format "" "from") (string :tag "From"))
(cons :format "%v" (const :format "" "to") (string :tag "To"))
(cons :format "%v" (const :format "" "both") (string :tag "Both")))
:group 'jabber-roster)
(defcustom jabber-resource-line-format " %r - %s (%S), priority %p"
"The format specification of resource lines in the roster display.
These are displayed when `jabber-show-resources' permits it.
These fields are available:
%c \"*\" if the contact is connected, or \" \" if not
%n Nickname of contact, or JID if no nickname
%j Bare JID of contact (without resource)
%p Priority of this resource
%r Name of this resource
%s Availability of resource as string (\"Online\", \"Away\" etc)
%S Status string specified by resource"
:type 'string
:group 'jabber-roster)
(defcustom jabber-roster-sort-functions
'(jabber-roster-sort-by-status jabber-roster-sort-by-displayname)
"Sort roster according to these criteria.
These functions should take two roster items A and B, and return:
<0 if A < B
0 if A = B
>0 if A > B"
:type 'hook
:options '(jabber-roster-sort-by-status
jabber-roster-sort-by-displayname
jabber-roster-sort-by-group)
:group 'jabber-roster)
(defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa")
"Sort by status in this order. Anything not in list goes last.
Offline is represented as nil."
:type '(repeat (restricted-sexp :match-alternatives (stringp nil)))
:group 'jabber-roster)
(defcustom jabber-show-resources 'sometimes
"Show contacts' resources in roster?
This can be one of the following symbols:
nil Never show resources
sometimes Show resources when there are more than one
always Always show resources"
:type '(radio (const :tag "Never" nil)
(const :tag "When more than one connected resource" sometimes)
(const :tag "Always" always))
:group 'jabber-roster)
(defcustom jabber-show-offline-contacts t
"Show offline contacts in roster when non-nil"
:type 'boolean
:group 'jabber-roster)
(defcustom jabber-remove-newlines t
"Remove newlines in status messages?
Newlines in status messages mess up the roster display. However,
they are essential to status message poets. Therefore, you get to
choose the behaviour.
Trailing newlines are always removed, regardless of this variable."
:type 'boolean
:group 'jabber-roster)
(defcustom jabber-roster-show-bindings t
"Show keybindings in roster buffer?"
:type 'boolean
:group 'jabber-roster)
(defcustom jabber-roster-show-title t
"Show title in roster buffer?"
:type 'boolean
:group 'jabber-roster)
(defcustom jabber-roster-mode-hook nil
"Hook run when entering Roster mode."
:group 'jabber-roster
:type 'hook)
(defcustom jabber-roster-default-group-name "other"
"Default group name for buddies without groups."
:group 'jabber-roster
:type 'string
:get '(lambda (var)
(let ((val (symbol-value var)))
(when (stringp val)
(set-text-properties 0 (length val) nil val))
val))
:set '(lambda (var val)
(when (stringp val)
(set-text-properties 0 (length val) nil val))
(custom-set-default var val))
)
(defcustom jabber-roster-show-empty-group nil
"Show empty groups in roster?"
:group 'jabber-roster
:type 'boolean)
(defcustom jabber-roster-roll-up-group nil
"Show empty groups in roster?"
:group 'jabber-roster
:type 'boolean)
(defface jabber-roster-user-online
'((t (:foreground "blue" :weight bold :slant normal)))
"face for displaying online users"
:group 'jabber-roster)
(defface jabber-roster-user-xa
'((((background dark)) (:foreground "magenta" :weight normal :slant italic))
(t (:foreground "black" :weight normal :slant italic)))
"face for displaying extended away users"
:group 'jabber-roster)
(defface jabber-roster-user-dnd
'((t (:foreground "red" :weight normal :slant italic)))
"face for displaying do not disturb users"
:group 'jabber-roster)
(defface jabber-roster-user-away
'((t (:foreground "dark green" :weight normal :slant italic)))
"face for displaying away users"
:group 'jabber-roster)
(defface jabber-roster-user-chatty
'((t (:foreground "dark orange" :weight bold :slant normal)))
"face for displaying chatty users"
:group 'jabber-roster)
(defface jabber-roster-user-error
'((t (:foreground "red" :weight light :slant italic)))
"face for displaying users sending presence errors"
:group 'jabber-roster)
(defface jabber-roster-user-offline
'((t (:foreground "dark grey" :weight light :slant italic)))
"face for displaying offline users"
:group 'jabber-roster)
(defvar jabber-roster-debug nil
"debug roster draw")
(defvar jabber-roster-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(set-keymap-parent map jabber-common-keymap)
(define-key map [mouse-2] 'jabber-roster-mouse-2-action-at-point)
(define-key map (kbd "TAB") 'jabber-go-to-next-roster-item)
(define-key map (kbd "S-TAB") 'jabber-go-to-previous-roster-item)
(define-key map (kbd "M-TAB") 'jabber-go-to-previous-roster-item)
(define-key map (kbd "<backtab>") 'jabber-go-to-previous-roster-item)
(define-key map (kbd "RET") 'jabber-roster-ret-action-at-point)
(define-key map (kbd "C-k") 'jabber-roster-delete-at-point)
(define-key map "e" 'jabber-roster-edit-action-at-point)
(define-key map "s" 'jabber-send-subscription-request)
(define-key map "q" 'bury-buffer)
(define-key map "i" 'jabber-get-disco-items)
(define-key map "j" 'jabber-muc-join)
(define-key map "I" 'jabber-get-disco-info)
(define-key map "b" 'jabber-get-browse)
(define-key map "v" 'jabber-get-version)
(define-key map "a" 'jabber-send-presence)
(define-key map "g" 'jabber-display-roster)
(define-key map "S" 'jabber-ft-send)
(define-key map "o" 'jabber-roster-toggle-offline-display)
(define-key map "H" 'jabber-roster-toggle-binding-display)
;;(define-key map "D" 'jabber-disconnect)
map))
(defun jabber-roster-ret-action-at-point ()
"Action for ret. Before try to roll up/down group. Eval
chat-with-jid-at-point is no group at point"
(interactive)
(let ((group-at-point (get-text-property (point)
'jabber-group))
(account-at-point (get-text-property (point)
'jabber-account))
(jid-at-point (get-text-property (point)
'jabber-jid)))
(if (and group-at-point account-at-point)
(jabber-roster-roll-group account-at-point group-at-point)
;; Is this a normal contact, or a groupchat? Let's ask it.
(jabber-disco-get-info
account-at-point (jabber-jid-user jid-at-point) nil
#'jabber-roster-ret-action-at-point-1
jid-at-point))))
(defun jabber-roster-ret-action-at-point-1 (jc jid result)
;; If we get an error, assume it's a normal contact.
(if (eq (car result) 'error)
(jabber-chat-with jc jid)
;; Otherwise, let's check whether it has a groupchat identity.
(let ((identities (car result)))
(if (find "conference" (if (sequencep identities) identities nil)
:key (lambda (i) (aref i 1))
:test #'string=)
;; Yes! Let's join it.
(jabber-muc-join jc jid
(jabber-muc-read-my-nickname jc jid t)
t)
;; No. Let's open a normal chat buffer.
(jabber-chat-with jc jid)))))
(defun jabber-roster-mouse-2-action-at-point (e)
"Action for mouse-2. Before try to roll up/down group. Eval
chat-with-jid-at-point is no group at point"
(interactive "e")
(mouse-set-point e)
(let ((group-at-point (get-text-property (point)
'jabber-group))
(account-at-point (get-text-property (point)
'jabber-account)))
(if (and group-at-point account-at-point)
(jabber-roster-roll-group account-at-point group-at-point)
(jabber-popup-combined-menu))))
(defun jabber-roster-delete-at-point ()
"Delete at point from roster.
Try to delete the group from all contaacs.
Delete a jid if there is no group at point."
(interactive)
(let ((group-at-point (get-text-property (point)
'jabber-group))
(account-at-point (get-text-property (point)
'jabber-account)))
(if (and group-at-point account-at-point)
(let ((jids-with-group
(gethash group-at-point
(plist-get
(fsm-get-state-data account-at-point)
:roster-hash))))
(jabber-roster-delete-group-from-jids account-at-point
jids-with-group
group-at-point))
(jabber-roster-delete-jid-at-point))))
(defun jabber-roster-edit-action-at-point ()
"Action for e. Before try to edit group name.
Eval `jabber-roster-change' is no group at point"
(interactive)
(let ((group-at-point (get-text-property (point)
'jabber-group))
(account-at-point (get-text-property (point)
'jabber-account)))
(if (and group-at-point account-at-point)
(let ((jids-with-group
(gethash group-at-point
(plist-get
(fsm-get-state-data account-at-point)
:roster-hash))))
(jabber-roster-edit-group-from-jids account-at-point
jids-with-group
group-at-point))
(call-interactively 'jabber-roster-change))))
(defun jabber-roster-roll-group (jc group-name &optional set)
"Roll up/down group in roster.
If optional SET is t, roll up group.
If SET is nor t or nil, roll down group."
(let* ((state-data (fsm-get-state-data jc))
(roll-groups (plist-get state-data :roster-roll-groups))
(new-roll-groups (if (find group-name roll-groups :test 'string=)
;; group is rolled up, roll it down if needed
(if (or (not set) (and set (not (eq set t))))
(remove-if-not (lambda (group-name-in-list)
(not (string= group-name
group-name-in-list)))
roll-groups)
roll-groups)
;; group is rolled down, roll it up if needed
(if (or (not set) (and set (eq set t)))
(append roll-groups (list group-name))
roll-groups))) )
(unless (equal roll-groups new-roll-groups)
(plist-put
state-data :roster-roll-groups
new-roll-groups)
(jabber-display-roster))))
(defun jabber-roster-mode ()
"Major mode for Jabber roster display.
Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to
bring up menus of actions.
\\{jabber-roster-mode-map}"
(kill-all-local-variables)
(setq major-mode 'jabber-roster-mode
mode-name "jabber-roster")
(use-local-map jabber-roster-mode-map)
(setq buffer-read-only t)
(if (fboundp 'run-mode-hooks)
(run-mode-hooks 'jabber-roster-mode-hook)
(run-hooks 'jabber-roster-mode-hook)))
(put 'jabber-roster-mode 'mode-class 'special)
;;;###autoload
(defun jabber-switch-to-roster-buffer (&optional jc)
"Switch to roster buffer.
Optional JC argument is ignored; it's there so this function can
be used in `jabber-post-connection-hooks'."
(interactive)
(if (not (get-buffer jabber-roster-buffer))
(jabber-display-roster)
(switch-to-buffer jabber-roster-buffer)))
(defun jabber-sort-roster (jc)
"sort roster according to online status"
(let ((state-data (fsm-get-state-data jc)))
(dolist (group (plist-get state-data :roster-groups))
(let ((group-name (car group)))
(puthash group-name
(sort
(gethash group-name
(plist-get state-data :roster-hash))
#'jabber-roster-sort-items)
(plist-get state-data :roster-hash))))))
(defun jabber-roster-prepare-roster (jc)
"make a hash based roster"
(let* ((state-data (fsm-get-state-data jc))
(hash (make-hash-table :test 'equal))
(buddies (plist-get state-data :roster))
(all-groups '()))
(dolist (buddy buddies)
(let ((groups (get buddy 'groups)))
(if groups
(progn
(dolist (group groups)
(progn
(setq all-groups (append all-groups (list group)))
(puthash group
(append (gethash group hash)
(list buddy))
hash))))
(progn
(setq all-groups (append all-groups
(list jabber-roster-default-group-name)))
(puthash jabber-roster-default-group-name
(append (gethash jabber-roster-default-group-name hash)
(list buddy))
hash)))))
;; remove duplicates name of group
(setq all-groups (sort
(remove-duplicates all-groups
:test 'string=)
'string<))
;; put to state-data all-groups as list of list
(plist-put state-data :roster-groups
(mapcar #'list all-groups))
;; put to state-data hash-roster
(plist-put state-data :roster-hash
hash)))
(defun jabber-roster-sort-items (a b)
"Sort roster items A and B according to `jabber-roster-sort-functions'.
Return t if A is less than B."
(dolist (fn jabber-roster-sort-functions)
(let ((comparison (funcall fn a b)))
(cond
((< comparison 0)
(return t))
((> comparison 0)
(return nil))))))
(defun jabber-roster-sort-by-status (a b)
"Sort roster items by online status.
See `jabber-sort-order' for order used."
(flet ((order (item) (length (member (get item 'show) jabber-sort-order))))
(let ((a-order (order a))
(b-order (order b)))
;; Note reversed test. Items with longer X-order go first.
(cond
((< a-order b-order)
1)
((> a-order b-order)
-1)
(t
0)))))
(defun jabber-roster-sort-by-displayname (a b)
"Sort roster items by displayed name."
(let ((a-name (jabber-jid-displayname a))
(b-name (jabber-jid-displayname b)))
(cond
((string-lessp a-name b-name) -1)
((string= a-name b-name) 0)
(t 1))))
(defun jabber-roster-sort-by-group (a b)
"Sort roster items by group membership."
(flet ((first-group (item) (or (car (get item 'groups)) "")))
(let ((a-group (first-group a))
(b-group (first-group b)))
(cond
((string-lessp a-group b-group) -1)
((string= a-group b-group) 0)
(t 1)))))
(defun jabber-fix-status (status)
"Make status strings more readable"
(when status
(when (string-match "\n+$" status)
(setq status (replace-match "" t t status)))
(when jabber-remove-newlines
(while (string-match "\n" status)
(setq status (replace-match " " t t status))))
status))
(defvar jabber-roster-ewoc nil
"Ewoc displaying the roster.
There is only one; we don't rely on buffer-local variables or
such.")
(defun jabber-roster-filter-display (buddies)
"Filter BUDDIES for items to be displayed in the roster"
(remove-if-not (lambda (buddy) (or jabber-show-offline-contacts
(get buddy 'connected)))
buddies))
(defun jabber-roster-toggle-offline-display ()
"Toggle display of offline contacts.
To change this permanently, customize the `jabber-show-offline-contacts'."
(interactive)
(setq jabber-show-offline-contacts
(not jabber-show-offline-contacts))
(jabber-display-roster))
(defun jabber-roster-toggle-binding-display ()
"Toggle display of the roster binding text."
(interactive)
(setq jabber-roster-show-bindings
(not jabber-roster-show-bindings))
(jabber-display-roster))
(defun jabber-display-roster ()
"switch to the main jabber buffer and refresh the roster display to reflect the current information"
(interactive)
(with-current-buffer (get-buffer-create jabber-roster-buffer)
(if (not (eq major-mode 'jabber-roster-mode))
(jabber-roster-mode))
(setq buffer-read-only nil)
;; line-number-at-pos is in Emacs >= 21.4. Only used to avoid
;; excessive scrolling when updating roster, so not absolutely
;; necessary.
(let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos)))
(current-column (current-column)))
(erase-buffer)
(setq jabber-roster-ewoc nil)
(when jabber-roster-show-title
(insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n"))
(when jabber-roster-show-bindings
(insert "RET Open chat buffer C-k Delete roster item
e Edit item s Send subscription request
q Bury buffer i Get disco items
I Get disco info b Browse
j Join groupchat (MUC) v Get client version
a Send presence o Show offline contacts on/off
C-c C-c Chat menu C-c C-m Multi-User Chat menu
C-c C-i Info menu C-c C-r Roster menu
C-c C-s Service menu
H Toggle displaying this text
"))
(insert "__________________________________\n\n")
(if (null jabber-connections)
(insert "Not connected\n")
(let ((map (make-sparse-keymap)))
(define-key map [mouse-2] #'jabber-send-presence)
(insert (jabber-propertize (concat (format " - %s"
(cdr (assoc *jabber-current-show* jabber-presence-strings)))
(if (not (zerop (length *jabber-current-status*)))
(format " (%s)"
(jabber-fix-status *jabber-current-status*)))
" -")
'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces))
'jabber-roster-user-online)
;;'mouse-face (cons 'background-color "light grey")
'keymap map)
"\n")))
(dolist (jc jabber-connections)
;; use a hash-based roster
(when (not (plist-get (fsm-get-state-data jc) :roster-hash))
(jabber-roster-prepare-roster jc))
;; We sort everything before putting it in the ewoc
(jabber-sort-roster jc)
(let ((before-ewoc (point))
(ewoc (ewoc-create
(lexical-let ((jc jc))
(lambda (data)
(let* ((group (car data))
(group-name (car group))
(buddy (car (cdr data))))
(jabber-display-roster-entry jc group-name buddy))))
(concat
(jabber-propertize (concat
(plist-get (fsm-get-state-data jc) :username)
"@"
(plist-get (fsm-get-state-data jc) :server))
'face 'jabber-title-medium)
"\n__________________________________\n")
"__________________________________"))
(new-groups '()))
(plist-put(fsm-get-state-data jc) :roster-ewoc ewoc)
(dolist (group (plist-get (fsm-get-state-data jc) :roster-groups))
(let* ((group-name (car group))
(buddies (jabber-roster-filter-display
(gethash group-name
(plist-get (fsm-get-state-data jc) :roster-hash)))))
(when (or jabber-roster-show-empty-group
(> (length buddies) 0))
(let ((group-node (ewoc-enter-last ewoc (list group nil))))
(if (not (find
group-name
(plist-get (fsm-get-state-data jc) :roster-roll-groups)
:test 'string=))
(dolist (buddy (reverse buddies))
(ewoc-enter-after ewoc group-node (list group buddy))))))))
(goto-char (point-max))
(insert "\n")
(put-text-property before-ewoc (point)
'jabber-account jc)))
(goto-char (point-min))
(setq buffer-read-only t)
(if (interactive-p)
(dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks))
(run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer)))))
(when current-line
;; Go back to previous line - don't use goto-line, since it
;; sets the mark.
(goto-char (point-min))
(forward-line (1- current-line))
;; ...and go back to previous column
(move-to-column current-column)))))
(defun jabber-display-roster-entry (jc group-name buddy)
"Format and insert a roster entry for BUDDY at point.
BUDDY is a JID symbol."
(if buddy
(let ((buddy-str (format-spec
jabber-roster-line-format
(list
(cons ?a (jabber-propertize
" "
'display (get buddy 'avatar)))
(cons ?c (if (get buddy 'connected) "*" " "))
(cons ?u (cdr (assoc
(or
(get buddy 'subscription) "none")
jabber-roster-subscription-display)))
(cons ?n (if (> (length (get buddy 'name)) 0)
(get buddy 'name)
(symbol-name buddy)))
(cons ?j (symbol-name buddy))
(cons ?r (or (get buddy 'resource) ""))
(cons ?s (or
(cdr (assoc (get buddy 'show)
jabber-presence-strings))
(get buddy 'show)))
(cons ?S (if (get buddy 'status)
(jabber-fix-status (get buddy 'status))
""))
))))
(add-text-properties 0
(length buddy-str)
(list
'face
(or (cdr (assoc (get buddy 'show) jabber-presence-faces))
'jabber-roster-user-online)
;;'mouse-face
;;(cons 'background-color "light grey")
'help-echo
(symbol-name buddy)
'jabber-jid
(symbol-name buddy)
'jabber-account
jc)
buddy-str)
(insert buddy-str)
(when (or (eq jabber-show-resources 'always)
(and (eq jabber-show-resources 'sometimes)
(> (jabber-count-connected-resources buddy) 1)))
(dolist (resource (get buddy 'resources))
(when (plist-get (cdr resource) 'connected)
(let ((resource-str (format-spec jabber-resource-line-format
(list
(cons ?c "*")
(cons ?n (if (>
(length
(get buddy 'name)) 0)
(get buddy 'name)
(symbol-name buddy)))
(cons ?j (symbol-name buddy))
(cons ?r (if (>
(length
(car resource)) 0)
(car resource)
"empty"))
(cons ?s (or
(cdr (assoc
(plist-get
(cdr resource) 'show)
jabber-presence-strings))
(plist-get
(cdr resource) 'show)))
(cons ?S (if (plist-get
(cdr resource) 'status)
(jabber-fix-status
(plist-get (cdr resource)
'status))
""))
(cons ?p (number-to-string
(plist-get (cdr resource)
'priority)))))))
(add-text-properties 0
(length resource-str)
(list
'face
(or (cdr (assoc (plist-get
(cdr resource)
'show)
jabber-presence-faces))
'jabber-roster-user-online)
'jabber-jid
(format "%s/%s" (symbol-name buddy) (car resource))
'jabber-account
jc)
resource-str)
(insert "\n" resource-str))))))
(let ((group-name (or group-name
jabber-roster-default-group-name)))
(add-text-properties 0
(length group-name)
(list
'face 'jabber-title-small
'jabber-group group-name
'jabber-account jc)
group-name)
(insert group-name))))
;;;###autoload
(defun jabber-roster-update (jc new-items changed-items deleted-items)
"Update roster, in memory and on display.
Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all
three being lists of JID symbols."
(let* ((roster (plist-get (fsm-get-state-data jc) :roster))
(hash (plist-get (fsm-get-state-data jc) :roster-hash))
(ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc))
(all-groups (plist-get (fsm-get-state-data jc) :roster-groups))
(terminator
(lambda (deleted-items)
(dolist (delete-this deleted-items)
(let ((groups (get delete-this 'groups))
(terminator
(lambda (g)
(let*
((group (or g jabber-roster-default-group-name))
(buddies (gethash group hash)))
(when (not buddies)
(setq new-groups (append new-groups (list group))))
(puthash group
(delq delete-this buddies)
hash)))))
(if groups
(dolist (group groups)
(terminator group))
(terminator groups)))))))
;; fix a old-roster
(dolist (delete-this deleted-items)
(setq roster (delq delete-this roster)))
(setq roster (append new-items roster))
(plist-put (fsm-get-state-data jc) :roster roster)
;; update a hash-roster
(if (not hash)
(jabber-roster-prepare-roster jc)
(when jabber-roster-debug
(message "update hash-based roster"))
;; delete items
(dolist (delete-this (append deleted-items changed-items))
(let ((jid (symbol-name delete-this)))
(when jabber-roster-debug
(message (concat "delete jid: " jid)))
(dolist (group (mapcar (lambda (g) (car g)) all-groups))
(when jabber-roster-debug
(message (concat "try to delete jid: " jid " from group " group)))
(puthash group
(delq delete-this (gethash group hash))
hash))))
;; insert changed-items
(dolist (insert-this (append changed-items new-items))
(let ((jid (symbol-name insert-this)))
(when jabber-roster-debug
(message (concat "insert jid: " jid)))
(dolist (group (or (get insert-this 'groups)
(list jabber-roster-default-group-name)))
(when jabber-roster-debug
(message (concat "insert jid: " jid " to group " group)))
(puthash group
(append (gethash group hash)
(list insert-this))
hash)
(setq all-groups (append all-groups (list (list group)))))))
(when jabber-roster-debug
(message "remove duplicates from new group"))
(setq all-groups (sort
(remove-duplicates all-groups
:test (lambda (g1 g2)
(let ((g1-name (car g1))
(g2-name (car g2)))
(string= g1-name
g2-name))))
(lambda (g1 g2)
(let ((g1-name (car g1))
(g2-name (car g2)))
(string< g1-name
g2-name)))))
(plist-put (fsm-get-state-data jc) :roster-groups all-groups))
(when jabber-roster-debug
(message "re display roster"))
;; recreate roster buffer
(jabber-display-roster)))
(defalias 'jabber-presence-update-roster 'ignore)
;;jabber-presence-update-roster is not needed anymore.
;;Its work is done in `jabber-process-presence'."
(make-obsolete 'jabber-presence-update-roster 'ignore)
(defun jabber-next-property (&optional prev)
"Return position of next property appearence or nil if there is none.
If optional PREV is non-nil, return position of previous property appearence."
(let ((pos (point))
(found nil)
(nextprev (if prev 'previous-single-property-change
'next-single-property-change)))
(while (not found)
(setq pos
(let ((jid (funcall nextprev pos 'jabber-jid))
(group (funcall nextprev pos 'jabber-group)))
(cond
((not jid) group)
((not group) jid)
(t (funcall (if prev 'max 'min) jid group)))))
(if (not pos)
(setq found t)
(setq found (or (get-text-property pos 'jabber-jid)
(get-text-property pos 'jabber-group)))))
pos))
(defun jabber-go-to-next-roster-item ()
"Move the cursor to the next jid/group in the buffer"
(interactive)
(let* ((next (jabber-next-property))
(next (if (not next)
(progn (goto-char (point-min))
(jabber-next-property)) next)))
(if next (goto-char next)
(goto-char (point-min)))))
(defun jabber-go-to-previous-roster-item ()
"Move the cursor to the previous jid/group in the buffer"
(interactive)
(let* ((previous (jabber-next-property 'prev))
(previous (if (not previous)
(progn (goto-char (point-max))
(jabber-next-property 'prev)) previous)))
(if previous (goto-char previous)
(goto-char (point-max)))))
(defun jabber-roster-restore-groups (jc)
"Restore roster's groups rolling state from private storage"
(interactive (list (jabber-read-account)))
(jabber-private-get jc 'roster "emacs-jabber"
'jabber-roster-restore-groups-1 'ignore))
(defun jabber-roster-restore-groups-1 (jc xml-data)
"Parse roster groups and restore rolling state"
(when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber")
(let* ((data (car (last xml-data)))
(groups (if (stringp data) (split-string data "\n") nil)))
(dolist (group groups)
(jabber-roster-roll-group jc group t)))))
(defun jabber-roster-save-groups ()
"Save roster's groups rolling state in private storage"
(interactive)
(dolist (jc jabber-connections)
(let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups))
(roll-groups
(if groups
(mapconcat (lambda (a) (substring-no-properties a)) groups "\n")
"")))
(jabber-private-set jc
`(roster ((xmlns . "emacs-jabber"))
,roll-groups)
'jabber-report-success "Roster groups saved"
'jabber-report-success "Failed to save roster groups"))))
(provide 'jabber-roster)
;;; arch-tag: 096af063-0526-4dd2-90fd-bc6b5ba07d32

321
elpa/jabber-20180927.2325/jabber-rtt.el Normal file
View File

@ -0,0 +1,321 @@
;;; jabber-rtt.el --- XEP-0301: In-Band Real Time Text
;; Copyright (C) 2013 Magnus Henoch
;; Author: Magnus Henoch <magnus.henoch@gmail.com>
;; This program 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 of the License, or
;; (at your option) any later version.
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(eval-when-compile (require 'cl))
;;;; Handling incoming events
;;;###autoload
(eval-after-load "jabber-disco"
'(jabber-disco-advertise-feature "urn:xmpp:rtt:0"))
(defvar jabber-rtt-ewoc-node nil)
(make-variable-buffer-local 'jabber-rtt-ewoc-node)
(defvar jabber-rtt-last-seq nil)
(make-variable-buffer-local 'jabber-rtt-last-seq)
(defvar jabber-rtt-message nil)
(make-variable-buffer-local 'jabber-rtt-message)
(defvar jabber-rtt-pending-events nil)
(make-variable-buffer-local 'jabber-rtt-pending-events)
(defvar jabber-rtt-timer nil)
(make-variable-buffer-local 'jabber-rtt-timer)
;; Add function last in chain, so a chat buffer is already created.
;;;###autoload
(eval-after-load "jabber-core"
'(add-to-list 'jabber-message-chain #'jabber-rtt-handle-message t))
;;;###autoload
(defun jabber-rtt-handle-message (jc xml-data)
;; We could support this for MUC as well, if useful.
(when (and (not (jabber-muc-message-p xml-data))
(get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))))
(with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
(let* ((rtt (jabber-xml-path xml-data '(("urn:xmpp:rtt:0" . "rtt"))))
(body (jabber-xml-path xml-data '(body)))
(seq (when rtt (jabber-xml-get-attribute rtt 'seq)))
(event (when rtt (or (jabber-xml-get-attribute rtt 'event) "edit")))
(actions (when rtt (jabber-xml-node-children rtt)))
(inhibit-read-only t))
(cond
((or body (string= event "cancel"))
;; A <body/> element supersedes real time text.
(jabber-rtt--reset))
((member event '("new" "reset"))
(jabber-rtt--reset)
(setq jabber-rtt-ewoc-node
(ewoc-enter-last jabber-chat-ewoc (list :notice "[typing...]"))
jabber-rtt-last-seq (string-to-number seq)
jabber-rtt-message ""
jabber-rtt-pending-events nil)
(jabber-rtt--enqueue-actions actions))
((string= event "edit")
;; TODO: check whether this works properly in 32-bit Emacs
(cond
((and jabber-rtt-last-seq
(equal (1+ jabber-rtt-last-seq)
(string-to-number seq)))
;; We are in sync.
(setq jabber-rtt-last-seq (string-to-number seq))
(jabber-rtt--enqueue-actions actions))
(t
;; TODO: show warning when not in sync
(message "out of sync! %s vs %s"
seq jabber-rtt-last-seq))
))
;; TODO: handle event="init"
)))))
(defun jabber-rtt--reset ()
(when jabber-rtt-ewoc-node
(ewoc-delete jabber-chat-ewoc jabber-rtt-ewoc-node))
(when (timerp jabber-rtt-timer)
(cancel-timer jabber-rtt-timer))
(setq jabber-rtt-ewoc-node nil
jabber-rtt-last-seq nil
jabber-rtt-message nil
jabber-rtt-pending-events nil
jabber-rtt-timer nil))
(defun jabber-rtt--enqueue-actions (new-actions)
(setq jabber-rtt-pending-events
;; Ensure that the queue never contains more than 700 ms worth
;; of wait events.
(jabber-rtt--fix-waits (append jabber-rtt-pending-events new-actions)))
(unless jabber-rtt-timer
(jabber-rtt--process-actions (current-buffer))))
(defun jabber-rtt--process-actions (buffer)
(with-current-buffer buffer
(setq jabber-rtt-timer nil)
(catch 'wait
(while jabber-rtt-pending-events
(let ((action (pop jabber-rtt-pending-events)))
(case (jabber-xml-node-name action)
((t)
;; insert text
(let* ((p (jabber-xml-get-attribute action 'p))
(position (if p (string-to-number p) (length jabber-rtt-message))))
(setq position (max position 0))
(setq position (min position (length jabber-rtt-message)))
(setf (substring jabber-rtt-message position position)
(car (jabber-xml-node-children action)))
(ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message)))
(let ((inhibit-read-only t))
(ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node))))
((e)
;; erase text
(let* ((p (jabber-xml-get-attribute action 'p))
(position (if p (string-to-number p) (length jabber-rtt-message)))
(n (jabber-xml-get-attribute action 'n))
(number (if n (string-to-number n) 1)))
(setq position (max position 0))
(setq position (min position (length jabber-rtt-message)))
(setq number (max number 0))
(setq number (min number position))
;; Now erase the NUMBER characters before POSITION.
(setf (substring jabber-rtt-message (- position number) position)
"")
(ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message)))
(let ((inhibit-read-only t))
(ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node))))
((w)
(setq jabber-rtt-timer
(run-with-timer
(/ (string-to-number (jabber-xml-get-attribute action 'n)) 1000.0)
nil
#'jabber-rtt--process-actions
buffer))
(throw 'wait nil))))))))
(defun jabber-rtt--fix-waits (actions)
;; Ensure that the sum of all wait events is no more than 700 ms.
(let ((sum 0))
(dolist (action actions)
(when (eq (jabber-xml-node-name action) 'w)
(let ((n (jabber-xml-get-attribute action 'n)))
(setq n (string-to-number n))
(when (>= n 0)
(setq sum (+ sum n))))))
(if (<= sum 700)
actions
(let ((scale (/ 700.0 sum)))
(mapcar
(lambda (action)
(if (eq (jabber-xml-node-name action) 'w)
(let ((n (jabber-xml-get-attribute action 'n)))
(setq n (string-to-number n))
(setq n (max n 0))
`(w ((n . ,(number-to-string (* scale n)))) nil))
action))
actions)))))
;;;; Sending events
(defvar jabber-rtt-send-timer nil)
(make-variable-buffer-local 'jabber-rtt-send-timer)
(defvar jabber-rtt-send-seq nil)
(make-variable-buffer-local 'jabber-rtt-send-seq)
(defvar jabber-rtt-outgoing-events nil)
(make-variable-buffer-local 'jabber-rtt-outgoing-events)
(defvar jabber-rtt-send-last-timestamp nil)
(make-variable-buffer-local 'jabber-rtt-send-last-timestamp)
;;;###autoload
(define-minor-mode jabber-rtt-send-mode
"Show text to recipient as it is being typed.
This lets the recipient see every change made to the message up
until it's sent. The recipient's client needs to implement
XEP-0301, In-Band Real Time Text."
nil " Real-Time" nil
(if (null jabber-rtt-send-mode)
(progn
(remove-hook 'after-change-functions #'jabber-rtt--queue-update t)
(remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t)
(jabber-rtt--cancel-send))
(unless (derived-mode-p 'jabber-chat-mode)
(error "Real Time Text only makes sense in chat buffers"))
(when (timerp jabber-rtt-send-timer)
(cancel-timer jabber-rtt-send-timer))
(setq jabber-rtt-send-timer nil
jabber-rtt-send-seq nil
jabber-rtt-outgoing-events nil
jabber-rtt-send-last-timestamp nil)
(jabber-rtt--send-current-text nil)
(add-hook 'after-change-functions #'jabber-rtt--queue-update nil t)
(add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t)))
(defun jabber-rtt--cancel-send ()
(when (timerp jabber-rtt-send-timer)
(cancel-timer jabber-rtt-send-timer))
(setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq))
(jabber-send-sexp jabber-buffer-connection
`(message ((to . ,jabber-chatting-with)
(type . "chat"))
(rtt ((xmlns . "urn:xmpp:rtt:0")
(seq . ,(number-to-string jabber-rtt-send-seq))
(event . "cancel"))
nil)))
(setq jabber-rtt-send-timer nil
jabber-rtt-send-seq nil
jabber-rtt-outgoing-events nil
jabber-rtt-send-last-timestamp nil))
(defun jabber-rtt--send-current-text (resetp)
(let ((text (buffer-substring-no-properties jabber-point-insert (point-max))))
;; This should give us enough room to avoid wrap-arounds, even
;; with just 28 bits...
(setq jabber-rtt-send-seq (random 100000))
(jabber-send-sexp jabber-buffer-connection
`(message ((to . ,jabber-chatting-with)
(type . "chat"))
(rtt ((xmlns . "urn:xmpp:rtt:0")
(seq . ,(number-to-string jabber-rtt-send-seq))
(event . ,(if resetp "reset" "new")))
(t () ,text))))))
(defun jabber-rtt--queue-update (beg end pre-change-length)
(unless (or (< beg jabber-point-insert)
(< end jabber-point-insert))
(let ((timestamp (current-time)))
(when jabber-rtt-send-last-timestamp
(let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp))
(interval (truncate (* 1000 (float-time time-difference)))))
(when (and (> interval 0)
;; Don't send too long intervals - this should have
;; been sent by our timer already.
(< interval 1000))
(push `(w ((n . ,(number-to-string interval))) nil)
jabber-rtt-outgoing-events))))
(setq jabber-rtt-send-last-timestamp timestamp))
(when (> pre-change-length 0)
;; Some text was deleted. Let's check if we can use a shorter
;; tag:
(let ((at-end (= end (point-max)))
(erase-one (= pre-change-length 1)))
(push `(e (
,@(unless at-end
`((p . ,(number-to-string
(+ beg
(- jabber-point-insert)
pre-change-length)))))
,@(unless erase-one
`((n . ,(number-to-string pre-change-length))))))
jabber-rtt-outgoing-events)))
(when (/= beg end)
;; Some text was inserted.
(let ((text (buffer-substring-no-properties beg end))
(at-end (= end (point-max))))
(push `(t (
,@(unless at-end
`((p . ,(number-to-string (- beg jabber-point-insert))))))
,text)
jabber-rtt-outgoing-events)))
(when (null jabber-rtt-send-timer)
(setq jabber-rtt-send-timer
(run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer))))))
(defun jabber-rtt--send-queued-events (buffer)
(with-current-buffer buffer
(setq jabber-rtt-send-timer nil)
(when jabber-rtt-outgoing-events
(let ((event (if jabber-rtt-send-seq "edit" "new")))
(setq jabber-rtt-send-seq
(if jabber-rtt-send-seq
(1+ jabber-rtt-send-seq)
(random 100000)))
(jabber-send-sexp jabber-buffer-connection
`(message ((to . ,jabber-chatting-with)
(type . "chat"))
(rtt ((xmlns . "urn:xmpp:rtt:0")
(seq . ,(number-to-string jabber-rtt-send-seq))
(event . ,event))
,@(nreverse jabber-rtt-outgoing-events))))
(setq jabber-rtt-outgoing-events nil)))))
(defun jabber-rtt--message-sent (_text _id)
;; We're sending a <body/> element; reset our state
(when (timerp jabber-rtt-send-timer)
(cancel-timer jabber-rtt-send-timer))
(setq jabber-rtt-send-timer nil
jabber-rtt-send-seq nil
jabber-rtt-outgoing-events nil
jabber-rtt-send-last-timestamp nil))
(provide 'jabber-rtt)
;;; jabber-rtt.el ends here

BIN
elpa/jabber-20180927.2325/jabber-rtt.elc Normal file
View File

Binary file not shown.

157
elpa/jabber-20180927.2325/jabber-sasl.el Normal file
View File

@ -0,0 +1,157 @@
;; jabber-sasl.el - SASL authentication
;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'cl)
;;; This file uses sasl.el from FLIM or Gnus. If it can't be found,
;;; jabber-core.el won't use the SASL functions.
(eval-and-compile
(condition-case nil
(require 'sasl)
(error nil)))
;;; Alternatives to FLIM would be the command line utility of GNU SASL,
;;; or anything the Gnus people decide to use.
;;; See XMPP-CORE and XMPP-IM for details about the protocol.
(require 'jabber-xml)
(defun jabber-sasl-start-auth (jc stream-features)
;; Find a suitable common mechanism.
(let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms)))
(mechanisms (mapcar
(lambda (tag)
(car (jabber-xml-node-children tag)))
(jabber-xml-get-children mechanism-elements 'mechanism)))
(mechanism
(if (and (member "ANONYMOUS" mechanisms)
(or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? ")))
(sasl-find-mechanism '("ANONYMOUS"))
(sasl-find-mechanism mechanisms))))
;; No suitable mechanism?
(if (null mechanism)
;; Maybe we can use legacy authentication
(let ((iq-auth (find "http://jabber.org/features/iq-auth"
(jabber-xml-get-children stream-features 'auth)
:key #'jabber-xml-get-xmlns
:test #'string=))
;; Or maybe we have to use STARTTLS, but can't
(starttls (find "urn:ietf:params:xml:ns:xmpp-tls"
(jabber-xml-get-children stream-features 'starttls)
:key #'jabber-xml-get-xmlns
:test #'string=)))
(cond
(iq-auth
(fsm-send jc :use-legacy-auth-instead))
(starttls
(message "STARTTLS encryption required, but disabled/non-functional at our end")
(fsm-send jc :authentication-failure))
(t
(message "Authentication failure: no suitable SASL mechanism found")
(fsm-send jc :authentication-failure))))
;; Watch for plaintext logins over unencrypted connections
(if (and (not (plist-get (fsm-get-state-data jc) :encrypted))
(member (sasl-mechanism-name mechanism)
'("PLAIN" "LOGIN"))
(not (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? ")))
(fsm-send jc :authentication-failure)
;; Start authentication.
(let* (passphrase
(client (sasl-make-client mechanism
(plist-get (fsm-get-state-data jc) :username)
"xmpp"
(plist-get (fsm-get-state-data jc) :server)))
(sasl-read-passphrase (jabber-sasl-read-passphrase-closure
jc
(lambda (p) (setq passphrase (copy-sequence p)) p)))
(step (sasl-next-step client nil)))
(jabber-send-sexp
jc
`(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")
(mechanism . ,(sasl-mechanism-name mechanism)))
,(when (sasl-step-data step)
(base64-encode-string (sasl-step-data step) t))))
(list client step passphrase))))))
(defun jabber-sasl-read-passphrase-closure (jc remember)
"Return a lambda function suitable for `sasl-read-passphrase' for JC.
Call REMEMBER with the password. REMEMBER is expected to return it as well."
(lexical-let ((password (plist-get (fsm-get-state-data jc) :password))
(bare-jid (jabber-connection-bare-jid jc))
(remember remember))
(if password
(lambda (prompt) (funcall remember (copy-sequence password)))
(lambda (prompt) (funcall remember (jabber-read-password bare-jid))))))
(defun jabber-sasl-process-input (jc xml-data sasl-data)
(let* ((client (first sasl-data))
(step (second sasl-data))
(passphrase (third sasl-data))
(sasl-read-passphrase (jabber-sasl-read-passphrase-closure
jc
(lambda (p) (setq passphrase (copy-sequence p)) p))))
(cond
((eq (car xml-data) 'challenge)
(sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
(setq step (sasl-next-step client step))
(jabber-send-sexp
jc
`(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))
,(when (sasl-step-data step)
(base64-encode-string (sasl-step-data step) t)))))
((eq (car xml-data) 'failure)
(message "%s: authentication failure: %s"
(jabber-connection-bare-jid jc)
(jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
(fsm-send jc :authentication-failure))
((eq (car xml-data) 'success)
;; The server might, depending on the mechanism, send
;; "additional data" (see RFC 4422) with the <success/> element.
;; Since some SASL mechanisms perform mutual authentication, we
;; need to pass this data to sasl.el - we're not necessarily
;; done just because the server says we're done.
(let* ((data (car (jabber-xml-node-children xml-data)))
(decoded (if data
(base64-decode-string data)
"")))
(sasl-step-set-data step decoded)
(condition-case e
(progn
;; Check that sasl-next-step doesn't signal an error.
;; TODO: once sasl.el allows it, check that all steps have
;; been completed.
(sasl-next-step client step)
(message "Authentication succeeded for %s" (jabber-connection-bare-jid jc))
(fsm-send jc (cons :authentication-success passphrase)))
(sasl-error
(message "%s: authentication failure: %s"
(jabber-connection-bare-jid jc)
(error-message-string e))
(fsm-send jc :authentication-failure))))))
(list client step passphrase)))
(provide 'jabber-sasl)
;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0

BIN
elpa/jabber-20180927.2325/jabber-sasl.elc Normal file
View File

Binary file not shown.

44
elpa/jabber-20180927.2325/jabber-sawfish.el Normal file
View File

@ -0,0 +1,44 @@
;; jabber-sawfish.el - emacs-jabber interface to sawfish
;; Copyright (C) 2005 - Mario Domenech Goulart
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(eval-when-compile (require 'jabber-alert))
(defcustom jabber-sawfish-display-time 3
"Time in seconds for displaying a jabber message through the
Sawfish window manager."
:type 'integer
:group 'jabber-alerts)
(defun jabber-sawfish-display-message (text &optional title)
"Displays MESSAGE through the Sawfish window manager."
(let ((process-connection-type nil))
(start-process-shell-command
"jabber-sawfish" nil "echo"
(concat "'(progn (require (quote timers)) (display-message \""
(or title text)
"\")(make-timer (lambda () (display-message nil)) "
(number-to-string jabber-sawfish-display-time)
"))' | sawfish-client - &> /dev/null"))))
(define-jabber-alert sawfish "Display a message through the Sawfish window manager"
'jabber-sawfish-display-message)
(provide 'jabber-sawfish)
;; arch-tag: 4F0154ED-5D05-11D9-9E6B-000A95C2FCD0

BIN
elpa/jabber-20180927.2325/jabber-sawfish.elc Normal file
View File

Binary file not shown.

31
elpa/jabber-20180927.2325/jabber-screen.el Normal file
View File

@ -0,0 +1,31 @@
;; jabber-screen.el - emacs-jabber interface to screen
;; Copyright (C) 2005 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(eval-when-compile (require 'jabber-alert))
(defun jabber-screen-message (text &optional title)
"Show MSG in screen"
(call-process "screen" nil nil nil "-X" "echo" (or title text)))
(define-jabber-alert screen "Show a message through the Screen terminal manager"
'jabber-screen-message)
(provide 'jabber-screen)
;; arch-tag: B576ADDA-5D04-11D9-AA52-000A95C2FCD0

BIN
elpa/jabber-20180927.2325/jabber-screen.elc Normal file
View File

Binary file not shown.

116
elpa/jabber-20180927.2325/jabber-search.el Normal file
View File

@ -0,0 +1,116 @@
;; jabber-search.el - searching by JEP-0055, with x:data support
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-register)
(add-to-list 'jabber-jid-service-menu
(cons "Search directory" 'jabber-get-search))
(defun jabber-get-search (jc to)
"Send IQ get request in namespace \"jabber:iq:search\"."
(interactive (list (jabber-read-account)
(jabber-read-jid-completing "Search what database: ")))
(jabber-send-iq jc to
"get"
'(query ((xmlns . "jabber:iq:search")))
#'jabber-process-data #'jabber-process-register-or-search
#'jabber-report-success "Search field retrieval"))
;; jabber-process-register-or-search logically comes here, rendering
;; the search form, but since register and search are so similar,
;; having two functions would be serious code duplication. See
;; jabber-register.el.
;; jabber-submit-search is called when the "submit" button of the
;; search form is activated.
(defun jabber-submit-search (&rest ignore)
"Submit search. See `jabber-process-register-or-search'."
(let ((text (concat "Search at " jabber-submit-to)))
(jabber-send-iq jabber-buffer-connection jabber-submit-to
"set"
(cond
((eq jabber-form-type 'register)
`(query ((xmlns . "jabber:iq:search"))
,@(jabber-parse-register-form)))
((eq jabber-form-type 'xdata)
`(query ((xmlns . "jabber:iq:search"))
,(jabber-parse-xdata-form)))
(t
(error "Unknown form type: %s" jabber-form-type)))
#'jabber-process-data #'jabber-process-search-result
#'jabber-report-success text))
(message "Search sent"))
(defun jabber-process-search-result (jc xml-data)
"Receive and display search results."
;; This function assumes that all search results come in one packet,
;; which is not necessarily the case.
(let ((query (jabber-iq-query xml-data))
(have-xdata nil)
xdata fields (jid-fields 0))
;; First, check for results in jabber:x:data form.
(dolist (x (jabber-xml-get-children query 'x))
(when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
(setq have-xdata t)
(setq xdata x)))
(if have-xdata
(jabber-render-xdata-search-results xdata)
(insert (jabber-propertize "Search results" 'face 'jabber-title-medium) "\n")
(setq fields '((first . (label "First name" column 0))
(last . (label "Last name" column 15))
(nick . (label "Nickname" column 30))
(jid . (label "JID" column 45))
(email . (label "E-mail" column 65))))
(setq jid-fields 1)
(dolist (field-cons fields)
(indent-to (plist-get (cdr field-cons) 'column) 1)
(insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))
(insert "\n\n")
;; Now, the items
(dolist (item (jabber-xml-get-children query 'item))
(let ((start-of-line (point))
jid)
(dolist (field-cons fields)
(let ((field-plist (cdr field-cons))
(value (if (eq (car field-cons) 'jid)
(setq jid (jabber-xml-get-attribute item 'jid))
(car (jabber-xml-node-children (car (jabber-xml-get-children item (car field-cons))))))))
(indent-to (plist-get field-plist 'column) 1)
(if value (insert value))))
(if jid
(put-text-property start-of-line (point)
'jabber-jid jid))
(insert "\n"))))))
(provide 'jabber-search)
;;; arch-tag: c39e9241-ab6f-4ac5-b1ba-7908bbae009c

70
elpa/jabber-20180927.2325/jabber-si-client.el Normal file
View File

@ -0,0 +1,70 @@
;; jabber-si-client.el - send stream requests, by JEP-0095
;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-feature-neg)
(require 'jabber-si-common)
(defun jabber-si-initiate (jc jid profile-namespace profile-data profile-function &optional mime-type)
"Try to initiate a stream to JID.
PROFILE-NAMESPACE is, well, the namespace of the profile to use.
PROFILE-DATA is the XML data to send within the SI request.
PROFILE-FUNCTION is the \"connection established\" function.
See `jabber-si-stream-methods'.
MIME-TYPE is the MIME type to specify.
Returns the SID."
(let ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time))))
(jabber-send-iq jc jid "set"
`(si ((xmlns . "http://jabber.org/protocol/si")
(id . ,sid)
,(if mime-type
(cons 'mime-type mime-type))
(profile . ,profile-namespace))
,profile-data
(feature ((xmlns . "http://jabber.org/protocol/feature-neg"))
,(jabber-fn-encode (list
(cons "stream-method"
(mapcar 'car jabber-si-stream-methods)))
'request)))
#'jabber-si-initiate-process (cons profile-function sid)
;; XXX: use other function here?
#'jabber-report-success "Stream initiation")
sid))
(defun jabber-si-initiate-process (jc xml-data closure-data)
"Act on response to our SI query."
(let* ((profile-function (car closure-data))
(sid (cdr closure-data))
(from (jabber-xml-get-attribute xml-data 'from))
(query (jabber-iq-query xml-data))
(feature-node (car (jabber-xml-get-children query 'feature)))
(feature-alist (jabber-fn-parse feature-node 'response))
(chosen-method (cadr (assoc "stream-method" feature-alist)))
(method-data (assoc chosen-method jabber-si-stream-methods)))
;; Our work is done. Hand it over to the stream method.
(let ((stream-negotiate (nth 1 method-data)))
(funcall stream-negotiate jc from sid profile-function))))
(provide 'jabber-si-client)
;;; arch-tag: e14ec451-3f18-4f36-b92a-e8a8aa1f5acd

61
elpa/jabber-20180927.2325/jabber-si-common.el Normal file
View File

@ -0,0 +1,61 @@
;;; jabber-si-common.el --- stream initiation (JEP-0095)
;; Copyright (C) 2006 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file 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 2, or (at your option)
;; any later version.
;; This file 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.
(defvar jabber-si-stream-methods nil
"Supported SI stream methods.
Each entry is a list, containing:
* The namespace URI of the stream method
* Active initiation function
* Passive initiation function
The active initiation function should initiate the connection,
while the passive initiation function should wait for an incoming
connection. Both functions take the same arguments:
* JID of peer
* SID
* \"connection established\" function
The \"connection established\" function should be called when the
stream has been established and data can be transferred. It is part
of the profile, and takes the following arguments:
* JID of peer
* SID
* Either:
- \"send data\" function, with one string argument
- an error message, when connection failed
It returns an \"incoming data\" function.
The \"incoming data\" function should be called when data arrives on
the stream. It takes these arguments:
* JID of peer
* SID
* A string containing the received data, or nil on EOF
If it returns nil, the stream should be closed.")
(provide 'jabber-si-common)
;; arch-tag: 9e7a5c8a-bdde-11da-8030-000a95c2fcd0
;;; jabber-si-common.el ends here

BIN
elpa/jabber-20180927.2325/jabber-si-common.elc Normal file
View File

Binary file not shown.

92
elpa/jabber-20180927.2325/jabber-si-server.el Normal file
View File

@ -0,0 +1,92 @@
;; jabber-si-server.el - handle incoming stream requests, by JEP-0095
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-disco)
(require 'jabber-feature-neg)
(require 'jabber-si-common)
(jabber-disco-advertise-feature "http://jabber.org/protocol/si")
;; Now, stream methods push data to profiles. It could be the other
;; way around; not sure which is better.
(defvar jabber-si-profiles nil
"Supported SI profiles.
Each entry is a list, containing:
* The namespace URI of the profile
* Accept function, taking entire IQ stanza, and signalling a 'forbidden'
error if request is declined; returning an XML node to return in
response, or nil of none needed
* \"Connection established\" function. See `jabber-si-stream-methods'.")
(add-to-list 'jabber-iq-set-xmlns-alist
(cons "http://jabber.org/protocol/si" 'jabber-si-process))
(defun jabber-si-process (jc xml-data)
(let* ((to (jabber-xml-get-attribute xml-data 'from))
(id (jabber-xml-get-attribute xml-data 'id))
(query (jabber-iq-query xml-data))
(profile (jabber-xml-get-attribute query 'profile))
(si-id (jabber-xml-get-attribute query 'id))
(feature (car (jabber-xml-get-children query 'feature))))
(message "Receiving SI with profile '%s'" profile)
(let (stream-method
;; Find profile
(profile-data (assoc profile jabber-si-profiles)))
;; Now, feature negotiation for stream type (errors
;; don't match JEP-0095, so convert)
(condition-case err
(setq stream-method (jabber-fn-intersection
(jabber-fn-parse feature 'request)
(list (cons "stream-method" (mapcar 'car jabber-si-stream-methods)))))
(jabber-error
(jabber-signal-error "cancel" 'bad-request nil
'((no-valid-streams ((xmlns . "http://jabber.org/protocol/si")))))))
(unless profile-data
;; profile not understood
(jabber-signal-error "cancel" 'bad-request nil
'((bad-profile ((xmlns . "http://jabber.org/protocol/si"))))))
(let* ((profile-accept-function (nth 1 profile-data))
;; accept-function might throw a "forbidden" error
;; on user cancel
(profile-response (funcall profile-accept-function jc xml-data))
(profile-connected-function (nth 2 profile-data))
(stream-method-id (nth 1 (assoc "stream-method" stream-method)))
(stream-data (assoc stream-method-id jabber-si-stream-methods))
(stream-accept-function (nth 2 stream-data)))
;; prepare stream for the transfer
(funcall stream-accept-function jc to si-id profile-connected-function)
;; return result of feature negotiation of stream type
(jabber-send-iq jc to "result"
`(si ((xmlns . "http://jabber.org/protocol/si"))
,@profile-response
(feature ((xmlns . "http://jabber.org/protocol/feature-neg"))
,(jabber-fn-encode stream-method 'response)))
nil nil nil nil
id)
))))
(provide 'jabber-si-server)
;;; arch-tag: d3c75c66-4052-4cf5-8f04-8765adfc8b96

678
elpa/jabber-20180927.2325/jabber-socks5.el Normal file
View File

@ -0,0 +1,678 @@
;; jabber-socks5.el - SOCKS5 bytestreams by JEP-0065
;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program 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 2 of the License, or
;; (at your option) any later version.
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'jabber-iq)
(require 'jabber-disco)
(require 'jabber-si-server)
(require 'jabber-si-client)
;; jabber-core will require fsm for us
(require 'jabber-core)
(eval-when-compile (require 'cl))
(defvar jabber-socks5-pending-sessions nil
"List of pending sessions.
Each entry is a list, containing:
* Stream ID
* Full JID of initiator
* State machine managing the session")
(defvar jabber-socks5-active-sessions nil
"List of active sessions.
Each entry is a list, containing:
* Network connection
* Stream ID
* Full JID of initiator
* Profile data function")
(defcustom jabber-socks5-proxies nil
"JIDs of JEP-0065 proxies to use for file transfer.
Put preferred ones first."
:type '(repeat string)
:group 'jabber
; :set 'jabber-socks5-set-proxies)
)
(defvar jabber-socks5-proxies-data nil
"Alist containing information about proxies.
Keys of the alist are strings, the JIDs of the proxies.
Values are \"streamhost\" XML nodes.")
(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams")
(add-to-list 'jabber-si-stream-methods
(list "http://jabber.org/protocol/bytestreams"
'jabber-socks5-client-1
'jabber-socks5-accept))
(defun jabber-socks5-set-proxies (symbol value)
"Set `jabber-socks5-proxies' and query proxies.
This is the set function of `jabber-socks5-proxies-data'."
(set-default symbol value)
(when jabber-connections
(jabber-socks5-query-all-proxies)))
(defun jabber-socks5-query-all-proxies (jc &optional callback)
"Ask all proxies in `jabber-socks5-proxies' for connection information.
If CALLBACK is non-nil, call it with no arguments when all
proxies have answered."
(interactive (list (jabber-read-account)))
(setq jabber-socks5-proxies-data nil)
(dolist (proxy jabber-socks5-proxies)
(jabber-socks5-query-proxy jc proxy callback)))
(defun jabber-socks5-query-proxy (jc jid &optional callback)
"Query the SOCKS5 proxy specified by JID for IP and port number."
(jabber-send-iq jc jid "get"
'(query ((xmlns . "http://jabber.org/protocol/bytestreams")))
#'jabber-socks5-process-proxy-response (list callback t)
#'jabber-socks5-process-proxy-response (list callback nil)))
(defun jabber-socks5-process-proxy-response (jc xml-data closure-data)
"Process response from proxy query."
(let* ((query (jabber-iq-query xml-data))
(from (jabber-xml-get-attribute xml-data 'from))
(streamhosts (jabber-xml-get-children query 'streamhost)))
(let ((existing-entry (assoc from jabber-socks5-proxies-data)))
(when existing-entry
(setq jabber-socks5-proxies-data
(delq existing-entry jabber-socks5-proxies-data))))
(destructuring-bind (callback successp) closure-data
(when successp
(setq jabber-socks5-proxies-data
(cons (cons from streamhosts)
jabber-socks5-proxies-data)))
(message "%s from %s. %d of %d proxies have answered."
(if successp "Response" "Error") from
(length jabber-socks5-proxies-data) (length jabber-socks5-proxies))
(when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)))
(funcall callback)))))
(define-state-machine jabber-socks5
:start ((jc jid sid profile-function role)
"Start JEP-0065 bytestream with JID.
SID is the session ID used.
PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'.
ROLE is either :initiator or :target. The initiator sends an IQ
set; the target waits for one."
(let ((new-state-data (list :jc jc
:jid jid
:sid sid
:profile-function profile-function
:role role))
(new-state
;; We want information about proxies; it might be needed in
;; various situations.
(cond
((null jabber-socks5-proxies)
;; We know no proxy addresses. Try to find them by disco.
'seek-proxies)
((null jabber-socks5-proxies-data)
;; We need to query the proxies for addresses.
'query-proxies)
;; So, we have our proxies.
(t
'initiate))))
(list new-state new-state-data nil))))
(defun jabber-socks5-accept (jc jid sid profile-function)
"Remember that we are waiting for connection from JID, with stream id SID"
;; asking the user for permission is done in the profile
(add-to-list 'jabber-socks5-pending-sessions
(list sid jid (start-jabber-socks5 jc jid sid profile-function :target))))
(define-enter-state jabber-socks5 seek-proxies (fsm state-data)
;; Look for items at the server.
(let* ((jc (plist-get state-data :jc))
(server (jabber-jid-server (jabber-connection-jid jc))))
(jabber-disco-get-items jc
server
nil
(lambda (jc fsm result)
(fsm-send-sync fsm (cons :items result)))
fsm))
;; Spend no more than five seconds looking for a proxy.
(list state-data 5))
(define-state jabber-socks5 seek-proxies (fsm state-data event callback)
"Collect disco results, looking for a bytestreams proxy."
;; We put the number of outstanding requests as :remaining-info in
;; the state-data plist.
(cond
;; We're not ready to handle the IQ stanza yet
((eq (car-safe event) :iq)
:defer)
;; Got list of items at the server.
((eq (car-safe event) :items)
(dolist (entry (cdr event))
;; Each entry is ["name" "jid" "node"]. We send a disco info
;; request to everything without a node.
(when (null (aref entry 2))
(lexical-let ((jid (aref entry 1)))
(jabber-disco-get-info
(plist-get state-data :jc)
jid nil
(lambda (jc fsm result)
(fsm-send-sync fsm (list :info jid result)))
fsm))))
;; Remember number of requests sent. But if none, we just go on.
(if (cdr event)
(list 'seek-proxies (plist-put state-data :remaining-info (length (cdr event))) :keep)
(list 'initiate state-data nil)))
;; Got disco info from an item at the server.
((eq (car-safe event) :info)
(fsm-debug-output "got disco event")
;; Count the response.
(plist-put state-data :remaining-info (1- (plist-get state-data :remaining-info)))
(unless (eq (first (third event)) 'error)
(let ((identities (first (third event))))
;; Is it a bytestream proxy?
(when (dolist (identity identities)
(when (and (string= (aref identity 1) "proxy")
(string= (aref identity 2) "bytestreams"))
(return t)))
;; Yes, it is. Add it to the list.
(push (second event) jabber-socks5-proxies))))
;; Wait for more responses, if any are to be expected.
(if (zerop (plist-get state-data :remaining-info))
;; No more... go on to querying the proxies.
(list 'query-proxies state-data nil)
;; We expect more responses...
(list 'seek-proxies state-data :keep)))
((eq event :timeout)
;; We can't wait anymore...
(list 'query-proxies state-data nil))))
(define-enter-state jabber-socks5 query-proxies (fsm state-data)
(jabber-socks5-query-all-proxies
(plist-get state-data :jc)
(lexical-let ((fsm fsm))
(lambda () (fsm-send-sync fsm :proxies))))
(list state-data 5))
(define-state jabber-socks5 query-proxies (fsm state-data event callback)
"Query proxies in `jabber-socks5-proxies'."
(cond
;; Can't handle the iq stanza yet...
((eq (car-safe event) :iq)
:defer)
((eq (car-safe event) :info)
;; stray event... do nothing
(list 'query-proxies state-data :keep))
;; Got response/error from all proxies, or timeout
((memq event '(:proxies :timeout))
(list 'initiate state-data nil))))
(define-enter-state jabber-socks5 initiate (fsm state-data)
;; Sort the alist jabber-socks5-proxies-data such that the
;; keys are in the same order as in jabber-socks5-proxies.
(setq jabber-socks5-proxies-data
(sort jabber-socks5-proxies-data
#'(lambda (a b)
(> (length (member (car a) jabber-socks5-proxies))
(length (member (car b) jabber-socks5-proxies))))))
;; If we're the initiator, send initiation stanza.
(when (eq (plist-get state-data :role) :initiator)
;; This is where initiation of server sockets would go
(jabber-send-iq
(plist-get state-data :jc)
(plist-get state-data :jid) "set"
`(query ((xmlns . "http://jabber.org/protocol/bytestreams")
(sid . ,(plist-get state-data :sid)))
,@(mapcar
#'(lambda (proxy)
(mapcar
#'(lambda (streamhost)
(list 'streamhost
(list (cons 'jid (jabber-xml-get-attribute streamhost 'jid))
(cons 'host (jabber-xml-get-attribute streamhost 'host))
(cons 'port (jabber-xml-get-attribute streamhost 'port)))
;; (proxy ((xmlns . "http://affinix.com/jabber/stream")))
))
(cdr proxy)))
jabber-socks5-proxies-data)
;; (fast ((xmlns . "http://affinix.com/jabber/stream")))
)
(lexical-let ((fsm fsm))
(lambda (jc xml-data closure-data)
(fsm-send-sync fsm (list :iq xml-data))))
nil
;; TODO: error handling
#'jabber-report-success "SOCKS5 negotiation"))
;; If we're the target, we just wait for an incoming stanza.
(list state-data nil))
(add-to-list 'jabber-iq-set-xmlns-alist
(cons "http://jabber.org/protocol/bytestreams" 'jabber-socks5-process))
(defun jabber-socks5-process (jc xml-data)
"Accept IQ get for SOCKS5 bytestream"
(let* ((jid (jabber-xml-get-attribute xml-data 'from))
(id (jabber-xml-get-attribute xml-data 'id))
(query (jabber-iq-query xml-data))
(sid (jabber-xml-get-attribute query 'sid))
(session (dolist (pending-session jabber-socks5-pending-sessions)
(when (and (equal sid (nth 0 pending-session))
(equal jid (nth 1 pending-session)))
(return pending-session)))))
;; check that we really are expecting this session
(unless session
(jabber-signal-error "auth" 'not-acceptable))
(setq jabber-socks5-pending-sessions (delq session jabber-socks5-pending-sessions))
(fsm-send-sync (nth 2 session) (list :iq xml-data))
;; find streamhost to connect to
;; (let* ((streamhosts (jabber-xml-get-children query 'streamhost))
;; (streamhost (dolist (streamhost streamhosts)
;; (let ((connection (jabber-socks5-connect streamhost sid jid (concat jabber-username "@" jabber-server "/" jabber-resource))))
;; (when connection
;; ;; We select the first streamhost that we are able to connect to.
;; (push (list connection sid jid profile-data-function)
;; jabber-socks5-active-sessions)
;; ;; Now set the filter, for the rest of the output
;; (set-process-filter connection #'jabber-socks5-filter)
;; (set-process-sentinel connection #'jabber-socks5-sentinel)
;; (return streamhost))))))
;; (unless streamhost
;; (jabber-signal-error "cancel" 'item-not-found))
;; ;; tell initiator which streamhost we use
;; (jabber-send-iq jid "result"
;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
;; (streamhost-used ((jid . ,(jabber-xml-get-attribute streamhost 'jid)))))
;; nil nil nil nil id)
;; ;; now, as data is sent, it will be passed to the profile.
;; )
))
(define-state jabber-socks5 initiate (fsm state-data event callback)
(let* ((jc (plist-get state-data :jc))
(jc-data (fsm-get-state-data jc))
(our-jid (concat (plist-get jc-data :username) "@"
(plist-get jc-data :server) "/"
(plist-get jc-data :resource)))
(their-jid (plist-get state-data :jid))
(initiator-jid (if (eq (plist-get state-data :role) :initiator) our-jid their-jid))
(target-jid (if (eq (plist-get state-data :role) :initiator) their-jid our-jid)))
(cond
;; Stray event...
((memq (car-safe event) '(:proxy :info))
(list 'initiate state-data :keep))
;; Incoming IQ
((eq (car-safe event) :iq)
(let ((xml-data (second event)))
;; This is either type "set" (with a list of streamhosts to
;; use), or a "result" (indicating the streamhost finally used
;; by the other party).
(cond
((string= (jabber-xml-get-attribute xml-data 'type) "set")
;; A "set" makes sense if we're the initiator and offered
;; Psi's "fast mode". We don't yet, though, so this is only
;; for target.
(dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost))
(jabber-xml-let-attributes
(jid host port) streamhost
;; This is where we would attempt to support zeroconf
(when (and jid host port)
(start-jabber-socks5-connection
jc initiator-jid target-jid jid
(plist-get state-data :sid) host port fsm))))
(list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30))
((string= (jabber-xml-get-attribute xml-data 'type) "result")
;; The other party has decided what streamhost to use.
(let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid))
;; If JID is our own JID, we have probably already detected
;; what connection to use. But that is a later problem...
(streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data))))
;; Try to connect to all addresses of this proxy...
(dolist (streamhost streamhosts)
(jabber-xml-let-attributes
(jid host port) streamhost
(when (and jid host port)
(start-jabber-socks5-connection
jc initiator-jid target-jid jid
(plist-get state-data :sid) host port fsm)))))
(list 'wait-for-connection state-data 30))))))))
(define-state-machine jabber-socks5-connection
:start
((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm)
"Connect to a single JEP-0065 streamhost."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
;; make-network-process, which we really want, for asynchronous
;; connection and such, was introduced in Emacs 22.
(if (fboundp 'make-network-process)
(let ((connection
(make-network-process
:name "socks5"
:buffer nil
:host host
:service (string-to-number port)
:nowait t
:filter (fsm-make-filter fsm)
:sentinel (fsm-make-sentinel fsm))))
(list 'wait-for-connection
(list :jc jc
:connection connection
:initiator-jid initiator-jid
:target-jid target-jid
:streamhost-jid streamhost-jid
:sid sid
:socks5-fsm socks5-fsm)
30))
;; So we open a stream, and wait for the connection to succeed.
(condition-case nil
(let ((connection
(open-network-stream "socks5" nil
host (string-to-number port))))
(set-process-filter connection (fsm-make-filter fsm))
(set-process-sentinel connection (fsm-make-sentinel fsm))
(list 'authenticate
(list :jc jc
:connection connection
:initiator-jid initiator-jid
:target-jid target-jid
:streamhost-jid streamhost-jid
:sid sid
:socks5-fsm socks5-fsm)
nil))
(error (list 'fail '() nil)))))))
(define-state jabber-socks5-connection wait-for-connection
(fsm state-data event callback)
(cond
((eq (car-safe event) :sentinel)
(let ((string (third event)))
(cond
;; Connection succeeded
((string= (substring string 0 4) "open")
(list 'authenticate state-data nil))
;; Connection failed
(t
(list 'fail state-data nil)))))))
(define-enter-state jabber-socks5-connection authenticate
(fsm state-data)
"Send authenticate command."
;; version: 5. number of auth methods supported: 1.
;; which one: no authentication.
(process-send-string (plist-get state-data :connection) (string 5 1 0))
(list state-data 30))
(define-state jabber-socks5-connection authenticate
(fsm state-data event callback)
"Receive response to authenticate command."
(cond
((eq (car-safe event) :filter)
(let ((string (third event)))
;; should return:
;; version: 5. auth method to use: none
(if (string= string (string 5 0))
;; Authenticated. Send connect command.
(list 'connect state-data nil)
;; Authentication failed...
(delete-process (second event))
(list 'fail state-data nil))))
((eq (car-safe event) :sentinel)
(list 'fail state-data nil))))
(define-enter-state jabber-socks5-connection connect (fsm state-data)
"Send connect command."
(let* ((sid (plist-get state-data :sid))
(initiator (plist-get state-data :initiator-jid))
(target (plist-get state-data :target-jid))
(hash (sha1-string (concat sid initiator target))))
(process-send-string
(plist-get state-data :connection)
(concat (string 5 1 0 3 (length hash))
hash
(string 0 0)))
(list state-data 30)))
(define-state jabber-socks5-connection connect
(fsm state-data event callback)
"Receive response to connect command."
(cond
((eq (car-safe event) :filter)
(let ((string (third event)))
(if (string= (substring string 0 2) (string 5 0))
;; connection established
(progn
(fsm-send (plist-get state-data :socks5-fsm)
(list :connected
(plist-get state-data :connection)
(plist-get state-data :streamhost-jid)))
;; Our work is done
(list 'done nil))
(list 'fail state-data nil))))
((eq (car-safe event) :sentinel)
(list 'fail state-data nil))))
(define-state jabber-socks5-connection done
(fsm state-data event callback)
;; ignore all events
(list 'done nil nil))
(define-enter-state jabber-socks5-connection fail (fsm state-data)
;; Notify parent fsm about failure
(fsm-send (plist-get state-data :socks5-fsm)
:not-connected)
(list nil nil))
(define-state jabber-socks5-connection fail
(fsm state-data event callback)
;; ignore all events
(list 'fail nil nil))
(define-state jabber-socks5 wait-for-connection
(fsm state-data event callback)
(cond
((eq (car-safe event) :connected)
(destructuring-bind (ignored connection streamhost-jid) event
(setq state-data (plist-put state-data :connection connection))
;; If we are expected to tell which streamhost we chose, do so.
(let ((iq-id (plist-get state-data :iq-id)))
(when iq-id
(jabber-send-iq
(plist-get state-data :jc)
(plist-get state-data :jid) "result"
`(query ((xmlns . "http://jabber.org/protocol/bytestreams"))
(streamhost-used ((jid . ,streamhost-jid))))
nil nil nil nil
iq-id)))
;; If we are the initiator, we should activate the bytestream.
(if (eq (plist-get state-data :role) :initiator)
(progn
(jabber-send-iq
(plist-get state-data :jc)
streamhost-jid "set"
`(query ((xmlns . "http://jabber.org/protocol/bytestreams")
(sid . ,(plist-get state-data :sid)))
(activate nil ,(plist-get state-data :jid)))
(lambda (jc xml-data fsm) (fsm-send-sync fsm :activated)) fsm
(lambda (jc xml-data fsm) (fsm-send-sync fsm :activation-failed)) fsm)
(list 'wait-for-activation state-data 10))
;; Otherwise, we just let the data flow.
(list 'stream-activated state-data nil))))
((eq event :not-connected)
;; If we were counting the streamhosts, we would know when there
;; are no more chances left.
(list 'wait-for-connection state-data :keep))
((eq event :timeout)
(list 'fail (plist-put state-data :error "Timeout when connecting to streamhosts") nil))))
(define-state jabber-socks5 wait-for-activation
(fsm state-data event callback)
(cond
((eq event :activated)
(list 'stream-activated state-data nil))
((eq event :activation-failed)
(list 'fail (plist-put state-data :error "Proxy activation failed") nil))
;; Stray events from earlier state
((eq (car-safe event) :connected)
;; We just close the connection
(delete-process (second event))
(list 'wait-for-activation state-data :keep))
((eq event :not-connected)
(list 'wait-for-activation state-data :keep))))
(define-enter-state jabber-socks5 stream-activated
(fsm state-data)
(let ((connection (plist-get state-data :connection))
(jc (plist-get state-data :jc))
(jid (plist-get state-data :jid))
(sid (plist-get state-data :sid))
(profile-function (plist-get state-data :profile-function)))
(set-process-filter connection (fsm-make-filter fsm))
(set-process-sentinel connection (fsm-make-sentinel fsm))
;; Call the profile function, passing the data send function, and
;; receiving the data receiving function. Put the data receiving
;; function in the plist.
(list (plist-put state-data
:profile-data-function
(funcall profile-function
jc jid sid
(lexical-let ((fsm fsm))
(lambda (data)
(fsm-send fsm (list :send data))))))
nil)))
(define-state jabber-socks5 stream-activated
(fsm state-data event callback)
(let ((jc (plist-get state-data :jc))
(connection (plist-get state-data :connection))
(profile-data-function (plist-get state-data :profile-data-function))
(sid (plist-get state-data :sid))
(jid (plist-get state-data :jid)))
(cond
((eq (car-safe event) :send)
(process-send-string connection (second event))
(list 'stream-activated state-data nil))
((eq (car-safe event) :filter)
;; Pass data from connection to profile data function
;; If the data function requests it, tear down the connection.
(unless (funcall profile-data-function jc jid sid (third event))
(fsm-send fsm (list :sentinel (second event) "shutdown")))
(list 'stream-activated state-data nil))
((eq (car-safe event) :sentinel)
;; Connection terminated. Shuffle together the remaining data,
;; and kill the buffer.
(delete-process (second event))
(funcall profile-data-function jc jid sid nil)
(list 'closed nil nil))
;; Stray events from earlier state
((eq (car-safe event) :connected)
;; We just close the connection
(delete-process (second event))
(list 'stream-activated state-data nil))
((eq event :not-connected)
(list 'stream-activated state-data nil)))))
(define-enter-state jabber-socks5 fail (fsm state-data)
"Tell our caller that we failed."
(let ((jc (plist-get state-data :jc))
(jid (plist-get state-data :jid))
(sid (plist-get state-data :sid))
(profile-function (plist-get state-data :profile-function))
(iq-id (plist-get state-data :iq-id)))
(funcall profile-function jc jid sid (plist-get state-data :error))
(when iq-id
(jabber-send-iq-error jc jid iq-id nil "cancel"
'remote-server-not-found)))
(list nil nil))
(defun jabber-socks5-client-1 (jc jid sid profile-function)
"Negotiate a SOCKS5 connection with JID.
This function simply starts a state machine."
(add-to-list 'jabber-socks5-pending-sessions
(list sid jid (start-jabber-socks5 jc jid sid profile-function :initiator))))
;; (defun jabber-socks5-client-2 (xml-data jid sid profile-function)
;; "Contact has selected a streamhost to use. Connect to the proxy."
;; (let* ((query (jabber-iq-query xml-data))
;; (streamhost-used (car (jabber-xml-get-children query 'streamhost-used)))
;; (proxy-used (jabber-xml-get-attribute streamhost-used 'jid))
;; connection)
;; (let ((streamhosts-left (cdr (assoc proxy-used jabber-socks5-proxies-data))))
;; (while (and streamhosts-left (not connection))
;; (setq connection
;; (jabber-socks5-connect (car streamhosts-left)
;; sid
;; (concat jabber-username "@" jabber-server "/" jabber-resource)
;; jid))
;; (setq streamhosts-left (cdr streamhosts-left))))
;; (unless connection
;; (error "Couldn't connect to proxy %s" proxy-used))
;; ;; Activation is only needed for proxies.
;; (jabber-send-iq proxy-used "set"
;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams")
;; (sid . ,sid))
;; (activate () ,jid))
;; (lexical-let ((jid jid) (sid sid) (profile-function profile-function)
;; (connection connection))
;; (lambda (xml-data closure-data)
;; (jabber-socks5-client-3 xml-data jid sid profile-function connection))) nil
;; ;; TODO: report error to contact?
;; #'jabber-report-success "Proxy activation")))
;; (defun jabber-socks5-client-3 (xml-data jid sid profile-function proxy-connection)
;; "Proxy is activated. Start the transfer."
;; ;; The response from the proxy does not contain any interesting
;; ;; information, beyond success confirmation.
;; (funcall profile-function jid sid
;; (lexical-let ((proxy-connection proxy-connection))
;; (lambda (data)
;; (process-send-string proxy-connection data)))))
(provide 'jabber-socks5)
;;; arch-tag: 9e70dfea-2522-40c6-a79f-302c8fb82ac5

Some files were not shown because too many files have changed in this diff Show More