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      (:italic t)))
  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-unknown-face
  73   '((t
  74      (:foreground "red")))
  75   "Face used for displaying the unknown addon."
  76   :group 'riece-addon-list-faces)
  77 (defvar riece-addon-list-unknown-face 'riece-addon-list-unknown-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-unknown-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 "n" 'next-line)
 115     (define-key keymap "p" 'previous-line)
 116     (define-key keymap " " 'scroll-up)
 117     (define-key keymap [delete] 'scroll-down)
 118     (define-key keymap "q" 'bury-buffer)
 119     keymap))
 120
 121 (defun riece-load-and-build-addon-dependencies (addons)
 122   (let ((load-path (cons riece-addon-directory load-path))
 123         dependencies)
 124     (while addons
 125       (require (car addons))            ;error will be reported here
 126       (let* ((requires
 127               (funcall (or (intern-soft
 128                             (concat (symbol-name (car addons)) "-requires"))
 129                            #'ignore)))
 130              (pointer requires)
 131              entry)
 132         ;; Increment succs' pred count.
 133         (if (setq entry (assq (car addons) dependencies))
 134             (setcar (cdr entry) (+ (length requires) (nth 1 entry)))
 135           (setq dependencies (cons (list (car addons) (length requires))
 136                                    dependencies)))
 137         ;; Merge pred's succs.
 138         (while pointer
 139           (if (setq entry (assq (car pointer) dependencies))
 140               (setcdr (cdr entry) (cons (car addons) (nthcdr 2 entry)))
 141             (setq dependencies (cons (list (car pointer) 0 (car addons))
 142                                      dependencies)))
 143           (setq pointer (cdr pointer))))
 144       (setq addons (cdr addons)))
 145     dependencies))
 146
 147 (defun riece-sort-addon-dependencies (dependencies)
 148   (let ((pointer dependencies)
 149         addons queue)
 150     (while pointer
 151       (if (zerop (nth 1 (car pointer)))
 152           (setq dependencies (delq (car pointer) dependencies)
 153                 queue (cons (car pointer) queue)))
 154       (setq pointer (cdr pointer)))
 155     (while queue
 156       (setq addons (cons (cons (car (car queue)) (nthcdr 2 (car queue)))
 157                          addons)
 158             pointer (nthcdr 2 (car queue)))
 159       (while pointer
 160         (let* ((entry (assq (car pointer) dependencies))
 161                (count (1- (nth 1 entry))))
 162           (if (zerop count)
 163               (setq dependencies (delq entry dependencies)
 164                     queue (nconc queue (list entry)))
 165             (setcar (cdr entry) count)))
 166         (setq pointer (cdr pointer)))
 167       (setq queue (cdr queue)))
 168     (if dependencies
 169         (error "Circular add-on dependency found: %S" dependencies))
 170     (nreverse addons)))
 171
 172 (defun riece-resolve-addons (addons)
 173   ;; Add files in riece-addon-directory to addons.
 174   (if (file-directory-p riece-addon-directory)
 175       (setq addons (nconc
 176                     addons
 177                     (mapcar
 178                      (lambda (name)
 179                        (unless (file-directory-p
 180                                 (expand-file-name name riece-addon-directory))
 181                          (intern (file-name-sans-extension name))))
 182                      (directory-files riece-addon-directory nil "\\`[^.]")))))
 183   ;; Sort & uniquify.
 184   (setq addons (sort addons (lambda (symbol1 symbol2)
 185                               (string-lessp (symbol-name symbol1)
 186                                             (symbol-name symbol2)))))
 187   (let ((pointer addons))
 188     (while pointer
 189       (if (memq (car pointer) (cdr pointer))
 190           (setcar pointer nil))
 191       (setq pointer (cdr pointer)))
 192     (delq nil addons))
 193   ;; Build & resolve dependencies.
 194   (riece-sort-addon-dependencies
 195    (riece-load-and-build-addon-dependencies addons)))
 196
 197 (defun riece-insinuate-addon (addon &optional verbose)
 198   (if (get addon 'riece-addon-insinuated)
 199       (if verbose
 200           (message "Add-on %S is already insinuated" addon))
 201     (funcall (intern (concat (symbol-name addon) "-insinuate")))
 202     (put addon 'riece-addon-insinuated t)
 203     (if verbose
 204         (message "Add-on %S is insinuated" addon))))
 205
 206 (defun riece-uninstall-addon (addon &optional verbose)
 207   (if (not (get addon 'riece-addon-insinuated))
 208       (if verbose
 209           (message "Add-on %S is not insinuated" addon))
 210     (let ((entry (assq addon riece-addon-dependencies))
 211           (enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 212       (if entry
 213           (if (cdr entry)
 214               (if (= (length (cdr entry)) 1)
 215                   (error "%S depends %S" (car (cdr entry)) addon)
 216                 (error "%s depends %S" (mapconcat #'identity (cdr entry) ",")
 217                        addon))
 218             (if (and enabled
 219                      (symbol-value enabled))
 220                 (riece-disable-addon addon verbose))
 221             (funcall (or (intern-soft (concat (symbol-name addon)
 222                                               "-uninstall"))
 223                          #'ignore))
 224             (setq riece-addon-dependencies
 225                   (delq entry riece-addon-dependencies))
 226             (put addon 'riece-addon-insinuated nil)))
 227       (if verbose
 228           (message "Add-on %S is uninstalled" addon)))))
 229
 230 (defun riece-enable-addon (addon &optional verbose)
 231   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 232     (if (null enabled)
 233         (if verbose
 234             (message "Add-on %S doesn't support enable/disable" addon))
 235       (if (symbol-value enabled)
 236           (if verbose
 237               (message "Add-on %S is already enabled" addon))
 238         (funcall (intern (concat (symbol-name addon) "-enable")))
 239         (if verbose
 240             (message "Add-on %S enabled" addon))))))
 241
 242 (defun riece-disable-addon (addon &optional verbose)
 243   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 244     (if (null enabled)
 245         (if verbose
 246             (message "Add-on %S doesn't support enable/disable" addon))
 247       (if (symbol-value enabled)
 248           (progn
 249             (funcall (intern (concat (symbol-name addon) "-disable")))
 250             (if verbose
 251                 (message "Add-on %S disabled" addon)))
 252         (if verbose
 253             (message "Add-on %S is already enabled" addon))))))
 254
 255 (put 'riece-addon-list-mode 'font-lock-defaults
 256      '(riece-addon-list-font-lock-keywords t))
 257
 258 (defun riece-addon-list-mode ()
 259   "Major mode for displaying addon list.
 260 All normal editing commands are turned off."
 261   (kill-all-local-variables)
 262   (buffer-disable-undo)
 263   (setq major-mode 'riece-addon-list-mode
 264         mode-name "AddOns"
 265         mode-line-buffer-identification
 266         (riece-mode-line-buffer-identification '("Riece: %12b"))
 267         truncate-lines t
 268         buffer-read-only t)
 269   (use-local-map riece-addon-list-mode-map)
 270   (make-local-variable 'font-lock-defaults)
 271   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
 272   ;; In XEmacs, auto-initialization of font-lock is not effective
 273   ;; if buffer-file-name is not set.
 274   (font-lock-set-defaults)
 275   (run-hooks 'riece-addon-list-mode-hook))
 276
 277 (defun riece-command-list-addons ()
 278   (interactive)
 279   (set-buffer (riece-get-buffer-create "*AddOns*" 'riece-addon-list-mode))
 280   (riece-addon-list-mode)
 281   (let ((inhibit-read-only t)
 282         buffer-read-only
 283         (pointer riece-addon-dependencies)
 284         module-description-alist
 285         description enabled point)
 286     (while pointer
 287
 288       (setq description (intern-soft (concat (symbol-name (car (car pointer)))
 289                                              "-description"))
 290             module-description-alist
 291             (cons (cons (car (car pointer))
 292                         (if description
 293                             (symbol-value description)
 294                           "(no description)"))
 295                   module-description-alist)
 296             pointer (cdr pointer)))
 297     (setq pointer riece-addon-modules)
 298     (while pointer
 299       (unless (assq (car (car pointer))
 300                     module-description-alist)
 301         (setq module-description-alist
 302               (cons (car pointer) module-description-alist)))
 303       (setq pointer (cdr pointer)))
 304     (erase-buffer)
 305     (riece-kill-all-overlays)
 306     (setq pointer (sort module-description-alist
 307                         (lambda (entry1 entry2)
 308                           (string-lessp (symbol-name (car entry1))
 309                                         (symbol-name (car entry2))))))
 310     (while pointer
 311       (setq enabled (intern-soft (concat (symbol-name (car (car pointer)))
 312                                          "-enabled")))
 313       (setq point (point))
 314       (insert (format "%c %S: %s\n"
 315                       (if (not (featurep (car (car pointer))))
 316                           ??
 317                         (if (null enabled)
 318                             ?!
 319                           (if (symbol-value enabled)
 320                               ?+
 321                             ?-)))
 322                       (car (car pointer))
 323                       (cdr (car pointer))))
 324       (put-text-property point (point) 'riece-addon (car (car pointer)))
 325       (setq pointer (cdr pointer)))
 326     (insert "
 327 Symbols in the leftmost column:
 328
 329   +     The add-on is enabled.
 330   -     The add-on is disabled.
 331   !     The add-on doesn't support enable/disable operation.
 332   ?     The add-on is not loaded.
 333 ")
 334     (insert (substitute-command-keys "
 335 Useful keys:
 336
 337   `\\[riece-command-enable-addon]' to enable the current add-on.
 338   `\\[riece-command-disable-addon]' to disable the current add-on.
 339 "))
 340     (goto-char (point-min))
 341     (pop-to-buffer (current-buffer))
 342     (delete-other-windows)))
 343
 344 (defun riece-command-enable-addon (addon)
 345   (interactive
 346    (list
 347     (or (if (eq major-mode 'riece-addon-list-mode)
 348             (get-text-property (point) 'riece-addon))
 349         (intern-soft
 350          (completing-read "Add-on: "
 351                           (mapcar (lambda (dependency)
 352                                     (list (symbol-name (car dependency))))
 353                                   riece-addon-dependencies)
 354                           (lambda (pointer)
 355                             (let ((enabled
 356                                    (intern-soft (concat (car pointer)
 357                                                         "-enabled"))))
 358                               (and enabled
 359                                    (null (symbol-value enabled)))))
 360                           t)))))
 361   (riece-enable-addon addon t)
 362   (when (eq major-mode 'riece-addon-list-mode)
 363     (riece-command-list-addons)
 364     (let ((point (point-min)))
 365       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 366                   (setq point (next-single-property-change point
 367                                                            'riece-addon))))
 368       (if point
 369           (goto-char point)))))
 370
 371 (defun riece-command-disable-addon (addon)
 372   (interactive
 373    (list
 374     (or (if (eq major-mode 'riece-addon-list-mode)
 375             (get-text-property (point) 'riece-addon))
 376         (intern-soft
 377          (completing-read "Add-on: "
 378                           (mapcar (lambda (dependency)
 379                                     (list (symbol-name (car dependency))))
 380                                   riece-addon-dependencies)
 381                           (lambda (pointer)
 382                             (let ((enabled
 383                                    (intern-soft (concat (car pointer)
 384                                                         "-enabled"))))
 385                               (and enabled
 386                                    (symbol-value enabled))))
 387                           t)))))
 388   (riece-disable-addon addon t)
 389   (when (eq major-mode 'riece-addon-list-mode)
 390     (riece-command-list-addons)
 391     (let ((point (point-min)))
 392       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 393                   (setq point (next-single-property-change point
 394                                                            'riece-addon))))
 395       (if point
 396           (goto-char point)))))
 397
 398 (provide 'riece-addon)
 399
 400 ;;; riece-addon.el ends here