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-19 02:25:33 +05:00
parent b39b3c4edf
commit f8c1c1396a
259 changed files with 1 additions and 88440 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
elpa/exwm-0.24.signed
View File

@ -1 +0,0 @@
Good signature from 066DAFCB81E42C40 GNU ELPA Signing Agent (2019) <elpasign@elpa.gnu.org> (trust undefined) created at 2020-05-25T02:05:01+0500 using RSA

1
elpa/exwm-0.24/.elpaignore
View File

@ -1 +0,0 @@
README.md

4448
elpa/exwm-0.24/ChangeLog
View File

File diff suppressed because it is too large Load Diff

315
elpa/exwm-0.24/exwm-autoloads.el
View File

@ -1,315 +0,0 @@
;;; exwm-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 "exwm" "exwm.el" (0 0 0 0))
;;; Generated autoloads from exwm.el
(autoload 'exwm-restart "exwm" "\
Restart EXWM." t nil)
(autoload 'exwm-init "exwm" "\
Initialize EXWM.
\(fn &optional FRAME)" t nil)
(autoload 'exwm-exit "exwm" "\
Exit EXWM." t nil)
(autoload 'exwm-enable "exwm" "\
Enable/Disable EXWM.
\(fn &optional UNDO)" nil nil)
(register-definition-prefixes "exwm" '("exwm-"))
;;;***
;;;### (autoloads nil "exwm-cm" "exwm-cm.el" (0 0 0 0))
;;; Generated autoloads from exwm-cm.el
(register-definition-prefixes "exwm-cm" '("exwm-cm-"))
;;;***
;;;### (autoloads nil "exwm-config" "exwm-config.el" (0 0 0 0))
;;; Generated autoloads from exwm-config.el
(register-definition-prefixes "exwm-config" '("exwm-config-"))
;;;***
;;;### (autoloads nil "exwm-core" "exwm-core.el" (0 0 0 0))
;;; Generated autoloads from exwm-core.el
(register-definition-prefixes "exwm-core" '("exwm-"))
;;;***
;;;### (autoloads nil "exwm-floating" "exwm-floating.el" (0 0 0 0))
;;; Generated autoloads from exwm-floating.el
(autoload 'exwm-floating-toggle-floating "exwm-floating" "\
Toggle the current window between floating and non-floating states." t nil)
(autoload 'exwm-floating-hide "exwm-floating" "\
Hide the current floating X window (which would show again when selected)." t nil)
(register-definition-prefixes "exwm-floating" '("exwm-floating-"))
;;;***
;;;### (autoloads nil "exwm-input" "exwm-input.el" (0 0 0 0))
;;; Generated autoloads from exwm-input.el
(autoload 'exwm-input-set-key "exwm-input" "\
Set a global key binding.
The new key binding only takes effect in real time when this command is
called interactively, and is lost when this session ends unless it's
specifically saved in the Customize interface for `exwm-input-global-keys'.
In configuration you should customize or set `exwm-input-global-keys'
instead.
\(fn KEY COMMAND)" t nil)
(autoload 'exwm-input-grab-keyboard "exwm-input" "\
Switch to line-mode.
\(fn &optional ID)" t nil)
(autoload 'exwm-input-release-keyboard "exwm-input" "\
Switch to char-mode.
\(fn &optional ID)" t nil)
(autoload 'exwm-input-toggle-keyboard "exwm-input" "\
Toggle between 'line-mode' and 'char-mode'.
\(fn &optional ID)" t nil)
(autoload 'exwm-input-send-next-key "exwm-input" "\
Send next key to client window.
EXWM will prompt for the key to send. This command can be prefixed to send
multiple keys. If END-KEY is non-nil, stop sending keys if it's pressed.
\(fn TIMES &optional END-KEY)" t nil)
(autoload 'exwm-input-set-simulation-key "exwm-input" "\
Set a simulation key.
The simulation key takes effect in real time, but is lost when this session
ends unless it's specifically saved in the Customize interface for
`exwm-input-simulation-keys'.
\(fn ORIGINAL-KEY SIMULATED-KEY)" t nil)
(autoload 'exwm-input-send-simulation-key "exwm-input" "\
Fake a key event according to the last input key sequence.
\(fn TIMES)" t nil)
(autoload 'exwm-input-invoke-factory "exwm-input" "\
Make a command that invokes KEYS when called.
One use is to access the keymap bound to KEYS (as prefix keys) in char-mode.
\(fn KEYS)" nil t)
(register-definition-prefixes "exwm-input" '("exwm-input-"))
;;;***
;;;### (autoloads nil "exwm-layout" "exwm-layout.el" (0 0 0 0))
;;; Generated autoloads from exwm-layout.el
(autoload 'exwm-layout-set-fullscreen "exwm-layout" "\
Make window ID fullscreen.
\(fn &optional ID)" t nil)
(autoload 'exwm-layout-unset-fullscreen "exwm-layout" "\
Restore window from fullscreen state.
\(fn &optional ID)" t nil)
(autoload 'exwm-layout-toggle-fullscreen "exwm-layout" "\
Toggle fullscreen mode.
\(fn &optional ID)" t nil)
(autoload 'exwm-layout-enlarge-window "exwm-layout" "\
Make the selected window DELTA pixels taller.
If no argument is given, make the selected window one pixel taller. If the
optional argument HORIZONTAL is non-nil, make selected window DELTA pixels
wider. If DELTA is negative, shrink selected window by -DELTA pixels.
Normal hints are checked and regarded if the selected window is displaying an
`exwm-mode' buffer. However, this may violate the normal hints set on other X
windows.
\(fn DELTA &optional HORIZONTAL)" t nil)
(autoload 'exwm-layout-enlarge-window-horizontally "exwm-layout" "\
Make the selected window DELTA pixels wider.
See also `exwm-layout-enlarge-window'.
\(fn DELTA)" t nil)
(autoload 'exwm-layout-shrink-window "exwm-layout" "\
Make the selected window DELTA pixels lower.
See also `exwm-layout-enlarge-window'.
\(fn DELTA)" t nil)
(autoload 'exwm-layout-shrink-window-horizontally "exwm-layout" "\
Make the selected window DELTA pixels narrower.
See also `exwm-layout-enlarge-window'.
\(fn DELTA)" t nil)
(autoload 'exwm-layout-hide-mode-line "exwm-layout" "\
Hide mode-line." t nil)
(autoload 'exwm-layout-show-mode-line "exwm-layout" "\
Show mode-line." t nil)
(autoload 'exwm-layout-toggle-mode-line "exwm-layout" "\
Toggle the display of mode-line." t nil)
(register-definition-prefixes "exwm-layout" '("exwm-layout-"))
;;;***
;;;### (autoloads nil "exwm-manage" "exwm-manage.el" (0 0 0 0))
;;; Generated autoloads from exwm-manage.el
(register-definition-prefixes "exwm-manage" '("exwm-manage-"))
;;;***
;;;### (autoloads nil "exwm-randr" "exwm-randr.el" (0 0 0 0))
;;; Generated autoloads from exwm-randr.el
(autoload 'exwm-randr-refresh "exwm-randr" "\
Refresh workspaces according to the updated RandR info." t nil)
(register-definition-prefixes "exwm-randr" '("exwm-randr-"))
;;;***
;;;### (autoloads nil "exwm-systemtray" "exwm-systemtray.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from exwm-systemtray.el
(register-definition-prefixes "exwm-systemtray" '("exwm-systemtray-" "xcb:systemtray:-ClientMessage"))
;;;***
;;;### (autoloads nil "exwm-workspace" "exwm-workspace.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from exwm-workspace.el
(autoload 'exwm-workspace--get-geometry "exwm-workspace" "\
Return the geometry of frame FRAME.
\(fn FRAME)" nil nil)
(autoload 'exwm-workspace--current-height "exwm-workspace" "\
Return the height of current workspace." nil nil)
(autoload 'exwm-workspace--minibuffer-own-frame-p "exwm-workspace" "\
Reports whether the minibuffer is displayed in its own frame." nil nil)
(autoload 'exwm-workspace-switch "exwm-workspace" "\
Switch to workspace INDEX (0-based).
Query for the index if not specified when called interactively. Passing a
workspace frame as the first option or making use of the rest options are
for internal use only.
\(fn FRAME-OR-INDEX &optional FORCE)" t nil)
(autoload 'exwm-workspace-switch-create "exwm-workspace" "\
Switch to workspace INDEX or creating it first if it does not exist yet.
Passing a workspace frame as the first option is for internal use only.
\(fn FRAME-OR-INDEX)" t nil)
(autoload 'exwm-workspace-swap "exwm-workspace" "\
Interchange position of WORKSPACE1 with that of WORKSPACE2.
\(fn WORKSPACE1 WORKSPACE2)" t nil)
(autoload 'exwm-workspace-move "exwm-workspace" "\
Move WORKSPACE to the NTH position.
When called interactively, prompt for a workspace and move current one just
before it.
\(fn WORKSPACE NTH)" t nil)
(autoload 'exwm-workspace-add "exwm-workspace" "\
Add a workspace as the INDEX-th workspace, or the last one if INDEX is nil.
INDEX must not exceed the current number of workspaces.
\(fn &optional INDEX)" t nil)
(autoload 'exwm-workspace-delete "exwm-workspace" "\
Delete the workspace FRAME-OR-INDEX.
\(fn &optional FRAME-OR-INDEX)" t nil)
(autoload 'exwm-workspace-move-window "exwm-workspace" "\
Move window ID to workspace FRAME-OR-INDEX.
\(fn FRAME-OR-INDEX &optional ID)" t nil)
(autoload 'exwm-workspace-switch-to-buffer "exwm-workspace" "\
Make the current Emacs window display another buffer.
\(fn BUFFER-OR-NAME)" t nil)
(autoload 'exwm-workspace-attach-minibuffer "exwm-workspace" "\
Attach the minibuffer so that it always shows." t nil)
(autoload 'exwm-workspace-detach-minibuffer "exwm-workspace" "\
Detach the minibuffer so that it automatically hides." t nil)
(autoload 'exwm-workspace-toggle-minibuffer "exwm-workspace" "\
Attach the minibuffer if it's detached, or detach it if it's attached." t nil)
(register-definition-prefixes "exwm-workspace" '("exwm-workspace-"))
;;;***
;;;### (autoloads nil "exwm-xim" "exwm-xim.el" (0 0 0 0))
;;; Generated autoloads from exwm-xim.el
(register-definition-prefixes "exwm-xim" '("exwm-xim-"))
;;;***
;;;### (autoloads nil nil ("exwm-pkg.el") (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; exwm-autoloads.el ends here

50
elpa/exwm-0.24/exwm-cm.el
View File

@ -1,50 +0,0 @@
;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2016-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module is obsolete since EXWM now supports third-party compositors.
;;; Code:
(make-obsolete-variable 'exwm-cm-opacity
"This variable should no longer be used." "26")
(defun exwm-cm-set-opacity (&rest _args)
(declare (obsolete nil "26")))
(defun exwm-cm-enable ()
(declare (obsolete nil "26")))
(defun exwm-cm-start ()
(declare (obsolete nil "26")))
(defun exwm-cm-stop ()
(declare (obsolete nil "26")))
(defun exwm-cm-toggle ()
(declare (obsolete nil "26")))
(provide 'exwm-cm)
;;; exwm-cm.el ends here

BIN
elpa/exwm-0.24/exwm-cm.elc
View File

Binary file not shown.

131
elpa/exwm-0.24/exwm-config.el
View File

@ -1,131 +0,0 @@
;;; exwm-config.el --- Predefined configurations -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module contains typical (yet minimal) configurations of EXWM.
;;; Code:
(require 'exwm)
(require 'ido)
(define-obsolete-function-alias 'exwm-config-default
#'exwm-config-example "27.1")
(defun exwm-config-example ()
"Default configuration of EXWM."
;; Set the initial workspace number.
(unless (get 'exwm-workspace-number 'saved-value)
(setq exwm-workspace-number 4))
;; Make class name the buffer name
(add-hook 'exwm-update-class-hook
(lambda ()
(exwm-workspace-rename-buffer exwm-class-name)))
;; Global keybindings.
(unless (get 'exwm-input-global-keys 'saved-value)
(setq exwm-input-global-keys
`(
;; 's-r': Reset (to line-mode).
([?\s-r] . exwm-reset)
;; 's-w': Switch workspace.
([?\s-w] . exwm-workspace-switch)
;; 's-&': Launch application.
([?\s-&] . (lambda (command)
(interactive (list (read-shell-command "$ ")))
(start-process-shell-command command nil command)))
;; 's-N': Switch to certain workspace.
,@(mapcar (lambda (i)
`(,(kbd (format "s-%d" i)) .
(lambda ()
(interactive)
(exwm-workspace-switch-create ,i))))
(number-sequence 0 9)))))
;; Line-editing shortcuts
(unless (get 'exwm-input-simulation-keys 'saved-value)
(setq exwm-input-simulation-keys
'(([?\C-b] . [left])
([?\C-f] . [right])
([?\C-p] . [up])
([?\C-n] . [down])
([?\C-a] . [home])
([?\C-e] . [end])
([?\M-v] . [prior])
([?\C-v] . [next])
([?\C-d] . [delete])
([?\C-k] . [S-end delete]))))
;; Enable EXWM
(exwm-enable)
;; Configure Ido
(exwm-config-ido)
;; Other configurations
(exwm-config-misc))
(defun exwm-config--fix/ido-buffer-window-other-frame ()
"Fix `ido-buffer-window-other-frame'."
(defalias 'exwm-config-ido-buffer-window-other-frame
(symbol-function #'ido-buffer-window-other-frame))
(defun ido-buffer-window-other-frame (buffer)
"This is a version redefined by EXWM.
You can find the original one at `exwm-config-ido-buffer-window-other-frame'."
(with-current-buffer (window-buffer (selected-window))
(if (and (derived-mode-p 'exwm-mode)
exwm--floating-frame)
;; Switch from a floating frame.
(with-current-buffer buffer
(if (and (derived-mode-p 'exwm-mode)
exwm--floating-frame
(eq exwm--frame exwm-workspace--current))
;; Switch to another floating frame.
(frame-root-window exwm--floating-frame)
;; Do not switch if the buffer is not on the current workspace.
(or (get-buffer-window buffer exwm-workspace--current)
(selected-window))))
(with-current-buffer buffer
(when (derived-mode-p 'exwm-mode)
(if (eq exwm--frame exwm-workspace--current)
(when exwm--floating-frame
;; Switch to a floating frame on the current workspace.
(frame-selected-window exwm--floating-frame))
;; Do not switch to exwm-mode buffers on other workspace (which
;; won't work unless `exwm-layout-show-all-buffers' is set)
(unless exwm-layout-show-all-buffers
(selected-window)))))))))
(defun exwm-config-ido ()
"Configure Ido to work with EXWM."
(ido-mode 1)
(add-hook 'exwm-init-hook #'exwm-config--fix/ido-buffer-window-other-frame))
(defun exwm-config-misc ()
"Other configurations."
;; Make more room
(menu-bar-mode -1)
(tool-bar-mode -1)
(scroll-bar-mode -1)
(fringe-mode 1))
(provide 'exwm-config)
;;; exwm-config.el ends here

BIN
elpa/exwm-0.24/exwm-config.elc
View File

Binary file not shown.

375
elpa/exwm-0.24/exwm-core.el
View File

@ -1,375 +0,0 @@
;;; exwm-core.el --- Core definitions -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module includes core definitions of variables, macros, functions, etc
;; shared by various other modules.
;;; Code:
(require 'kmacro)
(require 'xcb)
(require 'xcb-icccm)
(require 'xcb-ewmh)
(require 'xcb-debug)
(defcustom exwm-debug-log-time-function #'exwm-debug-log-uptime
"Function used for generating timestamps in `exwm-debug' logs.
Here are some predefined candidates:
`exwm-debug-log-uptime': Display the uptime of this Emacs instance.
`exwm-debug-log-time': Display time of day.
`nil': Disable timestamp."
:group 'exwm-debug
:type `(choice (const :tag "Emacs uptime" ,#'exwm-debug-log-uptime)
(const :tag "Time of day" ,#'exwm-debug-log-time)
(const :tag "Off" nil)
(function :tag "Other"))
:set (lambda (symbol value)
(set-default symbol value)
;; Also change the format for XELB to make logs consistent
;; (as they share the same buffer).
(setq xcb-debug:log-time-function value)))
(defalias 'exwm-debug-log-uptime 'xcb-debug:log-uptime
"Add uptime to `exwm-debug' logs.")
(defalias 'exwm-debug-log-time 'xcb-debug:log-time
"Add time of day to `exwm-debug' logs.")
(defvar exwm--connection nil "X connection.")
(defvar exwm--wmsn-window nil
"An X window owning the WM_S0 selection.")
(defvar exwm--wmsn-acquire-timeout 3
"Number of seconds to wait for other window managers to release the selection.")
(defvar exwm--guide-window nil
"An X window separating workspaces and X windows.")
(defvar exwm--id-buffer-alist nil "Alist of (<X window ID> . <Emacs buffer>).")
(defvar exwm--root nil "Root window.")
(defvar exwm-input--global-prefix-keys)
(defvar exwm-input--simulation-keys)
(defvar exwm-input-line-mode-passthrough)
(defvar exwm-input-prefix-keys)
(declare-function exwm-input--fake-key "exwm-input.el" (event))
(declare-function exwm-input--on-KeyPress-line-mode "exwm-input.el"
(key-press raw-data))
(declare-function exwm-floating-hide "exwm-floating.el")
(declare-function exwm-floating-toggle-floating "exwm-floating.el")
(declare-function exwm-input-release-keyboard "exwm-input.el")
(declare-function exwm-input-send-next-key "exwm-input.el" (times))
(declare-function exwm-layout-set-fullscreen "exwm-layout.el" (&optional id))
(declare-function exwm-layout-toggle-mode-line "exwm-layout.el")
(declare-function exwm-manage--kill-buffer-query-function "exwm-manage.el")
(declare-function exwm-workspace-move-window "exwm-workspace.el"
(frame-or-index &optional id))
(define-minor-mode exwm-debug
"Debug-logging enabled if non-nil"
:global t)
(defmacro exwm--debug (&rest forms)
(when exwm-debug `(progn ,@forms)))
(defmacro exwm--log (&optional format-string &rest objects)
"Emit a message prepending the name of the function being executed.
FORMAT-STRING is a string specifying the message to output, as in
`format'. The OBJECTS arguments specify the substitutions."
(unless format-string (setq format-string ""))
`(when exwm-debug
(xcb-debug:message ,(concat "%s%s:\t" format-string "\n")
(if exwm-debug-log-time-function
(funcall exwm-debug-log-time-function)
"")
(xcb-debug:compile-time-function-name)
,@objects)
nil))
(defsubst exwm--id->buffer (id)
"X window ID => Emacs buffer."
(cdr (assoc id exwm--id-buffer-alist)))
(defsubst exwm--buffer->id (buffer)
"Emacs buffer BUFFER => X window ID."
(car (rassoc buffer exwm--id-buffer-alist)))
(defun exwm--lock (&rest _args)
"Lock (disable all events)."
(exwm--log)
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window exwm--root
:value-mask xcb:CW:EventMask
:event-mask xcb:EventMask:NoEvent))
(xcb:flush exwm--connection))
(defun exwm--unlock (&rest _args)
"Unlock (enable all events)."
(exwm--log)
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window exwm--root
:value-mask xcb:CW:EventMask
:event-mask (eval-when-compile
(logior xcb:EventMask:SubstructureRedirect
xcb:EventMask:StructureNotify))))
(xcb:flush exwm--connection))
(defun exwm--set-geometry (xwin x y width height)
"Set the geometry of X window XWIN to WIDTHxHEIGHT+X+Y.
Nil can be passed as placeholder."
(exwm--log "Setting #x%x to %sx%s+%s+%s" xwin width height x y)
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window xwin
:value-mask (logior (if x xcb:ConfigWindow:X 0)
(if y xcb:ConfigWindow:Y 0)
(if width xcb:ConfigWindow:Width 0)
(if height xcb:ConfigWindow:Height 0))
:x x :y y :width width :height height)))
(defun exwm--intern-atom (atom)
"Intern X11 ATOM."
(slot-value (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:InternAtom
:only-if-exists 0
:name-len (length atom)
:name atom))
'atom))
(defmacro exwm--defer (secs function &rest args)
"Defer the execution of FUNCTION.
The action is to call FUNCTION with arguments ARGS. If Emacs is not idle,
defer the action until Emacs is idle. Otherwise, defer the action until at
least SECS seconds later."
`(run-with-idle-timer (+ (float-time (or (current-idle-time)
(seconds-to-time (- ,secs))))
,secs)
nil
,function
,@args))
(defun exwm--get-client-event-mask ()
"Return event mask set on all managed windows."
(logior xcb:EventMask:StructureNotify
xcb:EventMask:PropertyChange
(if mouse-autoselect-window
xcb:EventMask:EnterWindow 0)))
(defun exwm--color->pixel (color)
"Convert COLOR to PIXEL (index in TrueColor colormap)."
(when (and color
(eq (x-display-visual-class) 'true-color))
(let ((rgb (x-color-values color)))
(logior (lsh (lsh (pop rgb) -8) 16)
(lsh (lsh (pop rgb) -8) 8)
(lsh (pop rgb) -8)))))
;; Internal variables
(defvar-local exwm--id nil) ;window ID
(defvar-local exwm--configurations nil) ;initial configurations.
(defvar-local exwm--frame nil) ;workspace frame
(defvar-local exwm--floating-frame nil) ;floating frame
(defvar-local exwm--mode-line-format nil) ;save mode-line-format
(defvar-local exwm--floating-frame-position nil) ;set when hidden.
(defvar-local exwm--fixed-size nil) ;fixed size
(defvar-local exwm--selected-input-mode 'line-mode
"Input mode as selected by the user.
One of `line-mode' or `char-mode'.")
(defvar-local exwm--input-mode 'line-mode
"Actual input mode, i.e. whether mouse and keyboard are grabbed.")
;; Properties
(defvar-local exwm--desktop nil "_NET_WM_DESKTOP.")
(defvar-local exwm-window-type nil "_NET_WM_WINDOW_TYPE.")
(defvar-local exwm--geometry nil)
(defvar-local exwm-class-name nil "Class name in WM_CLASS.")
(defvar-local exwm-instance-name nil "Instance name in WM_CLASS.")
(defvar-local exwm-title nil "Window title (either _NET_WM_NAME or WM_NAME)")
(defvar-local exwm--title-is-utf8 nil)
(defvar-local exwm-transient-for nil "WM_TRANSIENT_FOR.")
(defvar-local exwm--protocols nil)
(defvar-local exwm-state xcb:icccm:WM_STATE:NormalState "WM_STATE.")
(defvar-local exwm--ewmh-state nil "_NET_WM_STATE.")
;; _NET_WM_NORMAL_HINTS
(defvar-local exwm--normal-hints-x nil)
(defvar-local exwm--normal-hints-y nil)
(defvar-local exwm--normal-hints-width nil)
(defvar-local exwm--normal-hints-height nil)
(defvar-local exwm--normal-hints-min-width nil)
(defvar-local exwm--normal-hints-min-height nil)
(defvar-local exwm--normal-hints-max-width nil)
(defvar-local exwm--normal-hints-max-height nil)
;; (defvar-local exwm--normal-hints-win-gravity nil)
;; WM_HINTS
(defvar-local exwm--hints-input nil)
(defvar-local exwm--hints-urgency nil)
;; _MOTIF_WM_HINTS
(defvar-local exwm--mwm-hints-decorations t)
(defvar exwm-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-d\C-l" #'xcb-debug:clear)
(define-key map "\C-c\C-d\C-m" #'xcb-debug:mark)
(define-key map "\C-c\C-d\C-t" #'exwm-debug)
(define-key map "\C-c\C-f" #'exwm-layout-set-fullscreen)
(define-key map "\C-c\C-h" #'exwm-floating-hide)
(define-key map "\C-c\C-k" #'exwm-input-release-keyboard)
(define-key map "\C-c\C-m" #'exwm-workspace-move-window)
(define-key map "\C-c\C-q" #'exwm-input-send-next-key)
(define-key map "\C-c\C-t\C-f" #'exwm-floating-toggle-floating)
(define-key map "\C-c\C-t\C-m" #'exwm-layout-toggle-mode-line)
map)
"Keymap for `exwm-mode'.")
(defvar exwm--kmacro-map
(let ((map (make-sparse-keymap)))
(define-key map [t]
(lambda ()
(interactive)
(cond
((or exwm-input-line-mode-passthrough
;; Do not test `exwm-input--during-command'.
(active-minibuffer-window)
(memq last-input-event exwm-input--global-prefix-keys)
(memq last-input-event exwm-input-prefix-keys)
(lookup-key exwm-mode-map (vector last-input-event))
(gethash last-input-event exwm-input--simulation-keys))
(set-transient-map (make-composed-keymap (list exwm-mode-map
global-map)))
(push last-input-event unread-command-events))
(t
(exwm-input--fake-key last-input-event)))))
map)
"Keymap used when executing keyboard macros.")
;; This menu mainly acts as an reminder for users. Thus it should be as
;; detailed as possible, even some entries do not make much sense here.
;; Also, inactive entries should be disabled rather than hidden.
(easy-menu-define exwm-mode-menu exwm-mode-map
"Menu for `exwm-mode'."
'("EXWM"
"---"
"*General*"
"---"
["Toggle floating" exwm-floating-toggle-floating]
["Toggle fullscreen mode" exwm-layout-toggle-fullscreen]
["Hide window" exwm-floating-hide exwm--floating-frame]
["Close window" (kill-buffer (current-buffer))]
"---"
"*Resizing*"
"---"
["Toggle mode-line" exwm-layout-toggle-mode-line]
["Enlarge window vertically" exwm-layout-enlarge-window]
["Enlarge window horizontally" exwm-layout-enlarge-window-horizontally]
["Shrink window vertically" exwm-layout-shrink-window]
["Shrink window horizontally" exwm-layout-shrink-window-horizontally]
"---"
"*Keyboard*"
"---"
["Toggle keyboard mode" exwm-input-toggle-keyboard]
["Send key" exwm-input-send-next-key (eq exwm--input-mode 'line-mode)]
;; This is merely a reference.
("Send simulation key" :filter
(lambda (&rest _args)
(let (result)
(maphash
(lambda (key value)
(when (sequencep key)
(setq result (append result
`([
,(format "Send '%s'"
(key-description value))
(lambda ()
(interactive)
(dolist (i ',value)
(exwm-input--fake-key i)))
:keys ,(key-description key)])))))
exwm-input--simulation-keys)
result)))
["Define global binding" exwm-input-set-key]
"---"
"*Workspace*"
"---"
["Add workspace" exwm-workspace-add]
["Delete current workspace" exwm-workspace-delete]
["Move workspace to" exwm-workspace-move]
["Swap workspaces" exwm-workspace-swap]
["Move X window to" exwm-workspace-move-window]
["Move X window from" exwm-workspace-switch-to-buffer]
["Toggle minibuffer" exwm-workspace-toggle-minibuffer]
["Switch workspace" exwm-workspace-switch]
;; Place this entry at bottom to avoid selecting others by accident.
("Switch to" :filter
(lambda (&rest _args)
(mapcar (lambda (i)
`[,(format "Workspace %d" i)
(lambda ()
(interactive)
(exwm-workspace-switch ,i))
(/= ,i exwm-workspace-current-index)])
(number-sequence 0 (1- (exwm-workspace--count))))))))
(define-derived-mode exwm-mode nil "EXWM"
"Major mode for managing X windows.
\\{exwm-mode-map}"
;;
(setq mode-name
'(:eval (propertize "EXWM" 'face
(when (cl-some (lambda (i)
(frame-parameter i 'exwm-urgency))
exwm-workspace--list)
'font-lock-warning-face))))
;; Change major-mode is not allowed
(add-hook 'change-major-mode-hook #'kill-buffer nil t)
;; Kill buffer -> close window
(add-hook 'kill-buffer-query-functions
#'exwm-manage--kill-buffer-query-function nil t)
;; Redirect events when executing keyboard macros.
(push `(executing-kbd-macro . ,exwm--kmacro-map)
minor-mode-overriding-map-alist)
(setq buffer-read-only t
cursor-type nil
left-margin-width nil
right-margin-width nil
left-fringe-width 0
right-fringe-width 0
vertical-scroll-bar nil))
(provide 'exwm-core)
;;; exwm-core.el ends here

BIN
elpa/exwm-0.24/exwm-core.elc
View File

Binary file not shown.

783
elpa/exwm-0.24/exwm-floating.el
View File

@ -1,783 +0,0 @@
;;; exwm-floating.el --- Floating Module for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module deals with the conversion between floating and non-floating
;; states and implements moving/resizing operations on floating windows.
;;; Code:
(require 'xcb-cursor)
(require 'exwm-core)
(defgroup exwm-floating nil
"Floating."
:version "25.3"
:group 'exwm)
(defcustom exwm-floating-setup-hook nil
"Normal hook run when an X window has been made floating, in the
context of the corresponding buffer."
:type 'hook)
(defcustom exwm-floating-exit-hook nil
"Normal hook run when an X window has exited floating state, in the
context of the corresponding buffer."
:type 'hook)
(defcustom exwm-floating-border-color "navy"
"Border color of floating windows."
:type 'color
:initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
;; Change border color for all floating X windows.
(when exwm--connection
(let ((border-pixel (exwm--color->pixel value)))
(when border-pixel
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when exwm--floating-frame
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window
(frame-parameter exwm--floating-frame
'exwm-container)
:value-mask xcb:CW:BorderPixel
:border-pixel border-pixel)))))
(xcb:flush exwm--connection))))))
(defcustom exwm-floating-border-width 1
"Border width of floating windows."
:type '(integer
:validate (lambda (widget)
(when (< (widget-value widget) 0)
(widget-put widget :error "Border width is at least 0")
widget)))
:initialize #'custom-initialize-default
:set (lambda (symbol value)
(let ((delta (- value exwm-floating-border-width))
container)
(set-default symbol value)
;; Change border width for all floating X windows.
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when exwm--floating-frame
(setq container (frame-parameter exwm--floating-frame
'exwm-container))
(with-slots (x y)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry
:drawable container))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window container
:value-mask
(logior xcb:ConfigWindow:X
xcb:ConfigWindow:Y
xcb:ConfigWindow:BorderWidth)
:border-width value
:x (- x delta)
:y (- y delta)))))))
(when exwm--connection
(xcb:flush exwm--connection)))))
;; Cursors for moving/resizing a window
(defvar exwm-floating--cursor-move nil)
(defvar exwm-floating--cursor-top-left nil)
(defvar exwm-floating--cursor-top nil)
(defvar exwm-floating--cursor-top-right nil)
(defvar exwm-floating--cursor-right nil)
(defvar exwm-floating--cursor-bottom-right nil)
(defvar exwm-floating--cursor-bottom nil)
(defvar exwm-floating--cursor-bottom-left nil)
(defvar exwm-floating--cursor-left nil)
(defvar exwm-floating--moveresize-calculate nil
"Calculate move/resize parameters [buffer event-mask x y width height].")
(defvar exwm-workspace--current)
(defvar exwm-workspace--frame-y-offset)
(defvar exwm-workspace--window-y-offset)
(defvar exwm-workspace--workareas)
(declare-function exwm-layout--hide "exwm-layout.el" (id))
(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id))
(declare-function exwm-layout--refresh "exwm-layout.el" ())
(declare-function exwm-layout--show "exwm-layout.el" (id &optional window))
(declare-function exwm-workspace--position "exwm-workspace.el" (frame))
(declare-function exwm-workspace--update-offsets "exwm-workspace.el" ())
(defun exwm-floating--set-allowed-actions (id tilling)
"Set _NET_WM_ALLOWED_ACTIONS."
(exwm--log "#x%x" id)
(xcb:+request exwm--connection
(make-instance 'xcb:ewmh:set-_NET_WM_ALLOWED_ACTIONS
:window id
:data (if tilling
(vector xcb:Atom:_NET_WM_ACTION_MINIMIZE
xcb:Atom:_NET_WM_ACTION_FULLSCREEN
xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP
xcb:Atom:_NET_WM_ACTION_CLOSE)
(vector xcb:Atom:_NET_WM_ACTION_MOVE
xcb:Atom:_NET_WM_ACTION_RESIZE
xcb:Atom:_NET_WM_ACTION_MINIMIZE
xcb:Atom:_NET_WM_ACTION_FULLSCREEN
xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP
xcb:Atom:_NET_WM_ACTION_CLOSE)))))
(defun exwm-floating--set-floating (id)
"Make window ID floating."
(let ((window (get-buffer-window (exwm--id->buffer id))))
(when window
;; Hide the non-floating X window first.
(set-window-buffer window (other-buffer nil t))))
(let* ((original-frame (buffer-local-value 'exwm--frame
(exwm--id->buffer id)))
;; Create new frame
(frame (with-current-buffer
(or (get-buffer "*scratch*")
(progn
(set-buffer-major-mode
(get-buffer-create "*scratch*"))
(get-buffer "*scratch*")))
(make-frame
`((minibuffer . ,(minibuffer-window exwm--frame))
(left . ,(* window-min-width -10000))
(top . ,(* window-min-height -10000))
(width . ,window-min-width)
(height . ,window-min-height)
(unsplittable . t))))) ;and fix the size later
(outer-id (string-to-number (frame-parameter frame 'outer-window-id)))
(window-id (string-to-number (frame-parameter frame 'window-id)))
(frame-container (xcb:generate-id exwm--connection))
(window (frame-first-window frame)) ;and it's the only window
(x (slot-value exwm--geometry 'x))
(y (slot-value exwm--geometry 'y))
(width (slot-value exwm--geometry 'width))
(height (slot-value exwm--geometry 'height)))
;; Force drawing menu-bar & tool-bar.
(redisplay t)
(exwm-workspace--update-offsets)
(exwm--log "Floating geometry (original): %dx%d%+d%+d" width height x y)
;; Save frame parameters.
(set-frame-parameter frame 'exwm-outer-id outer-id)
(set-frame-parameter frame 'exwm-id window-id)
(set-frame-parameter frame 'exwm-container frame-container)
;; Fix illegal parameters
;; FIXME: check normal hints restrictions
(let* ((workarea (elt exwm-workspace--workareas
(exwm-workspace--position original-frame)))
(x* (aref workarea 0))
(y* (aref workarea 1))
(width* (aref workarea 2))
(height* (aref workarea 3)))
;; Center floating windows
(when (and (or (= x 0) (= x x*))
(or (= y 0) (= y y*)))
(let ((buffer (exwm--id->buffer exwm-transient-for))
window edges)
(when (and buffer (setq window (get-buffer-window buffer)))
(setq edges (window-inside-absolute-pixel-edges window))
(unless (and (<= width (- (elt edges 2) (elt edges 0)))
(<= height (- (elt edges 3) (elt edges 1))))
(setq edges nil)))
(if edges
;; Put at the center of leading window
(setq x (+ x* (/ (- (elt edges 2) (elt edges 0) width) 2))
y (+ y* (/ (- (elt edges 3) (elt edges 1) height) 2)))
;; Put at the center of screen
(setq x (/ (- width* width) 2)
y (/ (- height* height) 2)))))
(if (> width width*)
;; Too wide
(progn (setq x x*
width width*))
;; Invalid width
(when (= 0 width) (setq width (/ width* 2)))
;; Make sure at least half of the window is visible
(unless (< x* (+ x (/ width 2)) (+ x* width*))
(setq x (+ x* (/ (- width* width) 2)))))
(if (> height height*)
;; Too tall
(setq y y*
height height*)
;; Invalid height
(when (= 0 height) (setq height (/ height* 2)))
;; Make sure at least half of the window is visible
(unless (< y* (+ y (/ height 2)) (+ y* height*))
(setq y (+ y* (/ (- height* height) 2)))))
;; The geometry can be overridden by user options.
(let ((x** (plist-get exwm--configurations 'x))
(y** (plist-get exwm--configurations 'y))
(width** (plist-get exwm--configurations 'width))
(height** (plist-get exwm--configurations 'height)))
(if (integerp x**)
(setq x (+ x* x**))
(when (and (floatp x**)
(>= 1 x** 0))
(setq x (+ x* (round (* x** width*))))))
(if (integerp y**)
(setq y (+ y* y**))
(when (and (floatp y**)
(>= 1 y** 0))
(setq y (+ y* (round (* y** height*))))))
(if (integerp width**)
(setq width width**)
(when (and (floatp width**)
(> 1 width** 0))
(setq width (max 1 (round (* width** width*))))))
(if (integerp height**)
(setq height height**)
(when (and (floatp height**)
(> 1 height** 0))
(setq height (max 1 (round (* height** height*))))))))
(exwm--set-geometry id x y nil nil)
(xcb:flush exwm--connection)
(exwm--log "Floating geometry (corrected): %dx%d%+d%+d" width height x y)
;; Fit frame to client
;; It seems we have to make the frame invisible in order to resize it
;; timely.
;; The frame will be made visible by `select-frame-set-input-focus'.
(make-frame-invisible frame)
(let* ((edges (window-inside-pixel-edges window))
(frame-width (+ width (- (frame-pixel-width frame)
(- (elt edges 2) (elt edges 0)))))
(frame-height (+ height (- (frame-pixel-height frame)
(- (elt edges 3) (elt edges 1)))
;; Use `frame-outer-height' in the future.
exwm-workspace--frame-y-offset))
(floating-mode-line (plist-get exwm--configurations
'floating-mode-line))
(floating-header-line (plist-get exwm--configurations
'floating-header-line))
(border-pixel (exwm--color->pixel exwm-floating-border-color)))
(if floating-mode-line
(setq exwm--mode-line-format (or exwm--mode-line-format
mode-line-format)
mode-line-format floating-mode-line)
(if (and (not (plist-member exwm--configurations 'floating-mode-line))
exwm--mwm-hints-decorations)
(when exwm--mode-line-format
(setq mode-line-format exwm--mode-line-format))
;; The mode-line need to be hidden in floating mode.
(setq frame-height (- frame-height (window-mode-line-height
(frame-root-window frame)))
exwm--mode-line-format (or exwm--mode-line-format
mode-line-format)
mode-line-format nil)))
(if floating-header-line
(setq header-line-format floating-header-line)
(if (and (not (plist-member exwm--configurations
'floating-header-line))
exwm--mwm-hints-decorations)
(setq header-line-format nil)
;; The header-line need to be hidden in floating mode.
(setq frame-height (- frame-height (window-header-line-height
(frame-root-window frame)))
header-line-format nil)))
(set-frame-size frame frame-width frame-height t)
;; Create the frame container as the parent of the frame.
(xcb:+request exwm--connection
(make-instance 'xcb:CreateWindow
:depth 0
:wid frame-container
:parent exwm--root
:x x
:y (- y exwm-workspace--window-y-offset)
:width width
:height height
:border-width
(with-current-buffer (exwm--id->buffer id)
(let ((border-witdh (plist-get exwm--configurations
'border-width)))
(if (and (integerp border-witdh)
(>= border-witdh 0))
border-witdh
exwm-floating-border-width)))
:class xcb:WindowClass:InputOutput
:visual 0
:value-mask (logior xcb:CW:BackPixmap
(if border-pixel
xcb:CW:BorderPixel 0)
xcb:CW:OverrideRedirect)
:background-pixmap xcb:BackPixmap:ParentRelative
:border-pixel border-pixel
:override-redirect 1))
(xcb:+request exwm--connection
(make-instance 'xcb:ewmh:set-_NET_WM_NAME
:window frame-container
:data
(format "EXWM floating frame container for 0x%x" id)))
;; Map it.
(xcb:+request exwm--connection
(make-instance 'xcb:MapWindow :window frame-container))
;; Put the X window right above this frame container.
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window id
:value-mask (logior xcb:ConfigWindow:Sibling
xcb:ConfigWindow:StackMode)
:sibling frame-container
:stack-mode xcb:StackMode:Above)))
;; Reparent this frame to its container.
(xcb:+request exwm--connection
(make-instance 'xcb:ReparentWindow
:window outer-id :parent frame-container :x 0 :y 0))
(exwm-floating--set-allowed-actions id nil)
(xcb:flush exwm--connection)
;; Set window/buffer
(with-current-buffer (exwm--id->buffer id)
(setq window-size-fixed exwm--fixed-size
exwm--floating-frame frame)
;; Do the refresh manually.
(remove-hook 'window-configuration-change-hook #'exwm-layout--refresh)
(set-window-buffer window (current-buffer)) ;this changes current buffer
(add-hook 'window-configuration-change-hook #'exwm-layout--refresh)
(set-window-dedicated-p window t)
(exwm-layout--show id window))
(with-current-buffer (exwm--id->buffer id)
(if (exwm-layout--iconic-state-p id)
;; Hide iconic floating X windows.
(exwm-floating-hide)
(with-selected-frame exwm--frame
(exwm-layout--refresh)))
(select-frame-set-input-focus frame))
;; FIXME: Strangely, the Emacs frame can move itself at this point
;; when there are left/top struts set. Force resetting its
;; position seems working, but it'd better to figure out why.
;; FIXME: This also happens in another case (#220) where the cause is
;; still unclear.
(exwm--set-geometry outer-id 0 0 nil nil)
(xcb:flush exwm--connection))
(with-current-buffer (exwm--id->buffer id)
(run-hooks 'exwm-floating-setup-hook))
;; Redraw the frame.
(redisplay t))
(defun exwm-floating--unset-floating (id)
"Make window ID non-floating."
(exwm--log "#x%x" id)
(let ((buffer (exwm--id->buffer id)))
(with-current-buffer buffer
(when exwm--floating-frame
;; The X window is already mapped.
;; Unmap the X window.
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask xcb:EventMask:NoEvent))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window id))
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask (exwm--get-client-event-mask)))
;; Reparent the floating frame back to the root window.
(let ((frame-id (frame-parameter exwm--floating-frame 'exwm-outer-id))
(frame-container (frame-parameter exwm--floating-frame
'exwm-container)))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window frame-id))
(xcb:+request exwm--connection
(make-instance 'xcb:ReparentWindow
:window frame-id
:parent exwm--root
:x 0 :y 0))
;; Also destroy its container.
(xcb:+request exwm--connection
(make-instance 'xcb:DestroyWindow :window frame-container))))
;; Place the X window just above the reference X window.
;; (the stacking order won't change from now on).
;; Also hide the possible floating border.
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window id
:value-mask (logior xcb:ConfigWindow:BorderWidth
xcb:ConfigWindow:Sibling
xcb:ConfigWindow:StackMode)
:border-width 0
:sibling exwm--guide-window
:stack-mode xcb:StackMode:Above)))
(exwm-floating--set-allowed-actions id t)
(xcb:flush exwm--connection)
(with-current-buffer buffer
(when exwm--floating-frame ;from floating to non-floating
(set-window-dedicated-p (frame-first-window exwm--floating-frame) nil)
;; Select a tiling window and delete the old frame.
(select-window (frame-selected-window exwm-workspace--current))
(with-current-buffer buffer
(delete-frame exwm--floating-frame))))
(with-current-buffer buffer
(setq window-size-fixed nil
exwm--floating-frame nil)
(if (not (plist-member exwm--configurations 'tiling-mode-line))
(when exwm--mode-line-format
(setq mode-line-format exwm--mode-line-format))
(setq exwm--mode-line-format (or exwm--mode-line-format
mode-line-format)
mode-line-format (plist-get exwm--configurations
'tiling-mode-line)))
(if (not (plist-member exwm--configurations 'tiling-header-line))
(setq header-line-format nil)
(setq header-line-format (plist-get exwm--configurations
'tiling-header-line))))
;; Only show X windows in normal state.
(unless (exwm-layout--iconic-state-p)
(pop-to-buffer-same-window buffer)))
(with-current-buffer (exwm--id->buffer id)
(run-hooks 'exwm-floating-exit-hook)))
;;;###autoload
(cl-defun exwm-floating-toggle-floating ()
"Toggle the current window between floating and non-floating states."
(interactive)
(exwm--log)
(unless (derived-mode-p 'exwm-mode)
(cl-return-from exwm-floating-toggle-floating))
(with-current-buffer (window-buffer)
(if exwm--floating-frame
(exwm-floating--unset-floating exwm--id)
(exwm-floating--set-floating exwm--id))))
;;;###autoload
(defun exwm-floating-hide ()
"Hide the current floating X window (which would show again when selected)."
(interactive)
(exwm--log)
(when (and (derived-mode-p 'exwm-mode)
exwm--floating-frame)
(exwm-layout--hide exwm--id)
(select-frame-set-input-focus exwm-workspace--current)))
(defun exwm-floating--start-moveresize (id &optional type)
"Start move/resize."
(exwm--log "#x%x" id)
(let ((buffer-or-id (or (exwm--id->buffer id) id))
frame container-or-id x y width height cursor)
(if (bufferp buffer-or-id)
;; Managed.
(with-current-buffer buffer-or-id
(setq frame exwm--floating-frame
container-or-id (frame-parameter exwm--floating-frame
'exwm-container)))
;; Unmanaged.
(setq container-or-id id))
(when (and container-or-id
;; Test if the pointer can be grabbed
(= xcb:GrabStatus:Success
(slot-value
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GrabPointer
:owner-events 0
:grab-window container-or-id
:event-mask xcb:EventMask:NoEvent
:pointer-mode xcb:GrabMode:Async
:keyboard-mode xcb:GrabMode:Async
:confine-to xcb:Window:None
:cursor xcb:Cursor:None
:time xcb:Time:CurrentTime))
'status)))
(with-slots (root-x root-y win-x win-y)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:QueryPointer :window id))
(if (not (bufferp buffer-or-id))
;; Unmanaged.
(unless (eq type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE)
(with-slots ((width* width)
(height* height))
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry :drawable id))
(setq width width*
height height*)))
;; Managed.
(select-window (frame-first-window frame)) ;transfer input focus
(setq width (frame-pixel-width frame)
height (frame-pixel-height frame))
(unless type
;; Determine the resize type according to the pointer position
;; Clicking the center 1/3 part to resize has no effect
(setq x (/ (* 3 win-x) (float width))
y (/ (* 3 win-y) (float height))
type (cond ((and (< x 1) (< y 1))
xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT)
((and (> x 2) (< y 1))
xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT)
((and (> x 2) (> y 2))
xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT)
((and (< x 1) (> y 2))
xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT)
((> x 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT)
((> y 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM)
((< x 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT)
((< y 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP)))))
(if (not type)
(exwm-floating--stop-moveresize)
(cond ((= type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE)
(setq cursor exwm-floating--cursor-move
exwm-floating--moveresize-calculate
(lambda (x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:X
xcb:ConfigWindow:Y))
(- x win-x) (- y win-y) 0 0))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT)
(setq cursor exwm-floating--cursor-top-left
exwm-floating--moveresize-calculate
(lambda (x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:X
xcb:ConfigWindow:Y
xcb:ConfigWindow:Width
xcb:ConfigWindow:Height))
(- x win-x) (- y win-y)
(- (+ root-x width) x)
(- (+ root-y height) y)))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP)
(setq cursor exwm-floating--cursor-top
exwm-floating--moveresize-calculate
(lambda (_x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:Y
xcb:ConfigWindow:Height))
0 (- y win-y) 0 (- (+ root-y height) y)))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT)
(setq cursor exwm-floating--cursor-top-right
exwm-floating--moveresize-calculate
(lambda (x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:Y
xcb:ConfigWindow:Width
xcb:ConfigWindow:Height))
0 (- y win-y) (- x (- root-x width))
(- (+ root-y height) y)))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT)
(setq cursor exwm-floating--cursor-right
exwm-floating--moveresize-calculate
(lambda (x _y)
(vector buffer-or-id
xcb:ConfigWindow:Width
0 0 (- x (- root-x width)) 0))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT)
(setq cursor exwm-floating--cursor-bottom-right
exwm-floating--moveresize-calculate
(lambda (x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:Width
xcb:ConfigWindow:Height))
0 0 (- x (- root-x width))
(- y (- root-y height))))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM)
(setq cursor exwm-floating--cursor-bottom
exwm-floating--moveresize-calculate
(lambda (_x y)
(vector buffer-or-id
xcb:ConfigWindow:Height
0 0 0 (- y (- root-y height))))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT)
(setq cursor exwm-floating--cursor-bottom-left
exwm-floating--moveresize-calculate
(lambda (x y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:X
xcb:ConfigWindow:Width
xcb:ConfigWindow:Height))
(- x win-x)
0
(- (+ root-x width) x)
(- y (- root-y height))))))
((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT)
(setq cursor exwm-floating--cursor-left
exwm-floating--moveresize-calculate
(lambda (x _y)
(vector buffer-or-id
(eval-when-compile
(logior xcb:ConfigWindow:X
xcb:ConfigWindow:Width))
(- x win-x) 0 (- (+ root-x width) x) 0)))))
;; Select events and change cursor (should always succeed)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GrabPointer
:owner-events 0 :grab-window container-or-id
:event-mask (eval-when-compile
(logior xcb:EventMask:ButtonRelease
xcb:EventMask:ButtonMotion))
:pointer-mode xcb:GrabMode:Async
:keyboard-mode xcb:GrabMode:Async
:confine-to xcb:Window:None
:cursor cursor
:time xcb:Time:CurrentTime)))))))
(defun exwm-floating--stop-moveresize (&rest _args)
"Stop move/resize."
(exwm--log)
(xcb:+request exwm--connection
(make-instance 'xcb:UngrabPointer :time xcb:Time:CurrentTime))
(when exwm-floating--moveresize-calculate
(let (result buffer-or-id outer-id container-id)
(setq result (funcall exwm-floating--moveresize-calculate 0 0)
buffer-or-id (aref result 0))
(when (bufferp buffer-or-id)
(with-current-buffer buffer-or-id
(setq outer-id (frame-parameter exwm--floating-frame 'exwm-outer-id)
container-id (frame-parameter exwm--floating-frame
'exwm-container))
(with-slots (x y width height border-width)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry
:drawable container-id))
;; Notify Emacs frame about this the position change.
(xcb:+request exwm--connection
(make-instance 'xcb:SendEvent
:propagate 0
:destination outer-id
:event-mask xcb:EventMask:StructureNotify
:event
(xcb:marshal
(make-instance 'xcb:ConfigureNotify
:event outer-id
:window outer-id
:above-sibling xcb:Window:None
:x (+ x border-width)
:y (+ y border-width)
:width width
:height height
:border-width 0
:override-redirect 0)
exwm--connection)))
(xcb:flush exwm--connection))
(exwm-layout--show exwm--id
(frame-root-window exwm--floating-frame)))))
(setq exwm-floating--moveresize-calculate nil)))
(defun exwm-floating--do-moveresize (data _synthetic)
"Perform move/resize."
(when exwm-floating--moveresize-calculate
(let* ((obj (make-instance 'xcb:MotionNotify))
result value-mask x y width height buffer-or-id container-or-id)
(xcb:unmarshal obj data)
(setq result (funcall exwm-floating--moveresize-calculate
(slot-value obj 'root-x) (slot-value obj 'root-y))
buffer-or-id (aref result 0)
value-mask (aref result 1)
x (aref result 2)
y (aref result 3)
width (max 1 (aref result 4))
height (max 1 (aref result 5)))
(if (not (bufferp buffer-or-id))
;; Unmanaged.
(setq container-or-id buffer-or-id)
;; Managed.
(setq container-or-id
(with-current-buffer buffer-or-id
(frame-parameter exwm--floating-frame 'exwm-container))
x (- x exwm-floating-border-width)
;; Use `frame-outer-height' in the future.
y (- y exwm-floating-border-width
exwm-workspace--window-y-offset)
height (+ height exwm-workspace--window-y-offset)))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window container-or-id
:value-mask (aref result 1)
:x x
:y y
:width width
:height height))
(when (bufferp buffer-or-id)
;; Managed.
(setq value-mask (logand value-mask (logior xcb:ConfigWindow:Width
xcb:ConfigWindow:Height)))
(when (/= 0 value-mask)
(with-current-buffer buffer-or-id
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window (frame-parameter exwm--floating-frame
'exwm-outer-id)
:value-mask value-mask
:width width
:height height)))))
(xcb:flush exwm--connection))))
(defun exwm-floating-move (&optional delta-x delta-y)
"Move a floating window right by DELTA-X pixels and down by DELTA-Y pixels.
Both DELTA-X and DELTA-Y default to 1. This command should be bound locally."
(exwm--log "delta-x: %s, delta-y: %s" delta-x delta-y)
(unless (and (derived-mode-p 'exwm-mode) exwm--floating-frame)
(user-error "[EXWM] `exwm-floating-move' is only for floating X windows"))
(unless delta-x (setq delta-x 1))
(unless delta-y (setq delta-y 1))
(unless (and (= 0 delta-x) (= 0 delta-y))
(let* ((floating-container (frame-parameter exwm--floating-frame
'exwm-container))
(geometry (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry
:drawable floating-container)))
(edges (window-inside-absolute-pixel-edges)))
(with-slots (x y) geometry
(exwm--set-geometry floating-container
(+ x delta-x) (+ y delta-y) nil nil))
(exwm--set-geometry exwm--id
(+ (pop edges) delta-x)
(+ (pop edges) delta-y)
nil nil))
(xcb:flush exwm--connection)))
(defun exwm-floating--init ()
"Initialize floating module."
(exwm--log)
;; Initialize cursors for moving/resizing a window
(xcb:cursor:init exwm--connection)
(setq exwm-floating--cursor-move
(xcb:cursor:load-cursor exwm--connection "fleur")
exwm-floating--cursor-top-left
(xcb:cursor:load-cursor exwm--connection "top_left_corner")
exwm-floating--cursor-top
(xcb:cursor:load-cursor exwm--connection "top_side")
exwm-floating--cursor-top-right
(xcb:cursor:load-cursor exwm--connection "top_right_corner")
exwm-floating--cursor-right
(xcb:cursor:load-cursor exwm--connection "right_side")
exwm-floating--cursor-bottom-right
(xcb:cursor:load-cursor exwm--connection "bottom_right_corner")
exwm-floating--cursor-bottom
(xcb:cursor:load-cursor exwm--connection "bottom_side")
exwm-floating--cursor-bottom-left
(xcb:cursor:load-cursor exwm--connection "bottom_left_corner")
exwm-floating--cursor-left
(xcb:cursor:load-cursor exwm--connection "left_side")))
(defun exwm-floating--exit ()
"Exit the floating module."
(exwm--log))
(provide 'exwm-floating)
;;; exwm-floating.el ends here

BIN
elpa/exwm-0.24/exwm-floating.elc
View File

Binary file not shown.

1221
elpa/exwm-0.24/exwm-input.el
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/exwm-0.24/exwm-input.elc
View File

Binary file not shown.

618
elpa/exwm-0.24/exwm-layout.el
View File

@ -1,618 +0,0 @@
;;; exwm-layout.el --- Layout Module for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module is responsible for keeping X client window properly displayed.
;;; Code:
(require 'exwm-core)
(defgroup exwm-layout nil
"Layout."
:version "25.3"
:group 'exwm)
(defcustom exwm-layout-auto-iconify t
"Non-nil to automatically iconify unused X windows when possible."
:type 'boolean)
(defcustom exwm-layout-show-all-buffers nil
"Non-nil to allow switching to buffers on other workspaces."
:type 'boolean)
(defconst exwm-layout--floating-hidden-position -101
"Where to place hidden floating X windows.")
(defvar exwm-layout--other-buffer-exclude-buffers nil
"List of buffers that should not be selected by `other-buffer'.")
(defvar exwm-layout--other-buffer-exclude-exwm-mode-buffers nil
"When non-nil, prevent EXWM buffers from being selected by `other-buffer'.")
(defvar exwm-layout--timer nil "Timer used to track echo area changes.")
(defvar exwm-workspace--current)
(defvar exwm-workspace--frame-y-offset)
(declare-function exwm-input--release-keyboard "exwm-input.el")
(declare-function exwm-input--grab-keyboard "exwm-input.el")
(declare-function exwm-input-grab-keyboard "exwm-input.el")
(declare-function exwm-workspace--active-p "exwm-workspace.el" (frame))
(declare-function exwm-workspace--client-p "exwm-workspace.el"
(&optional frame))
(declare-function exwm-workspace--minibuffer-own-frame-p "exwm-workspace.el")
(declare-function exwm-workspace--workspace-p "exwm-workspace.el"
(workspace))
(declare-function exwm-workspace-move-window "exwm-workspace.el"
(frame-or-index &optional id))
(defun exwm-layout--set-state (id state)
"Set WM_STATE."
(exwm--log "id=#x%x" id)
(xcb:+request exwm--connection
(make-instance 'xcb:icccm:set-WM_STATE
:window id :state state :icon xcb:Window:None))
(with-current-buffer (exwm--id->buffer id)
(setq exwm-state state)))
(defun exwm-layout--iconic-state-p (&optional id)
(= xcb:icccm:WM_STATE:IconicState
(if id
(buffer-local-value 'exwm-state (exwm--id->buffer id))
exwm-state)))
(defun exwm-layout--set-ewmh-state (xwin)
"Set _NET_WM_STATE."
(with-current-buffer (exwm--id->buffer xwin)
(xcb:+request exwm--connection
(make-instance 'xcb:ewmh:set-_NET_WM_STATE
:window exwm--id
:data exwm--ewmh-state))))
(defun exwm-layout--fullscreen-p ()
(when (derived-mode-p 'exwm-mode)
(memq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state)))
(defun exwm-layout--auto-iconify ()
(when (and exwm-layout-auto-iconify
(not exwm-transient-for))
(let ((xwin exwm--id)
(state exwm-state))
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when (and exwm--floating-frame
(eq exwm-transient-for xwin)
(not (eq exwm-state state)))
(if (eq state xcb:icccm:WM_STATE:NormalState)
(exwm-layout--refresh-floating exwm--floating-frame)
(exwm-layout--hide exwm--id))))))))
(defun exwm-layout--show (id &optional window)
"Show window ID exactly fit in the Emacs window WINDOW."
(exwm--log "Show #x%x in %s" id window)
(let* ((edges (window-inside-absolute-pixel-edges window))
(x (pop edges))
(y (pop edges))
(width (- (pop edges) x))
(height (- (pop edges) y))
frame-x frame-y frame-width frame-height)
(with-current-buffer (exwm--id->buffer id)
(when exwm--floating-frame
(setq frame-width (frame-pixel-width exwm--floating-frame)
frame-height (+ (frame-pixel-height exwm--floating-frame)
;; Use `frame-outer-height' in the future.
exwm-workspace--frame-y-offset))
(when exwm--floating-frame-position
(setq frame-x (elt exwm--floating-frame-position 0)
frame-y (elt exwm--floating-frame-position 1)
x (+ x frame-x (- exwm-layout--floating-hidden-position))
y (+ y frame-y (- exwm-layout--floating-hidden-position)))
(setq exwm--floating-frame-position nil))
(exwm--set-geometry (frame-parameter exwm--floating-frame
'exwm-container)
frame-x frame-y frame-width frame-height))
(when (exwm-layout--fullscreen-p)
(with-slots ((x* x)
(y* y)
(width* width)
(height* height))
(exwm-workspace--get-geometry exwm--frame)
(setq x x*
y y*
width width*
height height*)))
(exwm--set-geometry id x y width height)
(xcb:+request exwm--connection (make-instance 'xcb:MapWindow :window id))
(exwm-layout--set-state id xcb:icccm:WM_STATE:NormalState)
(setq exwm--ewmh-state
(delq xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state))
(exwm-layout--set-ewmh-state id)
(exwm-layout--auto-iconify)))
(xcb:flush exwm--connection))
(defun exwm-layout--hide (id)
"Hide window ID."
(with-current-buffer (exwm--id->buffer id)
(unless (or (exwm-layout--iconic-state-p)
(and exwm--floating-frame
(eq 4294967295. exwm--desktop)))
(exwm--log "Hide #x%x" id)
(when exwm--floating-frame
(let* ((container (frame-parameter exwm--floating-frame
'exwm-container))
(geometry (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry
:drawable container))))
(setq exwm--floating-frame-position
(vector (slot-value geometry 'x) (slot-value geometry 'y)))
(exwm--set-geometry container exwm-layout--floating-hidden-position
exwm-layout--floating-hidden-position
1
1)))
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask xcb:EventMask:NoEvent))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window id))
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask (exwm--get-client-event-mask)))
(exwm-layout--set-state id xcb:icccm:WM_STATE:IconicState)
(cl-pushnew xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state)
(exwm-layout--set-ewmh-state id)
(exwm-layout--auto-iconify)
(xcb:flush exwm--connection))))
;;;###autoload
(cl-defun exwm-layout-set-fullscreen (&optional id)
"Make window ID fullscreen."
(interactive)
(exwm--log "id=#x%x" (or id 0))
(unless (and (or id (derived-mode-p 'exwm-mode))
(not (exwm-layout--fullscreen-p)))
(cl-return-from exwm-layout-set-fullscreen))
(with-current-buffer (if id (exwm--id->buffer id) (window-buffer))
;; Expand the X window to fill the whole screen.
(with-slots (x y width height) (exwm-workspace--get-geometry exwm--frame)
(exwm--set-geometry exwm--id x y width height))
;; Raise the X window.
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window exwm--id
:value-mask (logior xcb:ConfigWindow:BorderWidth
xcb:ConfigWindow:StackMode)
:border-width 0
:stack-mode xcb:StackMode:Above))
(cl-pushnew xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state)
(exwm-layout--set-ewmh-state id)
(xcb:flush exwm--connection)
(set-window-dedicated-p (get-buffer-window) t)
(exwm-input--release-keyboard exwm--id)))
;;;###autoload
(cl-defun exwm-layout-unset-fullscreen (&optional id)
"Restore window from fullscreen state."
(interactive)
(exwm--log "id=#x%x" (or id 0))
(unless (and (or id (derived-mode-p 'exwm-mode))
(exwm-layout--fullscreen-p))
(cl-return-from exwm-layout-unset-fullscreen))
(with-current-buffer (if id (exwm--id->buffer id) (window-buffer))
(setq exwm--ewmh-state
(delq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state))
(if exwm--floating-frame
(exwm-layout--show exwm--id (frame-root-window exwm--floating-frame))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window exwm--id
:value-mask (logior xcb:ConfigWindow:Sibling
xcb:ConfigWindow:StackMode)
:sibling exwm--guide-window
:stack-mode xcb:StackMode:Above))
(let ((window (get-buffer-window nil t)))
(when window
(exwm-layout--show exwm--id window))))
(exwm-layout--set-ewmh-state id)
(xcb:flush exwm--connection)
(set-window-dedicated-p (get-buffer-window) nil)
(when (eq 'line-mode exwm--selected-input-mode)
(exwm-input--grab-keyboard exwm--id))))
;;;###autoload
(cl-defun exwm-layout-toggle-fullscreen (&optional id)
"Toggle fullscreen mode."
(interactive (list (exwm--buffer->id (window-buffer))))
(exwm--log "id=#x%x" (or id 0))
(unless (or id (derived-mode-p 'exwm-mode))
(cl-return-from exwm-layout-toggle-fullscreen))
(when id
(with-current-buffer (exwm--id->buffer id)
(if (exwm-layout--fullscreen-p)
(exwm-layout-unset-fullscreen id)
(exwm-layout-set-fullscreen id)))))
(defun exwm-layout--other-buffer-predicate (buffer)
"Return non-nil when the BUFFER may be displayed in selected frame.
Prevents EXWM-mode buffers already being displayed on some other window from
being selected.
Should be set as `buffer-predicate' frame parameter for all
frames. Used by `other-buffer'.
When variable `exwm-layout--other-buffer-exclude-exwm-mode-buffers'
is t EXWM buffers are never selected by `other-buffer'.
When variable `exwm-layout--other-buffer-exclude-buffers' is a
list of buffers, EXWM buffers belonging to that list are never
selected by `other-buffer'."
(or (not (with-current-buffer buffer (derived-mode-p 'exwm-mode)))
(and (not exwm-layout--other-buffer-exclude-exwm-mode-buffers)
(not (memq buffer exwm-layout--other-buffer-exclude-buffers))
;; Do not select if already shown in some window.
(not (get-buffer-window buffer t)))))
(defun exwm-layout--set-client-list-stacking ()
"Set _NET_CLIENT_LIST_STACKING."
(exwm--log)
(let (id clients-floating clients clients-iconic clients-other)
(dolist (pair exwm--id-buffer-alist)
(setq id (car pair))
(with-current-buffer (cdr pair)
(if (eq exwm--frame exwm-workspace--current)
(if exwm--floating-frame
;; A floating X window on the current workspace.
(setq clients-floating (cons id clients-floating))
(if (get-buffer-window (cdr pair) exwm-workspace--current)
;; A normal tilling X window on the current workspace.
(setq clients (cons id clients))
;; An iconic tilling X window on the current workspace.
(setq clients-iconic (cons id clients-iconic))))
;; X window on other workspaces.
(setq clients-other (cons id clients-other)))))
(xcb:+request exwm--connection
(make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST_STACKING
:window exwm--root
:data (vconcat (append clients-other clients-iconic
clients clients-floating))))))
(defun exwm-layout--refresh (&optional frame)
"Refresh layout."
;; `window-size-change-functions' sets this argument while
;; `window-configuration-change-hook' makes the frame selected.
(unless frame
(setq frame (selected-frame)))
(exwm--log "frame=%s" frame)
(if (not (exwm-workspace--workspace-p frame))
(if (frame-parameter frame 'exwm-outer-id)
(exwm-layout--refresh-floating frame)
(exwm-layout--refresh-other frame))
(exwm-layout--refresh-workspace frame)))
(defun exwm-layout--refresh-floating (frame)
"Refresh floating frame FRAME."
(exwm--log "Refresh floating %s" frame)
(let ((window (frame-first-window frame)))
(with-current-buffer (window-buffer window)
(when (and (derived-mode-p 'exwm-mode)
;; It may be a buffer waiting to be killed.
(exwm--id->buffer exwm--id))
(exwm--log "Refresh floating window #x%x" exwm--id)
(if (exwm-workspace--active-p exwm--frame)
(exwm-layout--show exwm--id window)
(exwm-layout--hide exwm--id))))))
(defun exwm-layout--refresh-other (frame)
"Refresh client or nox frame FRAME."
;; Other frames (e.g. terminal/graphical frame of emacsclient)
;; We shall bury all `exwm-mode' buffers in this case
(exwm--log "Refresh other %s" frame)
(let ((windows (window-list frame 'nomini)) ;exclude minibuffer
(exwm-layout--other-buffer-exclude-exwm-mode-buffers t))
(dolist (window windows)
(with-current-buffer (window-buffer window)
(when (derived-mode-p 'exwm-mode)
(if (window-prev-buffers window)
(switch-to-prev-buffer window)
(switch-to-next-buffer window)))))))
(defun exwm-layout--refresh-workspace (frame)
"Refresh workspace frame FRAME."
(exwm--log "Refresh workspace %s" frame)
;; Workspaces other than the active one can also be refreshed (RandR)
(let (covered-buffers ;EXWM-buffers covered by a new X window.
vacated-windows) ;Windows previously displaying EXWM-buffers.
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when (and (not exwm--floating-frame) ;exclude floating X windows
(or exwm-layout-show-all-buffers
;; Exclude X windows on other workspaces
(eq frame exwm--frame)))
(let (;; List of windows in current frame displaying the `exwm-mode'
;; buffers.
(windows (get-buffer-window-list (current-buffer) 'nomini
frame)))
(if (not windows)
(when (eq frame exwm--frame)
;; Hide it if it was being shown in this workspace.
(exwm-layout--hide exwm--id))
(let ((window (car windows)))
(if (eq frame exwm--frame)
;; Show it if `frame' is active, hide otherwise.
(if (exwm-workspace--active-p frame)
(exwm-layout--show exwm--id window)
(exwm-layout--hide exwm--id))
;; It was last shown in other workspace; move it here.
(exwm-workspace-move-window frame exwm--id))
;; Vacate any other windows (in any workspace) showing this
;; `exwm-mode' buffer.
(setq vacated-windows
(append vacated-windows (remove
window
(get-buffer-window-list
(current-buffer) 'nomini t))))
;; Note any `exwm-mode' buffer is being covered by another
;; `exwm-mode' buffer. We want to avoid that `exwm-mode'
;; buffer to be reappear in any of the vacated windows.
(let ((prev-buffer (car-safe
(car-safe (window-prev-buffers window)))))
(and
prev-buffer
(with-current-buffer prev-buffer
(derived-mode-p 'exwm-mode))
(push prev-buffer covered-buffers)))))))))
;; Set some sensible buffer to vacated windows.
(let ((exwm-layout--other-buffer-exclude-buffers covered-buffers))
(dolist (window vacated-windows)
(if (window-prev-buffers window)
(switch-to-prev-buffer window)
(switch-to-next-buffer window))))
;; Make sure windows floating / on other workspaces are excluded
(let ((exwm-layout--other-buffer-exclude-exwm-mode-buffers t))
(dolist (window (window-list frame 'nomini))
(with-current-buffer (window-buffer window)
(when (and (derived-mode-p 'exwm-mode)
(or exwm--floating-frame (not (eq frame exwm--frame))))
(if (window-prev-buffers window)
(switch-to-prev-buffer window)
(switch-to-next-buffer window))))))
(exwm-layout--set-client-list-stacking)
(xcb:flush exwm--connection)))
(defun exwm-layout--on-minibuffer-setup ()
"Refresh layout when minibuffer grows."
(exwm--log)
(unless (exwm-workspace--client-p)
(exwm--defer 0 (lambda ()
(when (< 1 (window-height (minibuffer-window)))
(exwm-layout--refresh))))))
(defun exwm-layout--on-echo-area-change (&optional dirty)
"Run when message arrives or in `echo-area-clear-hook' to refresh layout."
(when (and (current-message)
(not (exwm-workspace--client-p))
(or (cl-position ?\n (current-message))
(> (length (current-message))
(frame-width exwm-workspace--current))))
(exwm--log)
(if dirty
(exwm-layout--refresh)
(exwm--defer 0 #'exwm-layout--refresh))))
;;;###autoload
(defun exwm-layout-enlarge-window (delta &optional horizontal)
"Make the selected window DELTA pixels taller.
If no argument is given, make the selected window one pixel taller. If the
optional argument HORIZONTAL is non-nil, make selected window DELTA pixels
wider. If DELTA is negative, shrink selected window by -DELTA pixels.
Normal hints are checked and regarded if the selected window is displaying an
`exwm-mode' buffer. However, this may violate the normal hints set on other X
windows."
(interactive "p")
(exwm--log)
(cond
((zerop delta)) ;no operation
((window-minibuffer-p)) ;avoid resize minibuffer-window
((not (and (derived-mode-p 'exwm-mode) exwm--floating-frame))
;; Resize on tiling layout
(unless (= 0 (window-resizable nil delta horizontal nil t)) ;not resizable
(let ((window-resize-pixelwise t))
(window-resize nil delta horizontal nil t))))
;; Resize on floating layout
(exwm--fixed-size) ;fixed size
(horizontal
(let* ((width (frame-pixel-width))
(edges (window-inside-pixel-edges))
(inner-width (- (elt edges 2) (elt edges 0)))
(margin (- width inner-width)))
(if (> delta 0)
(if (not exwm--normal-hints-max-width)
(cl-incf width delta)
(if (>= inner-width exwm--normal-hints-max-width)
(setq width nil)
(setq width (min (+ exwm--normal-hints-max-width margin)
(+ width delta)))))
(if (not exwm--normal-hints-min-width)
(cl-incf width delta)
(if (<= inner-width exwm--normal-hints-min-width)
(setq width nil)
(setq width (max (+ exwm--normal-hints-min-width margin)
(+ width delta))))))
(when (and width (> width 0))
(setf (slot-value exwm--geometry 'width) width)
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window (frame-parameter exwm--floating-frame
'exwm-outer-id)
:value-mask xcb:ConfigWindow:Width
:width width))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window (frame-parameter exwm--floating-frame
'exwm-container)
:value-mask xcb:ConfigWindow:Width
:width width))
(xcb:flush exwm--connection))))
(t
(let* ((height (+ (frame-pixel-height) exwm-workspace--frame-y-offset))
(edges (window-inside-pixel-edges))
(inner-height (- (elt edges 3) (elt edges 1)))
(margin (- height inner-height)))
(if (> delta 0)
(if (not exwm--normal-hints-max-height)
(cl-incf height delta)
(if (>= inner-height exwm--normal-hints-max-height)
(setq height nil)
(setq height (min (+ exwm--normal-hints-max-height margin)
(+ height delta)))))
(if (not exwm--normal-hints-min-height)
(cl-incf height delta)
(if (<= inner-height exwm--normal-hints-min-height)
(setq height nil)
(setq height (max (+ exwm--normal-hints-min-height margin)
(+ height delta))))))
(when (and height (> height 0))
(setf (slot-value exwm--geometry 'height) height)
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window (frame-parameter exwm--floating-frame
'exwm-outer-id)
:value-mask xcb:ConfigWindow:Height
:height height))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window (frame-parameter exwm--floating-frame
'exwm-container)
:value-mask xcb:ConfigWindow:Height
:height height))
(xcb:flush exwm--connection))))))
;;;###autoload
(defun exwm-layout-enlarge-window-horizontally (delta)
"Make the selected window DELTA pixels wider.
See also `exwm-layout-enlarge-window'."
(interactive "p")
(exwm--log "%s" delta)
(exwm-layout-enlarge-window delta t))
;;;###autoload
(defun exwm-layout-shrink-window (delta)
"Make the selected window DELTA pixels lower.
See also `exwm-layout-enlarge-window'."
(interactive "p")
(exwm--log "%s" delta)
(exwm-layout-enlarge-window (- delta)))
;;;###autoload
(defun exwm-layout-shrink-window-horizontally (delta)
"Make the selected window DELTA pixels narrower.
See also `exwm-layout-enlarge-window'."
(interactive "p")
(exwm--log "%s" delta)
(exwm-layout-enlarge-window (- delta) t))
;;;###autoload
(defun exwm-layout-hide-mode-line ()
"Hide mode-line."
(interactive)
(exwm--log)
(when (and (derived-mode-p 'exwm-mode) mode-line-format)
(let (mode-line-height)
(when exwm--floating-frame
(setq mode-line-height (window-mode-line-height
(frame-root-window exwm--floating-frame))))
(setq exwm--mode-line-format mode-line-format
mode-line-format nil)
(if (not exwm--floating-frame)
(exwm-layout--show exwm--id)
(set-frame-height exwm--floating-frame
(- (frame-pixel-height exwm--floating-frame)
mode-line-height)
nil t)))))
;;;###autoload
(defun exwm-layout-show-mode-line ()
"Show mode-line."
(interactive)
(exwm--log)
(when (and (derived-mode-p 'exwm-mode) (not mode-line-format))
(setq mode-line-format exwm--mode-line-format
exwm--mode-line-format nil)
(if (not exwm--floating-frame)
(exwm-layout--show exwm--id)
(set-frame-height exwm--floating-frame
(+ (frame-pixel-height exwm--floating-frame)
(window-mode-line-height (frame-root-window
exwm--floating-frame)))
nil t)
(call-interactively #'exwm-input-grab-keyboard))
(force-mode-line-update)))
;;;###autoload
(defun exwm-layout-toggle-mode-line ()
"Toggle the display of mode-line."
(interactive)
(exwm--log)
(when (derived-mode-p 'exwm-mode)
(if mode-line-format
(exwm-layout-hide-mode-line)
(exwm-layout-show-mode-line))))
(defun exwm-layout--init ()
"Initialize layout module."
;; Auto refresh layout
(exwm--log)
(add-hook 'window-configuration-change-hook #'exwm-layout--refresh)
;; The behavior of `window-configuration-change-hook' will be changed.
(when (fboundp 'window-pixel-width-before-size-change)
(add-hook 'window-size-change-functions #'exwm-layout--refresh))
(unless (exwm-workspace--minibuffer-own-frame-p)
;; Refresh when minibuffer grows
(add-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup t)
(setq exwm-layout--timer
(run-with-idle-timer 0 t #'exwm-layout--on-echo-area-change t))
(add-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change)))
(defun exwm-layout--exit ()
"Exit the layout module."
(exwm--log)
(remove-hook 'window-configuration-change-hook #'exwm-layout--refresh)
(when (fboundp 'window-pixel-width-before-size-change)
(remove-hook 'window-size-change-functions #'exwm-layout--refresh))
(remove-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup)
(when exwm-layout--timer
(cancel-timer exwm-layout--timer)
(setq exwm-layout--timer nil))
(remove-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change))
(provide 'exwm-layout)
;;; exwm-layout.el ends here

BIN
elpa/exwm-0.24/exwm-layout.elc
View File

Binary file not shown.

805
elpa/exwm-0.24/exwm-manage.el
View File

@ -1,805 +0,0 @@
;;; exwm-manage.el --- Window Management Module for -*- lexical-binding: t -*-
;;; EXWM
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is the fundamental module of EXWM that deals with window management.
;;; Code:
(require 'exwm-core)
(defgroup exwm-manage nil
"Manage."
:version "25.3"
:group 'exwm)
(defcustom exwm-manage-finish-hook nil
"Normal hook run after a window is just managed, in the context of the
corresponding buffer."
:type 'hook)
(defcustom exwm-manage-force-tiling nil
"Non-nil to force managing all X windows in tiling layout.
You can still make the X windows floating afterwards."
:type 'boolean)
(defcustom exwm-manage-ping-timeout 3
"Seconds to wait before killing a client."
:type 'integer)
(defcustom exwm-manage-configurations nil
"Per-application configurations.
Configuration options allow to override various default behaviors of EXWM
and only take effect when they are present. Note for certain options
specifying nil is not exactly the same as leaving them out. Currently
possible choices:
* floating: Force floating (non-nil) or tiling (nil) on startup.
* x/y/width/height: Override the initial geometry (floating X window only).
* border-width: Override the border width (only visible when floating).
* fullscreen: Force full screen (non-nil) on startup.
* floating-mode-line: `mode-line-format' used when floating.
* tiling-mode-line: `mode-line-format' used when tiling.
* floating-header-line: `header-line-format' used when floating.
* tiling-header-line: `header-line-format' used when tiling.
* char-mode: Force char-mode (non-nil) on startup.
* prefix-keys: `exwm-input-prefix-keys' local to this X window.
* simulation-keys: `exwm-input-simulation-keys' local to this X window.
* workspace: The initial workspace.
* managed: Force to manage (non-nil) or not manage (nil) the X window.
For each X window managed for the first time, matching criteria (sexps) are
evaluated sequentially and the first configuration with a non-nil matching
criterion would be applied. Apart from generic forms, one would typically
want to match against EXWM internal variables such as `exwm-title',
`exwm-class-name' and `exwm-instance-name'."
:type '(alist :key-type (sexp :tag "Matching criterion" nil)
:value-type
(plist :tag "Configurations"
:options
(((const :tag "Floating" floating) boolean)
((const :tag "X" x) number)
((const :tag "Y" y) number)
((const :tag "Width" width) number)
((const :tag "Height" height) number)
((const :tag "Border width" border-width) integer)
((const :tag "Fullscreen" fullscreen) boolean)
((const :tag "Floating mode-line" floating-mode-line)
sexp)
((const :tag "Tiling mode-line" tiling-mode-line) sexp)
((const :tag "Floating header-line"
floating-header-line)
sexp)
((const :tag "Tiling header-line" tiling-header-line)
sexp)
((const :tag "Char-mode" char-mode) boolean)
((const :tag "Prefix keys" prefix-keys)
(repeat key-sequence))
((const :tag "Simulation keys" simulation-keys)
(alist :key-type (key-sequence :tag "From")
:value-type (key-sequence :tag "To")))
((const :tag "Workspace" workspace) integer)
((const :tag "Managed" managed) boolean)
;; For forward compatibility.
((other) sexp))))
;; TODO: This is admittedly ugly. We'd be better off with an event type.
:get (lambda (symbol)
(mapcar (lambda (pair)
(let* ((match (car pair))
(config (cdr pair))
(prefix-keys (plist-get config 'prefix-keys)))
(when prefix-keys
(setq config (copy-tree config)
config (plist-put config 'prefix-keys
(mapcar (lambda (i)
(if (sequencep i)
i
(vector i)))
prefix-keys))))
(cons match config)))
(default-value symbol)))
:set (lambda (symbol value)
(set symbol
(mapcar (lambda (pair)
(let* ((match (car pair))
(config (cdr pair))
(prefix-keys (plist-get config 'prefix-keys)))
(when prefix-keys
(setq config (copy-tree config)
config (plist-put config 'prefix-keys
(mapcar (lambda (i)
(if (sequencep i)
(aref i 0)
i))
prefix-keys))))
(cons match config)))
value))))
;; FIXME: Make the following values as small as possible.
(defconst exwm-manage--height-delta-min 5)
(defconst exwm-manage--width-delta-min 5)
;; The _MOTIF_WM_HINTS atom (see <Xm/MwmUtil.h> for more details)
;; It's currently only used in 'exwm-manage' module
(defvar exwm-manage--_MOTIF_WM_HINTS nil "_MOTIF_WM_HINTS atom.")
(defvar exwm-manage--desktop nil "The desktop X window.")
(defvar exwm-manage--frame-outer-id-list nil
"List of window-outer-id's of all frames.")
(defvar exwm-manage--ping-lock nil
"Non-nil indicates EXWM is pinging a window.")
(defvar exwm-input--skip-buffer-list-update)
(defvar exwm-input-prefix-keys)
(defvar exwm-workspace--current)
(defvar exwm-workspace--id-struts-alist)
(defvar exwm-workspace--list)
(defvar exwm-workspace--switch-history-outdated)
(defvar exwm-workspace--workareas)
(defvar exwm-workspace-current-index)
(declare-function exwm--update-class "exwm.el" (id &optional force))
(declare-function exwm--update-hints "exwm.el" (id &optional force))
(declare-function exwm--update-normal-hints "exwm.el" (id &optional force))
(declare-function exwm--update-protocols "exwm.el" (id &optional force))
(declare-function exwm--update-struts "exwm.el" (id))
(declare-function exwm--update-title "exwm.el" (id))
(declare-function exwm--update-transient-for "exwm.el" (id &optional force))
(declare-function exwm--update-desktop "exwm.el" (id &optional force))
(declare-function exwm--update-window-type "exwm.el" (id &optional force))
(declare-function exwm-floating--set-floating "exwm-floating.el" (id))
(declare-function exwm-floating--unset-floating "exwm-floating.el" (id))
(declare-function exwm-input-grab-keyboard "exwm-input.el")
(declare-function exwm-input-set-local-simulation-keys "exwm-input.el")
(declare-function exwm-layout--fullscreen-p "exwm-layout.el" ())
(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id))
(declare-function exwm-workspace--position "exwm-workspace.el" (frame))
(declare-function exwm-workspace--set-fullscreen "exwm-workspace.el" (frame))
(declare-function exwm-workspace--update-struts "exwm-workspace.el" ())
(declare-function exwm-workspace--update-workareas "exwm-workspace.el" ())
(defun exwm-manage--update-geometry (id &optional force)
"Update window geometry."
(exwm--log "id=#x%x" id)
(with-current-buffer (exwm--id->buffer id)
(unless (and exwm--geometry (not force))
(let ((reply (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetGeometry :drawable id))))
(setq exwm--geometry
(or reply
;; Provide a reasonable fallback value.
(make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width (/ (x-display-pixel-width) 2)
:height (/ (x-display-pixel-height) 2))))))))
(defun exwm-manage--update-ewmh-state (id)
"Update _NET_WM_STATE."
(exwm--log "id=#x%x" id)
(with-current-buffer (exwm--id->buffer id)
(unless exwm--ewmh-state
(let ((reply (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:ewmh:get-_NET_WM_STATE
:window id))))
(when reply
(setq exwm--ewmh-state (append (slot-value reply 'value) nil)))))))
(defun exwm-manage--update-mwm-hints (id &optional force)
"Update _MOTIF_WM_HINTS."
(exwm--log "id=#x%x" id)
(with-current-buffer (exwm--id->buffer id)
(unless (and (not exwm--mwm-hints-decorations) (not force))
(let ((reply (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:icccm:-GetProperty
:window id
:property exwm-manage--_MOTIF_WM_HINTS
:type exwm-manage--_MOTIF_WM_HINTS
:long-length 5))))
(when reply
;; Check MotifWmHints.decorations.
(with-slots (value) reply
(setq value (append value nil))
(when (and value
;; See <Xm/MwmUtil.h> for fields definitions.
(/= 0 (logand
(elt value 0) ;MotifWmHints.flags
2)) ;MWM_HINTS_DECORATIONS
(= 0
(elt value 2))) ;MotifWmHints.decorations
(setq exwm--mwm-hints-decorations nil))))))))
(defun exwm-manage--set-client-list ()
"Set _NET_CLIENT_LIST."
(exwm--log)
(xcb:+request exwm--connection
(make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST
:window exwm--root
:data (vconcat (mapcar #'car exwm--id-buffer-alist)))))
(cl-defun exwm-manage--get-configurations ()
"Retrieve configurations for this buffer."
(exwm--log)
(when (derived-mode-p 'exwm-mode)
(dolist (i exwm-manage-configurations)
(save-current-buffer
(when (with-demoted-errors "Problematic configuration: %S"
(eval (car i) t))
(cl-return-from exwm-manage--get-configurations (cdr i)))))))
(defun exwm-manage--manage-window (id)
"Manage window ID."
(exwm--log "Try to manage #x%x" id)
(catch 'return
;; Ensure it's alive
(when (xcb:+request-checked+request-check exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask (exwm--get-client-event-mask)))
(throw 'return 'dead))
;; Add this X window to save-set.
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeSaveSet
:mode xcb:SetMode:Insert
:window id))
(with-current-buffer (let ((exwm-input--skip-buffer-list-update t))
(generate-new-buffer "*EXWM*"))
;; Keep the oldest X window first.
(setq exwm--id-buffer-alist
(nconc exwm--id-buffer-alist `((,id . ,(current-buffer)))))
(exwm-mode)
(setq exwm--id id
exwm--frame exwm-workspace--current)
(exwm--update-window-type id)
(exwm--update-class id)
(exwm--update-transient-for id)
(exwm--update-normal-hints id)
(exwm--update-hints id)
(exwm-manage--update-geometry id)
(exwm-manage--update-mwm-hints id)
(exwm--update-title id)
(exwm--update-protocols id)
(setq exwm--configurations (exwm-manage--get-configurations))
;; OverrideRedirect is not checked here.
(when (and
;; The user has specified to manage it.
(not (plist-get exwm--configurations 'managed))
(or
;; The user has specified not to manage it.
(plist-member exwm--configurations 'managed)
;; This is not a type of X window we can manage.
(and exwm-window-type
(not (cl-intersection
exwm-window-type
(list xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY
xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG
xcb:Atom:_NET_WM_WINDOW_TYPE_NORMAL))))
;; Check the _MOTIF_WM_HINTS property to not manage floating X
;; windows without decoration.
(and (not exwm--mwm-hints-decorations)
(not exwm--hints-input)
;; Floating windows only
(or exwm-transient-for exwm--fixed-size
(memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY
exwm-window-type)
(memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG
exwm-window-type)))))
(exwm--log "No need to manage #x%x" id)
;; Update struts.
(when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK exwm-window-type)
(exwm--update-struts id))
;; Remove all events
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask
(if (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK
exwm-window-type)
;; Listen for PropertyChange (struts) and
;; UnmapNotify/DestroyNotify event of the dock.
(exwm--get-client-event-mask)
xcb:EventMask:NoEvent)))
;; The window needs to be mapped
(xcb:+request exwm--connection
(make-instance 'xcb:MapWindow :window id))
(with-slots (x y width height) exwm--geometry
;; Center window of type _NET_WM_WINDOW_TYPE_SPLASH
(when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_SPLASH exwm-window-type)
(let* ((workarea (elt exwm-workspace--workareas
(exwm-workspace--position exwm--frame)))
(x* (aref workarea 0))
(y* (aref workarea 1))
(width* (aref workarea 2))
(height* (aref workarea 3)))
(exwm--set-geometry id
(+ x* (/ (- width* width) 2))
(+ y* (/ (- height* height) 2))
nil
nil))))
;; Check for desktop.
(when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DESKTOP exwm-window-type)
;; There should be only one desktop X window.
(setq exwm-manage--desktop id)
;; Put it at bottom.
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window id
:value-mask xcb:ConfigWindow:StackMode
:stack-mode xcb:StackMode:Below)))
(xcb:flush exwm--connection)
(setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist))
(let ((kill-buffer-query-functions nil)
(exwm-input--skip-buffer-list-update t))
(kill-buffer (current-buffer)))
(throw 'return 'ignored))
(let ((index (plist-get exwm--configurations 'workspace)))
(when (and index (< index (length exwm-workspace--list)))
(setq exwm--frame (elt exwm-workspace--list index))))
;; Manage the window
(exwm--log "Manage #x%x" id)
(xcb:+request exwm--connection ;remove border
(make-instance 'xcb:ConfigureWindow
:window id :value-mask xcb:ConfigWindow:BorderWidth
:border-width 0))
(dolist (button ;grab buttons to set focus / move / resize
(list xcb:ButtonIndex:1 xcb:ButtonIndex:2 xcb:ButtonIndex:3))
(xcb:+request exwm--connection
(make-instance 'xcb:GrabButton
:owner-events 0 :grab-window id
:event-mask xcb:EventMask:ButtonPress
:pointer-mode xcb:GrabMode:Sync
:keyboard-mode xcb:GrabMode:Async
:confine-to xcb:Window:None :cursor xcb:Cursor:None
:button button :modifiers xcb:ModMask:Any)))
(exwm-manage--set-client-list)
(xcb:flush exwm--connection)
(if (plist-member exwm--configurations 'floating)
;; User has specified whether it should be floating.
(if (plist-get exwm--configurations 'floating)
(exwm-floating--set-floating id)
(with-selected-window (frame-selected-window exwm--frame)
(exwm-floating--unset-floating id)))
;; Try to determine if it should be floating.
(if (and (not exwm-manage-force-tiling)
(or exwm-transient-for exwm--fixed-size
(memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY
exwm-window-type)
(memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG
exwm-window-type)))
(exwm-floating--set-floating id)
(with-selected-window (frame-selected-window exwm--frame)
(exwm-floating--unset-floating id))))
(if (plist-get exwm--configurations 'char-mode)
(exwm-input-release-keyboard id)
(exwm-input-grab-keyboard id))
(let ((simulation-keys (plist-get exwm--configurations 'simulation-keys))
(prefix-keys (plist-get exwm--configurations 'prefix-keys)))
(with-current-buffer (exwm--id->buffer id)
(when simulation-keys
(exwm-input-set-local-simulation-keys simulation-keys))
(when prefix-keys
(setq-local exwm-input-prefix-keys prefix-keys))))
(setq exwm-workspace--switch-history-outdated t)
(exwm--update-desktop id)
(exwm-manage--update-ewmh-state id)
(with-current-buffer (exwm--id->buffer id)
(when (or (plist-get exwm--configurations 'fullscreen)
(exwm-layout--fullscreen-p))
(setq exwm--ewmh-state (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN
exwm--ewmh-state))
(exwm-layout-set-fullscreen id))
(run-hooks 'exwm-manage-finish-hook)))))
(defun exwm-manage--unmanage-window (id &optional withdraw-only)
"Unmanage window ID.
If WITHDRAW-ONLY is non-nil, the X window will be properly placed back to the
root window. Set WITHDRAW-ONLY to 'quit if this functions is used when window
manager is shutting down."
(let ((buffer (exwm--id->buffer id)))
(exwm--log "Unmanage #x%x (buffer: %s, widthdraw: %s)"
id buffer withdraw-only)
(setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist))
;; Update workspaces when a dock is destroyed.
(when (and (null withdraw-only)
(assq id exwm-workspace--id-struts-alist))
(setq exwm-workspace--id-struts-alist
(assq-delete-all id exwm-workspace--id-struts-alist))
(exwm-workspace--update-struts)
(exwm-workspace--update-workareas)
(dolist (f exwm-workspace--list)
(exwm-workspace--set-fullscreen f)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
;; Unmap the X window.
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window id))
;;
(setq exwm-workspace--switch-history-outdated t)
;;
(when withdraw-only
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window id :value-mask xcb:CW:EventMask
:event-mask xcb:EventMask:NoEvent))
;; Delete WM_STATE property
(xcb:+request exwm--connection
(make-instance 'xcb:DeleteProperty
:window id :property xcb:Atom:WM_STATE))
(cond
((eq withdraw-only 'quit)
;; Remap the window when exiting.
(xcb:+request exwm--connection
(make-instance 'xcb:MapWindow :window id)))
(t
;; Remove _NET_WM_DESKTOP.
(xcb:+request exwm--connection
(make-instance 'xcb:DeleteProperty
:window id
:property xcb:Atom:_NET_WM_DESKTOP)))))
(when exwm--floating-frame
;; Unmap the floating frame before destroying its container.
(let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id))
(container (frame-parameter exwm--floating-frame
'exwm-container)))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window window))
(xcb:+request exwm--connection
(make-instance 'xcb:ReparentWindow
:window window :parent exwm--root :x 0 :y 0))
(xcb:+request exwm--connection
(make-instance 'xcb:DestroyWindow :window container))))
(when (exwm-layout--fullscreen-p)
(let ((window (get-buffer-window)))
(when window
(set-window-dedicated-p window nil))))
(exwm-manage--set-client-list)
(xcb:flush exwm--connection))
(let ((kill-buffer-func
(lambda (buffer)
(when (buffer-local-value 'exwm--floating-frame buffer)
(select-window
(frame-selected-window exwm-workspace--current)))
(with-current-buffer buffer
(let ((kill-buffer-query-functions nil))
(kill-buffer buffer))))))
(exwm--defer 0 kill-buffer-func buffer)
(when (active-minibuffer-window)
(exit-minibuffer))))))
(defun exwm-manage--scan ()
"Search for existing windows and try to manage them."
(exwm--log)
(let* ((tree (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:QueryTree
:window exwm--root)))
reply)
(dolist (i (slot-value tree 'children))
(setq reply (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:GetWindowAttributes
:window i)))
;; It's possible the X window has been destroyed.
(when reply
(with-slots (override-redirect map-state) reply
(when (and (= 0 override-redirect)
(= xcb:MapState:Viewable map-state))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow
:window i))
(xcb:flush exwm--connection)
(exwm-manage--manage-window i)))))))
(defun exwm-manage--kill-buffer-query-function ()
"Run in `kill-buffer-query-functions'."
(exwm--log "id=#x%x; buffer=%s" exwm--id (current-buffer))
(catch 'return
(when (or (not exwm--id)
(xcb:+request-checked+request-check exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window exwm--id
:value-mask xcb:CW:EventMask
:event-mask (exwm--get-client-event-mask))))
;; The X window is no longer alive so just close the buffer.
(when exwm--floating-frame
(let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id))
(container (frame-parameter exwm--floating-frame
'exwm-container)))
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow :window window))
(xcb:+request exwm--connection
(make-instance 'xcb:ReparentWindow
:window window
:parent exwm--root
:x 0 :y 0))
(xcb:+request exwm--connection
(make-instance 'xcb:DestroyWindow
:window container))))
(xcb:flush exwm--connection)
(throw 'return t))
(unless (memq xcb:Atom:WM_DELETE_WINDOW exwm--protocols)
;; The X window does not support WM_DELETE_WINDOW; destroy it.
(xcb:+request exwm--connection
(make-instance 'xcb:DestroyWindow :window exwm--id))
(xcb:flush exwm--connection)
;; Wait for DestroyNotify event.
(throw 'return nil))
(let ((id exwm--id))
;; Try to close the X window with WM_DELETE_WINDOW client message.
(xcb:+request exwm--connection
(make-instance 'xcb:icccm:SendEvent
:destination id
:event (xcb:marshal
(make-instance 'xcb:icccm:WM_DELETE_WINDOW
:window id)
exwm--connection)))
(xcb:flush exwm--connection)
;;
(unless (memq xcb:Atom:_NET_WM_PING exwm--protocols)
;; For X windows without _NET_WM_PING support, we'd better just
;; wait for DestroyNotify events.
(throw 'return nil))
;; Try to determine if the X window is dead with _NET_WM_PING.
(setq exwm-manage--ping-lock t)
(xcb:+request exwm--connection
(make-instance 'xcb:SendEvent
:propagate 0
:destination id
:event-mask xcb:EventMask:NoEvent
:event (xcb:marshal
(make-instance 'xcb:ewmh:_NET_WM_PING
:window id
:timestamp 0
:client-window id)
exwm--connection)))
(xcb:flush exwm--connection)
(with-timeout (exwm-manage-ping-timeout
(if (y-or-n-p (format "'%s' is not responding. \
Would you like to kill it? "
(buffer-name)))
(progn (exwm-manage--kill-client id)
;; Kill the unresponsive X window and
;; wait for DestroyNotify event.
(throw 'return nil))
;; Give up.
(throw 'return nil)))
(while (and exwm-manage--ping-lock
(exwm--id->buffer id)) ;may have been destroyed.
(accept-process-output nil 0.1))
;; Give up.
(throw 'return nil)))))
(defun exwm-manage--kill-client (&optional id)
"Kill an X client."
(unless id (setq id (exwm--buffer->id (current-buffer))))
(exwm--log "id=#x%x" id)
(let* ((response (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:ewmh:get-_NET_WM_PID :window id)))
(pid (and response (slot-value response 'value)))
(request (make-instance 'xcb:KillClient :resource id)))
(if (not pid)
(xcb:+request exwm--connection request)
;; What if the PID is fake/wrong?
(signal-process pid 'SIGKILL)
;; Ensure it's dead
(run-with-timer exwm-manage-ping-timeout nil
(lambda ()
(xcb:+request exwm--connection request))))
(xcb:flush exwm--connection)))
(defun exwm-manage--add-frame (frame)
"Run in `after-make-frame-functions'."
(exwm--log "frame=%s" frame)
(when (display-graphic-p frame)
(push (string-to-number (frame-parameter frame 'outer-window-id))
exwm-manage--frame-outer-id-list)))
(defun exwm-manage--remove-frame (frame)
"Run in `delete-frame-functions'."
(exwm--log "frame=%s" frame)
(when (display-graphic-p frame)
(setq exwm-manage--frame-outer-id-list
(delq (string-to-number (frame-parameter frame 'outer-window-id))
exwm-manage--frame-outer-id-list))))
(defun exwm-manage--on-ConfigureRequest (data _synthetic)
"Handle ConfigureRequest event."
(exwm--log)
(let ((obj (make-instance 'xcb:ConfigureRequest))
buffer edges width-delta height-delta)
(xcb:unmarshal obj data)
(with-slots (window x y width height
border-width sibling stack-mode value-mask)
obj
(exwm--log "#x%x (#x%x) @%dx%d%+d%+d; \
border-width: %d; sibling: #x%x; stack-mode: %d"
window value-mask width height x y
border-width sibling stack-mode)
(if (and (setq buffer (exwm--id->buffer window))
(with-current-buffer buffer
(or (exwm-layout--fullscreen-p)
;; Make sure it's a floating X window wanting to resize
;; itself.
(or (not exwm--floating-frame)
(progn
(setq edges
(window-inside-pixel-edges
(get-buffer-window buffer t))
width-delta (- width (- (elt edges 2)
(elt edges 0)))
height-delta (- height (- (elt edges 3)
(elt edges 1))))
;; We cannot do resizing precisely for now.
(and (if (= 0 (logand value-mask
xcb:ConfigWindow:Width))
t
(< (abs width-delta)
exwm-manage--width-delta-min))
(if (= 0 (logand value-mask
xcb:ConfigWindow:Height))
t
(< (abs height-delta)
exwm-manage--height-delta-min))))))))
;; Send client message for managed windows
(with-current-buffer buffer
(setq edges
(if (exwm-layout--fullscreen-p)
(with-slots (x y width height)
(exwm-workspace--get-geometry exwm--frame)
(list x y width height))
(window-inside-absolute-pixel-edges
(get-buffer-window buffer t))))
(exwm--log "Reply with ConfigureNotify (edges): %s" edges)
(xcb:+request exwm--connection
(make-instance 'xcb:SendEvent
:propagate 0 :destination window
:event-mask xcb:EventMask:StructureNotify
:event (xcb:marshal
(make-instance
'xcb:ConfigureNotify
:event window :window window
:above-sibling xcb:Window:None
:x (elt edges 0) :y (elt edges 1)
:width (- (elt edges 2) (elt edges 0))
:height (- (elt edges 3) (elt edges 1))
:border-width 0 :override-redirect 0)
exwm--connection))))
(if buffer
(with-current-buffer buffer
(exwm--log "ConfigureWindow (resize floating X window)")
(exwm--set-geometry (frame-parameter exwm--floating-frame
'exwm-outer-id)
nil
nil
(+ (frame-pixel-width exwm--floating-frame)
width-delta)
(+ (frame-pixel-height exwm--floating-frame)
height-delta)))
(exwm--log "ConfigureWindow (preserve geometry)")
;; Configure the unmanaged window.
;; But Emacs frames should be excluded. Generally we don't
;; receive ConfigureRequest events from Emacs frames since we
;; have set OverrideRedirect on them, but this is not true for
;; Lucid build (as of 25.1).
(unless (memq window exwm-manage--frame-outer-id-list)
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window window
:value-mask value-mask
:x x :y y :width width :height height
:border-width border-width
:sibling sibling
:stack-mode stack-mode)))))))
(xcb:flush exwm--connection))
(defun exwm-manage--on-MapRequest (data _synthetic)
"Handle MapRequest event."
(let ((obj (make-instance 'xcb:MapRequest)))
(xcb:unmarshal obj data)
(with-slots (parent window) obj
(exwm--log "id=#x%x parent=#x%x" window parent)
(if (assoc window exwm--id-buffer-alist)
(with-current-buffer (exwm--id->buffer window)
(if (exwm-layout--iconic-state-p)
;; State change: iconic => normal.
(when (eq exwm--frame exwm-workspace--current)
(pop-to-buffer-same-window (current-buffer)))
(exwm--log "#x%x is already managed" window)))
(if (/= exwm--root parent)
(progn (xcb:+request exwm--connection
(make-instance 'xcb:MapWindow :window window))
(xcb:flush exwm--connection))
(exwm--log "#x%x" window)
(exwm-manage--manage-window window))))))
(defun exwm-manage--on-UnmapNotify (data _synthetic)
"Handle UnmapNotify event."
(let ((obj (make-instance 'xcb:UnmapNotify)))
(xcb:unmarshal obj data)
(with-slots (window) obj
(exwm--log "id=#x%x" window)
(exwm-manage--unmanage-window window t))))
(defun exwm-manage--on-MapNotify (data _synthetic)
"Handle MapNotify event."
(let ((obj (make-instance 'xcb:MapNotify)))
(xcb:unmarshal obj data)
(with-slots (window) obj
(when (assoc window exwm--id-buffer-alist)
(exwm--log "id=#x%x" window)
;; With this we ensure that a "window hierarchy change" happens after
;; mapping the window, as some servers (XQuartz) do not generate it.
(with-current-buffer (exwm--id->buffer window)
(if exwm--floating-frame
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window window
:value-mask xcb:ConfigWindow:StackMode
:stack-mode xcb:StackMode:Above))
(xcb:+request exwm--connection
(make-instance 'xcb:ConfigureWindow
:window window
:value-mask (logior xcb:ConfigWindow:Sibling
xcb:ConfigWindow:StackMode)
:sibling exwm--guide-window
:stack-mode xcb:StackMode:Above))))
(xcb:flush exwm--connection)))))
(defun exwm-manage--on-DestroyNotify (data synthetic)
"Handle DestroyNotify event."
(unless synthetic
(exwm--log)
(let ((obj (make-instance 'xcb:DestroyNotify)))
(xcb:unmarshal obj data)
(exwm--log "#x%x" (slot-value obj 'window))
(exwm-manage--unmanage-window (slot-value obj 'window)))))
(defun exwm-manage--init ()
"Initialize manage module."
;; Intern _MOTIF_WM_HINTS
(exwm--log)
(setq exwm-manage--_MOTIF_WM_HINTS (exwm--intern-atom "_MOTIF_WM_HINTS"))
(add-hook 'after-make-frame-functions #'exwm-manage--add-frame)
(add-hook 'delete-frame-functions #'exwm-manage--remove-frame)
(xcb:+event exwm--connection 'xcb:ConfigureRequest
#'exwm-manage--on-ConfigureRequest)
(xcb:+event exwm--connection 'xcb:MapRequest #'exwm-manage--on-MapRequest)
(xcb:+event exwm--connection 'xcb:UnmapNotify #'exwm-manage--on-UnmapNotify)
(xcb:+event exwm--connection 'xcb:MapNotify #'exwm-manage--on-MapNotify)
(xcb:+event exwm--connection 'xcb:DestroyNotify
#'exwm-manage--on-DestroyNotify))
(defun exwm-manage--exit ()
"Exit the manage module."
(exwm--log)
(dolist (pair exwm--id-buffer-alist)
(exwm-manage--unmanage-window (car pair) 'quit))
(remove-hook 'after-make-frame-functions #'exwm-manage--add-frame)
(remove-hook 'delete-frame-functions #'exwm-manage--remove-frame)
(setq exwm-manage--_MOTIF_WM_HINTS nil))
(provide 'exwm-manage)
;;; exwm-manage.el ends here

BIN
elpa/exwm-0.24/exwm-manage.elc
View File

Binary file not shown.

2
elpa/exwm-0.24/exwm-pkg.el
View File

@ -1,2 +0,0 @@
;; Generated package description from exwm.el -*- no-byte-compile: t -*-
(define-package "exwm" "0.24" "Emacs X Window Manager" '((xelb "0.18")) :keywords '("unix") :authors '(("Chris Feng" . "chris.w.feng@gmail.com")) :maintainer '("Chris Feng" . "chris.w.feng@gmail.com") :url "https://github.com/ch11ng/exwm")

375
elpa/exwm-0.24/exwm-randr.el
View File

@ -1,375 +0,0 @@
;;; exwm-randr.el --- RandR Module for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module adds RandR support for EXWM. Currently it requires external
;; tools such as xrandr(1) to properly configure RandR first. This
;; dependency may be removed in the future, but more work is needed before
;; that.
;; To use this module, load, enable it and configure
;; `exwm-randr-workspace-monitor-plist' and `exwm-randr-screen-change-hook'
;; as follows:
;;
;; (require 'exwm-randr)
;; (setq exwm-randr-workspace-monitor-plist '(0 "VGA1"))
;; (add-hook 'exwm-randr-screen-change-hook
;; (lambda ()
;; (start-process-shell-command
;; "xrandr" nil "xrandr --output VGA1 --left-of LVDS1 --auto")))
;; (exwm-randr-enable)
;;
;; With above lines, workspace 0 should be assigned to the output named "VGA1",
;; staying at the left of other workspaces on the output "LVDS1". Please refer
;; to xrandr(1) for the configuration of RandR.
;; References:
;; + RandR (http://www.x.org/archive/X11R7.7/doc/randrproto/randrproto.txt)
;;; Code:
(require 'xcb-randr)
(require 'exwm-core)
(require 'exwm-workspace)
(defgroup exwm-randr nil
"RandR."
:version "25.3"
:group 'exwm)
(defcustom exwm-randr-refresh-hook nil
"Normal hook run when the RandR module just refreshed."
:type 'hook)
(defcustom exwm-randr-screen-change-hook nil
"Normal hook run when screen changes."
:type 'hook)
(defcustom exwm-randr-workspace-monitor-plist nil
"Plist mapping workspaces to monitors.
In RandR 1.5 a monitor is a rectangle region decoupled from the physical
size of screens, and can be identified with `xrandr --listmonitors' (name of
the primary monitor is prefixed with an `*'). When no monitor is created it
automatically fallback to RandR 1.2 output which represents the physical
screen size. RandR 1.5 monitors can be created with `xrandr --setmonitor'.
For example, to split an output (`LVDS-1') of size 1280x800 into two
side-by-side monitors one could invoke (the digits after `/' are size in mm)
xrandr --setmonitor *LVDS-1-L 640/135x800/163+0+0 LVDS-1
xrandr --setmonitor LVDS-1-R 640/135x800/163+640+0 none
If a monitor is not active, the workspaces mapped to it are displayed on the
primary monitor until it becomes active (if ever). Unspecified workspaces
are all mapped to the primary monitor. For example, with the following
setting workspace other than 1 and 3 would always be displayed on the
primary monitor where workspace 1 and 3 would be displayed on their
corresponding monitors whenever the monitors are active.
\\='(1 \"HDMI-1\" 3 \"DP-1\")"
:type '(plist :key-type integer :value-type string))
(with-no-warnings
(define-obsolete-variable-alias 'exwm-randr-workspace-output-plist
'exwm-randr-workspace-monitor-plist "27.1"))
(defvar exwm-randr--last-timestamp 0 "Used for debouncing events.")
(defvar exwm-randr--prev-screen-change-seqnum nil
"The most recent ScreenChangeNotify sequence number.")
(defvar exwm-randr--compatibility-mode nil
"Non-nil when the server does not support RandR 1.5 protocol.")
(defun exwm-randr--get-monitors ()
"Get RandR 1.5 monitors."
(exwm--log)
(let (monitor-name geometry monitor-geometry-alist primary-monitor)
(with-slots (timestamp monitors)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:randr:GetMonitors
:window exwm--root
:get-active 1))
(when (> timestamp exwm-randr--last-timestamp)
(setq exwm-randr--last-timestamp timestamp))
(dolist (monitor monitors)
(with-slots (name primary x y width height) monitor
(setq monitor-name (x-get-atom-name name)
geometry (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
monitor-geometry-alist (cons (cons monitor-name geometry)
monitor-geometry-alist))
(exwm--log "%s: %sx%s+%s+%s" monitor-name x y width height)
;; Save primary monitor when available (fallback to the first one).
(when (or (/= 0 primary)
(not primary-monitor))
(setq primary-monitor monitor-name)))))
(exwm--log "Primary monitor: %s" primary-monitor)
(list primary-monitor monitor-geometry-alist
(exwm-randr--get-monitor-alias primary-monitor
monitor-geometry-alist))))
(defun exwm-randr--get-outputs ()
"Get RandR 1.2 outputs.
Only used when RandR 1.5 is not supported by the server."
(exwm--log)
(let (output-name geometry output-geometry-alist primary-output)
(with-slots (config-timestamp outputs)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:randr:GetScreenResourcesCurrent
:window exwm--root))
(when (> config-timestamp exwm-randr--last-timestamp)
(setq exwm-randr--last-timestamp config-timestamp))
(dolist (output outputs)
(with-slots (crtc connection name)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:randr:GetOutputInfo
:output output
:config-timestamp config-timestamp))
(when (and (= connection xcb:randr:Connection:Connected)
(/= crtc 0))
(with-slots (x y width height)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:randr:GetCrtcInfo
:crtc crtc
:config-timestamp config-timestamp))
(setq output-name (decode-coding-string
(apply #'unibyte-string name) 'utf-8)
geometry (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
output-geometry-alist (cons (cons output-name geometry)
output-geometry-alist))
(exwm--log "%s: %sx%s+%s+%s" output-name x y width height)
;; The primary output is the first one.
(unless primary-output
(setq primary-output output-name)))))))
(exwm--log "Primary output: %s" primary-output)
(list primary-output output-geometry-alist
(exwm-randr--get-monitor-alias primary-output
output-geometry-alist))))
(defun exwm-randr--get-monitor-alias (primary-monitor monitor-geometry-alist)
"Generate monitor aliases using PRIMARY-MONITOR MONITOR-GEOMETRY-ALIST.
In a mirroring setup some monitors overlap and should be treated as one."
(let (monitor-position-alist monitor-alias-alist monitor-name geometry)
(setq monitor-position-alist (with-slots (x y)
(cdr (assoc primary-monitor
monitor-geometry-alist))
(list (cons primary-monitor (vector x y)))))
(setq monitor-alias-alist (list (cons primary-monitor primary-monitor)))
(dolist (pair monitor-geometry-alist)
(setq monitor-name (car pair)
geometry (cdr pair))
(unless (assoc monitor-name monitor-alias-alist)
(let* ((position (vector (slot-value geometry 'x)
(slot-value geometry 'y)))
(alias (car (rassoc position monitor-position-alist))))
(if alias
(setq monitor-alias-alist (cons (cons monitor-name alias)
monitor-alias-alist))
(setq monitor-position-alist (cons (cons monitor-name position)
monitor-position-alist)
monitor-alias-alist (cons (cons monitor-name monitor-name)
monitor-alias-alist))))))
monitor-alias-alist))
;;;###autoload
(defun exwm-randr-refresh ()
"Refresh workspaces according to the updated RandR info."
(interactive)
(exwm--log)
(let* ((result (if exwm-randr--compatibility-mode
(exwm-randr--get-outputs)
(exwm-randr--get-monitors)))
(primary-monitor (elt result 0))
(monitor-geometry-alist (elt result 1))
(monitor-alias-alist (elt result 2))
container-monitor-alist container-frame-alist)
(when (and primary-monitor monitor-geometry-alist)
(when exwm-workspace--fullscreen-frame-count
;; Not all workspaces are fullscreen; reset this counter.
(setq exwm-workspace--fullscreen-frame-count 0))
(dotimes (i (exwm-workspace--count))
(let* ((monitor (plist-get exwm-randr-workspace-monitor-plist i))
(geometry (cdr (assoc monitor monitor-geometry-alist)))
(frame (elt exwm-workspace--list i))
(container (frame-parameter frame 'exwm-container)))
(if geometry
;; Unify monitor names in case it's a mirroring setup.
(setq monitor (cdr (assoc monitor monitor-alias-alist)))
;; Missing monitors fallback to the primary one.
(setq monitor primary-monitor
geometry (cdr (assoc primary-monitor
monitor-geometry-alist))))
(setq container-monitor-alist (nconc
`((,container . ,(intern monitor)))
container-monitor-alist)
container-frame-alist (nconc `((,container . ,frame))
container-frame-alist))
(set-frame-parameter frame 'exwm-randr-monitor monitor)
(set-frame-parameter frame 'exwm-geometry geometry)))
;; Update workareas.
(exwm-workspace--update-workareas)
;; Resize workspace.
(dolist (f exwm-workspace--list)
(exwm-workspace--set-fullscreen f))
(xcb:flush exwm--connection)
;; Raise the minibuffer if it's active.
(when (and (active-minibuffer-window)
(exwm-workspace--minibuffer-own-frame-p))
(exwm-workspace--show-minibuffer))
;; Set _NET_DESKTOP_GEOMETRY.
(exwm-workspace--set-desktop-geometry)
;; Update active/inactive workspaces.
(dolist (w exwm-workspace--list)
(exwm-workspace--set-active w nil))
;; Mark the workspace on the top of each monitor as active.
(dolist (xwin
(reverse
(slot-value (xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:QueryTree
:window exwm--root))
'children)))
(let ((monitor (cdr (assq xwin container-monitor-alist))))
(when monitor
(setq container-monitor-alist
(rassq-delete-all monitor container-monitor-alist))
(exwm-workspace--set-active (cdr (assq xwin container-frame-alist))
t))))
(xcb:flush exwm--connection)
(run-hooks 'exwm-randr-refresh-hook))))
(define-obsolete-function-alias 'exwm-randr--refresh #'exwm-randr-refresh
"27.1")
(defun exwm-randr--on-ScreenChangeNotify (data _synthetic)
"Handle `ScreenChangeNotify' event.
Run `exwm-randr-screen-change-hook' (usually user scripts to configure RandR)."
(exwm--log)
(let ((evt (make-instance 'xcb:randr:ScreenChangeNotify)))
(xcb:unmarshal evt data)
(let ((seqnum (slot-value evt '~sequence)))
(unless (equal seqnum exwm-randr--prev-screen-change-seqnum)
(setq exwm-randr--prev-screen-change-seqnum seqnum)
(run-hooks 'exwm-randr-screen-change-hook)))))
(defun exwm-randr--on-Notify (data _synthetic)
"Handle `CrtcChangeNotify' and `OutputChangeNotify' events.
Refresh when any CRTC/output changes."
(exwm--log)
(let ((evt (make-instance 'xcb:randr:Notify))
notify)
(xcb:unmarshal evt data)
(with-slots (subCode u) evt
(cl-case subCode
(xcb:randr:Notify:CrtcChange
(setq notify (slot-value u 'cc)))
(xcb:randr:Notify:OutputChange
(setq notify (slot-value u 'oc))))
(when notify
(with-slots (timestamp) notify
(when (> timestamp exwm-randr--last-timestamp)
(exwm-randr-refresh)
(setq exwm-randr--last-timestamp timestamp)))))))
(defun exwm-randr--on-ConfigureNotify (data _synthetic)
"Handle `ConfigureNotify' event.
Refresh when any RandR 1.5 monitor changes."
(exwm--log)
(let ((evt (make-instance 'xcb:ConfigureNotify)))
(xcb:unmarshal evt data)
(with-slots (window) evt
(when (eq window exwm--root)
(exwm-randr-refresh)))))
(defun exwm-randr--init ()
"Initialize RandR extension and EXWM RandR module."
(exwm--log)
(when (= 0 (slot-value (xcb:get-extension-data exwm--connection 'xcb:randr)
'present))
(error "[EXWM] RandR extension is not supported by the server"))
(with-slots (major-version minor-version)
(xcb:+request-unchecked+reply exwm--connection
(make-instance 'xcb:randr:QueryVersion
:major-version 1 :minor-version 5))
(cond ((and (= major-version 1) (= minor-version 5))
(setq exwm-randr--compatibility-mode nil))
((and (= major-version 1) (>= minor-version 2))
(setq exwm-randr--compatibility-mode t))
(t
(error "[EXWM] The server only support RandR version up to %d.%d"
major-version minor-version)))
;; External monitor(s) may already be connected.
(run-hooks 'exwm-randr-screen-change-hook)
(exwm-randr-refresh)
;; Listen for `ScreenChangeNotify' to notify external tools to
;; configure RandR and `CrtcChangeNotify/OutputChangeNotify' to
;; refresh the workspace layout.
(xcb:+event exwm--connection 'xcb:randr:ScreenChangeNotify
#'exwm-randr--on-ScreenChangeNotify)
(xcb:+event exwm--connection 'xcb:randr:Notify
#'exwm-randr--on-Notify)
(xcb:+event exwm--connection 'xcb:ConfigureNotify
#'exwm-randr--on-ConfigureNotify)
(xcb:+request exwm--connection
(make-instance 'xcb:randr:SelectInput
:window exwm--root
:enable (logior
xcb:randr:NotifyMask:ScreenChange
xcb:randr:NotifyMask:CrtcChange
xcb:randr:NotifyMask:OutputChange)))
(xcb:flush exwm--connection)
(add-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh))
;; Prevent frame parameters introduced by this module from being
;; saved/restored.
(dolist (i '(exwm-randr-monitor))
(unless (assq i frameset-filter-alist)
(push (cons i :never) frameset-filter-alist))))
(defun exwm-randr--exit ()
"Exit the RandR module."
(exwm--log)
(remove-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh))
(defun exwm-randr-enable ()
"Enable RandR support for EXWM."
(exwm--log)
(add-hook 'exwm-init-hook #'exwm-randr--init)
(add-hook 'exwm-exit-hook #'exwm-randr--exit))
(provide 'exwm-randr)
;;; exwm-randr.el ends here

BIN
elpa/exwm-0.24/exwm-randr.elc
View File

Binary file not shown.

587
elpa/exwm-0.24/exwm-systemtray.el
View File

@ -1,587 +0,0 @@
;;; exwm-systemtray.el --- System Tray Module for -*- lexical-binding: t -*-
;;; EXWM
;; Copyright (C) 2016-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module adds system tray support for EXWM.
;; To use this module, load and enable it as follows:
;; (require 'exwm-systemtray)
;; (exwm-systemtray-enable)
;;; Code:
(require 'xcb-icccm)
(require 'xcb-xembed)
(require 'xcb-systemtray)
(require 'exwm-core)
(require 'exwm-workspace)
(defclass exwm-systemtray--icon ()
((width :initarg :width)
(height :initarg :height)
(visible :initarg :visible))
:documentation "Attributes of a system tray icon.")
(defclass xcb:systemtray:-ClientMessage
(xcb:icccm:--ClientMessage xcb:ClientMessage)
((format :initform 32)
(type :initform xcb:Atom:MANAGER)
(time :initarg :time :type xcb:TIMESTAMP) ;new slot
(selection :initarg :selection :type xcb:ATOM) ;new slot
(owner :initarg :owner :type xcb:WINDOW)) ;new slot
:documentation "A systemtray client message.")
(defgroup exwm-systemtray nil
"System tray."
:version "25.3"
:group 'exwm)
(defcustom exwm-systemtray-height nil
"System tray height.
You shall use the default value if using auto-hide minibuffer."
:type 'integer)
(defcustom exwm-systemtray-icon-gap 2
"Gap between icons."
:type 'integer)
(defvar exwm-systemtray--embedder-window nil "The embedder window.")
(defcustom exwm-systemtray-background-color nil
"Background color of systemtray.
This should be a color, or nil for transparent background."
:type '(choice (const :tag "Transparent" nil)
(color))
:initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
;; Change the background color for embedder.
(when (and exwm--connection
exwm-systemtray--embedder-window)
(let ((background-pixel (exwm--color->pixel value)))
(xcb:+request exwm--connection
(make-instance 'xcb:ChangeWindowAttributes
:window exwm-systemtray--embedder-window
:value-mask (logior xcb:CW:BackPixmap
(if background-pixel
xcb:CW:BackPixel 0))
:background-pixmap
xcb:BackPixmap:ParentRelative
:background-pixel background-pixel))
;; Unmap & map to take effect immediately.
(xcb:+request exwm--connection
(make-instance 'xcb:UnmapWindow
:window exwm-systemtray--embedder-window))
(xcb:+request exwm--connection
(make-instance 'xcb:MapWindow
:window exwm-systemtray--embedder-window))
(xcb:flush exwm--connection)))))
;; GTK icons require at least 16 pixels to show normally.
(defconst exwm-systemtray--icon-min-size 16 "Minimum icon size.")
(defvar exwm-systemtray--connection nil "The X connection.")
(defvar exwm-systemtray--list nil "The icon list.")
(defvar exwm-systemtray--selection-owner-window nil
"The selection owner window.")
(defvar xcb:Atom:_NET_SYSTEM_TRAY_S0)
(defun exwm-systemtray--embed (icon)
"Embed an icon."
(exwm--log "Try to embed #x%x" icon)
(let ((info (xcb:+request-unchecked+reply exwm-systemtray--connection
(make-instance 'xcb:xembed:get-_XEMBED_INFO
:window icon)))
width* height* visible)
(when info
(exwm--log "Embed #x%x" icon)
(with-slots (width height)
(xcb:+request-unchecked+reply exwm-systemtray--connection
(make-instance 'xcb:GetGeometry :drawable icon))
(setq height* exwm-systemtray-height
width* (round (* width (/ (float height*) height))))
(when (< width* exwm-systemtray--icon-min-size)
(setq width* exwm-systemtray--icon-min-size
height* (round (* height (/ (float width*) width)))))
(exwm--log "Resize from %dx%d to %dx%d"
width height width* height*))
;; Add this icon to save-set.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ChangeSaveSet
:mode xcb:SetMode:Insert
:window icon))
;; Reparent to the embedder.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ReparentWindow
:window icon
:parent exwm-systemtray--embedder-window
:x 0
;; Vertically centered.
:y (/ (- exwm-systemtray-height height*) 2)))
;; Resize the icon.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ConfigureWindow
:window icon
:value-mask (logior xcb:ConfigWindow:Width
xcb:ConfigWindow:Height
xcb:ConfigWindow:BorderWidth)
:width width*
:height height*
:border-width 0))
;; Set event mask.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ChangeWindowAttributes
:window icon
:value-mask xcb:CW:EventMask
:event-mask (logior xcb:EventMask:ResizeRedirect
xcb:EventMask:KeyPress
xcb:EventMask:PropertyChange)))
;; Grab all keys and forward them to Emacs frame.
(unless (exwm-workspace--minibuffer-own-frame-p)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:GrabKey
:owner-events 0
:grab-window icon
:modifiers xcb:ModMask:Any
:key xcb:Grab:Any
:pointer-mode xcb:GrabMode:Async
:keyboard-mode xcb:GrabMode:Async)))
(setq visible (slot-value info 'flags))
(if visible
(setq visible
(/= 0 (logand (slot-value info 'flags) xcb:xembed:MAPPED)))
;; Default to visible.
(setq visible t))
(when visible
(exwm--log "Map the window")
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:MapWindow :window icon)))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:xembed:SendEvent
:destination icon
:event
(xcb:marshal
(make-instance 'xcb:xembed:EMBEDDED-NOTIFY
:window icon
:time xcb:Time:CurrentTime
:embedder
exwm-systemtray--embedder-window
:version 0)
exwm-systemtray--connection)))
(push `(,icon . ,(make-instance 'exwm-systemtray--icon
:width width*
:height height*
:visible visible))
exwm-systemtray--list)
(exwm-systemtray--refresh))))
(defun exwm-systemtray--unembed (icon)
"Unembed an icon."
(exwm--log "Unembed #x%x" icon)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:UnmapWindow :window icon))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ReparentWindow
:window icon
:parent exwm--root
:x 0 :y 0))
(setq exwm-systemtray--list
(assq-delete-all icon exwm-systemtray--list))
(exwm-systemtray--refresh))
(defun exwm-systemtray--refresh ()
"Refresh the system tray."
(exwm--log)
;; Make sure to redraw the embedder.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:UnmapWindow
:window exwm-systemtray--embedder-window))
(let ((x exwm-systemtray-icon-gap)
map)
(dolist (pair exwm-systemtray--list)
(when (slot-value (cdr pair) 'visible)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ConfigureWindow
:window (car pair)
:value-mask xcb:ConfigWindow:X
:x x))
(setq x (+ x (slot-value (cdr pair) 'width)
exwm-systemtray-icon-gap))
(setq map t)))
(let ((workarea (elt exwm-workspace--workareas
exwm-workspace-current-index)))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ConfigureWindow
:window exwm-systemtray--embedder-window
:value-mask (logior xcb:ConfigWindow:X
xcb:ConfigWindow:Width)
:x (- (aref workarea 2) x)
:width x)))
(when map
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:MapWindow
:window exwm-systemtray--embedder-window))))
(xcb:flush exwm-systemtray--connection))
(defun exwm-systemtray--on-DestroyNotify (data _synthetic)
"Unembed icons on DestroyNotify."
(exwm--log)
(let ((obj (make-instance 'xcb:DestroyNotify)))
(xcb:unmarshal obj data)
(with-slots (window) obj
(when (assoc window exwm-systemtray--list)
(exwm-systemtray--unembed window)))))
(defun exwm-systemtray--on-ReparentNotify (data _synthetic)
"Unembed icons on ReparentNotify."
(exwm--log)
(let ((obj (make-instance 'xcb:ReparentNotify)))
(xcb:unmarshal obj data)
(with-slots (window parent) obj
(when (and (/= parent exwm-systemtray--embedder-window)
(assoc window exwm-systemtray--list))
(exwm-systemtray--unembed window)))))
(defun exwm-systemtray--on-ResizeRequest (data _synthetic)
"Resize the tray icon on ResizeRequest."
(exwm--log)
(let ((obj (make-instance 'xcb:ResizeRequest))
attr)
(xcb:unmarshal obj data)
(with-slots (window width height) obj
(when (setq attr (cdr (assoc window exwm-systemtray--list)))
(with-slots ((width* width)
(height* height))
attr
(setq height* exwm-systemtray-height
width* (round (* width (/ (float height*) height))))
(when (< width* exwm-systemtray--icon-min-size)
(setq width* exwm-systemtray--icon-min-size
height* (round (* height (/ (float width*) width)))))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ConfigureWindow
:window window
:value-mask (logior xcb:ConfigWindow:Y
xcb:ConfigWindow:Width
xcb:ConfigWindow:Height)
;; Vertically centered.
:y (/ (- exwm-systemtray-height height*) 2)
:width width*
:height height*)))
(exwm-systemtray--refresh)))))
(defun exwm-systemtray--on-PropertyNotify (data _synthetic)
"Map/Unmap the tray icon on PropertyNotify."
(exwm--log)
(let ((obj (make-instance 'xcb:PropertyNotify))
attr info visible)
(xcb:unmarshal obj data)
(with-slots (window atom state) obj
(when (and (eq state xcb:Property:NewValue)
(eq atom xcb:Atom:_XEMBED_INFO)
(setq attr (cdr (assoc window exwm-systemtray--list))))
(setq info (xcb:+request-unchecked+reply exwm-systemtray--connection
(make-instance 'xcb:xembed:get-_XEMBED_INFO
:window window)))
(when info
(setq visible (/= 0 (logand (slot-value info 'flags)
xcb:xembed:MAPPED)))
(exwm--log "#x%x visible? %s" window visible)
(if visible
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:MapWindow :window window))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:UnmapWindow :window window)))
(setf (slot-value attr 'visible) visible)
(exwm-systemtray--refresh))))))
(defun exwm-systemtray--on-ClientMessage (data _synthetic)
"Handle client messages."
(let ((obj (make-instance 'xcb:ClientMessage))
opcode data32)
(xcb:unmarshal obj data)
(with-slots (window type data) obj
(when (eq type xcb:Atom:_NET_SYSTEM_TRAY_OPCODE)
(setq data32 (slot-value data 'data32)
opcode (elt data32 1))
(exwm--log "opcode: %s" opcode)
(cond ((= opcode xcb:systemtray:opcode:REQUEST-DOCK)
(unless (assoc (elt data32 2) exwm-systemtray--list)
(exwm-systemtray--embed (elt data32 2))))
;; Not implemented (rarely used nowadays).
((or (= opcode xcb:systemtray:opcode:BEGIN-MESSAGE)
(= opcode xcb:systemtray:opcode:CANCEL-MESSAGE)))
(t
(exwm--log "Unknown opcode message: %s" obj)))))))
(defun exwm-systemtray--on-KeyPress (data _synthetic)
"Forward all KeyPress events to Emacs frame."
(exwm--log)
;; This function is only executed when there's no autohide minibuffer,
;; a workspace frame has the input focus and the pointer is over a
;; tray icon.
(let ((dest (frame-parameter (selected-frame) 'exwm-outer-id))
(obj (make-instance 'xcb:KeyPress)))
(xcb:unmarshal obj data)
(setf (slot-value obj 'event) dest)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:SendEvent
:propagate 0
:destination dest
:event-mask xcb:EventMask:NoEvent
:event (xcb:marshal obj exwm-systemtray--connection))))
(xcb:flush exwm-systemtray--connection))
(defun exwm-systemtray--on-workspace-switch ()
"Reparent/Refresh the system tray in `exwm-workspace-switch-hook'."
(exwm--log)
(unless (exwm-workspace--minibuffer-own-frame-p)
(exwm-workspace--update-offsets)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ReparentWindow
:window exwm-systemtray--embedder-window
:parent (string-to-number
(frame-parameter exwm-workspace--current
'window-id))
:x 0
:y (- (elt (elt exwm-workspace--workareas
exwm-workspace-current-index)
3)
exwm-workspace--frame-y-offset
exwm-systemtray-height))))
(exwm-systemtray--refresh))
(defun exwm-systemtray--refresh-all ()
"Reposition/Refresh the system tray."
(exwm--log)
(unless (exwm-workspace--minibuffer-own-frame-p)
(exwm-workspace--update-offsets)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ConfigureWindow
:window exwm-systemtray--embedder-window
:value-mask xcb:ConfigWindow:Y
:y (- (elt (elt exwm-workspace--workareas
exwm-workspace-current-index)
3)
exwm-workspace--frame-y-offset
exwm-systemtray-height))))
(exwm-systemtray--refresh))
(cl-defun exwm-systemtray--init ()
"Initialize system tray module."
(exwm--log)
(cl-assert (not exwm-systemtray--connection))
(cl-assert (not exwm-systemtray--list))
(cl-assert (not exwm-systemtray--selection-owner-window))
(cl-assert (not exwm-systemtray--embedder-window))
(unless exwm-systemtray-height
(setq exwm-systemtray-height (max exwm-systemtray--icon-min-size
(line-pixel-height))))
;; Create a new connection.
(setq exwm-systemtray--connection (xcb:connect))
(set-process-query-on-exit-flag (slot-value exwm-systemtray--connection
'process)
nil)
;; Initialize XELB modules.
(xcb:xembed:init exwm-systemtray--connection t)
(xcb:systemtray:init exwm-systemtray--connection t)
;; Acquire the manager selection _NET_SYSTEM_TRAY_S0.
(with-slots (owner)
(xcb:+request-unchecked+reply exwm-systemtray--connection
(make-instance 'xcb:GetSelectionOwner
:selection xcb:Atom:_NET_SYSTEM_TRAY_S0))
(when (/= owner xcb:Window:None)
(xcb:disconnect exwm-systemtray--connection)
(setq exwm-systemtray--connection nil)
(warn "[EXWM] Other system tray detected")
(cl-return-from exwm-systemtray--init)))
(let ((id (xcb:generate-id exwm-systemtray--connection)))
(setq exwm-systemtray--selection-owner-window id)
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:CreateWindow
:depth 0
:wid id
:parent exwm--root
:x 0
:y 0
:width 1
:height 1
:border-width 0
:class xcb:WindowClass:InputOnly
:visual 0
:value-mask xcb:CW:OverrideRedirect
:override-redirect 1))
;; Get the selection ownership.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:SetSelectionOwner
:owner id
:selection xcb:Atom:_NET_SYSTEM_TRAY_S0
:time xcb:Time:CurrentTime))
;; Send a client message to announce the selection.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:SendEvent
:propagate 0
:destination exwm--root
:event-mask xcb:EventMask:StructureNotify
:event (xcb:marshal
(make-instance 'xcb:systemtray:-ClientMessage
:window exwm--root
:time xcb:Time:CurrentTime
:selection
xcb:Atom:_NET_SYSTEM_TRAY_S0
:owner id)
exwm-systemtray--connection)))
;; Set _NET_WM_NAME.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ewmh:set-_NET_WM_NAME
:window id
:data "EXWM: exwm-systemtray--selection-owner-window"))
;; Set the _NET_SYSTEM_TRAY_ORIENTATION property.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:xembed:set-_NET_SYSTEM_TRAY_ORIENTATION
:window id
:data xcb:systemtray:ORIENTATION:HORZ)))
;; Create the embedder.
(let ((id (xcb:generate-id exwm-systemtray--connection))
(background-pixel (exwm--color->pixel exwm-systemtray-background-color))
frame parent depth y)
(setq exwm-systemtray--embedder-window id)
(if (exwm-workspace--minibuffer-own-frame-p)
(setq frame exwm-workspace--minibuffer
y (if (>= (line-pixel-height) exwm-systemtray-height)
;; Bottom aligned.
(- (line-pixel-height) exwm-systemtray-height)
;; Vertically centered.
(/ (- (line-pixel-height) exwm-systemtray-height) 2)))
(exwm-workspace--update-offsets)
(setq frame exwm-workspace--current
;; Bottom aligned.
y (- (elt (elt exwm-workspace--workareas
exwm-workspace-current-index)
3)
exwm-workspace--frame-y-offset
exwm-systemtray-height)))
(setq parent (string-to-number (frame-parameter frame 'window-id))
depth (slot-value (xcb:+request-unchecked+reply
exwm-systemtray--connection
(make-instance 'xcb:GetGeometry
:drawable parent))
'depth))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:CreateWindow
:depth depth
:wid id
:parent parent
:x 0
:y y
:width 1
:height exwm-systemtray-height
:border-width 0
:class xcb:WindowClass:InputOutput
:visual 0
:value-mask (logior xcb:CW:BackPixmap
(if background-pixel
xcb:CW:BackPixel 0)
xcb:CW:EventMask)
:background-pixmap xcb:BackPixmap:ParentRelative
:background-pixel background-pixel
:event-mask xcb:EventMask:SubstructureNotify))
;; Set _NET_WM_NAME.
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ewmh:set-_NET_WM_NAME
:window id
:data "EXWM: exwm-systemtray--embedder-window")))
(xcb:flush exwm-systemtray--connection)
;; Attach event listeners.
(xcb:+event exwm-systemtray--connection 'xcb:DestroyNotify
#'exwm-systemtray--on-DestroyNotify)
(xcb:+event exwm-systemtray--connection 'xcb:ReparentNotify
#'exwm-systemtray--on-ReparentNotify)
(xcb:+event exwm-systemtray--connection 'xcb:ResizeRequest
#'exwm-systemtray--on-ResizeRequest)
(xcb:+event exwm-systemtray--connection 'xcb:PropertyNotify
#'exwm-systemtray--on-PropertyNotify)
(xcb:+event exwm-systemtray--connection 'xcb:ClientMessage
#'exwm-systemtray--on-ClientMessage)
(unless (exwm-workspace--minibuffer-own-frame-p)
(xcb:+event exwm-systemtray--connection 'xcb:KeyPress
#'exwm-systemtray--on-KeyPress))
;; Add hook to move/reparent the embedder.
(add-hook 'exwm-workspace-switch-hook #'exwm-systemtray--on-workspace-switch)
(add-hook 'exwm-workspace--update-workareas-hook
#'exwm-systemtray--refresh-all)
(add-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all)
(add-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all)
(when (boundp 'exwm-randr-refresh-hook)
(add-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all))
;; The struts can be updated already.
(when exwm-workspace--workareas
(exwm-systemtray--refresh-all)))
(defun exwm-systemtray--exit ()
"Exit the systemtray module."
(exwm--log)
(when exwm-systemtray--connection
;; Hide & reparent out the embedder before disconnection to prevent
;; embedded icons from being reparented to an Emacs frame (which is the
;; parent of the embedder).
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:UnmapWindow
:window exwm-systemtray--embedder-window))
(xcb:+request exwm-systemtray--connection
(make-instance 'xcb:ReparentWindow
:window exwm-systemtray--embedder-window
:parent exwm--root
:x 0
:y 0))
(xcb:disconnect exwm-systemtray--connection)
(setq exwm-systemtray--connection nil
exwm-systemtray--list nil
exwm-systemtray--selection-owner-window nil
exwm-systemtray--embedder-window nil)
(remove-hook 'exwm-workspace-switch-hook
#'exwm-systemtray--on-workspace-switch)
(remove-hook 'exwm-workspace--update-workareas-hook
#'exwm-systemtray--refresh-all)
(remove-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all)
(remove-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all)
(when (boundp 'exwm-randr-refresh-hook)
(remove-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all))))
(defun exwm-systemtray-enable ()
"Enable system tray support for EXWM."
(exwm--log)
(add-hook 'exwm-init-hook #'exwm-systemtray--init)
(add-hook 'exwm-exit-hook #'exwm-systemtray--exit))
(provide 'exwm-systemtray)
;;; exwm-systemtray.el ends here

BIN
elpa/exwm-0.24/exwm-systemtray.elc
View File

Binary file not shown.

1750
elpa/exwm-0.24/exwm-workspace.el
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/exwm-0.24/exwm-workspace.elc
View File

Binary file not shown.

800
elpa/exwm-0.24/exwm-xim.el
View File

@ -1,800 +0,0 @@
;;; exwm-xim.el --- XIM Module for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module adds XIM support for EXWM and allows sending characters
;; generated by any Emacs's builtin input method (info node `Input Methods')
;; to X windows.
;; This module is essentially an X input method server utilizing Emacs as
;; its backend. It talks with X windows through the XIM protocol. The XIM
;; protocol is quite flexible by itself, stating that an implementation can
;; create network connections of various types as well as make use of an
;; existing X connection for communication, and that an IM server may
;; support multiple transport versions, various input styles and several
;; event flow modals, etc. Here we only make choices that are most popular
;; among other IM servers and more importantly, practical for Emacs to act
;; as an IM server:
;;
;; + Packets are transported on top of an X connection like most IMEs.
;; + Only transport version 0.0 (i.e. only-CM & Property-with-CM) is
;; supported (same as "IM Server Developers Kit", adopted by most IMEs).
;; + Only support static event flow, on-demand-synchronous method.
;; + Only "root-window" input style is supported.
;; To use this module, first load and enable it as follows:
;;
;; (require 'exwm-xim)
;; (exwm-xim-enable)
;;
;; A keybinding for `toggle-input-method' is probably required to turn on &
;; off an input method (default to `default-input-method'). It's bound to
;; 'C-\' by default and can be made reachable when working with X windows:
;;
;; (push ?\C-\\ exwm-input-prefix-keys)
;;
;; It's also required (and error-prone) to setup environment variables to
;; make applications actually use this input method. Typically the
;; following lines should be inserted into '~/.xinitrc'.
;;
;; export XMODIFIERS=@im=exwm-xim
;; export GTK_IM_MODULE=xim
;; export QT_IM_MODULE=xim
;; export CLUTTER_IM_MODULE=xim
;; References:
;; + XIM (http://www.x.org/releases/X11R7.6/doc/libX11/specs/XIM/xim.html)
;; + IMdkit (http://xorg.freedesktop.org/archive/unsupported/lib/IMdkit/)
;; + UIM (https://github.com/uim/uim)
;;; Code:
(eval-when-compile (require 'cl-lib))
(require 'xcb-keysyms)
(require 'xcb-xim)
(require 'exwm-core)
(require 'exwm-input)
(defconst exwm-xim--locales
"@locale=\
aa,af,ak,am,an,anp,ar,as,ast,ayc,az,be,bem,ber,bg,bhb,bho,bn,bo,br,brx,bs,byn,\
ca,ce,cmn,crh,cs,csb,cv,cy,da,de,doi,dv,dz,el,en,es,et,eu,fa,ff,fi,fil,fo,fr,\
fur,fy,ga,gd,gez,gl,gu,gv,ha,hak,he,hi,hne,hr,hsb,ht,hu,hy,ia,id,ig,ik,is,it,\
iu,iw,ja,ka,kk,kl,km,kn,ko,kok,ks,ku,kw,ky,lb,lg,li,li,lij,lo,lt,lv,lzh,mag,\
mai,mg,mhr,mi,mk,ml,mn,mni,mr,ms,mt,my,nan,nb,nds,ne,nhn,niu,nl,nn,nr,nso,oc,\
om,or,os,pa,pa,pap,pl,ps,pt,quz,raj,ro,ru,rw,sa,sat,sc,sd,se,shs,si,sid,sk,sl,\
so,sq,sr,ss,st,sv,sw,szl,ta,tcy,te,tg,th,the,ti,tig,tk,tl,tn,tr,ts,tt,ug,uk,\
unm,ur,uz,ve,vi,wa,wae,wal,wo,xh,yi,yo,yue,zh,zu,\
C,no"
"All supported locales (stolen from glibc).")
(defconst exwm-xim--default-error
(make-instance 'xim:error
:im-id 0
:ic-id 0
:flag xim:error-flag:invalid-both
:error-code xim:error-code:bad-something
:length 0
:type 0
:detail nil)
"Default error returned to clients.")
(defconst exwm-xim--default-im-attrs
(list (make-instance 'xim:XIMATTR
:id 0
:type xim:ATTRIBUTE-VALUE-TYPE:xim-styles
:length (length xlib:XNQueryInputStyle)
:attribute xlib:XNQueryInputStyle))
"Default IM attrs returned to clients.")
(defconst exwm-xim--default-ic-attrs
(list (make-instance 'xim:XICATTR
:id 0
:type xim:ATTRIBUTE-VALUE-TYPE:long-data
:length (length xlib:XNInputStyle)
:attribute xlib:XNInputStyle)
(make-instance 'xim:XICATTR
:id 1
:type xim:ATTRIBUTE-VALUE-TYPE:window
:length (length xlib:XNClientWindow)
:attribute xlib:XNClientWindow)
;; Required by e.g. xterm.
(make-instance 'xim:XICATTR
:id 2
:type xim:ATTRIBUTE-VALUE-TYPE:window
:length (length xlib:XNFocusWindow)
:attribute xlib:XNFocusWindow))
"Default IC attrs returned to clients.")
(defconst exwm-xim--default-styles
(make-instance 'xim:XIMStyles
:number nil
:styles (list (logior xlib:XIMPreeditNothing
xlib:XIMStatusNothing)))
"Default styles: root-window, i.e. no preediting or status display support.")
(defconst exwm-xim--default-attributes
(list (make-instance 'xim:XIMATTRIBUTE
:id 0
:length nil
:value exwm-xim--default-styles))
"Default IM/IC attributes returned to clients.")
(defvar exwm-xim--conn nil
"The X connection for initiating other XIM connections.")
(defvar exwm-xim--event-xwin nil
"X window for initiating new XIM connections.")
(defvar exwm-xim--server-client-plist '(nil nil)
"Plist mapping server window to [X connection, client window, byte-order].")
(defvar exwm-xim--client-server-plist '(nil nil)
"Plist mapping client window to server window.")
(defvar exwm-xim--property-index 0 "For generating a unique property name.")
(defvar exwm-xim--im-id 0 "Last IM ID.")
(defvar exwm-xim--ic-id 0 "Last IC ID.")
;; X11 atoms.
(defvar exwm-xim--@server nil)
(defvar exwm-xim--LOCALES nil)
(defvar exwm-xim--TRANSPORT nil)
(defvar exwm-xim--XIM_SERVERS nil)
(defvar exwm-xim--_XIM_PROTOCOL nil)
(defvar exwm-xim--_XIM_XCONNECT nil)
(defun exwm-xim--on-SelectionRequest (data _synthetic)
"Handle SelectionRequest events on IMS window.
Such events would be received when clients query for LOCALES or TRANSPORT."
(exwm--log)
(let ((evt (make-instance 'xcb:SelectionRequest))
value fake-event)
(xcb:unmarshal evt data)
(with-slots (time requestor selection target property) evt
(setq value (cond ((= target exwm-xim--LOCALES)
;; Return supported locales.
exwm-xim--locales)
((= target exwm-xim--TRANSPORT)
;; Use XIM over an X connection.
"@transport=X/")))
(when value
;; Change the property.
(xcb:+request exwm-xim--conn
(make-instance 'xcb:ChangeProperty
:mode xcb:PropMode:Replace
:window requestor
:property property
:type target
:format 8
:data-len (length value)
:data value))
;; Send a SelectionNotify event.
(setq fake-event (make-instance 'xcb:SelectionNotify
:time time
:requestor requestor
:selection selection
:target target
:property property))
(xcb:+request exwm-xim--conn
(make-instance 'xcb:SendEvent
:propagate 0
:destination requestor
:event-mask xcb:EventMask:NoEvent
:event (xcb:marshal fake-event exwm-xim--conn)))
(xcb:flush exwm-xim--conn)))))
(cl-defun exwm-xim--on-ClientMessage-0 (data _synthetic)
"Handle ClientMessage event on IMS window (new connection).
Such events would be received when clients request for _XIM_XCONNECT.
A new X connection and server window would be created to communicate with
this client."
(exwm--log)
(let ((evt (make-instance 'xcb:ClientMessage))
conn client-xwin server-xwin)
(xcb:unmarshal evt data)
(with-slots (window type data) evt
(unless (= type exwm-xim--_XIM_XCONNECT)
;; Only handle _XIM_XCONNECT.
(exwm--log "Ignore ClientMessage %s" type)
(cl-return-from exwm-xim--on-ClientMessage-0))
(setq client-xwin (elt (slot-value data 'data32) 0)
;; Create a new X connection and a new server window.
conn (xcb:connect)
server-xwin (xcb:generate-id conn))
(set-process-query-on-exit-flag (slot-value conn 'process) nil)
;; Store this client.
(plist-put exwm-xim--server-client-plist server-xwin
`[,conn ,client-xwin nil])
(plist-put exwm-xim--client-server-plist client-xwin server-xwin)
;; Select DestroyNotify events on this client window.
(xcb:+request exwm-xim--conn
(make-instance 'xcb:ChangeWindowAttributes
:window client-xwin
:value-mask xcb:CW:EventMask
:event-mask xcb:EventMask:StructureNotify))
(xcb:flush exwm-xim--conn)
;; Handle ClientMessage events from this new connection.
(xcb:+event conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage)
;; Create a communication window.
(xcb:+request conn
(make-instance 'xcb:CreateWindow
:depth 0
:wid server-xwin
:parent exwm--root
:x 0
:y 0
:width 1
:height 1
:border-width 0
:class xcb:WindowClass:InputOutput
:visual 0
:value-mask xcb:CW:OverrideRedirect
:override-redirect 1))
(xcb:flush conn)
;; Send connection establishment ClientMessage.
(setf window client-xwin
(slot-value data 'data32) `(,server-xwin 0 0 0 0))
(slot-makeunbound data 'data8)
(slot-makeunbound data 'data16)
(xcb:+request exwm-xim--conn
(make-instance 'xcb:SendEvent
:propagate 0
:destination client-xwin
:event-mask xcb:EventMask:NoEvent
:event (xcb:marshal evt exwm-xim--conn)))
(xcb:flush exwm-xim--conn))))
(cl-defun exwm-xim--on-ClientMessage (data _synthetic)
"Handle ClientMessage event on IMS communication window (request).
Such events would be received when clients request for _XIM_PROTOCOL.
The actual XIM request is in client message data or a property."
(exwm--log)
(let ((evt (make-instance 'xcb:ClientMessage))
conn client-xwin server-xwin)
(xcb:unmarshal evt data)
(with-slots (format window type data) evt
(unless (= type exwm-xim--_XIM_PROTOCOL)
(exwm--log "Ignore ClientMessage %s" type)
(cl-return-from exwm-xim--on-ClientMessage))
(setq server-xwin window
conn (plist-get exwm-xim--server-client-plist server-xwin)
client-xwin (elt conn 1)
conn (elt conn 0))
(cond ((= format 8)
;; Data.
(exwm-xim--on-request (vconcat (slot-value data 'data8))
conn client-xwin server-xwin))
((= format 32)
;; Atom.
(with-slots (data32) data
(with-slots (value)
(xcb:+request-unchecked+reply conn
(make-instance 'xcb:GetProperty
:delete 1
:window server-xwin
:property (elt data32 1)
:type xcb:GetPropertyType:Any
:long-offset 0
:long-length (elt data32 0)))
(when (> (length value) 0)
(exwm-xim--on-request value conn client-xwin
server-xwin)))))))))
(defun exwm-xim--on-request (data conn client-xwin server-xwin)
"Handle an XIM reuqest."
(exwm--log)
(let ((opcode (elt data 0))
;; Let-bind `xim:lsb' to make pack/unpack functions work correctly.
(xim:lsb (elt (plist-get exwm-xim--server-client-plist server-xwin) 2))
req replies)
(cond ((= opcode xim:opcode:error)
(exwm--log "ERROR: %s" data))
((= opcode xim:opcode:connect)
(exwm--log "CONNECT")
(setq xim:lsb (= (elt data 4) xim:connect-byte-order:lsb-first))
;; Store byte-order.
(setf (elt (plist-get exwm-xim--server-client-plist server-xwin) 2)
xim:lsb)
(setq req (make-instance 'xim:connect))
(xcb:unmarshal req data)
(if (and (= (slot-value req 'major-version) 1)
(= (slot-value req 'minor-version) 0)
;; Do not support authentication.
(= (slot-value req 'number) 0))
;; Accept the connection.
(push (make-instance 'xim:connect-reply) replies)
;; Deny it.
(push exwm-xim--default-error replies)))
((memq opcode (list xim:opcode:auth-required
xim:opcode:auth-reply
xim:opcode:auth-next
xim:opcode:auth-ng))
(exwm--log "AUTH: %d" opcode)
;; Deny any attempt to make authentication.
(push exwm-xim--default-error replies))
((= opcode xim:opcode:disconnect)
(exwm--log "DISCONNECT")
;; Gracefully disconnect from the client.
(exwm-xim--make-request (make-instance 'xim:disconnect-reply)
conn client-xwin)
;; Destroy the communication window & connection.
(xcb:+request conn
(make-instance 'xcb:DestroyWindow
:window server-xwin))
(xcb:disconnect conn)
;; Clean up cache.
(cl-remf exwm-xim--server-client-plist server-xwin)
(cl-remf exwm-xim--client-server-plist client-xwin))
((= opcode xim:opcode:open)
(exwm--log "OPEN")
;; Note: We make no check here.
(setq exwm-xim--im-id (if (< exwm-xim--im-id #xffff)
(1+ exwm-xim--im-id)
1))
(setq replies
(list
(make-instance 'xim:open-reply
:im-id exwm-xim--im-id
:im-attrs-length nil
:im-attrs exwm-xim--default-im-attrs
:ic-attrs-length nil
:ic-attrs exwm-xim--default-ic-attrs)
(make-instance 'xim:set-event-mask
:im-id exwm-xim--im-id
:ic-id 0
;; Static event flow.
:forward-event-mask xcb:EventMask:KeyPress
;; on-demand-synchronous method.
:synchronous-event-mask
xcb:EventMask:NoEvent))))
((= opcode xim:opcode:close)
(exwm--log "CLOSE")
(setq req (make-instance 'xim:close))
(xcb:unmarshal req data)
(push (make-instance 'xim:close-reply
:im-id (slot-value req 'im-id))
replies))
((= opcode xim:opcode:trigger-notify)
(exwm--log "TRIGGER-NOTIFY")
;; Only static event flow modal is supported.
(push exwm-xim--default-error replies))
((= opcode xim:opcode:encoding-negotiation)
(exwm--log "ENCODING-NEGOTIATION")
(setq req (make-instance 'xim:encoding-negotiation))
(xcb:unmarshal req data)
(let ((index (cl-position "COMPOUND_TEXT"
(mapcar (lambda (i) (slot-value i 'name))
(slot-value req 'names))
:test #'equal)))
(unless index
;; Fallback to portable character encoding (a subset of ASCII).
(setq index -1))
(push (make-instance 'xim:encoding-negotiation-reply
:im-id (slot-value req 'im-id)
:category
xim:encoding-negotiation-reply-category:name
:index index)
replies)))
((= opcode xim:opcode:query-extension)
(exwm--log "QUERY-EXTENSION")
(setq req (make-instance 'xim:query-extension))
(xcb:unmarshal req data)
(push (make-instance 'xim:query-extension-reply
:im-id (slot-value req 'im-id)
;; No extension support.
:length 0
:extensions nil)
replies))
((= opcode xim:opcode:set-im-values)
(exwm--log "SET-IM-VALUES")
;; There's only one possible input method attribute.
(setq req (make-instance 'xim:set-im-values))
(xcb:unmarshal req data)
(push (make-instance 'xim:set-im-values-reply
:im-id (slot-value req 'im-id))
replies))
((= opcode xim:opcode:get-im-values)
(exwm--log "GET-IM-VALUES")
(setq req (make-instance 'xim:get-im-values))
(let (im-attributes-id)
(xcb:unmarshal req data)
(setq im-attributes-id (slot-value req 'im-attributes-id))
(if (cl-notevery (lambda (i) (= i 0)) im-attributes-id)
;; Only support one IM attributes.
(push (make-instance 'xim:error
:im-id (slot-value req 'im-id)
:ic-id 0
:flag xim:error-flag:invalid-ic-id
:error-code xim:error-code:bad-something
:length 0
:type 0
:detail nil)
replies)
(push
(make-instance 'xim:get-im-values-reply
:im-id (slot-value req 'im-id)
:length nil
:im-attributes exwm-xim--default-attributes)
replies))))
((= opcode xim:opcode:create-ic)
(exwm--log "CREATE-IC")
(setq req (make-instance 'xim:create-ic))
(xcb:unmarshal req data)
;; Note: The ic-attributes slot is ignored.
(setq exwm-xim--ic-id (if (< exwm-xim--ic-id #xffff)
(1+ exwm-xim--ic-id)
1))
(push (make-instance 'xim:create-ic-reply
:im-id (slot-value req 'im-id)
:ic-id exwm-xim--ic-id)
replies))
((= opcode xim:opcode:destroy-ic)
(exwm--log "DESTROY-IC")
(setq req (make-instance 'xim:destroy-ic))
(xcb:unmarshal req data)
(push (make-instance 'xim:destroy-ic-reply
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id))
replies))
((= opcode xim:opcode:set-ic-values)
(exwm--log "SET-IC-VALUES")
(setq req (make-instance 'xim:set-ic-values))
(xcb:unmarshal req data)
;; We don't distinguish between input contexts.
(push (make-instance 'xim:set-ic-values-reply
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id))
replies))
((= opcode xim:opcode:get-ic-values)
(exwm--log "GET-IC-VALUES")
(setq req (make-instance 'xim:get-ic-values))
(xcb:unmarshal req data)
(push (make-instance 'xim:get-ic-values-reply
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id)
:length nil
:ic-attributes exwm-xim--default-attributes)
replies))
((= opcode xim:opcode:set-ic-focus)
(exwm--log "SET-IC-FOCUS")
;; All input contexts are the same.
)
((= opcode xim:opcode:unset-ic-focus)
(exwm--log "UNSET-IC-FOCUS")
;; All input contexts are the same.
)
((= opcode xim:opcode:forward-event)
(exwm--log "FORWARD-EVENT")
(setq req (make-instance 'xim:forward-event))
(xcb:unmarshal req data)
(exwm-xim--handle-forward-event-request req xim:lsb conn
client-xwin))
((= opcode xim:opcode:sync)
(exwm--log "SYNC")
(setq req (make-instance 'xim:sync))
(xcb:unmarshal req data)
(push (make-instance 'xim:sync-reply
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id))
replies))
((= opcode xim:opcode:sync-reply)
(exwm--log "SYNC-REPLY"))
((= opcode xim:opcode:reset-ic)
(exwm--log "RESET-IC")
;; No context-specific data saved.
(setq req (make-instance 'xim:reset-ic))
(xcb:unmarshal req data)
(push (make-instance 'xim:reset-ic-reply
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id)
:length 0
:string "")
replies))
((memq opcode (list xim:opcode:str-conversion-reply
xim:opcode:preedit-start-reply
xim:opcode:preedit-caret-reply))
(exwm--log "PREEDIT: %d" opcode)
;; No preedit support.
(push exwm-xim--default-error replies))
(t
(exwm--log "Bad protocol")
(push exwm-xim--default-error replies)))
;; Actually send the replies.
(when replies
(mapc (lambda (reply)
(exwm-xim--make-request reply conn client-xwin))
replies)
(xcb:flush conn))))
(defun exwm-xim--handle-forward-event-request (req lsb conn client-xwin)
(let ((im-func (with-current-buffer (window-buffer)
input-method-function))
key-event keysym keysyms event result)
;; Note: The flag slot is ignored.
;; Do conversion in client's byte-order.
(let ((xcb:lsb lsb))
(setq key-event (make-instance 'xcb:KeyPress))
(xcb:unmarshal key-event (slot-value req 'event)))
(with-slots (detail state) key-event
(setq keysym (xcb:keysyms:keycode->keysym exwm-xim--conn detail
state))
(when (/= (car keysym) 0)
(setq event (xcb:keysyms:keysym->event
exwm-xim--conn
(car keysym)
(logand state (lognot (cdr keysym)))))))
(while (or (slot-value req 'event) unread-command-events)
(unless (slot-value req 'event)
(setq event (pop unread-command-events))
;; Handle events in (t . EVENT) format.
(when (and (consp event)
(eq (car event) t))
(setq event (cdr event))))
(if (or (not im-func)
;; `list' is the default method.
(eq im-func #'list)
(not event)
;; Select only printable keys.
(not (integerp event)) (> #x20 event) (< #x7e event))
;; Either there is no active input method, or invalid key
;; is detected.
(with-slots ((raw-event event)
im-id ic-id serial-number)
req
(if raw-event
(setq event raw-event)
(setq keysyms (xcb:keysyms:event->keysyms exwm-xim--conn event))
(with-slots (detail state) key-event
(setf detail (xcb:keysyms:keysym->keycode exwm-xim--conn
(caar keysyms))
state (cdar keysyms)))
(setq event (let ((xcb:lsb lsb))
(xcb:marshal key-event conn))))
(when event
(exwm-xim--make-request
(make-instance 'xim:forward-event
:im-id im-id
:ic-id ic-id
:flag xim:commit-flag:synchronous
:serial-number serial-number
:event event)
conn client-xwin)))
(when (eq exwm--selected-input-mode 'char-mode)
;; Grab keyboard temporarily for char-mode.
(exwm-input--grab-keyboard))
(unwind-protect
(with-temp-buffer
;; Always show key strokes.
(let ((input-method-use-echo-area t)
(exwm-input-line-mode-passthrough t))
(setq result (funcall im-func event))
;; Clear echo area for the input method.
(message nil)
;; This also works for portable character encoding.
(setq result
(encode-coding-string (concat result)
'compound-text-with-extensions))
(exwm-xim--make-request
(make-instance 'xim:commit-x-lookup-chars
:im-id (slot-value req 'im-id)
:ic-id (slot-value req 'ic-id)
:flag (logior xim:commit-flag:synchronous
xim:commit-flag:x-lookup-chars)
:length (length result)
:string result)
conn client-xwin)))
(when (eq exwm--selected-input-mode 'char-mode)
(exwm-input--release-keyboard))))
(xcb:flush conn)
(setf event nil
(slot-value req 'event) nil))))
(defun exwm-xim--make-request (req conn client-xwin)
"Make an XIM request REQ via connection CONN.
CLIENT-XWIN would receive a ClientMessage event either telling the client
the request data or where to fetch the data."
(exwm--log)
(let ((data (xcb:marshal req))
property format client-message-data client-message)
(if (<= (length data) 20)
;; Send short requests directly with client messages.
(setq format 8
;; Pad to 20 bytes.
data (append data (make-list (- 20 (length data)) 0))
client-message-data (make-instance 'xcb:ClientMessageData
:data8 data))
;; Send long requests with properties.
(setq property (exwm--intern-atom (format "_EXWM_XIM_%x"
exwm-xim--property-index)))
(cl-incf exwm-xim--property-index)
(xcb:+request conn
(make-instance 'xcb:ChangeProperty
:mode xcb:PropMode:Append
:window client-xwin
:property property
:type xcb:Atom:STRING
:format 8
:data-len (length data)
:data data))
;; Also send a client message to notify the client about this property.
(setq format 32
client-message-data (make-instance 'xcb:ClientMessageData
:data32 `(,(length data)
,property
;; Pad to 20 bytes.
0 0 0))))
;; Send the client message.
(setq client-message (make-instance 'xcb:ClientMessage
:format format
:window client-xwin
:type exwm-xim--_XIM_PROTOCOL
:data client-message-data))
(xcb:+request conn
(make-instance 'xcb:SendEvent
:propagate 0
:destination client-xwin
:event-mask xcb:EventMask:NoEvent
:event (xcb:marshal client-message conn)))))
(defun exwm-xim--on-DestroyNotify (data synthetic)
"Do cleanups on receiving DestroyNotify event.
Such event would be received when the client window is destroyed."
(exwm--log)
(unless synthetic
(let ((evt (make-instance 'xcb:DestroyNotify))
conn client-xwin server-xwin)
(xcb:unmarshal evt data)
(setq client-xwin (slot-value evt 'window)
server-xwin (plist-get exwm-xim--client-server-plist client-xwin))
(when server-xwin
(setq conn (aref (plist-get exwm-xim--server-client-plist server-xwin)
0))
(cl-remf exwm-xim--server-client-plist server-xwin)
(cl-remf exwm-xim--client-server-plist client-xwin)
;; Destroy the communication window & connection.
(xcb:+request conn
(make-instance 'xcb:DestroyWindow
:window server-xwin))
(xcb:disconnect conn)))))
(cl-defun exwm-xim--init ()
"Initialize the XIM module."
(exwm--log)
(when exwm-xim--conn
(cl-return-from exwm-xim--init))
;; Initialize atoms.
(setq exwm-xim--@server (exwm--intern-atom "@server=exwm-xim")
exwm-xim--LOCALES (exwm--intern-atom "LOCALES")
exwm-xim--TRANSPORT (exwm--intern-atom "TRANSPORT")
exwm-xim--XIM_SERVERS (exwm--intern-atom "XIM_SERVERS")
exwm-xim--_XIM_PROTOCOL (exwm--intern-atom "_XIM_PROTOCOL")
exwm-xim--_XIM_XCONNECT (exwm--intern-atom "_XIM_XCONNECT"))
;; Create a new connection and event window.
(setq exwm-xim--conn (xcb:connect)
exwm-xim--event-xwin (xcb:generate-id exwm-xim--conn))
(set-process-query-on-exit-flag (slot-value exwm-xim--conn 'process) nil)
;; Initialize xcb:keysyms module.
(xcb:keysyms:init exwm-xim--conn)
;; Listen to SelectionRequest event for connection establishment.
(xcb:+event exwm-xim--conn 'xcb:SelectionRequest
#'exwm-xim--on-SelectionRequest)
;; Listen to ClientMessage event on IMS window for new XIM connection.
(xcb:+event exwm-xim--conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage-0)
;; Listen to DestroyNotify event to do cleanups.
(xcb:+event exwm-xim--conn 'xcb:DestroyNotify #'exwm-xim--on-DestroyNotify)
;; Create the event window.
(xcb:+request exwm-xim--conn
(make-instance 'xcb:CreateWindow
:depth 0
:wid exwm-xim--event-xwin
:parent exwm--root
:x 0
:y 0
:width 1
:height 1
:border-width 0
:class xcb:WindowClass:InputOutput
:visual 0
:value-mask xcb:CW:OverrideRedirect
:override-redirect 1))
;; Set the selection owner.
(xcb:+request exwm-xim--conn
(make-instance 'xcb:SetSelectionOwner
:owner exwm-xim--event-xwin
:selection exwm-xim--@server
:time xcb:Time:CurrentTime))
;; Set XIM_SERVERS property on the root window.
(xcb:+request exwm-xim--conn
(make-instance 'xcb:ChangeProperty
:mode xcb:PropMode:Prepend
:window exwm--root
:property exwm-xim--XIM_SERVERS
:type xcb:Atom:ATOM
:format 32
:data-len 1
:data (funcall (if xcb:lsb
#'xcb:-pack-u4-lsb
#'xcb:-pack-u4)
exwm-xim--@server)))
(xcb:flush exwm-xim--conn))
(cl-defun exwm-xim--exit ()
"Exit the XIM module."
(exwm--log)
;; Close IMS communication connections.
(mapc (lambda (i)
(when (vectorp i)
(xcb:disconnect (elt i 0))))
exwm-xim--server-client-plist)
;; Close the IMS connection.
(unless exwm-xim--conn
(cl-return-from exwm-xim--exit))
;; Remove exwm-xim from XIM_SERVERS.
(let ((reply (xcb:+request-unchecked+reply exwm-xim--conn
(make-instance 'xcb:GetProperty
:delete 1
:window exwm--root
:property exwm-xim--XIM_SERVERS
:type xcb:Atom:ATOM
:long-offset 0
:long-length 1000)))
unpacked-reply pack unpack)
(unless reply
(cl-return-from exwm-xim--exit))
(setq reply (slot-value reply 'value))
(unless (> (length reply) 4)
(cl-return-from exwm-xim--exit))
(setq reply (vconcat reply)
pack (if xcb:lsb #'xcb:-pack-u4-lsb #'xcb:-pack-u4)
unpack (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4))
(dotimes (i (/ (length reply) 4))
(push (funcall unpack reply (* i 4)) unpacked-reply))
(setq unpacked-reply (delq exwm-xim--@server unpacked-reply)
reply (mapcar pack unpacked-reply))
(xcb:+request exwm-xim--conn
(make-instance 'xcb:ChangeProperty
:mode xcb:PropMode:Replace
:window exwm--root
:property exwm-xim--XIM_SERVERS
:type xcb:Atom:ATOM
:format 32
:data-len (length reply)
:data reply))
(xcb:flush exwm-xim--conn))
(xcb:disconnect exwm-xim--conn)
(setq exwm-xim--conn nil))
(defun exwm-xim-enable ()
"Enable XIM support for EXWM."
(exwm--log)
(add-hook 'exwm-init-hook #'exwm-xim--init)
(add-hook 'exwm-exit-hook #'exwm-xim--exit))
(provide 'exwm-xim)
;;; exwm-xim.el ends here

BIN
elpa/exwm-0.24/exwm-xim.elc
View File

Binary file not shown.

1019
elpa/exwm-0.24/exwm.el
View File

File diff suppressed because it is too large Load Diff

BIN
elpa/exwm-0.24/exwm.elc
View File

Binary file not shown.

20
elpa/exwm-0.24/xinitrc
View File

@ -1,20 +0,0 @@
# Disable access control for the current user.
xhost +SI:localuser:$USER
# Make Java applications aware this is a non-reparenting window manager.
export _JAVA_AWT_WM_NONREPARENTING=1
# Set default cursor.
xsetroot -cursor_name left_ptr
# Set keyboard repeat rate.
xset r rate 200 60
# Uncomment the following block to use the exwm-xim module.
#export XMODIFIERS=@im=exwm-xim
#export GTK_IM_MODULE=xim
#export QT_IM_MODULE=xim
#export CLUTTER_IM_MODULE=xim
# Finally start Emacs
exec emacs

18
elpa/jabber-20180927.2325/dir
View File

@ -1,18 +0,0 @@
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
View File

@ -1,439 +0,0 @@
;;; 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
View File

@ -1,107 +0,0 @@
;; 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
View File

@ -1,231 +0,0 @@
;; 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
View File

@ -1,514 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,211 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,852 +0,0 @@
;;; 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
View File

@ -1,234 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,42 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,248 +0,0 @@
;; 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
View File

@ -1,100 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,683 +0,0 @@
;; 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
View File

@ -1,137 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,177 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,82 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,405 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,143 +0,0 @@
;; 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
View File

Binary file not shown.

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

File diff suppressed because it is too large Load Diff

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

Binary file not shown.

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

@ -1,652 +0,0 @@
;; 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
View File

@ -1,245 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,251 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,731 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,125 +0,0 @@
;; 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
View File

@ -1,35 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,68 +0,0 @@
;; 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
View File

@ -1,46 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,131 +0,0 @@
;; 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
View File

@ -1,98 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,337 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,213 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,176 +0,0 @@
;; 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
View File

@ -1,62 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,103 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,83 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,207 +0,0 @@
;; 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
View File

@ -1,98 +0,0 @@
;; 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
View File

@ -1,85 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,188 +0,0 @@
;;; 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
View File

File diff suppressed because it is too large Load Diff

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

@ -1,91 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,35 +0,0 @@
;;; 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
View File

Binary file not shown.

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

@ -1,8 +0,0 @@
;; 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
View File

Binary file not shown.

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

@ -1,61 +0,0 @@
;; 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
View File

@ -1,7 +0,0 @@
(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:

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