forked from scymtym/rudel
-
Notifications
You must be signed in to change notification settings - Fork 0
/
rudel-interactive.el
244 lines (212 loc) · 7.8 KB
/
rudel-interactive.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
;;; rudel-interactive.el --- User interaction functions for Rudel.
;;
;; Copyright (C) 2008, 2009, 2010 Jan Moringen
;;
;; Author: Jan Moringen <scymtym@users.sourceforge.net>
;; Keywords: Rudel, user, interface, interaction
;; X-RCS: $Id:$
;;
;; This file is part of Rudel.
;;
;; Rudel 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.
;;
;; Rudel 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 Rudel. If not, see <http://www.gnu.org/licenses>.
;;; Commentary:
;;
;; Functions for user interactions commonly used in Rudel components.
;;; History:
;;
;; 0.2 - Password function
;;
;; 0.1 - Initial version
;;; Code:
;;
(require 'rudel-compat) ;; for `read-color' replacement
(require 'rudel-backend) ;; for `rudel-backend-cons-p'
;;; Function for reading Rudel objects from the user.
;;
(defun rudel-read-backend (backends &optional prompt return)
"Read a backend name from BACKENDS and return that name or the actual backend depending on RETURN.
If RETURN is 'object, return the backend object which is of the
form (NAME . CLASS-OR-OBJECT); Otherwise return the name as
string."
(unless prompt
(setq prompt "Backend: "))
(let* ((backend-names (mapcar (lambda (cell)
(symbol-name (car cell)))
backends))
(backend-name (completing-read prompt backend-names nil t)))
(cond
((eq return 'object)
(assoc (intern backend-name) backends))
(t backend-name)))
)
(defun rudel-read-session (sessions &optional prompt return)
"Read a session name from SESSIONS and return that name or the session info depending on RETURN.
If PROMPT is non-nil use as prompt string.
If RETURN is 'object, return the session object; Otherwise return
the name as string."
(unless prompt
(setq prompt "Session: "))
;; For presentation and identification of sessions, use the :name
;; property.
(flet ((to-string (session)
(if (rudel-backend-cons-p session)
(symbol-name (car session))
(plist-get session :name))))
;; Read a session by name, then return that name or the
;; corresponding session info.
(let ((session-name (completing-read prompt
(mapcar #'to-string sessions)
nil t)))
(cond
((eq return 'object)
(find session-name sessions
:key #'to-string :test #'string=))
(t session-name))))
)
(defun rudel-read-user-name ()
"Read a username.
The default is taken from `rudel-default-username'."
(read-string "Username: " rudel-default-username))
(defun rudel-read-user-color ()
"Read a color."
(read-color "Color: " t))
(defun rudel-read-user (&optional users prompt return)
"Read a user name from USERS and return that name or the actual user depending on RETURN.
If USERS is nil, use the user list of `rudel-current-session'.
If RETURN. is 'object, return the user object; Otherwise return
the name as string."
;; If no user list is provided, the user list of the current session
;; is used.
(unless users
(if rudel-current-session
(setq users (oref rudel-current-session :users))
(error "No user list and no active Rudel session")))
(unless prompt
(setq prompt "User: "))
;; Construct a list of user name, read a name with completion and
;; return a user name of object.
(let* ((user-names (mapcar 'object-name-string users))
(user-name (completing-read prompt user-names nil t)))
(cond
((eq return 'object)
(find user-name users
:test 'string= :key 'object-name-string))
(t user-name)))
)
(defun rudel-read-document (&optional documents prompt return)
"Read a document name from DOCUMENTS and return that name or the actual document depending on RETURN.
If RETURN. is 'object, return the backend object; Otherwise
return the name as string."
(unless documents
(if rudel-current-session
(setq documents (oref rudel-current-session :documents))
(error "No document list and no active Rudel session")))
(unless documents
(error "No documents")) ; TODO error is a bit harsh
(unless prompt
(setq prompt "Document: "))
;; Construct list of names, read one name and return that name or
;; the named object.
(let* ((document-names (mapcar #'rudel-unique-name documents))
(document-name (completing-read prompt document-names nil t)))
(cond
((eq return 'object)
(find document-name documents
:test #'string= :key #'rudel-unique-name))
(t document-name)))
)
;;; Password functions
;;
(defun rudel-obtain-password (id context prompt)
"Obtain the password identified by ID using info in CONTEXT.
ID is a symbol identifying the requested password. CONTEXT is a
property list that specifies additional information identifying
the requested password. PROMPT is used when it is necessary to
ask the user for the password.
For example, the XMPP backend would set ID to 'xmpp-sasl and
CONTEXT to (:host \"jabber.org\" :port 5222 :username
\"joe\"). This Information would be used to search auth-source's
sources for a matching password entry."
(or
;; Do not try anything fancy, if CONTEXT already has the password.
(plist-get context (intern-soft
(concat ":" (symbol-name id) "-password")))
;; Try secret stores.
;; TODO finish this
;; TODO use secrets.el directly?
;; (progn
;; (when (require 'auth-source nil t)
;; (auth-source-user-or-password
;; "login"
;; (plist-get context :host)
;; (plist-get context :port)
;; (plist-get context :username))))
;; Fall back to just read the password.
(read-passwd prompt))
)
;;; Buffer allocation functions
;;
(defun rudel-allocate-buffer-clear-existing (name)
"When the requested buffer NAME exists, clear its contents and use it."
(let ((buffer (get-buffer name)))
(if buffer
(progn
;; Ask the user whether it is OK to erase the contents of
;; the buffer.
(unless (yes-or-no-p (format
"Buffer `%s' already exists; Erase contents? "
name))
(error "Buffer `%s' already exists" name)) ;; TODO throw or signal; not error
;; When the buffer is attached to a different document, ask
;; whether it is OK to detach the buffer.
(let ((document (rudel-buffer-document buffer)))
(unless (or (not document)
(yes-or-no-p (format
"Buffer `%s' is attached to the document `%s'; Detach? "
name
(rudel-unique-name document))))
(error "Buffer `%s' already attached to a document" name)))
;; Delete buffer contents; maybe detach buffer first.
(when (rudel-buffer-has-document-p buffer)
(rudel-unpublish-buffer buffer))
(with-current-buffer buffer
(erase-buffer)))
(setq buffer (get-buffer-create name)))
buffer)
)
(defun rudel-allocate-buffer-make-unique (name)
"When the requested buffer NAME exists, create another buffer."
(get-buffer-create (generate-new-buffer-name name)))
;;; Progress reporting
;;
(defun rudel-make-state-progress-callback (label)
"Return a progress reporter that displays LABEL along with states.
This function's primary purpose is constructing callbacks
suitable for `rudel-state-wait'"
(lexical-let ((label1 label)
(reporter (make-progress-reporter label)))
(lambda (state)
(cond
;; For all states, just spin.
((consp state)
(progress-reporter-force-update
reporter nil (format "%s(%s)" label1 (car state))))
;; Done
(t
(progress-reporter-force-update
reporter nil label1)
(progress-reporter-done reporter)))))
)
(provide 'rudel-interactive)
;;; rudel-interactive.el ends here