cgit.sxemacs.org Git - gnus/blob - lisp/assistant.el

   1 ;;; assistant.el --- guiding users through Emacs setup
   2 ;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: util
   6
   7 ;; This file is part of GNU Emacs.
   8
   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)
  12 ;; any later version.
  13
  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.
  18
  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/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (eval-when-compile
  27   (require 'cl))
  28
  29 (require 'widget)
  30 (require 'wid-edit)
  31
  32 (autoload 'gnus-error "gnus-util")
  33 (autoload 'netrc-get "netrc")
  34 (autoload 'netrc-machine "netrc")
  35 (autoload 'netrc-parse "netrc")
  36
  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)))
  43
  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)
  49
  50 ;;; Internal variables
  51
  52 (defvar assistant-data nil)
  53 (defvar assistant-current-node nil)
  54 (defvar assistant-previous-nodes nil)
  55 (defvar assistant-widgets nil)
  56
  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]+"))
  62           (error "Dangling @")
  63         (setq command (downcase (match-string 0)))
  64         (goto-char (match-end 0)))
  65       (setq value
  66             (if (looking-at "[ \t]*\n")
  67                 (let (start)
  68                   (forward-line 1)
  69                   (setq start (point))
  70                   (unless (re-search-forward (concat "^@end " command) nil t)
  71                     (error "No @end %s found" command))
  72                   (beginning-of-line)
  73                   (prog1
  74                       (buffer-substring start (point))
  75                     (forward-line 1)))
  76               (skip-chars-forward " \t")
  77               (prog1
  78                   (buffer-substring (point) (point-at-eol))
  79                 (forward-line 1))))
  80       (push (list command (assistant-reader command value))
  81             results))
  82     (assistant-segment (nreverse results))))
  83
  84 (defun assistant-text-reader (text)
  85   (with-temp-buffer
  86     (insert text)
  87     (goto-char (point-min))
  88     (let ((start (point))
  89           (sections nil))
  90       (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t)
  91         (push (buffer-substring start (match-beginning 0))
  92               sections)
  93         (push (list (match-string 1) (match-string 2))
  94               sections)
  95         (setq start (point)))
  96       (push (buffer-substring start (point-max))
  97             sections)
  98       (nreverse sections))))
  99
 100 ;; Segment the raw assistant data into a list of nodes.
 101 (defun assistant-segment (list)
 102   (let ((ast nil)
 103         (node nil)
 104         (title (pop list)))
 105     (dolist (elem list)
 106       (when (and (equal (car elem) "node")
 107                  node)
 108         (push (list "save" nil) node)
 109         (push (nreverse node) ast)
 110         (setq node nil))
 111       (push elem node))
 112     (when node
 113       (push (list "save" nil) node)
 114       (push (nreverse node) ast))
 115     (cons title (nreverse ast))))
 116
 117 (defun assistant-reader (command value)
 118   (let ((formatter (cadr (assoc command assistant-readers))))
 119     (if (not formatter)
 120         value
 121       (funcall formatter value))))
 122
 123 (defun assistant-list-reader (value)
 124   (car (read-from-string (concat "(" value ")"))))
 125
 126 (defun assistant-variable-reader (value)
 127   (let ((section (car (read-from-string (concat "(" value ")")))))
 128     (append section (list 'default))))
 129
 130 (defun assistant-sexp-reader (value)
 131   (if (zerop (length value))
 132       nil
 133     (car (read-from-string value))))
 134
 135 (defun assistant-buffer-name (title)
 136   (format "*Assistant %s*" title))
 137
 138 (defun assistant-get (ast command)
 139   (cadr (assoc command ast)))
 140
 141 (defun assistant-set (ast command value)
 142   (let ((elem (assoc command ast)))
 143     (when elem
 144       (setcar (cdr elem) value))))
 145
 146 (defun assistant-get-list (ast command)
 147   (let ((result nil))
 148     (dolist (elem ast)
 149       (when (equal (car elem) command)
 150         (push elem result)))
 151     (nreverse result)))
 152
 153 ;;;###autoload
 154 (defun assistant (file)
 155   "Assist setting up Emacs based on FILE."
 156   (interactive "fAssistant file name: ")
 157   (let ((ast
 158          (with-temp-buffer
 159            (insert-file-contents file)
 160            (assistant-parse-buffer))))
 161     (pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
 162     (assistant-render ast)))
 163
 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)))
 170
 171 (defun assistant-find-node (node-name)
 172   (let ((ast (cdr assistant-data)))
 173     (while (and ast
 174                 (not (string= node-name (assistant-get (car ast) "node"))))
 175       (pop ast))
 176     (car ast)))
 177
 178 (defun assistant-node-name (node)
 179   (assistant-get node "node"))
 180
 181 (defun assistant-previous-node-text (node)
 182   (format "<< Go back to %s" node))
 183
 184 (defun assistant-next-node-text (node)
 185   (if (and node
 186            (not (eq node 'finish)))
 187       (format "Proceed to %s >>" node)
 188     "Finish"))
 189
 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)
 194               forcep)
 195       (setcar (nthcdr 3 variable)
 196               (assistant-eval (nth 2 variable))))))
 197
 198 (defun assistant-get-variable (node variable &optional type raw)
 199   (let ((variables (assistant-get-list node "variable"))
 200         (result nil)
 201         elem)
 202     (while (and (setq elem (pop variables))
 203                 (not result))
 204       (setq elem (cadr elem))
 205       (when (eq (intern variable) (car elem))
 206         (if type
 207             (setq result (nth 1 elem))
 208           (setq result (if raw (nth 3 elem)
 209                          (format "%s" (nth 3 elem)))))))
 210     result))
 211
 212 (defun assistant-set-variable (node variable value)
 213   (let ((variables (assistant-get-list node "variable"))
 214         elem)
 215     (while (setq elem (pop variables))
 216       (setq elem (cadr elem))
 217       (when (eq (intern variable) (car elem))
 218         (setcar (nthcdr 3 elem) value)))))
 219
 220 (defun assistant-render-text (text node)
 221   (unless (and text node)
 222     (gnus-error
 223      5
 224      "The assistant was asked to render invalid text or node data"))
 225   (dolist (elem text)
 226     (if (stringp elem)
 227         ;; Ordinary text
 228         (insert elem)
 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)))
 233         (cond
 234          ((eq (car-safe type) :radio)
 235           (push
 236            (apply
 237             #'widget-create
 238             'radio-button-choice
 239             :assistant-variable variable
 240             :assistant-node node
 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
 248                        (assistant-get
 249                         (widget-get widget :assistant-node)
 250                         "node")))
 251             (cadr type))
 252            assistant-widgets))
 253          ((eq (car-safe type) :set)
 254           (push
 255            (apply
 256             #'widget-create
 257             'set
 258             :assistant-variable variable
 259             :assistant-node node
 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
 267                        (assistant-get
 268                         (widget-get widget :assistant-node)
 269                         "node")))
 270             (cadr type))
 271            assistant-widgets))
 272          (t
 273           (push
 274            (widget-create
 275             'editable-field
 276             :value-face 'assistant-field
 277             :assistant-variable variable
 278             (assistant-get-variable node variable))
 279            assistant-widgets)
 280           (add-text-properties start (point)
 281                                (list
 282                                 'bold t
 283                                 'face 'assistant-field
 284                                 'not-read-only t)))))))
 285   (widget-setup))
 286
 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))
 292     (unless node
 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)
 299       (when previous
 300         (push previous assistant-previous-nodes))
 301       (erase-buffer)
 302       (insert (cadar assistant-data) "\n\n")
 303       (insert node-name "\n\n")
 304       (assistant-render-text (assistant-get node "text") node)
 305       (insert "\n\n")
 306       (when assistant-previous-nodes
 307         (assistant-node-button 'previous (car assistant-previous-nodes)))
 308       (widget-create
 309        'push-button
 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)))
 315        "Reset")
 316       (insert "\n")
 317       (dolist (nnode (assistant-find-next-nodes))
 318         (assistant-node-button 'next nnode)
 319         (insert "\n"))
 320
 321       (goto-char (point-min))
 322       (assistant-make-read-only))))
 323
 324 (defun assistant-make-read-only ()
 325   (let ((start (point-min))
 326         end)
 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)
 331         (incf end))
 332       (setq start end))
 333     (put-text-property start (point-max) 'read-only t)))
 334
 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))))
 339     (widget-create
 340      'push-button
 341      :assistant-node node
 342      :assistant-type type
 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)
 347                      (progn
 348                        (setq assistant-current-node nil)
 349                        (pop assistant-previous-nodes))
 350                    (assistant-get-widget-values)
 351                    (assistant-validate))
 352                  (if (null node)
 353                      (assistant-finish)
 354                    (assistant-render-node node))))
 355      text)
 356     (use-local-map widget-keymap)))
 357
 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)))
 363       (when
 364           (cond
 365            ((eq type :number)
 366             (string-match "[^0-9]" value))
 367            (t
 368             nil))
 369         (error "%s is not of type %s: %s"
 370                (car variable) type value)))))
 371
 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)))))
 378
 379 (defun assistant-validate ()
 380   (let* ((node (assistant-find-node assistant-current-node))
 381          (validation (assistant-get node "validate"))
 382          result)
 383     (assistant-validate-types node)
 384     (when validation
 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)))
 389
 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)
 395
 396 ;;     (while (setq elem (pop nexts))
 397 ;;       (when (assistant-eval (car (cadr elem)))
 398 ;;      (setq applicable (cons elem applicable))))
 399
 400 ;;     ;; return the first thing we can
 401 ;;     (cadr (cadr (pop applicable)))))
 402
 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)
 407
 408     (while (setq elem (pop nexts))
 409       (when (assistant-eval (car (cadr elem)))
 410         (setq applicable (cons elem applicable))))
 411
 412     ;; return the first thing we can
 413
 414     (while (setq elem (pop applicable))
 415       (push (cadr (cadr elem)) return))
 416
 417     return))
 418
 419 (defun assistant-get-all-variables ()
 420   (let ((variables nil))
 421     (dolist (node (cdr assistant-data))
 422       (setq variables
 423             (append (assistant-get-list node "variable")
 424                     variables)))
 425     variables))
 426
 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)
 433                       nil
 434                     (if (listp (nth 3 variable))
 435                         `(list ,@(nth 3 variable))
 436                       (nth 3 variable))))
 437             bindings))
 438     (eval
 439      `(let ,bindings
 440         ,form))))
 441
 442 (defun assistant-finish ()
 443   (let ((results nil)
 444         result)
 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)))
 450               results)))
 451     (message "Results: %s"
 452              (nreverse results))))
 453
 454 ;;; Validation functions.
 455
 456 (defun assistant-validate-connect-to-server (server port)
 457   (let* ((error nil)
 458          (stream
 459           (condition-case err
 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)))
 464         (progn
 465           (delete-process stream)
 466           nil)
 467       error)))
 468
 469 (defun assistant-authinfo-data (server port type)
 470   (when (file-exists-p "~/.authinfo")
 471     (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
 472                               server port)
 473                (if (eq type 'user)
 474                    "login"
 475                  "password"))))
 476
 477 (defun assistant-password-required-p ()
 478   nil)
 479
 480 (provide 'assistant)
 481
 482 ;;; assistant.el ends here