X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fassistant.el;h=93d72193f4199efe7ddefc0e43acb6838ca013d1;hp=d16ee8c897b9493b95623aa5daa715288dc71d7e;hb=b52037f4a9c6bee1ff556c22750e158da1208d4b;hpb=daa9e85532ca8d3dec34679c53fd2ff7bfb72bee

diff --git a/lisp/assistant.el b/lisp/assistant.el
index d16ee8c89..93d72193f 100644
--- a/lisp/assistant.el
+++ b/lisp/assistant.el
@@ -1,5 +1,5 @@
 ;;; assistant.el --- guiding users through Emacs setup
-;; Copyright (C) 2004 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: util
@@ -8,7 +8,7 @@
 
 ;; 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 2, or (at your option)
+;; 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,
@@ -17,9 +17,7 @@
 ;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -28,5 +26,457 @@
 (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)
+	  (add-text-properties start (point)
+	  		       (list
+	  			'bold t
+	  			'face 'assistant-field
+	  			'not-read-only t)))))))
+  (widget-setup))
+
+(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)
+
+;;; assistant.el ends here