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 2, 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; 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.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile
  29   (require 'cl))
  30
  31 (require 'widget)
  32 (require 'wid-edit)
  33
  34 (autoload 'gnus-error "gnus-util")
  35 (autoload 'netrc-get "netrc")
  36 (autoload 'netrc-machine "netrc")
  37 (autoload 'netrc-parse "netrc")
  38
  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)))
  45
  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)
  51
  52 ;;; Internal variables
  53
  54 (defvar assistant-data nil)
  55 (defvar assistant-current-node nil)
  56 (defvar assistant-previous-nodes nil)
  57 (defvar assistant-widgets nil)
  58
  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]+"))
  64           (error "Dangling @")
  65         (setq command (downcase (match-string 0)))
  66         (goto-char (match-end 0)))
  67       (setq value
  68             (if (looking-at "[ \t]*\n")
  69                 (let (start)
  70                   (forward-line 1)
  71                   (setq start (point))
  72                   (unless (re-search-forward (concat "^@end " command) nil t)
  73                     (error "No @end %s found" command))
  74                   (beginning-of-line)
  75                   (prog1
  76                       (buffer-substring start (point))
  77                     (forward-line 1)))
  78               (skip-chars-forward " \t")
  79               (prog1
  80                   (buffer-substring (point) (point-at-eol))
  81                 (forward-line 1))))
  82       (push (list command (assistant-reader command value))
  83             results))
  84     (assistant-segment (nreverse results))))
  85
  86 (defun assistant-text-reader (text)
  87   (with-temp-buffer
  88     (insert text)
  89     (goto-char (point-min))
  90     (let ((start (point))
  91           (sections nil))
  92       (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t)
  93         (push (buffer-substring start (match-beginning 0))
  94               sections)
  95         (push (list (match-string 1) (match-string 2))
  96               sections)
  97         (setq start (point)))
  98       (push (buffer-substring start (point-max))
  99             sections)
 100       (nreverse sections))))
 101
 102 ;; Segment the raw assistant data into a list of nodes.
 103 (defun assistant-segment (list)
 104   (let ((ast nil)
 105         (node nil)
 106         (title (pop list)))
 107     (dolist (elem list)
 108       (when (and (equal (car elem) "node")
 109                  node)
 110         (push (list "save" nil) node)
 111         (push (nreverse node) ast)
 112         (setq node nil))
 113       (push elem node))
 114     (when node
 115       (push (list "save" nil) node)
 116       (push (nreverse node) ast))
 117     (cons title (nreverse ast))))
 118
 119 (defun assistant-reader (command value)
 120   (let ((formatter (cadr (assoc command assistant-readers))))
 121     (if (not formatter)
 122         value
 123       (funcall formatter value))))
 124
 125 (defun assistant-list-reader (value)
 126   (car (read-from-string (concat "(" value ")"))))
 127
 128 (defun assistant-variable-reader (value)
 129   (let ((section (car (read-from-string (concat "(" value ")")))))
 130     (append section (list 'default))))
 131
 132 (defun assistant-sexp-reader (value)
 133   (if (zerop (length value))
 134       nil
 135     (car (read-from-string value))))
 136
 137 (defun assistant-buffer-name (title)
 138   (format "*Assistant %s*" title))
 139
 140 (defun assistant-get (ast command)
 141   (cadr (assoc command ast)))
 142
 143 (defun assistant-set (ast command value)
 144   (let ((elem (assoc command ast)))
 145     (when elem
 146       (setcar (cdr elem) value))))
 147
 148 (defun assistant-get-list (ast command)
 149   (let ((result nil))
 150     (dolist (elem ast)
 151       (when (equal (car elem) command)
 152         (push elem result)))
 153     (nreverse result)))
 154
 155 ;;;###autoload
 156 (defun assistant (file)
 157   "Assist setting up Emacs based on FILE."
 158   (interactive "fAssistant file name: ")
 159   (let ((ast
 160          (with-temp-buffer
 161            (insert-file-contents file)
 162            (assistant-parse-buffer))))
 163     (pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
 164     (assistant-render ast)))
 165
 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)))
 172
 173 (defun assistant-find-node (node-name)
 174   (let ((ast (cdr assistant-data)))
 175     (while (and ast
 176                 (not (string= node-name (assistant-get (car ast) "node"))))
 177       (pop ast))
 178     (car ast)))
 179
 180 (defun assistant-node-name (node)
 181   (assistant-get node "node"))
 182
 183 (defun assistant-previous-node-text (node)
 184   (format "<< Go back to %s" node))
 185
 186 (defun assistant-next-node-text (node)
 187   (if (and node
 188            (not (eq node 'finish)))
 189       (format "Proceed to %s >>" node)
 190     "Finish"))
 191
 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)
 196               forcep)
 197       (setcar (nthcdr 3 variable)
 198               (assistant-eval (nth 2 variable))))))
 199
 200 (defun assistant-get-variable (node variable &optional type raw)
 201   (let ((variables (assistant-get-list node "variable"))
 202         (result nil)
 203         elem)
 204     (while (and (setq elem (pop variables))
 205                 (not result))
 206       (setq elem (cadr elem))
 207       (when (eq (intern variable) (car elem))
 208         (if type
 209             (setq result (nth 1 elem))
 210           (setq result (if raw (nth 3 elem)
 211                          (format "%s" (nth 3 elem)))))))
 212     result))
 213
 214 (defun assistant-set-variable (node variable value)
 215   (let ((variables (assistant-get-list node "variable"))
 216         elem)
 217     (while (setq elem (pop variables))
 218       (setq elem (cadr elem))
 219       (when (eq (intern variable) (car elem))
 220         (setcar (nthcdr 3 elem) value)))))
 221
 222 (defun assistant-render-text (text node)
 223   (unless (and text node)
 224     (gnus-error
 225      5
 226      "The assistant was asked to render invalid text or node data"))
 227   (dolist (elem text)
 228     (if (stringp elem)
 229         ;; Ordinary text
 230         (insert elem)
 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)))
 235         (cond
 236          ((eq (car-safe type) :radio)
 237           (push
 238            (apply
 239             #'widget-create
 240             'radio-button-choice
 241             :assistant-variable variable
 242             :assistant-node node
 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
 250                        (assistant-get
 251                         (widget-get widget :assistant-node)
 252                         "node")))
 253             (cadr type))
 254            assistant-widgets))
 255          ((eq (car-safe type) :set)
 256           (push
 257            (apply
 258             #'widget-create
 259             'set
 260             :assistant-variable variable
 261             :assistant-node node
 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
 269                        (assistant-get
 270                         (widget-get widget :assistant-node)
 271                         "node")))
 272             (cadr type))
 273            assistant-widgets))
 274          (t
 275           (push
 276            (widget-create
 277             'editable-field
 278             :value-face 'assistant-field
 279             :assistant-variable variable
 280             (assistant-get-variable node variable))
 281            assistant-widgets)
 282           ;; The editable-field widget apparently inserts a newline;
 283           ;; remove it.
 284           (delete-char -1)
 285           (add-text-properties start (point)
 286                                (list
 287                                 'bold t
 288                                 'face 'assistant-field
 289                                 'not-read-only t))))))))
 290
 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))
 296     (unless node
 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)
 303       (when previous
 304         (push previous assistant-previous-nodes))
 305       (erase-buffer)
 306       (insert (cadar assistant-data) "\n\n")
 307       (insert node-name "\n\n")
 308       (assistant-render-text (assistant-get node "text") node)
 309       (insert "\n\n")
 310       (when assistant-previous-nodes
 311         (assistant-node-button 'previous (car assistant-previous-nodes)))
 312       (widget-create
 313        'push-button
 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)))
 319        "Reset")
 320       (insert "\n")
 321       (dolist (nnode (assistant-find-next-nodes))
 322         (assistant-node-button 'next nnode)
 323         (insert "\n"))
 324
 325       (goto-char (point-min))
 326       (assistant-make-read-only))))
 327
 328 (defun assistant-make-read-only ()
 329   (let ((start (point-min))
 330         end)
 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)
 335         (incf end))
 336       (setq start end))
 337     (put-text-property start (point-max) 'read-only t)))
 338
 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))))
 343     (widget-create
 344      'push-button
 345      :assistant-node node
 346      :assistant-type type
 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)
 351                      (progn
 352                        (setq assistant-current-node nil)
 353                        (pop assistant-previous-nodes))
 354                    (assistant-get-widget-values)
 355                    (assistant-validate))
 356                  (if (null node)
 357                      (assistant-finish)
 358                    (assistant-render-node node))))
 359      text)
 360     (use-local-map widget-keymap)))
 361
 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)))
 367       (when
 368           (cond
 369            ((eq type :number)
 370             (string-match "[^0-9]" value))
 371            (t
 372             nil))
 373         (error "%s is not of type %s: %s"
 374                (car variable) type value)))))
 375
 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)))))
 382
 383 (defun assistant-validate ()
 384   (let* ((node (assistant-find-node assistant-current-node))
 385          (validation (assistant-get node "validate"))
 386          result)
 387     (assistant-validate-types node)
 388     (when validation
 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)))
 393
 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)
 399
 400 ;;     (while (setq elem (pop nexts))
 401 ;;       (when (assistant-eval (car (cadr elem)))
 402 ;;      (setq applicable (cons elem applicable))))
 403
 404 ;;     ;; return the first thing we can
 405 ;;     (cadr (cadr (pop applicable)))))
 406
 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)
 411
 412     (while (setq elem (pop nexts))
 413       (when (assistant-eval (car (cadr elem)))
 414         (setq applicable (cons elem applicable))))
 415
 416     ;; return the first thing we can
 417
 418     (while (setq elem (pop applicable))
 419       (push (cadr (cadr elem)) return))
 420
 421     return))
 422
 423 (defun assistant-get-all-variables ()
 424   (let ((variables nil))
 425     (dolist (node (cdr assistant-data))
 426       (setq variables
 427             (append (assistant-get-list node "variable")
 428                     variables)))
 429     variables))
 430
 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)
 437                       nil
 438                     (if (listp (nth 3 variable))
 439                         `(list ,@(nth 3 variable))
 440                       (nth 3 variable))))
 441             bindings))
 442     (eval
 443      `(let ,bindings
 444         ,form))))
 445
 446 (defun assistant-finish ()
 447   (let ((results nil)
 448         result)
 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)))
 454               results)))
 455     (message "Results: %s"
 456              (nreverse results))))
 457
 458 ;;; Validation functions.
 459
 460 (defun assistant-validate-connect-to-server (server port)
 461   (let* ((error nil)
 462          (stream
 463           (condition-case err
 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)))
 468         (progn
 469           (delete-process stream)
 470           nil)
 471       error)))
 472
 473 (defun assistant-authinfo-data (server port type)
 474   (when (file-exists-p "~/.authinfo")
 475     (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
 476                               server port)
 477                (if (eq type 'user)
 478                    "login"
 479                  "password"))))
 480
 481 (defun assistant-password-required-p ()
 482   nil)
 483
 484 (provide 'assistant)
 485
 486 ;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
 487 ;;; assistant.el ends here