;;; xwem-manage.el --- Manage stuff for xwem. ;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny ;; Richard Klinda ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem ;; X-CVS: $Id: xwem-manage.el,v 1.11 2005-04-04 19:54:13 lg Exp $ ;; This file is part of XWEM. ;; XWEM is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XWEM is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public ;; License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. ;;; Synched up with: Not in FSF ;;; Commentary: ;; Manage database. Manage database is list of manda entries, which ;; are used to decide how to manage certain client. Every manda entry ;; has methods to operate on client. ;;; Customization: ;; Only one customisable variable is `xwem-manage-list' is a list ;; where each element is a list in form: ;; \(MANAGE-TYPE CLIENT-PLIST MATCH-SPEC\) ;; Configuration looks like this: ;; (setq xwem-manage-list ;; '((fullscreen (ignore-has-input-p t fs-real-size t ;; x-border-width 2 x-border-color "brown4" ;; xwem-focus-mode follow-mouse) ;; (application "rdesktop")) ;; (rooter (dummy-client-p t) ;; (or (application "xclock") ;; (application "gkrellm") ;; (application "gdesklets") ;; (application "gdeskcal"))) ;; )) ;;; Code (require 'xwem-load) ;;;; Variables (defcustom xwem-manage-default-expectance-expire-timeout 5 "*Default expire timeout for expectance entries." :type 'number :group 'xwem) ;;;###autoload (defcustom xwem-manage-default-properties '(reguard-x-border-width t) "*Default managing properties. These properties are always set in any managing model. Supported properties are: `reguard-x-border-width' - Reguard border width. `win-support' - Managing model uses window operations. ." :type 'list :group 'xwem) ;;;###autoload (defcustom xwem-manage-list nil "List where each element in form: \(MANAGE-TYPE CLIENT-PLIST MATCH-SPEC\) MANAGE-TYPE is symbol. CLIENT-PLIST is list of client properties to set when client manages and unset when client changes manage type. In core supported properties are: `noselect' - Non-nil mean client can't be selected, usefull for `rooter' clients. `no-minib-overlap' - Non-nil to not overlap xwem minibuffer, usefull for `fullscreen' clients. `xwem-icon-name' - Icon to use for this client. `xwem-focus-mode' - Specifies client's focus mode. `xwem-tab-format' - Format to use in tabber. `xwem-tab-face' - Face to use in tabber. MATCH-TYPE is a list of match entries, where each entrie TODO: describe me." :type 'list :group 'xwem) ;;;###autoload (defcustom xwem-applications-alist '(("xemacs" (and (class-inst "^emacs$") (class-name "Emacs$"))) ("xterm" (and (class-inst "^xterm$") (class-name "^XTerm$"))) ("xdvi" (and (class-inst "^xdvi$") (class-name "^XDvi$"))) ("djview" (and (class-inst "^djview$") (class-name "^Djview$"))) ("rdesktop" (and (class-inst "^rdesktop$") (class-name "^rdesktop$"))) ("vncviewer" (and (class-inst "^vncviewer$") (class-name "^Vncviewer$"))) ("display" (and (class-inst "^display$") (class-name "^[dD]isplay$"))) ("xv" (and (class-inst "^xv$") (class-name "^XV"))) ("xcalc" (and (class-inst "^xcalc$") (class-name "^XCalc$"))) ("xclock" (and (class-inst "^xclock$") (class-name "^[Xx][cC]lock$"))) ("xload" (and (class-inst "^xload$") (class-name "^XLoad$"))) ("xkeycaps" (and (class-inst "^xkeycaps$") (class-name "^XKeyCaps$"))) ("gimp_startup" (and (class-inst "^gimp_startup$") (class-name "^Gimp$"))) ("gv" (and (class-inst "^gv$") (class-name "^GV$"))) ("ghostview" (and (class-inst "^ghostview$") (class-name "^Ghostview$"))) ("xfd" (and (class-inst "^xfd$") (class-name "^Xfd$"))) ("xfontsel" (and (class-inst "^xfontsel$") (class-name "^XFontSel$"))) ("gnumeric" (and (class-inst "^gnumeric$") (class-name "^Gnumeric$"))) ("ethereal" (and (class-inst "^ethereal$") (class-name "^Ethereal$"))) ("gkrellm" (and (class-inst "gkrellm") (class-name "Gkrellm"))) ;; Gdesklets stuff ("gdesklets" (and (class-inst "^gDesklets$") (class-name "^Gdesklets$"))) ("gdeskcal" (and (class-inst "^gdeskcal$") (class-name "^Gdeskcal$"))) ("links" (and (class-inst "^Links$") (class-name "^Links$"))) ("licq" (and (class-inst "^licq$") (class-name "^Licq$"))) ;; CLASS-NAME only ("mozilla" (or (class-name "^[mM]ozilla") (class-inst "^[mM]ozilla"))) ("xmms" (class-name "^[Xx]mms$")) ("xine" (class-name "^xine$")) ("mplayer" (class-name "^MPlayer$")) ("xchat" (class-name "^X-Chat$")) ("gimp" (class-name "^Gimp$")) ("ddd" (class-name "^Ddd$")) ("firefox" (class-name "^Firefox")) ("opera" (class-name "^Opera$")) ("xpdf" (class-name "^Xpdf$")) ("acroread" (class-name "^AcroRead$")) ;; NAME only ("gnuplot" (name "^Gnuplot$")) ("xchm" (name "^xCHM")) ) "Alist of known applications. CAR is appllication name, CDR is match-spec. Use `xwem-appcollect' to create `xwem-applications-alist'." :type '(cons string sexp) :group 'xwem) (defvar xwem-manage-internal-list nil "Internal manage list in `xwem-manage-list' format.") ;;;###autoload (defvar xwem-manage-expectances nil "List of expectances in `xwem-manage-list' format. The difference from `xwem-manage-list' is that, when matching occurs in `xwem-manage-expectances', matched entry removed from `xwem-manage-expectances' list.") ;;; Internal variables ;;; Matching ;;;###xwem-autoload (defun xwem-class-match-p (cl cli-regex &optional cln-regex wmname-regex) "Return non-nil if CL matches CLI-REGEX, CLN-REGEX, WMNAME-REGEX. CLI-REGEX is regexp to match class instance name. CLN-REGEX is regexp to match class name. WMNAME-REGEX is regexp to match CL's WM_NAME." (let* ((case-fold-search nil) (hints (xwem-cl-hints cl)) (class (xwem-hints-wm-class hints)) (wmname (xwem-hints-wm-name hints))) (and (or (null cli-regex) (string-match cli-regex (or (car class) ""))) (or (null cln-regex) (string-match cln-regex (or (cdr class) ""))) (or (null wmname-regex) (string-match wmname-regex wmname))))) (defmacro define-xwem-class-matcher (cli-regex &optional cln-regex wmname-regex) "Create and return new class matcher function. Result of this macro is function which is passed with on argument - CL. This function returns non-nil if CL's WM_CLASS matches CLI-REGEX/CLN-REGEX and CL's WM_NAME matches WMNAME-REGEX. If CLN-REGEX or WMNAME-REGEX ommited, then \".*\" expression will be used (i.e. match everything)." `(lambda (cl) (xwem-class-match-p cl ,cli-regex ,cln-regex ,wmname-regex))) ;;;###xwem-autoload (defun xwem-cl-match-p (cl match-spec) "Check whether CL matches MATCH-SPEC. MATCH-SPEC format is a list in form (or (TYPE PARAM) ..) or (and (TYPE PARAM) ..). TYPE is one of: `class-name' - To match CL's class name (PARAM is regex). `class-inst' - To match CL's class instance name (PARAM is regex). `name' - Client name (PARAM is regex). `command' - Client's WM_COMMAND (PARAM is regex) `property' - PARAM is either property symbol, or cons cell where car is property symbol and cdr is value of property to match. `function' - PARAM is function which passed with one argument CL and returns non-nil if CL matches. `eval' - PARAM is form to evaluate. `or'|`and' - Starts subspec, PARAM is MATCH-SPEC. `override-redirect' - If this TYPE is used, also match client with override-redirect attribute, otherwise clients with override-redirect are skiped, even if others specs matches. `buffer-major-mode' - PARAM is major-mode name. Matches if current client is Emacs frame, frame's buffer is current and its major mode is eq to PARAM. `buffer-name' - PARAM is regexp. As `buffer-major-mode' but if PARAM matches current buffer's name. `buffer-filename' - PARAM is regexp. As `buffer-name' but if PARAM matches current buffer's filename. `application' - PARAM is application name that is looked in `xwem-applications-alist'. " (let ((case-fold-search nil) ; case sensivity searching (gm-type 'and) ; global matching type 'or or 'and hints ; for optimisation type param ires or) ;; Setup global matching, default to 'and (when (memq (caar match-spec) '(or and)) (if (eq 'or (caar match-spec)) (setq gm-type 'or) (setq gm-type 'and)) (setq match-spec (cdar match-spec))) ;; Scan MATCH-SPEC for matching (while match-spec (setq type (car (car match-spec)) param (car (cdr (car match-spec))) ires (cond ((eq type 'class-inst) (and (xwem-cl-p cl) (or (null param) (string-match param (or (car (xwem-hints-wm-class (or hints (setq hints (xwem-cl-hints cl))))) ""))))) ((eq type 'class-name) (and (xwem-cl-p cl) (or (null param) (string-match param (or (cdr (xwem-hints-wm-class (or hints (setq hints (xwem-cl-hints cl))))) ""))))) ((eq type 'name) (and (xwem-cl-p cl) (or (null param) (string-match param (or (xwem-hints-wm-name (or hints (setq hints (xwem-cl-hints cl)))) ""))))) ((eq type 'command) (and (xwem-cl-p cl) (or (null param) (string-match param (or (xwem-hints-wm-command (or hints (setq hints (xwem-cl-hints cl)))) ""))))) ((eq type 'property) (and (xwem-cl-p cl) (cond ((symbolp param) (xwem-client-property cl param)) ((and (consp param) (symbolp (car param))) (equal (xwem-client-property cl (car param)) (cdr param)))))) ((eq type 'application) (and (xwem-cl-p cl) (xwem-cl-match-p cl (cdr (assoc param xwem-applications-alist))))) ((eq type 'eval) (eval param)) ((eq type 'function) (funcall param cl)) ((memq type '(or and)) ;; Subspec (xwem-cl-match-p cl (list (car match-spec)))) ((eq type 'override-redirect) (and (xwem-cl-p cl) (X-Attr-override-redirect (xwem-cl-initial-xattrs cl)) (setq or t))) ;; Emacs stuff ((memq type '(buffer-major-mode buffer-name buffer-filename)) (let* ((fr (xwem-misc-find-emacs-frame cl)) (buf (and (frame-live-p fr) (window-buffer (frame-selected-window fr))))) (when (bufferp buf) (with-current-buffer buf (cond ((eq type 'buffer-major-mode) (eq param major-mode)) ((eq type 'buffer-name) (string-match param (buffer-name))) ((eq type 'buffer-filename) (and (buffer-file-name) (string-match param (buffer-file-name))))))))) )) (if (or (and (eq gm-type 'and) (null ires)) (and (eq gm-type 'or) ires)) ;; Break conditions, not-match or already matches (setq match-spec nil) ;; Continue traversing (setq match-spec (cdr match-spec)))) (if (and (xwem-cl-p cl) (X-Attr-override-redirect (xwem-cl-initial-xattrs cl))) (and or ires) ires))) ;;;###xwem-autoload (defun xwem-manda-find-match-1 (cl manage-list &optional extractor) "Search for CL match in MANAGE-LIST. EXTRACTOR is where to obtain match-spec from MANAGE-LIST elements, default is 'cddr." (unless extractor (setq extractor 'cddr)) (while (and manage-list (not (xwem-cl-match-p cl (funcall extractor (car manage-list))))) (setq manage-list (cdr manage-list))) (car manage-list)) (defun xwem-manda-find-expectance (cl) "Search in `xwem-manage-expectances' to match CL. If match occurs, matching entry removed from `xwem-manage-expectances'." (let ((expects xwem-manage-expectances) rval) (while (and expects (not (xwem-cl-match-p cl (cddr (car expects))))) (setq expects (cdr expects))) (when expects (setq rval (car expects)) (setcar expects nil) (setq xwem-manage-expectances (delq nil xwem-manage-expectances))) rval)) ;;;###xwem-autoload (defun xwem-cl-was-expected (cl new) "Mark/unmark CL as it was expected according to NEW value. If NEW is non-nil mark CL as was expected. If NEW is nil then unmark." (xwem-cl-put-sys-prop cl 'cl-was-expected new)) ;;;###xwem-autoload (defun xwem-cl-was-expected-p (cl) "Return non-nil if CL was expected for managing." (xwem-cl-get-sys-prop cl 'cl-was-expected)) (defun xwem-manda-find-match (cl) "Find match for CL in manage database. Search `xwem-manage-internal-list' with 'override-manage-list non-nil property, then search for match in `xwem-manage-list' and `xwem-manage-internal-list' respectively. `xwem-manda-find-match' also checks expectances. Only expectances of same manage type as normal match is used." (let ((expt-spec (xwem-manda-find-expectance cl)) (mspec (or (xwem-manda-find-match-1 cl (delq nil (mapcar #'(lambda (mm) (and (xwem-manage-property (car mm) 'override-manage-list) mm)) xwem-manage-internal-list))) (xwem-manda-find-match-1 cl xwem-manage-list) (xwem-manda-find-match-1 cl xwem-manage-internal-list)))) ;; Check that EXPT-SPEC is the same manage type as MSPEC (if (and expt-spec (car expt-spec)) ;; Mark CL as it was expected (progn (xwem-cl-was-expected cl t) expt-spec) (when (and mspec expt-spec (null (car expt-spec)) (cadr expt-spec)) ;; EXPT-SPEC does not has manage type, but has plist, which we ;; need to merge into MSPEC plist. (let ((m-plist (cadr mspec)) (e-plist (cadr expt-spec))) (while e-plist (setq m-plist (plist-put m-plist (car e-plist) (cadr e-plist))) (setq e-plist (cddr e-plist))) (setcdr mspec (cons m-plist (cddr mspec)))) ;; Mark CL as it was expected (xwem-cl-was-expected cl t)) mspec))) (defun xwem-manda-del-expectance (expt) "Remove EXPT from `xwem-manage-expectances' list." ;; Delete expect window if there is nothing managed in it ; (let ((ew (plist-get (cadr expt) 'expect-win))) ; (when (and (xwem-win-p ew) ; (not (xwem-win-only-one-p ew)) ; (not (xwem-win-cl ew)) ; (null (xwem-win-clients ew))) ; (xwem-window-delete ew))) (setq xwem-manage-expectances (delq expt xwem-manage-expectances))) ;;;###xwem-autoload (defun xwem-manda-add-expectance (expectance &optional expire-timeout) "Install new EXPECTANCE in `xwem-manage-expectances' list. EXPIRE-TIMEOUT specifies time-to-live for new entry in seconds \(default is `xwem-manage-default-expectance-expire-timeout'\)." (push expectance xwem-manage-expectances) ;; Install expectance timeout handler (start-itimer "xwem-expectance" 'xwem-manda-del-expectance (or expire-timeout xwem-manage-default-expectance-expire-timeout) nil nil t expectance)) ;;;###xwem-autoload (defun xwem-manage-property (manage-type prop) "For MANAGE-TYPE, return manage property PROP." (plist-get (get manage-type 'xwem-manage-properties) prop)) ;;;###xwem-autoload (defun xwem-manage-rem-property (manage-type prop) "For MANAGE-TYPE, remove property PROP." (put manage-type 'xwem-manage-properties (plist-remprop (get manage-type 'xwem-manage-properties) prop))) ;;;###xwem-autoload (defun xwem-manage-set-property (manage-type prop val) "For MANAGE-TYPE, set manage property PROP to VAL." (if val (put manage-type 'xwem-manage-properties (plist-put (get manage-type 'xwem-manage-properties) prop val)) (xwem-manage-rem-property manage-type prop))) ;;;###xwem-autoload (defun* define-xwem-manage-model-1 (manage-name docstring &key manage-properties cl-properties match-spec append manage-method activate-method deactivate-method refit-method iconify-method withdraw-method) "Define new managing model of MANAGE-NAME. DOCSTRING is documentation for managing model. MANAGE-PROPERTIES - Some manage properties used when managing clients of this managing model. CL-PROPERTIES - Client properties to import into client when client managing using this managing model. MATCH-SPEC - Client matching specification, see `xwem-cl-match-p'. APPEND - Non-nil mean append to the end of managing models list. By default managing models are prepended to list." (put manage-name :docstring docstring) (add-to-list 'xwem-manage-internal-list (list manage-name cl-properties match-spec) append) ;; Set manage properties (setq manage-properties (xwem-misc-merge-plists xwem-manage-default-properties manage-properties)) (while manage-properties (xwem-manage-set-property manage-name (car manage-properties) (cadr manage-properties)) (setq manage-properties (cddr manage-properties))) ;; Register methods (when manage-method (put 'manage manage-name manage-method)) (when activate-method (put 'activate manage-name activate-method)) (when deactivate-method (put 'deactivate manage-name deactivate-method)) (when refit-method (put 'refit manage-name refit-method)) (when iconify-method (put 'iconify manage-name iconify-method)) (when withdraw-method (put 'withdraw manage-name withdraw-method)) ) (defmacro define-xwem-manage-model (manage-name docstring &rest args) "Define new managing model." `(funcall 'define-xwem-manage-model-1 (quote ,manage-name) ,docstring ,@args)) ;;; New concept, generic functions and methods (like CLOS) (defsubst xwem-execute-method (method-name manda-type &rest args) "Execute METHOD-NAME passing ARGS. If no method METHOD-NAME found for MANDA-TYPE, use 'default type." (let ((fun (get method-name manda-type))) (when (or fun (setq fun (get method-name 'default))) (apply fun args)))) (defsubst xwem-method-manage (cl) (xwem-execute-method 'manage (xwem-cl-manage-type cl) cl)) (defsubst xwem-method-activate (cl &optional type) "Activation method for CL. For TYPE, see documentation for `xwem-activate'." (xwem-execute-method 'activate (xwem-cl-manage-type cl) cl type)) (defsubst xwem-method-deactivate (cl &optional type) (xwem-execute-method 'deactivate (xwem-cl-manage-type cl) cl type)) (defsubst xwem-method-refit (cl) (xwem-execute-method 'refit (xwem-cl-manage-type cl) cl)) (defsubst xwem-method-iconify (cl) (xwem-execute-method 'iconify (xwem-cl-manage-type cl) cl)) (defsubst xwem-method-withdraw (cl) (xwem-execute-method 'withdraw (xwem-cl-manage-type cl) cl)) (defsubst xwem-method-on-kill (cl) (xwem-execute-method 'on-kill (xwem-cl-manage-type cl) cl)) (defsubst xwem-method-on-type-change (cl &optional new-type) (xwem-execute-method 'on-type-change (xwem-cl-manage-type cl) cl new-type)) (defmacro define-xwem-method (method-name manda-type arg-list &optional doc-string &rest forms) "Define new method METHOD-NAME for MANDA-TYPE. DOC-STRING is documentation. FORMS - elisp forms to eval." (let ((sym (intern (format "xwem:-%s-%s" manda-type method-name)))) `(eval-and-compile (defun ,sym ,arg-list ,doc-string ,@forms) (put (quote ,method-name) (quote ,manda-type) (quote ,sym))))) (provide 'xwem-manage) ;;; xwem-manage.el ends here