1. xemacs
  2. xwem


xwem / lisp / xwem-manage.el

;;; xwem-manage.el --- Manage stuff for xwem.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 21 Mar 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id$

;; 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
;; 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:


;;; Code

;; Variables
(defvar xwem-manda-list nil
  "Manage database list, all manage instances should be there.")

(defstruct xwem-manda
  name                                  ; manda name
  exclude-p                             ; non-nil if such clients
					; should be excluded from
					; clients list


;;; Functions
(defun xwem-manda-fun-run (manel fun &rest args)
  "Run function FUN for MANEL.
FUN is one of 'init, 'manage, 'demanage or 'refit
NOTE: A little bit hackish, do not do so at home." 
  (let* ((ifun (intern (format "xwem-manda-%s-fun" fun)))
	 (val (funcall ifun manel)))

    (when val
      (apply val args))))

(defun xwem-manda-find-inst (cl)
  "Find instance for CL in manage database.
NOTE: Find first match."
  (let ((manls xwem-manda-list))
    (while (and manls (not (funcall (xwem-manda-matcher-function (car manls)) cl)))
      (setq manls (cdr manls)))

    (car manls)))

(defun define-xwem-manda (name matcher-function &optional priority exclude-p 
                               init-fun manage-fun demanage-fun iconify-fun refit-fun)
  "Define new entry in manage database."
  (let ((man (make-xwem-manda :name name
                              :priority priority
                              :exclude-p exclude-p
                              :matcher-function matcher-function
                              :init-fun init-fun
                              :manage-fun manage-fun
                              :demanage-fun demanage-fun
                              :iconify-fun iconify-fun
                              :refit-fun refit-fun)))
    (setq xwem-manda-list (cons man xwem-manda-list))

    ;; Resort by priority
    (setq xwem-manda-list (sort xwem-manda-list
                                (lambda (el1 el2)
                                  (> (xwem-manda-priority el1)
                                     (xwem-manda-priority el2)))))

(defmacro xwem-class-matcher (class-name &optional class-instance wm-name)
  "Define new WM_CLASS based CL matcher.

CLASS-NAME is regexp to match class-name, CLASS-INSTANCE is regexp to
match class instance, nil mean match any class instance WM-NAME is
regexp to match against WM_NAME, nil mean match any."
  `(lambda (cl)
     (let* ((hints (xwem-cl-hints cl))
            (class (xwem-hints-wm-class hints))
            (wmname (and ,wm-name (xwem-hints-wm-name hints))))
       (and (nth 0 class)
            (string-match ,class-name (nth 0 class))
            (or (not ,class-instance)
                (and (nth 1 class)
                     (string-match ,class-instance (nth 1 class))))
            (or (not wmname)
                (string-match ,wm-name wmname))))))

(defun xwem-manda-init ()
  "Initialize manage database."
  ;; Generic manda entry
  (define-xwem-manda 'generic (lambda (cl) t)
    -100 nil
    'xwem-init-clients 'xwem-cl-manage 'xwem-cl-demanage
    'xwem-cl-iconify 'xwem-cl-refit)

  ;; Manda entry to handle xwem minibuffer
  (define-xwem-manda 'xwem-minibuffer (xwem-class-matcher (concat "^" xwem-minibuffer-name "$"))
    0 t
    'xwem-minibuffer-init 'xwem-minib-manage nil nil 'xwem-minib-refit)

  ;; Manda entry to manage special Emacs frames
  (define-xwem-manda 'xwem-special (xwem-class-matcher (concat "^" xwem-special-frame-name "$"))
    0 t
    'xwem-special-frame-init 'xwem-special-frame-manage
    'xwem-special-frame-demanage 'xwem-special-frame-iconify)

  ;; Manda entry to manage transient-for(dialogs) windows
  (define-xwem-manda 'transient-for (lambda (cl)
                                      (xwem-hints-wm-transient-for (xwem-cl-hints cl)))
    0 t
    nil 'xwem-trans-for-manage 'xwem-trans-for-demanage

  ;; run init functions
  (mapc (lambda (manel)
	  (xwem-manda-fun-run manel 'init))

;; Transient for clients handling
(defcustom xwem-cl-transient-border-color "blue4"
  "Border color for transient for windows."
  :type '(restricted-sexp :match-alternatives (xwem-misc-colorspec-valid-p))
  :group 'xwem-cl)

(defcustom xwem-cl-transient-border-width 2
  "Border width in pixels of transient for windows."
  :type 'number
  :group 'xwem-cl)

(defun xwem-trans-for-manage (cl &rest others)
  "Manage CL that have transient-for flag."
  ;; Map window for witch CL is transient and just map and raise CL
  ;; over it
  (let* ((xwin (xwem-cl-xwin cl))
	 (tfwin (xwem-cl-transient-for cl))
	 (trc (xwem-find-client tfwin)))

    (XChangeWindowAttributes (xwem-dpy) xwin
			     (make-X-Attr :border-pixel (XAllocNamedColor
							 (xwem-dpy) (XDefaultColormap (xwem-dpy))
    (XSetWindowBorderWidth (xwem-dpy) xwin xwem-cl-transient-border-width)

    (XMapWindow (xwem-dpy) (xwem-cl-xwin cl))
    (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl))
    (XSelectInput (xwem-dpy) (xwem-cl-xwin cl) (Xmask-or XM-StructureNotify))

    (when (xwem-cl-p trc)
      (setf (xwem-cl-translist trc) (cons cl (xwem-cl-translist trc))))

    (xwem-focus-set cl)

(defun xwem-trans-for-demanage (cl &rest others)
  "Demanage CL that have transient-for flag."
  (let* ((tfwin (xwem-cl-transient-for cl))
	 (trc (xwem-find-client tfwin)))

    (when (xwem-cl-p trc)
      (xwem-message 'info "here i trc=%d" (X-Win-id (xwem-cl-xwin trc)))

      (setf (xwem-cl-translist trc) (delete cl (xwem-cl-translist trc))))

(provide 'xwem-manage)

;;; xwem-manage.el ends here