1 ;;; assistant.el --- guiding users through Emacs setup
2 ;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 3, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
34 (autoload 'gnus-error
"gnus-util")
35 (autoload 'netrc-get
"netrc")
36 (autoload 'netrc-machine
"netrc")
37 (autoload 'netrc-parse
"netrc")
39 (defvar assistant-readers
40 '(("variable" assistant-variable-reader
)
41 ("validate" assistant-sexp-reader
)
42 ("result" assistant-list-reader
)
43 ("next" assistant-list-reader
)
44 ("text" assistant-text-reader
)))
46 (defface assistant-field
'((t (:bold t
)))
47 "Face used for editable fields."
48 :group
'gnus-article-emphasis
)
49 ;; backward-compatibility alias
50 (put 'assistant-field-face
'face-alias
'assistant-field
)
52 ;;; Internal variables
54 (defvar assistant-data nil
)
55 (defvar assistant-current-node nil
)
56 (defvar assistant-previous-nodes nil
)
57 (defvar assistant-widgets nil
)
59 (defun assistant-parse-buffer ()
60 (let (results command value
)
61 (goto-char (point-min))
62 (while (search-forward "@" nil t
)
63 (if (not (looking-at "[^ \t\n]+"))
65 (setq command
(downcase (match-string 0)))
66 (goto-char (match-end 0)))
68 (if (looking-at "[ \t]*\n")
72 (unless (re-search-forward (concat "^@end " command
) nil t
)
73 (error "No @end %s found" command
))
76 (buffer-substring start
(point))
78 (skip-chars-forward " \t")
80 (buffer-substring (point) (point-at-eol))
82 (push (list command
(assistant-reader command value
))
84 (assistant-segment (nreverse results
))))
86 (defun assistant-text-reader (text)
89 (goto-char (point-min))
92 (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t
)
93 (push (buffer-substring start
(match-beginning 0))
95 (push (list (match-string 1) (match-string 2))
98 (push (buffer-substring start
(point-max))
100 (nreverse sections
))))
102 ;; Segment the raw assistant data into a list of nodes.
103 (defun assistant-segment (list)
108 (when (and (equal (car elem
) "node")
110 (push (list "save" nil
) node
)
111 (push (nreverse node
) ast
)
115 (push (list "save" nil
) node
)
116 (push (nreverse node
) ast
))
117 (cons title
(nreverse ast
))))
119 (defun assistant-reader (command value
)
120 (let ((formatter (cadr (assoc command assistant-readers
))))
123 (funcall formatter value
))))
125 (defun assistant-list-reader (value)
126 (car (read-from-string (concat "(" value
")"))))
128 (defun assistant-variable-reader (value)
129 (let ((section (car (read-from-string (concat "(" value
")")))))
130 (append section
(list 'default
))))
132 (defun assistant-sexp-reader (value)
133 (if (zerop (length value
))
135 (car (read-from-string value
))))
137 (defun assistant-buffer-name (title)
138 (format "*Assistant %s*" title
))
140 (defun assistant-get (ast command
)
141 (cadr (assoc command ast
)))
143 (defun assistant-set (ast command value
)
144 (let ((elem (assoc command ast
)))
146 (setcar (cdr elem
) value
))))
148 (defun assistant-get-list (ast command
)
151 (when (equal (car elem
) command
)
156 (defun assistant (file)
157 "Assist setting up Emacs based on FILE."
158 (interactive "fAssistant file name: ")
161 (insert-file-contents file
)
162 (assistant-parse-buffer))))
163 (pop-to-buffer (assistant-buffer-name (assistant-get ast
"title")))
164 (assistant-render ast
)))
166 (defun assistant-render (ast)
167 (let ((first-node (assistant-get (nth 1 ast
) "node")))
168 (set (make-local-variable 'assistant-data
) ast
)
169 (set (make-local-variable 'assistant-current-node
) nil
)
170 (set (make-local-variable 'assistant-previous-nodes
) nil
)
171 (assistant-render-node first-node
)))
173 (defun assistant-find-node (node-name)
174 (let ((ast (cdr assistant-data
)))
176 (not (string= node-name
(assistant-get (car ast
) "node"))))
180 (defun assistant-node-name (node)
181 (assistant-get node
"node"))
183 (defun assistant-previous-node-text (node)
184 (format "<< Go back to %s" node
))
186 (defun assistant-next-node-text (node)
188 (not (eq node
'finish
)))
189 (format "Proceed to %s >>" node
)
192 (defun assistant-set-defaults (node &optional forcep
)
193 (dolist (variable (assistant-get-list node
"variable"))
194 (setq variable
(cadr variable
))
195 (when (or (eq (nth 3 variable
) 'default
)
197 (setcar (nthcdr 3 variable
)
198 (assistant-eval (nth 2 variable
))))))
200 (defun assistant-get-variable (node variable
&optional type raw
)
201 (let ((variables (assistant-get-list node
"variable"))
204 (while (and (setq elem
(pop variables
))
206 (setq elem
(cadr elem
))
207 (when (eq (intern variable
) (car elem
))
209 (setq result
(nth 1 elem
))
210 (setq result
(if raw
(nth 3 elem
)
211 (format "%s" (nth 3 elem
)))))))
214 (defun assistant-set-variable (node variable value
)
215 (let ((variables (assistant-get-list node
"variable"))
217 (while (setq elem
(pop variables
))
218 (setq elem
(cadr elem
))
219 (when (eq (intern variable
) (car elem
))
220 (setcar (nthcdr 3 elem
) value
)))))
222 (defun assistant-render-text (text node
)
223 (unless (and text node
)
226 "The assistant was asked to render invalid text or node data"))
231 ;; A variable to be inserted as a widget.
232 (let* ((start (point))
233 (variable (cadr elem
))
234 (type (assistant-get-variable node variable
'type
)))
236 ((eq (car-safe type
) :radio
)
241 :assistant-variable variable
243 :value
(assistant-get-variable node variable
)
244 :notify
(lambda (widget &rest ignore
)
245 (assistant-set-variable
246 (widget-get widget
:assistant-node
)
247 (widget-get widget
:assistant-variable
)
248 (widget-value widget
))
249 (assistant-render-node
251 (widget-get widget
:assistant-node
)
255 ((eq (car-safe type
) :set
)
260 :assistant-variable variable
262 :value
(assistant-get-variable node variable nil t
)
263 :notify
(lambda (widget &rest ignore
)
264 (assistant-set-variable
265 (widget-get widget
:assistant-node
)
266 (widget-get widget
:assistant-variable
)
267 (widget-value widget
))
268 (assistant-render-node
270 (widget-get widget
:assistant-node
)
278 :value-face
'assistant-field
279 :assistant-variable variable
280 (assistant-get-variable node variable
))
282 ;; The editable-field widget apparently inserts a newline;
285 (add-text-properties start
(point)
288 'face
'assistant-field
289 'not-read-only t
))))))))
291 (defun assistant-render-node (node-name)
292 (let ((node (assistant-find-node node-name
))
293 (inhibit-read-only t
)
294 (previous assistant-current-node
)
295 (buffer-read-only nil
))
297 (gnus-error 5 "The node for %s could not be found" node-name
))
298 (set (make-local-variable 'assistant-widgets
) nil
)
299 (assistant-set-defaults node
)
300 (if (equal (assistant-get node
"type") "interstitial")
301 (assistant-render-node (nth 0 (assistant-find-next-nodes node-name
)))
302 (setq assistant-current-node node-name
)
304 (push previous assistant-previous-nodes
))
306 (insert (cadar assistant-data
) "\n\n")
307 (insert node-name
"\n\n")
308 (assistant-render-text (assistant-get node
"text") node
)
310 (when assistant-previous-nodes
311 (assistant-node-button 'previous
(car assistant-previous-nodes
)))
314 :assistant-node node-name
315 :notify
(lambda (widget &rest ignore
)
316 (let* ((node (widget-get widget
:assistant-node
)))
317 (assistant-set-defaults (assistant-find-node node
) 'force
)
318 (assistant-render-node node
)))
321 (dolist (nnode (assistant-find-next-nodes))
322 (assistant-node-button 'next nnode
)
325 (goto-char (point-min))
326 (assistant-make-read-only))))
328 (defun assistant-make-read-only ()
329 (let ((start (point-min))
331 (while (setq end
(text-property-any start
(point-max) 'not-read-only t
))
332 (put-text-property start end
'read-only t
)
333 (put-text-property start end
'rear-nonsticky t
)
334 (while (get-text-property end
'not-read-only
)
337 (put-text-property start
(point-max) 'read-only t
)))
339 (defun assistant-node-button (type node
)
340 (let ((text (if (eq type
'next
)
341 (assistant-next-node-text node
)
342 (assistant-previous-node-text node
))))
347 :notify
(lambda (widget &rest ignore
)
348 (let* ((node (widget-get widget
:assistant-node
))
349 (type (widget-get widget
:assistant-type
)))
350 (if (eq type
'previous
)
352 (setq assistant-current-node nil
)
353 (pop assistant-previous-nodes
))
354 (assistant-get-widget-values)
355 (assistant-validate))
358 (assistant-render-node node
))))
360 (use-local-map widget-keymap
)))
362 (defun assistant-validate-types (node)
363 (dolist (variable (assistant-get-list node
"variable"))
364 (setq variable
(cadr variable
))
365 (let ((type (nth 1 variable
))
366 (value (nth 3 variable
)))
370 (string-match "[^0-9]" value
))
373 (error "%s is not of type %s: %s"
374 (car variable
) type value
)))))
376 (defun assistant-get-widget-values ()
377 (let ((node (assistant-find-node assistant-current-node
)))
378 (dolist (widget assistant-widgets
)
379 (assistant-set-variable
380 node
(widget-get widget
:assistant-variable
)
381 (widget-value widget
)))))
383 (defun assistant-validate ()
384 (let* ((node (assistant-find-node assistant-current-node
))
385 (validation (assistant-get node
"validate"))
387 (assistant-validate-types node
)
389 (when (setq result
(assistant-eval validation
))
390 (unless (y-or-n-p (format "Error: %s. Continue? " result
))
391 (error "%s" result
))))
392 (assistant-set node
"save" t
)))
394 ;; (defun assistant-find-next-node (&optional node)
395 ;; (let* ((node (assistant-find-node (or node assistant-current-node)))
396 ;; (node-name (assistant-node-name node))
397 ;; (nexts (assistant-get-list node "next"))
398 ;; next elem applicable)
400 ;; (while (setq elem (pop nexts))
401 ;; (when (assistant-eval (car (cadr elem)))
402 ;; (setq applicable (cons elem applicable))))
404 ;; ;; return the first thing we can
405 ;; (cadr (cadr (pop applicable)))))
407 (defun assistant-find-next-nodes (&optional node
)
408 (let* ((node (assistant-find-node (or node assistant-current-node
)))
409 (nexts (assistant-get-list node
"next"))
410 next elem applicable return
)
412 (while (setq elem
(pop nexts
))
413 (when (assistant-eval (car (cadr elem
)))
414 (setq applicable
(cons elem applicable
))))
416 ;; return the first thing we can
418 (while (setq elem
(pop applicable
))
419 (push (cadr (cadr elem
)) return
))
423 (defun assistant-get-all-variables ()
424 (let ((variables nil
))
425 (dolist (node (cdr assistant-data
))
427 (append (assistant-get-list node
"variable")
431 (defun assistant-eval (form)
432 (let ((bindings nil
))
433 (dolist (variable (assistant-get-all-variables))
434 (setq variable
(cadr variable
))
435 (push (list (car variable
)
436 (if (eq (nth 3 variable
) 'default
)
438 (if (listp (nth 3 variable
))
439 `(list ,@(nth 3 variable
))
446 (defun assistant-finish ()
449 (dolist (node (cdr assistant-data
))
450 (when (assistant-get node
"save")
451 (setq result
(assistant-get node
"result"))
452 (push (list (car result
)
453 (assistant-eval (cadr result
)))
455 (message "Results: %s"
456 (nreverse results
))))
458 ;;; Validation functions.
460 (defun assistant-validate-connect-to-server (server port
)
464 (open-network-stream "nntpd" nil server port
)
465 (error (setq error err
)))))
466 (if (and (processp stream
)
467 (memq (process-status stream
) '(open run
)))
469 (delete-process stream
)
473 (defun assistant-authinfo-data (server port type
)
474 (when (file-exists-p "~/.authinfo")
475 (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
481 (defun assistant-password-required-p ()
486 ;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
487 ;;; assistant.el ends here