487 lines
14 KiB
EmacsLisp
487 lines
14 KiB
EmacsLisp
;;; assistant.el --- guiding users through Emacs setup
|
|
;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
|
|
|
|
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
|
;; Keywords: util
|
|
|
|
;; 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, 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., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
(require 'widget)
|
|
(require 'wid-edit)
|
|
|
|
(autoload 'gnus-error "gnus-util")
|
|
(autoload 'netrc-get "netrc")
|
|
(autoload 'netrc-machine "netrc")
|
|
(autoload 'netrc-parse "netrc")
|
|
|
|
(defvar assistant-readers
|
|
'(("variable" assistant-variable-reader)
|
|
("validate" assistant-sexp-reader)
|
|
("result" assistant-list-reader)
|
|
("next" assistant-list-reader)
|
|
("text" assistant-text-reader)))
|
|
|
|
(defface assistant-field '((t (:bold t)))
|
|
"Face used for editable fields."
|
|
:group 'gnus-article-emphasis)
|
|
;; backward-compatibility alias
|
|
(put 'assistant-field-face 'face-alias 'assistant-field)
|
|
|
|
;;; Internal variables
|
|
|
|
(defvar assistant-data nil)
|
|
(defvar assistant-current-node nil)
|
|
(defvar assistant-previous-nodes nil)
|
|
(defvar assistant-widgets nil)
|
|
|
|
(defun assistant-parse-buffer ()
|
|
(let (results command value)
|
|
(goto-char (point-min))
|
|
(while (search-forward "@" nil t)
|
|
(if (not (looking-at "[^ \t\n]+"))
|
|
(error "Dangling @")
|
|
(setq command (downcase (match-string 0)))
|
|
(goto-char (match-end 0)))
|
|
(setq value
|
|
(if (looking-at "[ \t]*\n")
|
|
(let (start)
|
|
(forward-line 1)
|
|
(setq start (point))
|
|
(unless (re-search-forward (concat "^@end " command) nil t)
|
|
(error "No @end %s found" command))
|
|
(beginning-of-line)
|
|
(prog1
|
|
(buffer-substring start (point))
|
|
(forward-line 1)))
|
|
(skip-chars-forward " \t")
|
|
(prog1
|
|
(buffer-substring (point) (point-at-eol))
|
|
(forward-line 1))))
|
|
(push (list command (assistant-reader command value))
|
|
results))
|
|
(assistant-segment (nreverse results))))
|
|
|
|
(defun assistant-text-reader (text)
|
|
(with-temp-buffer
|
|
(insert text)
|
|
(goto-char (point-min))
|
|
(let ((start (point))
|
|
(sections nil))
|
|
(while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t)
|
|
(push (buffer-substring start (match-beginning 0))
|
|
sections)
|
|
(push (list (match-string 1) (match-string 2))
|
|
sections)
|
|
(setq start (point)))
|
|
(push (buffer-substring start (point-max))
|
|
sections)
|
|
(nreverse sections))))
|
|
|
|
;; Segment the raw assistant data into a list of nodes.
|
|
(defun assistant-segment (list)
|
|
(let ((ast nil)
|
|
(node nil)
|
|
(title (pop list)))
|
|
(dolist (elem list)
|
|
(when (and (equal (car elem) "node")
|
|
node)
|
|
(push (list "save" nil) node)
|
|
(push (nreverse node) ast)
|
|
(setq node nil))
|
|
(push elem node))
|
|
(when node
|
|
(push (list "save" nil) node)
|
|
(push (nreverse node) ast))
|
|
(cons title (nreverse ast))))
|
|
|
|
(defun assistant-reader (command value)
|
|
(let ((formatter (cadr (assoc command assistant-readers))))
|
|
(if (not formatter)
|
|
value
|
|
(funcall formatter value))))
|
|
|
|
(defun assistant-list-reader (value)
|
|
(car (read-from-string (concat "(" value ")"))))
|
|
|
|
(defun assistant-variable-reader (value)
|
|
(let ((section (car (read-from-string (concat "(" value ")")))))
|
|
(append section (list 'default))))
|
|
|
|
(defun assistant-sexp-reader (value)
|
|
(if (zerop (length value))
|
|
nil
|
|
(car (read-from-string value))))
|
|
|
|
(defun assistant-buffer-name (title)
|
|
(format "*Assistant %s*" title))
|
|
|
|
(defun assistant-get (ast command)
|
|
(cadr (assoc command ast)))
|
|
|
|
(defun assistant-set (ast command value)
|
|
(let ((elem (assoc command ast)))
|
|
(when elem
|
|
(setcar (cdr elem) value))))
|
|
|
|
(defun assistant-get-list (ast command)
|
|
(let ((result nil))
|
|
(dolist (elem ast)
|
|
(when (equal (car elem) command)
|
|
(push elem result)))
|
|
(nreverse result)))
|
|
|
|
;;;###autoload
|
|
(defun assistant (file)
|
|
"Assist setting up Emacs based on FILE."
|
|
(interactive "fAssistant file name: ")
|
|
(let ((ast
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(assistant-parse-buffer))))
|
|
(pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
|
|
(assistant-render ast)))
|
|
|
|
(defun assistant-render (ast)
|
|
(let ((first-node (assistant-get (nth 1 ast) "node")))
|
|
(set (make-local-variable 'assistant-data) ast)
|
|
(set (make-local-variable 'assistant-current-node) nil)
|
|
(set (make-local-variable 'assistant-previous-nodes) nil)
|
|
(assistant-render-node first-node)))
|
|
|
|
(defun assistant-find-node (node-name)
|
|
(let ((ast (cdr assistant-data)))
|
|
(while (and ast
|
|
(not (string= node-name (assistant-get (car ast) "node"))))
|
|
(pop ast))
|
|
(car ast)))
|
|
|
|
(defun assistant-node-name (node)
|
|
(assistant-get node "node"))
|
|
|
|
(defun assistant-previous-node-text (node)
|
|
(format "<< Go back to %s" node))
|
|
|
|
(defun assistant-next-node-text (node)
|
|
(if (and node
|
|
(not (eq node 'finish)))
|
|
(format "Proceed to %s >>" node)
|
|
"Finish"))
|
|
|
|
(defun assistant-set-defaults (node &optional forcep)
|
|
(dolist (variable (assistant-get-list node "variable"))
|
|
(setq variable (cadr variable))
|
|
(when (or (eq (nth 3 variable) 'default)
|
|
forcep)
|
|
(setcar (nthcdr 3 variable)
|
|
(assistant-eval (nth 2 variable))))))
|
|
|
|
(defun assistant-get-variable (node variable &optional type raw)
|
|
(let ((variables (assistant-get-list node "variable"))
|
|
(result nil)
|
|
elem)
|
|
(while (and (setq elem (pop variables))
|
|
(not result))
|
|
(setq elem (cadr elem))
|
|
(when (eq (intern variable) (car elem))
|
|
(if type
|
|
(setq result (nth 1 elem))
|
|
(setq result (if raw (nth 3 elem)
|
|
(format "%s" (nth 3 elem)))))))
|
|
result))
|
|
|
|
(defun assistant-set-variable (node variable value)
|
|
(let ((variables (assistant-get-list node "variable"))
|
|
elem)
|
|
(while (setq elem (pop variables))
|
|
(setq elem (cadr elem))
|
|
(when (eq (intern variable) (car elem))
|
|
(setcar (nthcdr 3 elem) value)))))
|
|
|
|
(defun assistant-render-text (text node)
|
|
(unless (and text node)
|
|
(gnus-error
|
|
5
|
|
"The assistant was asked to render invalid text or node data"))
|
|
(dolist (elem text)
|
|
(if (stringp elem)
|
|
;; Ordinary text
|
|
(insert elem)
|
|
;; A variable to be inserted as a widget.
|
|
(let* ((start (point))
|
|
(variable (cadr elem))
|
|
(type (assistant-get-variable node variable 'type)))
|
|
(cond
|
|
((eq (car-safe type) :radio)
|
|
(push
|
|
(apply
|
|
#'widget-create
|
|
'radio-button-choice
|
|
:assistant-variable variable
|
|
:assistant-node node
|
|
:value (assistant-get-variable node variable)
|
|
:notify (lambda (widget &rest ignore)
|
|
(assistant-set-variable
|
|
(widget-get widget :assistant-node)
|
|
(widget-get widget :assistant-variable)
|
|
(widget-value widget))
|
|
(assistant-render-node
|
|
(assistant-get
|
|
(widget-get widget :assistant-node)
|
|
"node")))
|
|
(cadr type))
|
|
assistant-widgets))
|
|
((eq (car-safe type) :set)
|
|
(push
|
|
(apply
|
|
#'widget-create
|
|
'set
|
|
:assistant-variable variable
|
|
:assistant-node node
|
|
:value (assistant-get-variable node variable nil t)
|
|
:notify (lambda (widget &rest ignore)
|
|
(assistant-set-variable
|
|
(widget-get widget :assistant-node)
|
|
(widget-get widget :assistant-variable)
|
|
(widget-value widget))
|
|
(assistant-render-node
|
|
(assistant-get
|
|
(widget-get widget :assistant-node)
|
|
"node")))
|
|
(cadr type))
|
|
assistant-widgets))
|
|
(t
|
|
(push
|
|
(widget-create
|
|
'editable-field
|
|
:value-face 'assistant-field
|
|
:assistant-variable variable
|
|
(assistant-get-variable node variable))
|
|
assistant-widgets)
|
|
;; The editable-field widget apparently inserts a newline;
|
|
;; remove it.
|
|
(delete-char -1)
|
|
(add-text-properties start (point)
|
|
(list
|
|
'bold t
|
|
'face 'assistant-field
|
|
'not-read-only t))))))))
|
|
|
|
(defun assistant-render-node (node-name)
|
|
(let ((node (assistant-find-node node-name))
|
|
(inhibit-read-only t)
|
|
(previous assistant-current-node)
|
|
(buffer-read-only nil))
|
|
(unless node
|
|
(gnus-error 5 "The node for %s could not be found" node-name))
|
|
(set (make-local-variable 'assistant-widgets) nil)
|
|
(assistant-set-defaults node)
|
|
(if (equal (assistant-get node "type") "interstitial")
|
|
(assistant-render-node (nth 0 (assistant-find-next-nodes node-name)))
|
|
(setq assistant-current-node node-name)
|
|
(when previous
|
|
(push previous assistant-previous-nodes))
|
|
(erase-buffer)
|
|
(insert (cadar assistant-data) "\n\n")
|
|
(insert node-name "\n\n")
|
|
(assistant-render-text (assistant-get node "text") node)
|
|
(insert "\n\n")
|
|
(when assistant-previous-nodes
|
|
(assistant-node-button 'previous (car assistant-previous-nodes)))
|
|
(widget-create
|
|
'push-button
|
|
:assistant-node node-name
|
|
:notify (lambda (widget &rest ignore)
|
|
(let* ((node (widget-get widget :assistant-node)))
|
|
(assistant-set-defaults (assistant-find-node node) 'force)
|
|
(assistant-render-node node)))
|
|
"Reset")
|
|
(insert "\n")
|
|
(dolist (nnode (assistant-find-next-nodes))
|
|
(assistant-node-button 'next nnode)
|
|
(insert "\n"))
|
|
|
|
(goto-char (point-min))
|
|
(assistant-make-read-only))))
|
|
|
|
(defun assistant-make-read-only ()
|
|
(let ((start (point-min))
|
|
end)
|
|
(while (setq end (text-property-any start (point-max) 'not-read-only t))
|
|
(put-text-property start end 'read-only t)
|
|
(put-text-property start end 'rear-nonsticky t)
|
|
(while (get-text-property end 'not-read-only)
|
|
(incf end))
|
|
(setq start end))
|
|
(put-text-property start (point-max) 'read-only t)))
|
|
|
|
(defun assistant-node-button (type node)
|
|
(let ((text (if (eq type 'next)
|
|
(assistant-next-node-text node)
|
|
(assistant-previous-node-text node))))
|
|
(widget-create
|
|
'push-button
|
|
:assistant-node node
|
|
:assistant-type type
|
|
:notify (lambda (widget &rest ignore)
|
|
(let* ((node (widget-get widget :assistant-node))
|
|
(type (widget-get widget :assistant-type)))
|
|
(if (eq type 'previous)
|
|
(progn
|
|
(setq assistant-current-node nil)
|
|
(pop assistant-previous-nodes))
|
|
(assistant-get-widget-values)
|
|
(assistant-validate))
|
|
(if (null node)
|
|
(assistant-finish)
|
|
(assistant-render-node node))))
|
|
text)
|
|
(use-local-map widget-keymap)))
|
|
|
|
(defun assistant-validate-types (node)
|
|
(dolist (variable (assistant-get-list node "variable"))
|
|
(setq variable (cadr variable))
|
|
(let ((type (nth 1 variable))
|
|
(value (nth 3 variable)))
|
|
(when
|
|
(cond
|
|
((eq type :number)
|
|
(string-match "[^0-9]" value))
|
|
(t
|
|
nil))
|
|
(error "%s is not of type %s: %s"
|
|
(car variable) type value)))))
|
|
|
|
(defun assistant-get-widget-values ()
|
|
(let ((node (assistant-find-node assistant-current-node)))
|
|
(dolist (widget assistant-widgets)
|
|
(assistant-set-variable
|
|
node (widget-get widget :assistant-variable)
|
|
(widget-value widget)))))
|
|
|
|
(defun assistant-validate ()
|
|
(let* ((node (assistant-find-node assistant-current-node))
|
|
(validation (assistant-get node "validate"))
|
|
result)
|
|
(assistant-validate-types node)
|
|
(when validation
|
|
(when (setq result (assistant-eval validation))
|
|
(unless (y-or-n-p (format "Error: %s. Continue? " result))
|
|
(error "%s" result))))
|
|
(assistant-set node "save" t)))
|
|
|
|
;; (defun assistant-find-next-node (&optional node)
|
|
;; (let* ((node (assistant-find-node (or node assistant-current-node)))
|
|
;; (node-name (assistant-node-name node))
|
|
;; (nexts (assistant-get-list node "next"))
|
|
;; next elem applicable)
|
|
|
|
;; (while (setq elem (pop nexts))
|
|
;; (when (assistant-eval (car (cadr elem)))
|
|
;; (setq applicable (cons elem applicable))))
|
|
|
|
;; ;; return the first thing we can
|
|
;; (cadr (cadr (pop applicable)))))
|
|
|
|
(defun assistant-find-next-nodes (&optional node)
|
|
(let* ((node (assistant-find-node (or node assistant-current-node)))
|
|
(nexts (assistant-get-list node "next"))
|
|
next elem applicable return)
|
|
|
|
(while (setq elem (pop nexts))
|
|
(when (assistant-eval (car (cadr elem)))
|
|
(setq applicable (cons elem applicable))))
|
|
|
|
;; return the first thing we can
|
|
|
|
(while (setq elem (pop applicable))
|
|
(push (cadr (cadr elem)) return))
|
|
|
|
return))
|
|
|
|
(defun assistant-get-all-variables ()
|
|
(let ((variables nil))
|
|
(dolist (node (cdr assistant-data))
|
|
(setq variables
|
|
(append (assistant-get-list node "variable")
|
|
variables)))
|
|
variables))
|
|
|
|
(defun assistant-eval (form)
|
|
(let ((bindings nil))
|
|
(dolist (variable (assistant-get-all-variables))
|
|
(setq variable (cadr variable))
|
|
(push (list (car variable)
|
|
(if (eq (nth 3 variable) 'default)
|
|
nil
|
|
(if (listp (nth 3 variable))
|
|
`(list ,@(nth 3 variable))
|
|
(nth 3 variable))))
|
|
bindings))
|
|
(eval
|
|
`(let ,bindings
|
|
,form))))
|
|
|
|
(defun assistant-finish ()
|
|
(let ((results nil)
|
|
result)
|
|
(dolist (node (cdr assistant-data))
|
|
(when (assistant-get node "save")
|
|
(setq result (assistant-get node "result"))
|
|
(push (list (car result)
|
|
(assistant-eval (cadr result)))
|
|
results)))
|
|
(message "Results: %s"
|
|
(nreverse results))))
|
|
|
|
;;; Validation functions.
|
|
|
|
(defun assistant-validate-connect-to-server (server port)
|
|
(let* ((error nil)
|
|
(stream
|
|
(condition-case err
|
|
(open-network-stream "nntpd" nil server port)
|
|
(error (setq error err)))))
|
|
(if (and (processp stream)
|
|
(memq (process-status stream) '(open run)))
|
|
(progn
|
|
(delete-process stream)
|
|
nil)
|
|
error)))
|
|
|
|
(defun assistant-authinfo-data (server port type)
|
|
(when (file-exists-p "~/.authinfo")
|
|
(netrc-get (netrc-machine (netrc-parse "~/.authinfo")
|
|
server port)
|
|
(if (eq type 'user)
|
|
"login"
|
|
"password"))))
|
|
|
|
(defun assistant-password-required-p ()
|
|
nil)
|
|
|
|
(provide 'assistant)
|
|
|
|
;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
|
|
;;; assistant.el ends here
|