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
|
;;; rudel-interactive.el --- User interaction functions for Rudel.
;;
;; Copyright (C) 2008, 2009 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.1 - Initial revision.
;;; Code:
;;
(require 'rudel-compat) ;; for `read-color' replacement
;;; 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)))
)
;;; 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)))
(provide 'rudel-interactive)
;;; rudel-interactive.el ends here
|
