cgit.sxemacs.org Git - riece/blob - lisp/riece-addon.el

   1 ;;; riece-addon.el --- add-on management
   2 ;; Copyright (C) 1998-2004 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'font-lock)
  28 (require 'riece-options)
  29 (require 'riece-compat)
  30 (require 'riece-misc)
  31 (require 'riece-addon-modules)
  32
  33 (defgroup riece-addon-list nil
  34   "Add-on listing."
  35   :tag "Addon list"
  36   :prefix "riece-addon-list-"
  37   :group 'riece)
  38
  39 (defgroup riece-addon-list-faces nil
  40   "Faces for riece-addon-list-mode."
  41   :tag "Faces"
  42   :prefix "riece-addon-list-"
  43   :group 'riece-addon-list)
  44
  45 (defface riece-addon-list-enabled-face
  46   '((((class color) (background dark))
  47      (:foreground "PaleTurquoise" :bold t))
  48     (t
  49      (:bold t)))
  50   "Face used for displaying the enabled addon."
  51   :group 'riece-addon-list-faces)
  52 (defvar riece-addon-list-enabled-face 'riece-addon-list-enabled-face)
  53
  54 (defface riece-addon-list-disabled-face
  55   '((((class color) (background dark))
  56      (:foreground "PaleTurquoise" :italic t))
  57     (t
  58      ()))
  59   "Face used for displaying the disabled addon."
  60   :group 'riece-addon-list-faces)
  61 (defvar riece-addon-list-disabled-face 'riece-addon-list-disabled-face)
  62
  63 (defface riece-addon-list-unsupported-face
  64   '((((class color) (background dark))
  65      (:foreground "PaleTurquoise"))
  66     (t
  67      ()))
  68   "Face used for displaying the unsupported addon."
  69   :group 'riece-addon-list-faces)
  70 (defvar riece-addon-list-unsupported-face 'riece-addon-list-unsupported-face)
  71
  72 (defface riece-addon-list-uninstalled-face
  73   '((t
  74      (:italic t)))
  75   "Face used for displaying the uninstalled addon."
  76   :group 'riece-addon-list-faces)
  77 (defvar riece-addon-list-uninstalled-face 'riece-addon-list-uninstalled-face)
  78
  79 (defface riece-addon-list-description-face
  80   '((((class color)
  81       (background dark))
  82      (:foreground "lightyellow"))
  83     (((class color)
  84       (background light))
  85      (:foreground "blue4"))
  86     (t
  87      ()))
  88   "Face used for displaying the description addon."
  89   :group 'riece-addon-list-faces)
  90 (defvar riece-addon-list-description-face 'riece-addon-list-description-face)
  91
  92 (defcustom riece-addon-list-mark-face-alist
  93   '((?+ . riece-addon-list-enabled-face)
  94     (?- . riece-addon-list-disabled-face)
  95     (?! . riece-addon-list-unsupported-face)
  96     (?  . riece-addon-list-uninstalled-face))
  97   "An alist mapping marks on riece-addon-list-buffer to faces."
  98   :type 'list
  99   :group 'riece-addon-list)
 100
 101 (defcustom riece-addon-list-font-lock-keywords
 102   '(("^\\([-+! ] [^:]+\\): \\(.*\\)"
 103      (1 (cdr (assq (aref (match-string 1) 0)
 104                    riece-addon-list-mark-face-alist)))
 105      (2 riece-addon-list-description-face)))
 106   "Default expressions to addon in riece-addon-list-mode."
 107   :type '(repeat (list string))
 108   :group 'riece-addon-list)
 109
 110 (defvar riece-addon-list-mode-map
 111   (let ((keymap (make-sparse-keymap)))
 112     (define-key keymap "+" 'riece-command-enable-addon)
 113     (define-key keymap "-" 'riece-command-disable-addon)
 114     (define-key keymap "I" 'riece-command-insinuate-addon)
 115     (define-key keymap "D" 'riece-command-uninstall-addon)
 116     (define-key keymap "n" 'next-line)
 117     (define-key keymap "p" 'previous-line)
 118     (define-key keymap " " 'scroll-up)
 119     (define-key keymap [delete] 'scroll-down)
 120     (define-key keymap "q" 'bury-buffer)
 121     keymap))
 122
 123 (defun riece-load-and-build-addon-dependencies (addons)
 124   (let ((load-path (cons riece-addon-directory load-path))
 125         dependencies)
 126     (while addons
 127       (require (car addons))            ;error will be reported here
 128       (let* ((requires
 129               (funcall (or (intern-soft
 130                             (concat (symbol-name (car addons)) "-requires"))
 131                            #'ignore)))
 132              (pointer requires)
 133              entry)
 134         ;; Increment succs' pred count.
 135         (if (setq entry (assq (car addons) dependencies))
 136             (setcar (cdr entry) (+ (length requires) (nth 1 entry)))
 137           (setq dependencies (cons (list (car addons) (length requires))
 138                                    dependencies)))
 139         ;; Merge pred's succs.
 140         (while pointer
 141           (if (setq entry (assq (car pointer) dependencies))
 142               (setcdr (cdr entry) (cons (car addons) (nthcdr 2 entry)))
 143             (setq dependencies (cons (list (car pointer) 0 (car addons))
 144                                      dependencies)))
 145           (setq pointer (cdr pointer))))
 146       (setq addons (cdr addons)))
 147     dependencies))
 148
 149 (defun riece-sort-addon-dependencies (dependencies)
 150   (let ((pointer dependencies)
 151         addons queue)
 152     (while pointer
 153       (if (zerop (nth 1 (car pointer)))
 154           (setq dependencies (delq (car pointer) dependencies)
 155                 queue (cons (car pointer) queue)))
 156       (setq pointer (cdr pointer)))
 157     (while queue
 158       (setq addons (cons (cons (car (car queue)) (nthcdr 2 (car queue)))
 159                          addons)
 160             pointer (nthcdr 2 (car queue)))
 161       (while pointer
 162         (let* ((entry (assq (car pointer) dependencies))
 163                (count (1- (nth 1 entry))))
 164           (if (zerop count)
 165               (setq dependencies (delq entry dependencies)
 166                     queue (nconc queue (list entry)))
 167             (setcar (cdr entry) count)))
 168         (setq pointer (cdr pointer)))
 169       (setq queue (cdr queue)))
 170     (if dependencies
 171         (error "Circular add-on dependency found: %S" dependencies))
 172     (nreverse addons)))
 173
 174 (defun riece-resolve-addons (addons)
 175   ;; Add files in riece-addon-directory to addons.
 176   (if (file-directory-p riece-addon-directory)
 177       (setq addons (nconc
 178                     addons
 179                     (mapcar
 180                      (lambda (name)
 181                        (unless (file-directory-p
 182                                 (expand-file-name name riece-addon-directory))
 183                          (intern (file-name-sans-extension name))))
 184                      (directory-files riece-addon-directory nil "\\`[^.]")))))
 185   ;; Sort & uniquify.
 186   (setq addons (sort addons (lambda (symbol1 symbol2)
 187                               (string-lessp (symbol-name symbol1)
 188                                             (symbol-name symbol2)))))
 189   (let ((pointer addons))
 190     (while pointer
 191       (if (memq (car pointer) (cdr pointer))
 192           (setcar pointer nil))
 193       (setq pointer (cdr pointer)))
 194     (delq nil addons))
 195   ;; Build & resolve dependencies.
 196   (riece-sort-addon-dependencies
 197    (riece-load-and-build-addon-dependencies addons)))
 198
 199 (defun riece-insinuate-addon (addon &optional verbose)
 200   (unless (assq addon riece-addon-dependencies)
 201     (setq riece-addons (cons addon riece-addons)
 202           riece-addon-dependencies (riece-resolve-addons
 203                                     (copy-sequence riece-addons))))
 204   (if (get addon 'riece-addon-insinuated)
 205       (if verbose
 206           (message "Add-on %S is already insinuated" addon))
 207     (funcall (intern (concat (symbol-name addon) "-insinuate")))
 208     (put addon 'riece-addon-insinuated t)
 209     (if verbose
 210         (message "Add-on %S is insinuated" addon))
 211     (unless (get addon 'riece-addon-default-disabled)
 212       (riece-enable-addon addon t))))
 213
 214 (defun riece-uninstall-addon (addon &optional verbose)
 215   (if (not (get addon 'riece-addon-insinuated))
 216       (if verbose
 217           (message "Add-on %S is not insinuated" addon))
 218     (let ((entry (assq addon riece-addon-dependencies))
 219           (enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 220       (if entry
 221           (if (cdr entry)
 222               (if (= (length (cdr entry)) 1)
 223                   (error "%S depends %S" (car (cdr entry)) addon)
 224                 (error "%s depends %S" (mapconcat #'identity (cdr entry) ",")
 225                        addon))
 226             (if (and enabled
 227                      (symbol-value enabled))
 228                 (riece-disable-addon addon verbose))
 229             (funcall (or (intern-soft (concat (symbol-name addon)
 230                                               "-uninstall"))
 231                          #'ignore))
 232             (setq riece-addon-dependencies
 233                   (delq entry riece-addon-dependencies))
 234             (remprop addon 'riece-addon-insinuated)
 235             (setq riece-addons (delq addon riece-addons)
 236                   riece-addon-dependencies (riece-resolve-addons
 237                                             (copy-sequence riece-addons)))))
 238       (if verbose
 239           (message "Add-on %S is uninstalled" addon)))))
 240
 241 (defun riece-enable-addon (addon &optional verbose)
 242   (unless (get addon 'riece-addon-insinuated)
 243     (error "Add-on %S is not insinuated" addon))
 244   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 245     (if (null enabled)
 246         (if verbose
 247             (message "Add-on %S doesn't support enable/disable" addon))
 248       (if (symbol-value enabled)
 249           (if verbose
 250               (message "Add-on %S is already enabled" addon))
 251         (funcall (intern (concat (symbol-name addon) "-enable")))
 252         (if verbose
 253             (message "Add-on %S enabled" addon))))))
 254
 255 (defun riece-disable-addon (addon &optional verbose)
 256   (unless (get addon 'riece-addon-insinuated)
 257     (error "Add-on %S is not insinuated" addon))
 258   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 259     (if (null enabled)
 260         (if verbose
 261             (message "Add-on %S doesn't support enable/disable" addon))
 262       (if (symbol-value enabled)
 263           (progn
 264             (funcall (intern (concat (symbol-name addon) "-disable")))
 265             (if verbose
 266                 (message "Add-on %S disabled" addon)))
 267         (if verbose
 268             (message "Add-on %S is already enabled" addon))))))
 269
 270 (put 'riece-addon-list-mode 'font-lock-defaults
 271      '(riece-addon-list-font-lock-keywords t))
 272
 273 (defun riece-addon-list-mode ()
 274   "Major mode for displaying addon list.
 275 All normal editing commands are turned off."
 276   (kill-all-local-variables)
 277   (buffer-disable-undo)
 278   (setq major-mode 'riece-addon-list-mode
 279         mode-name "AddOns"
 280         mode-line-buffer-identification
 281         (riece-mode-line-buffer-identification '("Riece: %12b"))
 282         truncate-lines t
 283         buffer-read-only t)
 284   (use-local-map riece-addon-list-mode-map)
 285   (make-local-variable 'font-lock-defaults)
 286   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
 287   ;; In XEmacs, auto-initialization of font-lock is not effective
 288   ;; if buffer-file-name is not set.
 289   (font-lock-set-defaults)
 290   (run-hooks 'riece-addon-list-mode-hook))
 291
 292 (defun riece-command-list-addons ()
 293   (interactive)
 294   (set-buffer (riece-get-buffer-create "*AddOns*" 'riece-addon-list-mode))
 295   (riece-addon-list-mode)
 296   (let ((inhibit-read-only t)
 297         buffer-read-only
 298         (pointer riece-addon-dependencies)
 299         module-description-alist
 300         description enabled point)
 301     (while pointer
 302
 303       (setq description (intern-soft (concat (symbol-name (car (car pointer)))
 304                                              "-description"))
 305             module-description-alist
 306             (cons (cons (car (car pointer))
 307                         (if description
 308                             (symbol-value description)
 309                           "(no description)"))
 310                   module-description-alist)
 311             pointer (cdr pointer)))
 312     (setq pointer riece-addon-modules)
 313     (while pointer
 314       (unless (assq (car (car pointer))
 315                     module-description-alist)
 316         (setq module-description-alist
 317               (cons (car pointer) module-description-alist)))
 318       (setq pointer (cdr pointer)))
 319     (erase-buffer)
 320     (riece-kill-all-overlays)
 321     (setq pointer (sort module-description-alist
 322                         (lambda (entry1 entry2)
 323                           (string-lessp (symbol-name (car entry1))
 324                                         (symbol-name (car entry2))))))
 325     (while pointer
 326       (setq enabled (intern-soft (concat (symbol-name (car (car pointer)))
 327                                          "-enabled")))
 328       (setq point (point))
 329       (insert (format "%c %S: %s\n"
 330                       (if (not (get (car (car pointer))
 331                                     'riece-addon-insinuated))
 332                           ?
 333                         (if (null enabled)
 334                             ?!
 335                           (if (symbol-value enabled)
 336                               ?+
 337                             ?-)))
 338                       (car (car pointer))
 339                       (cdr (car pointer))))
 340       (put-text-property point (point) 'riece-addon (car (car pointer)))
 341       (setq pointer (cdr pointer)))
 342     (insert "
 343 Symbols in the leftmost column:
 344
 345   +     The add-on is enabled.
 346   -     The add-on is disabled.
 347   !     The add-on doesn't support enable/disable operation.
 348         The add-on is not insinuated.
 349 ")
 350     (insert (substitute-command-keys "
 351 Useful keys:
 352
 353   `\\[riece-command-enable-addon]' to enable the current add-on.
 354   `\\[riece-command-disable-addon]' to disable the current add-on.
 355 "))
 356     (goto-char (point-min))
 357     (pop-to-buffer (current-buffer))
 358     (delete-other-windows)))
 359
 360 (defun riece-command-enable-addon (addon)
 361   (interactive
 362    (list
 363     (or (if (eq major-mode 'riece-addon-list-mode)
 364             (get-text-property (point) 'riece-addon))
 365         (intern-soft
 366          (completing-read "Add-on: "
 367                           (mapcar (lambda (dependency)
 368                                     (list (symbol-name (car dependency))))
 369                                   riece-addon-dependencies)
 370                           (lambda (pointer)
 371                             (let ((enabled
 372                                    (intern-soft (concat (car pointer)
 373                                                         "-enabled"))))
 374                               (and enabled
 375                                    (null (symbol-value enabled)))))
 376                           t)))))
 377   (riece-enable-addon addon t)
 378   (when (eq major-mode 'riece-addon-list-mode)
 379     (riece-command-list-addons)
 380     (let ((point (point-min)))
 381       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 382                   (setq point (next-single-property-change point
 383                                                            'riece-addon))))
 384       (if point
 385           (goto-char point)))))
 386
 387 (defun riece-command-disable-addon (addon)
 388   (interactive
 389    (list
 390     (or (if (eq major-mode 'riece-addon-list-mode)
 391             (get-text-property (point) 'riece-addon))
 392         (intern-soft
 393          (completing-read "Add-on: "
 394                           (mapcar (lambda (dependency)
 395                                     (list (symbol-name (car dependency))))
 396                                   riece-addon-dependencies)
 397                           (lambda (pointer)
 398                             (let ((enabled
 399                                    (intern-soft (concat (car pointer)
 400                                                         "-enabled"))))
 401                               (and enabled
 402                                    (symbol-value enabled))))
 403                           t)))))
 404   (riece-disable-addon addon t)
 405   (when (eq major-mode 'riece-addon-list-mode)
 406     (riece-command-list-addons)
 407     (let ((point (point-min)))
 408       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 409                   (setq point (next-single-property-change point
 410                                                            'riece-addon))))
 411       (if point
 412           (goto-char point)))))
 413
 414 (defun riece-command-insinuate-addon (addon)
 415   (interactive
 416    (list
 417     (or (if (eq major-mode 'riece-addon-list-mode)
 418             (get-text-property (point) 'riece-addon))
 419         (intern-soft
 420          (completing-read "Add-on: "
 421                           (mapcar (lambda (dependency)
 422                                     (list (symbol-name (car dependency))))
 423                                   riece-addon-modules)
 424                           (lambda (pointer)
 425                             (get (car pointer) 'riece-addon-insinuated))
 426                           t)))))
 427   (riece-insinuate-addon addon t)
 428   (when (eq major-mode 'riece-addon-list-mode)
 429     (riece-command-list-addons)
 430     (let ((point (point-min)))
 431       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 432                   (setq point (next-single-property-change point
 433                                                            'riece-addon))))
 434       (if point
 435           (goto-char point)))))
 436
 437 (defun riece-command-uninstall-addon (addon)
 438   (interactive
 439    (list
 440     (or (if (eq major-mode 'riece-addon-list-mode)
 441             (get-text-property (point) 'riece-addon))
 442         (intern-soft
 443          (completing-read "Add-on: "
 444                           (mapcar (lambda (dependency)
 445                                     (list (symbol-name (car dependency))))
 446                                   riece-addon-dependencies)
 447                           nil t)))))
 448   (riece-uninstall-addon addon t)
 449   (when (eq major-mode 'riece-addon-list-mode)
 450     (riece-command-list-addons)
 451     (let ((point (point-min)))
 452       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 453                   (setq point (next-single-property-change point
 454                                                            'riece-addon))))
 455       (if point
 456           (goto-char point)))))
 457
 458 (provide 'riece-addon)
 459
 460 ;;; riece-addon.el ends here