Source

xwem / lisp / xwem-manage.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
;;; xwem-manage.el --- Manage stuff for xwem.

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

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;;         Richard Klinda <ignotus@hixsplit.hu>
;; 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
;; 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$")))
    ("acroread" (class-name "^AcroRead$"))
    ("mozilla" (class-inst "^Mozilla"))
    ("firefox" (class-name "^Firefox"))
    ("rdesktop" (and (class-inst "^rdesktop$")
                     (class-name "^rdesktop$")))
    ("ddd" (class-name "^Ddd$"))
    ("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$")))
    ("gimp" (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$")))
    ("xchat" (class-name "^X-Chat$"))
    ("gnumeric" (and (class-inst "^gnumeric$")
                     (class-name "^Gnumeric$")))
    ("gnuplot" (name "^Gnuplot$"))
    ("ethereal" (and (class-inst "^ethereal$")
                     (class-name "^Ethereal$")))

    ("xmms" (class-name "^[Xx]mms$"))
    ("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$")))
    )
  "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)

  `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 '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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.