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

;; Copyright (C) 2003-2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;;         Richard Klinda <ignotus@hixsplit.hu>
;; 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
