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. If not, see <http://www.gnu.org/licenses/>.
32 (autoload 'gnus-error
"gnus-util")
33 (autoload 'netrc-get
"netrc")
34 (autoload 'netrc-machine
"netrc")
35 (autoload 'netrc-parse
"netrc")
37 (defvar assistant-readers
38 '(("variable" assistant-variable-reader
)
39 ("validate" assistant-sexp-reader
)
40 ("result" assistant-list-reader
)
41 ("next" assistant-list-reader
)
42 ("text" assistant-text-reader
)))
44 (defface assistant-field
'((t (:bold t
)))
45 "Face used for editable fields."
46 :group
'gnus-article-emphasis
)
47 ;; backward-compatibility alias
48 (put 'assistant-field-face
'face-alias
'assistant-field
)
50 ;;; Internal variables
52 (defvar assistant-data nil
)
53 (defvar assistant-current-node nil
)
54 (defvar assistant-previous-nodes nil
)
55 (defvar assistant-widgets nil
)
57 (defun assistant-parse-buffer ()
58 (let (results command value
)
59 (goto-char (point-min))
60 (while (search-forward "@" nil t
)
61 (if (not (looking-at "[^ \t\n]+"))
63 (setq command
(downcase (match-string 0)))
64 (goto-char (match-end 0)))
66 (if (looking-at "[ \t]*\n")
70 (unless (re-search-forward (concat "^@end " command
) nil t
)
71 (error "No @end %s found" command
))
74 (buffer-substring start
(point))
76 (skip-chars-forward " \t")
78 (buffer-substring (point) (point-at-eol))
80 (push (list command
(assistant-reader command value
))
82 (assistant-segment (nreverse results
))))
84 (defun assistant-text-reader (text)
87 (goto-char (point-min))
90 (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t
)
91 (push (buffer-substring start
(match-beginning 0))
93 (push (list (match-string 1) (match-string 2))
96 (push (buffer-substring start
(point-max))
98 (nreverse sections
))))
100 ;; Segment the raw assistant data into a list of nodes.
101 (defun assistant-segment (list)
106 (when (and (equal (car elem
) "node")
108 (push (list "save" nil
) node
)
109 (push (nreverse node
) ast
)
113 (push (list "save" nil
) node
)
114 (push (nreverse node
) ast
))
115 (cons title
(nreverse ast
))))
117 (defun assistant-reader (command value
)
118 (let ((formatter (cadr (assoc command assistant-readers
))))
121 (funcall formatter value
))))
123 (defun assistant-list-reader (value)
124 (car (read-from-string (concat "(" value
")"))))
126 (defun assistant-variable-reader (value)
127 (let ((section (car (read-from-string (concat "(" value
")")))))
128 (append section
(list 'default
))))
130 (defun assistant-sexp-reader (value)
131 (if (zerop (length value
))
133 (car (read-from-string value
))))
135 (defun assistant-buffer-name (title)
136 (format "*Assistant %s*" title
))
138 (defun assistant-get (ast command
)
139 (cadr (assoc command ast
)))
141 (defun assistant-set (ast command value
)
142 (let ((elem (assoc command ast
)))
144 (setcar (cdr elem
) value
))))
146 (defun assistant-get-list (ast command
)
149 (when (equal (car elem
) command
)
154 (defun assistant (file)
155 "Assist setting up Emacs based on FILE."
156 (interactive "fAssistant file name: ")
159 (insert-file-contents file
)
160 (assistant-parse-buffer))))
161 (pop-to-buffer (assistant-buffer-name (assistant-get ast
"title")))
162 (assistant-render ast
)))
164 (defun assistant-render (ast)
165 (let ((first-node (assistant-get (nth 1 ast
) "node")))
166 (set (make-local-variable 'assistant-data
) ast
)
167 (set (make-local-variable 'assistant-current-node
) nil
)
168 (set (make-local-variable 'assistant-previous-nodes
) nil
)
169 (assistant-render-node first-node
)))
171 (defun assistant-find-node (node-name)
172 (let ((ast (cdr assistant-data
)))
174 (not (string= node-name
(assistant-get (car ast
) "node"))))
178 (defun assistant-node-name (node)
179 (assistant-get node
"node"))
181 (defun assistant-previous-node-text (node)
182 (format "<< Go back to %s" node
))
184 (defun assistant-next-node-text (node)
186 (not (eq node
'finish
)))
187 (format "Proceed to %s >>" node
)
190 (defun assistant-set-defaults (node &optional forcep
)
191 (dolist (variable (assistant-get-list node
"variable"))
192 (setq variable
(cadr variable
))
193 (when (or (eq (nth 3 variable
) 'default
)
195 (setcar (nthcdr 3 variable
)
196 (assistant-eval (nth 2 variable
))))))
198 (defun assistant-get-variable (node variable
&optional type raw
)
199 (let ((variables (assistant-get-list node
"variable"))
202 (while (and (setq elem
(pop variables
))
204 (setq elem
(cadr elem
))
205 (when (eq (intern variable
) (car elem
))
207 (setq result
(nth 1 elem
))
208 (setq result
(if raw
(nth 3 elem
)
209 (format "%s" (nth 3 elem
)))))))
212 (defun assistant-set-variable (node variable value
)
213 (let ((variables (assistant-get-list node
"variable"))
215 (while (setq elem
(pop variables
))
216 (setq elem
(cadr elem
))
217 (when (eq (intern variable
) (car elem
))
218 (setcar (nthcdr 3 elem
) value
)))))
220 (defun assistant-render-text (text node
)
221 (unless (and text node
)
224 "The assistant was asked to render invalid text or node data"))
229 ;; A variable to be inserted as a widget.
230 (let* ((start (point))
231 (variable (cadr elem
))
232 (type (assistant-get-variable node variable
'type
)))
234 ((eq (car-safe type
) :radio
)
239 :assistant-variable variable
241 :value
(assistant-get-variable node variable
)
242 :notify
(lambda (widget &rest ignore
)
243 (assistant-set-variable
244 (widget-get widget
:assistant-node
)
245 (widget-get widget
:assistant-variable
)
246 (widget-value widget
))
247 (assistant-render-node
249 (widget-get widget
:assistant-node
)
253 ((eq (car-safe type
) :set
)
258 :assistant-variable variable
260 :value
(assistant-get-variable node variable nil t
)
261 :notify
(lambda (widget &rest ignore
)
262 (assistant-set-variable
263 (widget-get widget
:assistant-node
)
264 (widget-get widget
:assistant-variable
)
265 (widget-value widget
))
266 (assistant-render-node
268 (widget-get widget
:assistant-node
)
276 :value-face
'assistant-field
277 :assistant-variable variable
278 (assistant-get-variable node variable
))
280 (add-text-properties start
(point)
283 'face
'assistant-field
284 'not-read-only t
)))))))
287 (defun assistant-render-node (node-name)
288 (let ((node (assistant-find-node node-name
))
289 (inhibit-read-only t
)
290 (previous assistant-current-node
)
291 (buffer-read-only nil
))
293 (gnus-error 5 "The node for %s could not be found" node-name
))
294 (set (make-local-variable 'assistant-widgets
) nil
)
295 (assistant-set-defaults node
)
296 (if (equal (assistant-get node
"type") "interstitial")
297 (assistant-render-node (nth 0 (assistant-find-next-nodes node-name
)))
298 (setq assistant-current-node node-name
)
300 (push previous assistant-previous-nodes
))
302 (insert (cadar assistant-data
) "\n\n")
303 (insert node-name
"\n\n")
304 (assistant-render-text (assistant-get node
"text") node
)
306 (when assistant-previous-nodes
307 (assistant-node-button 'previous
(car assistant-previous-nodes
)))
310 :assistant-node node-name
311 :notify
(lambda (widget &rest ignore
)
312 (let* ((node (widget-get widget
:assistant-node
)))
313 (assistant-set-defaults (assistant-find-node node
) 'force
)
314 (assistant-render-node node
)))
317 (dolist (nnode (assistant-find-next-nodes))
318 (assistant-node-button 'next nnode
)
321 (goto-char (point-min))
322 (assistant-make-read-only))))
324 (defun assistant-make-read-only ()
325 (let ((start (point-min))
327 (while (setq end
(text-property-any start
(point-max) 'not-read-only t
))
328 (put-text-property start end
'read-only t
)
329 (put-text-property start end
'rear-nonsticky t
)
330 (while (get-text-property end
'not-read-only
)
333 (put-text-property start
(point-max) 'read-only t
)))
335 (defun assistant-node-button (type node
)
336 (let ((text (if (eq type
'next
)
337 (assistant-next-node-text node
)
338 (assistant-previous-node-text node
))))
343 :notify
(lambda (widget &rest ignore
)
344 (let* ((node (widget-get widget
:assistant-node
))
345 (type (widget-get widget
:assistant-type
)))
346 (if (eq type
'previous
)
348 (setq assistant-current-node nil
)
349 (pop assistant-previous-nodes
))
350 (assistant-get-widget-values)
351 (assistant-validate))
354 (assistant-render-node node
))))
356 (use-local-map widget-keymap
)))
358 (defun assistant-validate-types (node)
359 (dolist (variable (assistant-get-list node
"variable"))
360 (setq variable
(cadr variable
))
361 (let ((type (nth 1 variable
))
362 (value (nth 3 variable
)))
366 (string-match "[^0-9]" value
))
369 (error "%s is not of type %s: %s"
370 (car variable
) type value
)))))
372 (defun assistant-get-widget-values ()
373 (let ((node (assistant-find-node assistant-current-node
)))
374 (dolist (widget assistant-widgets
)
375 (assistant-set-variable
376 node
(widget-get widget
:assistant-variable
)
377 (widget-value widget
)))))
379 (defun assistant-validate ()
380 (let* ((node (assistant-find-node assistant-current-node
))
381 (validation (assistant-get node
"validate"))
383 (assistant-validate-types node
)
385 (when (setq result
(assistant-eval validation
))
386 (unless (y-or-n-p (format "Error: %s. Continue? " result
))
387 (error "%s" result
))))
388 (assistant-set node
"save" t
)))
390 ;; (defun assistant-find-next-node (&optional node)
391 ;; (let* ((node (assistant-find-node (or node assistant-current-node)))
392 ;; (node-name (assistant-node-name node))
393 ;; (nexts (assistant-get-list node "next"))
394 ;; next elem applicable)
396 ;; (while (setq elem (pop nexts))
397 ;; (when (assistant-eval (car (cadr elem)))
398 ;; (setq applicable (cons elem applicable))))
400 ;; ;; return the first thing we can
401 ;; (cadr (cadr (pop applicable)))))
403 (defun assistant-find-next-nodes (&optional node
)
404 (let* ((node (assistant-find-node (or node assistant-current-node
)))
405 (nexts (assistant-get-list node
"next"))
406 next elem applicable return
)
408 (while (setq elem
(pop nexts
))
409 (when (assistant-eval (car (cadr elem
)))
410 (setq applicable
(cons elem applicable
))))
412 ;; return the first thing we can
414 (while (setq elem
(pop applicable
))
415 (push (cadr (cadr elem
)) return
))
419 (defun assistant-get-all-variables ()
420 (let ((variables nil
))
421 (dolist (node (cdr assistant-data
))
423 (append (assistant-get-list node
"variable")
427 (defun assistant-eval (form)
428 (let ((bindings nil
))
429 (dolist (variable (assistant-get-all-variables))
430 (setq variable
(cadr variable
))
431 (push (list (car variable
)
432 (if (eq (nth 3 variable
) 'default
)
434 (if (listp (nth 3 variable
))
435 `(list ,@(nth 3 variable
))
442 (defun assistant-finish ()
445 (dolist (node (cdr assistant-data
))
446 (when (assistant-get node
"save")
447 (setq result
(assistant-get node
"result"))
448 (push (list (car result
)
449 (assistant-eval (cadr result
)))
451 (message "Results: %s"
452 (nreverse results
))))
454 ;;; Validation functions.
456 (defun assistant-validate-connect-to-server (server port
)
460 (open-network-stream "nntpd" nil server port
)
461 (error (setq error err
)))))
462 (if (and (processp stream
)
463 (memq (process-status stream
) '(open run
)))
465 (delete-process stream
)
469 (defun assistant-authinfo-data (server port type
)
470 (when (file-exists-p "~/.authinfo")
471 (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
477 (defun assistant-password-required-p ()
482 ;;; assistant.el ends here