cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-manage.el

   1 ;;; xwem-manage.el --- Manage stuff for xwem.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;;         Richard Klinda <ignotus@hixsplit.hu>
   7 ;; Created: 21 Mar 2003
   8 ;; Keywords: xlib, xwem
   9 ;; X-CVS: $Id: xwem-manage.el,v 1.11 2005-04-04 19:54:13 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; Manage database.  Manage database is list of manda entries, which
  33 ;; are used to decide how to manage certain client.  Every manda entry
  34 ;; has methods to operate on client.
  35
  36 ;;; Customization:
  37
  38 ;; Only one customisable variable is `xwem-manage-list' is a list
  39 ;; where each element is a list in form:
  40
  41 ;;   \(MANAGE-TYPE CLIENT-PLIST MATCH-SPEC\)
  42
  43 ;; Configuration looks like this:
  44
  45 ;;    (setq xwem-manage-list
  46 ;;          '((fullscreen (ignore-has-input-p t fs-real-size t
  47 ;;                         x-border-width 2 x-border-color "brown4"
  48 ;;                         xwem-focus-mode follow-mouse)
  49 ;;                        (application "rdesktop"))
  50 ;;            (rooter (dummy-client-p t)
  51 ;;                    (or (application "xclock")
  52 ;;                        (application "gkrellm")
  53 ;;                        (application "gdesklets")
  54 ;;                        (application "gdeskcal")))
  55 ;;            ))
  56
  57 ;;; Code
  58 \f
  59 (require 'xwem-load)
  60
  61 ;;;; Variables
  62 (defcustom xwem-manage-default-expectance-expire-timeout 5
  63   "*Default expire timeout for expectance entries."
  64   :type 'number
  65   :group 'xwem)
  66
  67 ;;;###autoload
  68 (defcustom xwem-manage-default-properties
  69   '(reguard-x-border-width t)
  70   "*Default managing properties.
  71 These properties are always set in any managing model.
  72 Supported properties are:
  73
  74   `reguard-x-border-width' - Reguard border width.
  75   `win-support'  - Managing model uses window operations.
  76 ."
  77   :type 'list
  78   :group 'xwem)
  79
  80 ;;;###autoload
  81 (defcustom xwem-manage-list nil
  82   "List where each element in form:
  83
  84 \(MANAGE-TYPE CLIENT-PLIST MATCH-SPEC\)
  85
  86 MANAGE-TYPE is symbol.
  87
  88 CLIENT-PLIST is list of client properties to set when client manages
  89 and unset when client changes manage type.  In core supported
  90 properties are:
  91
  92   `noselect' - Non-nil mean client can't be selected, usefull for
  93                `rooter' clients.
  94
  95   `no-minib-overlap' - Non-nil to not overlap xwem minibuffer, usefull
  96                        for `fullscreen' clients.
  97
  98   `xwem-icon-name'   - Icon to use for this client.
  99
 100   `xwem-focus-mode'  - Specifies client's focus mode.
 101
 102   `xwem-tab-format'  - Format to use in tabber.
 103
 104   `xwem-tab-face'    - Face to use in tabber.
 105
 106 MATCH-TYPE is a list of match entries, where each entrie TODO:
 107 describe me."
 108   :type 'list
 109   :group 'xwem)
 110
 111 ;;;###autoload
 112 (defcustom xwem-applications-alist
 113   '(("xemacs" (and (class-inst "^emacs$")
 114                    (class-name "Emacs$")))
 115     ("xterm" (and (class-inst "^xterm$")
 116                   (class-name "^XTerm$")))
 117     ("xdvi" (and (class-inst "^xdvi$")
 118                  (class-name "^XDvi$")))
 119     ("djview" (and (class-inst "^djview$")
 120                    (class-name "^Djview$")))
 121     ("rdesktop" (and (class-inst "^rdesktop$")
 122                      (class-name "^rdesktop$")))
 123     ("vncviewer" (and (class-inst "^vncviewer$")
 124                       (class-name "^Vncviewer$")))
 125     ("display" (and (class-inst "^display$")
 126                     (class-name "^[dD]isplay$")))
 127     ("xv" (and (class-inst "^xv$")
 128                (class-name "^XV")))
 129     ("xcalc" (and (class-inst "^xcalc$")
 130                   (class-name "^XCalc$")))
 131     ("xclock" (and (class-inst "^xclock$")
 132                    (class-name "^[Xx][cC]lock$")))
 133     ("xload" (and (class-inst "^xload$")
 134                   (class-name "^XLoad$")))
 135     ("xkeycaps" (and (class-inst "^xkeycaps$")
 136                      (class-name "^XKeyCaps$")))
 137     ("gimp_startup" (and (class-inst "^gimp_startup$")
 138                          (class-name "^Gimp$")))
 139     ("gv" (and (class-inst "^gv$")
 140                (class-name "^GV$")))
 141     ("ghostview" (and (class-inst "^ghostview$")
 142                       (class-name "^Ghostview$")))
 143     ("xfd" (and (class-inst "^xfd$")
 144                 (class-name "^Xfd$")))
 145     ("xfontsel" (and (class-inst "^xfontsel$")
 146                      (class-name "^XFontSel$")))
 147     ("gnumeric" (and (class-inst "^gnumeric$")
 148                      (class-name "^Gnumeric$")))
 149     ("ethereal" (and (class-inst "^ethereal$")
 150                      (class-name "^Ethereal$")))
 151
 152     ("gkrellm" (and (class-inst "gkrellm")
 153                     (class-name "Gkrellm")))
 154     ;; Gdesklets stuff
 155     ("gdesklets" (and (class-inst "^gDesklets$")
 156                       (class-name "^Gdesklets$")))
 157     ("gdeskcal" (and (class-inst "^gdeskcal$")
 158                      (class-name "^Gdeskcal$")))
 159
 160     ("links" (and (class-inst "^Links$")
 161                   (class-name "^Links$")))
 162     ("licq" (and (class-inst "^licq$")
 163                  (class-name "^Licq$")))
 164
 165     ;; CLASS-NAME only
 166     ("mozilla" (or (class-name "^[mM]ozilla")
 167                    (class-inst "^[mM]ozilla")))
 168     ("xmms" (class-name "^[Xx]mms$"))
 169     ("xine" (class-name "^xine$"))
 170     ("mplayer" (class-name "^MPlayer$"))
 171     ("xchat" (class-name "^X-Chat$"))
 172     ("gimp" (class-name "^Gimp$"))
 173     ("ddd" (class-name "^Ddd$"))
 174     ("firefox" (class-name "^Firefox"))
 175     ("opera" (class-name "^Opera$"))
 176     ("xpdf" (class-name "^Xpdf$"))
 177     ("acroread" (class-name "^AcroRead$"))
 178
 179     ;; NAME only
 180     ("gnuplot" (name "^Gnuplot$"))
 181     ("xchm" (name "^xCHM"))
 182     )
 183   "Alist of known applications.
 184 CAR is appllication name, CDR is match-spec.
 185
 186 Use `xwem-appcollect' to create `xwem-applications-alist'."
 187   :type '(cons string sexp)
 188   :group 'xwem)
 189
 190 (defvar xwem-manage-internal-list nil
 191   "Internal manage list in `xwem-manage-list' format.")
 192
 193 ;;;###autoload
 194 (defvar xwem-manage-expectances nil
 195   "List of expectances in `xwem-manage-list' format.
 196 The difference from `xwem-manage-list' is that, when matching occurs
 197 in `xwem-manage-expectances', matched entry removed from
 198 `xwem-manage-expectances' list.")
 199
 200 ;;; Internal variables
 201
 202 \f
 203 ;;; Matching
 204
 205 ;;;###xwem-autoload
 206 (defun xwem-class-match-p (cl cli-regex &optional cln-regex wmname-regex)
 207   "Return non-nil if CL matches CLI-REGEX, CLN-REGEX, WMNAME-REGEX.
 208 CLI-REGEX is regexp to match class instance name.
 209 CLN-REGEX is regexp to match class name.
 210 WMNAME-REGEX is regexp to match CL's WM_NAME."
 211   (let* ((case-fold-search nil)
 212          (hints (xwem-cl-hints cl))
 213          (class (xwem-hints-wm-class hints))
 214          (wmname (xwem-hints-wm-name hints)))
 215     (and (or (null cli-regex)
 216              (string-match cli-regex (or (car class) "")))
 217          (or (null cln-regex)
 218              (string-match cln-regex (or (cdr class) "")))
 219          (or (null wmname-regex)
 220              (string-match wmname-regex wmname)))))
 221
 222 (defmacro define-xwem-class-matcher (cli-regex &optional cln-regex wmname-regex)
 223   "Create and return new class matcher function.
 224
 225 Result of this macro is function which is passed with on argument - CL.
 226
 227 This function returns non-nil if CL's WM_CLASS matches
 228 CLI-REGEX/CLN-REGEX and CL's WM_NAME matches WMNAME-REGEX.
 229 If CLN-REGEX or WMNAME-REGEX ommited, then \".*\" expression will be
 230 used (i.e. match everything)."
 231   `(lambda (cl)
 232      (xwem-class-match-p cl ,cli-regex ,cln-regex ,wmname-regex)))
 233
 234 ;;;###xwem-autoload
 235 (defun xwem-cl-match-p (cl match-spec)
 236   "Check whether CL matches MATCH-SPEC.
 237 MATCH-SPEC format is a list in form
 238
 239   (or (TYPE PARAM) ..)
 240
 241 or
 242
 243   (and (TYPE PARAM) ..).
 244
 245 TYPE is one of:
 246
 247   `class-name' - To match CL's class name (PARAM is regex).
 248
 249   `class-inst' - To match CL's class instance name (PARAM is regex).
 250
 251   `name'       - Client name (PARAM is regex).
 252
 253   `command'    - Client's WM_COMMAND (PARAM is regex)
 254
 255   `property'   - PARAM is either property symbol, or cons cell where car
 256                  is property symbol and cdr is value of property to match.
 257
 258   `function'   - PARAM is function which passed with one argument CL and
 259                  returns non-nil if CL matches.
 260
 261   `eval'       - PARAM is form to evaluate.
 262
 263   `or'|`and'   - Starts subspec, PARAM is MATCH-SPEC.
 264
 265   `override-redirect' - If this TYPE is used, also match client with
 266                         override-redirect attribute, otherwise clients
 267                         with override-redirect are skiped, even if others
 268                         specs matches.
 269
 270   `buffer-major-mode' - PARAM is major-mode name.  Matches if current
 271                         client is Emacs frame, frame's buffer is current
 272                         and its major mode is eq to PARAM.
 273
 274   `buffer-name' - PARAM is regexp.  As `buffer-major-mode' but if PARAM matches
 275                   current buffer's name.
 276
 277   `buffer-filename' - PARAM is regexp.  As `buffer-name' but if PARAM matches
 278                       current buffer's filename.
 279
 280   `application' - PARAM is application name that is looked in
 281                   `xwem-applications-alist'.
 282 "
 283   (let ((case-fold-search nil)          ; case sensivity searching
 284         (gm-type 'and)                  ; global matching type 'or or 'and
 285         hints                           ; for optimisation
 286         type param ires or)
 287
 288     ;; Setup global matching, default to 'and
 289     (when (memq (caar match-spec) '(or and))
 290       (if (eq 'or (caar match-spec))
 291           (setq gm-type 'or)
 292         (setq gm-type 'and))
 293       (setq match-spec (cdar match-spec)))
 294
 295     ;; Scan MATCH-SPEC for matching
 296     (while match-spec
 297       (setq type (car (car match-spec))
 298             param (car (cdr (car match-spec)))
 299             ires (cond ((eq type 'class-inst)
 300                         (and (xwem-cl-p cl)
 301                              (or (null param)
 302                                  (string-match param (or (car (xwem-hints-wm-class (or hints (setq hints (xwem-cl-hints cl))))) "")))))
 303                        ((eq type 'class-name)
 304                         (and (xwem-cl-p cl)
 305                              (or (null param)
 306                                  (string-match param (or (cdr (xwem-hints-wm-class (or hints (setq hints (xwem-cl-hints cl))))) "")))))
 307                        ((eq type 'name)
 308                         (and (xwem-cl-p cl)
 309                              (or (null param)
 310                                  (string-match param (or (xwem-hints-wm-name (or hints (setq hints (xwem-cl-hints cl)))) "")))))
 311                        ((eq type 'command)
 312                         (and (xwem-cl-p cl)
 313                              (or (null param)
 314                                  (string-match param (or (xwem-hints-wm-command (or hints (setq hints (xwem-cl-hints cl)))) "")))))
 315                        ((eq type 'property)
 316                         (and (xwem-cl-p cl)
 317                              (cond ((symbolp param)
 318                                     (xwem-client-property cl param))
 319                                    ((and (consp param)
 320                                          (symbolp (car param)))
 321                                     (equal (xwem-client-property cl (car param))
 322                                            (cdr param))))))
 323                        ((eq type 'application)
 324                         (and (xwem-cl-p cl)
 325                              (xwem-cl-match-p cl (cdr (assoc param xwem-applications-alist)))))
 326                        ((eq type 'eval)
 327                         (eval param))
 328                        ((eq type 'function)
 329                         (funcall param cl))
 330                        ((memq type '(or and))
 331                         ;; Subspec
 332                         (xwem-cl-match-p cl (list (car match-spec))))
 333                        ((eq type 'override-redirect)
 334                         (and (xwem-cl-p cl)
 335                              (X-Attr-override-redirect (xwem-cl-initial-xattrs cl))
 336                              (setq or t)))
 337
 338                        ;; Emacs stuff
 339                        ((memq type '(buffer-major-mode buffer-name buffer-filename))
 340                         (let* ((fr (xwem-misc-find-emacs-frame cl))
 341                                (buf (and (frame-live-p fr) (window-buffer (frame-selected-window fr)))))
 342                           (when (bufferp buf)
 343                             (with-current-buffer buf
 344                               (cond ((eq type 'buffer-major-mode)
 345                                      (eq param major-mode))
 346                                     ((eq type 'buffer-name)
 347                                      (string-match param (buffer-name)))
 348                                     ((eq type 'buffer-filename)
 349                                      (and (buffer-file-name)
 350                                           (string-match param (buffer-file-name)))))))))
 351                        ))
 352
 353       (if (or (and (eq gm-type 'and) (null ires))
 354               (and (eq gm-type 'or) ires))
 355           ;; Break conditions, not-match or already matches
 356           (setq match-spec nil)
 357         ;; Continue traversing
 358         (setq match-spec (cdr match-spec))))
 359
 360     (if (and (xwem-cl-p cl)
 361              (X-Attr-override-redirect (xwem-cl-initial-xattrs cl)))
 362         (and or ires)
 363       ires)))
 364
 365 ;;;###xwem-autoload
 366 (defun xwem-manda-find-match-1 (cl manage-list &optional extractor)
 367   "Search for CL match in MANAGE-LIST.
 368 EXTRACTOR is where to obtain match-spec from MANAGE-LIST elements,
 369 default is 'cddr."
 370   (unless extractor
 371     (setq extractor 'cddr))
 372
 373   (while (and manage-list
 374               (not (xwem-cl-match-p cl (funcall extractor (car manage-list)))))
 375     (setq manage-list (cdr manage-list)))
 376   (car manage-list))
 377
 378 (defun xwem-manda-find-expectance (cl)
 379   "Search in `xwem-manage-expectances' to match CL.
 380 If match occurs, matching entry removed from `xwem-manage-expectances'."
 381   (let ((expects xwem-manage-expectances)
 382         rval)
 383     (while (and expects
 384                 (not (xwem-cl-match-p cl (cddr (car expects)))))
 385       (setq expects (cdr expects)))
 386
 387     (when expects
 388       (setq rval (car expects))
 389       (setcar expects nil)
 390       (setq xwem-manage-expectances (delq nil xwem-manage-expectances)))
 391     rval))
 392
 393 ;;;###xwem-autoload
 394 (defun xwem-cl-was-expected (cl new)
 395   "Mark/unmark CL as it was expected according to NEW value.
 396 If NEW is non-nil mark CL as was expected.
 397 If NEW is nil then unmark."
 398   (xwem-cl-put-sys-prop cl 'cl-was-expected new))
 399
 400 ;;;###xwem-autoload
 401 (defun xwem-cl-was-expected-p (cl)
 402   "Return non-nil if CL was expected for managing."
 403   (xwem-cl-get-sys-prop cl 'cl-was-expected))
 404
 405 (defun xwem-manda-find-match (cl)
 406   "Find match for CL in manage database.
 407 Search `xwem-manage-internal-list' with 'override-manage-list non-nil
 408 property, then search for match in `xwem-manage-list' and
 409 `xwem-manage-internal-list' respectively.
 410 `xwem-manda-find-match' also checks expectances.  Only expectances of
 411 same manage type as normal match is used."
 412   (let ((expt-spec (xwem-manda-find-expectance cl))
 413         (mspec (or (xwem-manda-find-match-1 cl
 414                     (delq nil (mapcar #'(lambda (mm)
 415                                           (and (xwem-manage-property
 416                                                 (car mm) 'override-manage-list)
 417                                                mm))
 418                                       xwem-manage-internal-list)))
 419                    (xwem-manda-find-match-1 cl xwem-manage-list)
 420                    (xwem-manda-find-match-1 cl xwem-manage-internal-list))))
 421     ;; Check that EXPT-SPEC is the same manage type as MSPEC
 422     (if (and expt-spec (car expt-spec))
 423         ;; Mark CL as it was expected
 424         (progn
 425           (xwem-cl-was-expected cl t)
 426           expt-spec)
 427
 428       (when (and mspec expt-spec
 429                  (null (car expt-spec)) (cadr expt-spec))
 430         ;; EXPT-SPEC does not has manage type, but has plist, which we
 431         ;; need to merge into MSPEC plist.
 432         (let ((m-plist (cadr mspec))
 433               (e-plist (cadr expt-spec)))
 434           (while e-plist
 435             (setq m-plist (plist-put m-plist (car e-plist) (cadr e-plist)))
 436             (setq e-plist (cddr e-plist)))
 437           (setcdr mspec (cons m-plist (cddr mspec))))
 438         ;; Mark CL as it was expected
 439         (xwem-cl-was-expected cl t))
 440       mspec)))
 441
 442 (defun xwem-manda-del-expectance (expt)
 443   "Remove EXPT from `xwem-manage-expectances' list."
 444   ;; Delete expect window if there is nothing managed in it
 445 ;  (let ((ew (plist-get (cadr expt) 'expect-win)))
 446 ;    (when (and (xwem-win-p ew)
 447 ;               (not (xwem-win-only-one-p ew))
 448 ;               (not (xwem-win-cl ew))
 449 ;               (null (xwem-win-clients ew)))
 450 ;      (xwem-window-delete ew)))
 451
 452   (setq xwem-manage-expectances
 453         (delq expt xwem-manage-expectances)))
 454
 455 ;;;###xwem-autoload
 456 (defun xwem-manda-add-expectance (expectance &optional expire-timeout)
 457   "Install new EXPECTANCE in `xwem-manage-expectances' list.
 458 EXPIRE-TIMEOUT specifies time-to-live for new entry in seconds
 459 \(default is `xwem-manage-default-expectance-expire-timeout'\)."
 460   (push expectance xwem-manage-expectances)
 461
 462   ;; Install expectance timeout handler
 463   (start-itimer "xwem-expectance" 'xwem-manda-del-expectance
 464                 (or expire-timeout xwem-manage-default-expectance-expire-timeout)
 465                 nil nil t expectance))
 466
 467 ;;;###xwem-autoload
 468 (defun xwem-manage-property (manage-type prop)
 469   "For MANAGE-TYPE, return manage property PROP."
 470   (plist-get (get manage-type 'xwem-manage-properties) prop))
 471
 472 ;;;###xwem-autoload
 473 (defun xwem-manage-rem-property (manage-type prop)
 474   "For MANAGE-TYPE, remove property PROP."
 475   (put manage-type 'xwem-manage-properties
 476        (plist-remprop (get manage-type 'xwem-manage-properties) prop)))
 477
 478 ;;;###xwem-autoload
 479 (defun xwem-manage-set-property (manage-type prop val)
 480   "For MANAGE-TYPE, set manage property PROP to VAL."
 481   (if val
 482       (put manage-type 'xwem-manage-properties
 483            (plist-put (get manage-type 'xwem-manage-properties) prop val))
 484     (xwem-manage-rem-property manage-type prop)))
 485
 486 ;;;###xwem-autoload
 487 (defun* define-xwem-manage-model-1
 488   (manage-name docstring &key manage-properties cl-properties match-spec append
 489                manage-method activate-method deactivate-method refit-method
 490                iconify-method withdraw-method)
 491   "Define new managing model of MANAGE-NAME.
 492 DOCSTRING is documentation for managing model.
 493 MANAGE-PROPERTIES - Some manage properties used when managing clients
 494 of this managing model.
 495 CL-PROPERTIES - Client properties to import into client when client
 496 managing using this managing model.
 497 MATCH-SPEC - Client matching specification, see `xwem-cl-match-p'.
 498 APPEND - Non-nil mean append to the end of managing models list.  By
 499 default managing models are prepended to list."
 500   (put manage-name :docstring docstring)
 501
 502   (add-to-list 'xwem-manage-internal-list
 503                (list manage-name cl-properties match-spec) append)
 504
 505   ;; Set manage properties
 506   (setq manage-properties
 507         (xwem-misc-merge-plists
 508          xwem-manage-default-properties manage-properties))
 509   (while manage-properties
 510     (xwem-manage-set-property
 511      manage-name (car manage-properties) (cadr manage-properties))
 512     (setq manage-properties (cddr manage-properties)))
 513
 514   ;; Register methods
 515   (when manage-method
 516     (put 'manage manage-name manage-method))
 517   (when activate-method
 518     (put 'activate manage-name activate-method))
 519   (when deactivate-method
 520     (put 'deactivate manage-name deactivate-method))
 521   (when refit-method
 522     (put 'refit manage-name refit-method))
 523   (when iconify-method
 524     (put 'iconify manage-name iconify-method))
 525   (when withdraw-method
 526     (put 'withdraw manage-name withdraw-method))
 527   )
 528
 529 (defmacro define-xwem-manage-model (manage-name docstring &rest args)
 530   "Define new managing model."
 531   `(funcall 'define-xwem-manage-model-1 (quote ,manage-name) ,docstring ,@args))
 532
 533 \f
 534 ;;; New concept, generic functions and methods (like CLOS)
 535 (defsubst xwem-execute-method (method-name manda-type &rest args)
 536   "Execute METHOD-NAME  passing ARGS.
 537 If no method METHOD-NAME found for MANDA-TYPE, use 'default type."
 538   (let ((fun (get method-name manda-type)))
 539     (when (or fun (setq fun (get method-name 'default)))
 540       (apply fun args))))
 541
 542 (defsubst xwem-method-manage (cl)
 543   (xwem-execute-method 'manage (xwem-cl-manage-type cl) cl))
 544
 545 (defsubst xwem-method-activate (cl &optional type)
 546   "Activation method for CL.
 547 For TYPE, see documentation for `xwem-activate'."
 548   (xwem-execute-method 'activate (xwem-cl-manage-type cl) cl type))
 549
 550 (defsubst xwem-method-deactivate (cl &optional type)
 551   (xwem-execute-method 'deactivate (xwem-cl-manage-type cl) cl type))
 552
 553 (defsubst xwem-method-refit (cl)
 554   (xwem-execute-method 'refit (xwem-cl-manage-type cl) cl))
 555
 556 (defsubst xwem-method-iconify (cl)
 557   (xwem-execute-method 'iconify (xwem-cl-manage-type cl) cl))
 558
 559 (defsubst xwem-method-withdraw (cl)
 560   (xwem-execute-method 'withdraw (xwem-cl-manage-type cl) cl))
 561
 562 (defsubst xwem-method-on-kill (cl)
 563   (xwem-execute-method 'on-kill (xwem-cl-manage-type cl) cl))
 564
 565 (defsubst xwem-method-on-type-change (cl &optional new-type)
 566   (xwem-execute-method 'on-type-change (xwem-cl-manage-type cl) cl new-type))
 567
 568 (defmacro define-xwem-method (method-name manda-type arg-list
 569                                           &optional doc-string &rest forms)
 570   "Define new method METHOD-NAME for MANDA-TYPE.
 571 DOC-STRING is documentation.
 572 FORMS - elisp forms to eval."
 573   (let ((sym (intern (format "xwem:-%s-%s" manda-type method-name))))
 574     `(eval-and-compile
 575        (defun ,sym ,arg-list
 576          ,doc-string
 577          ,@forms)
 578        (put (quote ,method-name) (quote ,manda-type) (quote ,sym)))))
 579
 580 \f
 581 (provide 'xwem-manage)
 582
 583 ;;; xwem-manage.el ends here