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

   1 ;;; xwem-tabbing.el --- Tabs in XWEM frames.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Sun Dec  7 18:35:15 MSK 2003
   7 ;; Keywords: xwem, xlib
   8 ;; X-CVS: $Id: xwem-tabbing.el,v 1.8 2005-04-04 19:54:16 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;; Tab format may contain one of escape seqs:
  32 ;;   %n - Client's name (WM_NAME)
  33 ;;   %c - Client's class instance (WM_CLASS)
  34 ;;   %C - Client's class name (WM_CLASS)
  35 ;;   %i - Client's icon
  36 ;;   %u - Client's uptime
  37 ;;   %U - Cilent's Uptime
  38 ;;   %s - Client's size in pixels
  39 ;;   %S - Client's size in units
  40 ;;   %f - Client's Frame number
  41 ;;   %F - Client's Frame name
  42 ;;   %* - "*" when client marked and "-" when not.
  43 ;;   %# - "#" when client support WM_DELETE and "-" when not.
  44 ;;   %I - Input model:
  45 ;;           "-"  - No Input
  46 ;;           "P"  - Passive
  47 ;;           "L"  - Locally Active
  48 ;;           "G"  - Globally Active
  49
  50 ;;   %{ - starts emacs lisp
  51 ;;   %} - ends emacs lisp
  52
  53 ;;   %0 - begin using default face
  54 ;;   %[1-9] - start using additional `xwem-tabber-face[num]' defined
  55 ;;            using `define-xwem-face'.
  56
  57 ;; Note that while running elisp within %{ and %} symbol `cl' refers
  58 ;; to client.
  59
  60 ;; Also `X-use-queryfont' is highly recommended to be `t' if you are
  61 ;; using this file.
  62
  63
  64 ;; Supported clients properties:
  65
  66 ;;    `xwem-tab-format' - Tab format for certain client.
  67
  68 ;;; Code:
  69 \f
  70 (require 'xlib-xlib)
  71 (require 'xlib-img)
  72
  73 (require 'xwem-load)
  74
  75 ;;; Customisation
  76 (defgroup xwem-tab nil
  77   "Group to customize tabs."
  78   :prefix "xwem-tab-"
  79   :prefix "xwem-face-"
  80   :group 'xwem)
  81
  82 (defcustom xwem-tab-default-format " %i %*%# %n"
  83   "*Default format for tab item."
  84   :type 'string
  85   :group 'xwem-tab)
  86
  87 (defcustom xwem-tab-empty-format "<empty>"
  88   "What to show when there no client."
  89   :type 'string
  90   :group 'xwem-tab)
  91
  92 (defcustom xwem-tab-delim-interval 2
  93   "*Number of clients to group, will draw largeer delimeter."
  94   :type 'number
  95   :group 'xwem-tab)
  96
  97 (defcustom xwem-tab-show-cl-info-on-click t
  98   "*Non-nil mean show client info when `xwem-tabber-switch-cl' called."
  99   :type 'boolean
 100   :group 'xwem-tab)
 101
 102 (define-xwem-face xwem-tabber-face
 103   `(((frame-selected tab-selected)
 104      (:foreground "white" :background "green4" :bold t))
 105     ((delimiter-left frame-selected tab-selected)
 106      (:foreground "white"))
 107     ((delimiter-right frame-selected tab-selected)
 108      (:foreground "black"))
 109
 110     ((frame-selected tab-nonselected)
 111      (:foreground "black" :background "gray80"))
 112     ((delimiter-left frame-selected tab-nonselected)
 113      (:foreground "white"))
 114     ((delimiter-right frame-selected tab-nonselected)
 115      (:foreground "black"))
 116
 117     ((frame-nonselected tab-selected)
 118      (:foreground "gray80" :background "DarkGreen" :bold t))
 119     ((delimiter-left frame-nonselected tab-selected)
 120      (:foreground "white"))
 121     ((delimiter-right frame-nonselected tab-selected)
 122      (:foreground "black"))
 123
 124     ((frame-nonselected tab-nonselected)
 125      (:foreground "black" :background "gray40"))
 126     ((delimiter-left frame-nonselected tab-nonselected)
 127      (:foreground "white"))
 128     ((delimiter-right frame-nonselected tab-nonselected)
 129      (:foreground "black"))
 130
 131     (t (:foreground "white")))
 132   "Face to draw tabs."
 133   :group 'xwem-tab
 134   :group 'xwem-faces)
 135
 136 ;; Another interface to customize tabber fonts
 137 (defcustom xwem-tabber-font:frame.selected-tab.selected nil
 138   "Font to be used in selected tab of selected frame."
 139   :type '(restricted-sexp :match-alternatives (nil try-font-name))
 140   :set (lambda (sym val)
 141          (set sym val)
 142          (xwem-set-face-font
 143           'xwem-tabber-face
 144           (or val (xwem-face-font 'xwem-tabber-face '(default)))
 145           '(frame-selected tab-selected)))
 146   :initialize 'custom-initialize-default
 147   :group 'xwem-tab)
 148
 149 (defcustom xwem-tabber-font:frame.selected-tab.nonselected nil
 150   "Font to be used in selected tab of selected frame."
 151   :type '(restricted-sexp :match-alternatives (nil try-font-name))
 152   :set (lambda (sym val)
 153          (set sym val)
 154          (xwem-set-face-font
 155           'xwem-tabber-face
 156           (or val (xwem-face-font 'xwem-tabber-face '(default)))
 157           '(frame-selected tab-nonselected)))
 158   :initialize 'custom-initialize-default
 159   :group 'xwem-tab)
 160
 161 (defcustom xwem-tabber-font:frame.nonselected-tab.selected nil
 162   "Font to be used in selected tab of selected frame."
 163   :type '(restricted-sexp :match-alternatives (nil try-font-name))
 164   :set (lambda (sym val)
 165          (set sym val)
 166          (xwem-set-face-font
 167           'xwem-tabber-face
 168           (or val (xwem-face-font 'xwem-tabber-face '(default)))
 169           '(frame-nonselected tab-selected)))
 170   :initialize 'custom-initialize-default
 171   :group 'xwem-tab)
 172
 173 (defcustom xwem-tabber-font:frame.nonselected-tab.nonselected nil
 174   "Font to be used in selected tab of selected frame."
 175   :type '(restricted-sexp :match-alternatives (nil try-font-name))
 176   :set (lambda (sym val)
 177          (set sym val)
 178          (xwem-set-face-font
 179           'xwem-tabber-face
 180           (or val (xwem-face-font 'xwem-tabber-face '(default)))
 181           '(frame-nonselected tab-nonselected)))
 182   :initialize 'custom-initialize-default
 183   :group 'xwem-tab)
 184
 185 ;;; Internal variables
 186
 187 (defvar xwem-tabber-map
 188   (let ((map (make-sparse-keymap)))
 189     (define-key map [button1] 'xwem-tabber-smart-drag-frame)
 190     (define-key map [button1up] 'xwem-tabber-switch-cl)
 191     (define-key map [button3] 'xwem-tabber-popup-cl-menu)
 192     map)
 193   "Keymap used when accessing `xwem-tabber'.")
 194
 195 (defvar xwem-tabber-dedicated-map
 196   (let ((map (make-sparse-keymap)))
 197     (define-key map [button1] 'xwem-tabber-drag-frame)
 198     (define-key map [button3] 'xwem-tabber-popup-cl-menu)
 199     map)
 200   "Keymap for dedicated clients.")
 201
 202 ;;;###autoload
 203 (defvar xwem-tabber-click-frame nil
 204   "Will be binded to frame when tabber clicked.")
 205 ;;;###autoload
 206 (defvar xwem-tabber-click-cl nil
 207   "Will be binded to cl when tabber clicked.")
 208
 209 \f
 210 ;;; Margins
 211 ;; Margin is some area in tabber, which is drawed specially.
 212 ;; Margin is a list in form (rect format face)
 213
 214 ;;; Tabber
 215 (defstruct xwem-tabber
 216   frame                                 ; xwem-frame, our parent
 217   xgeom                                 ; Tabber's geometry
 218   clients                               ; clients list
 219
 220   xwin                                  ; Tabber's X-Win
 221   xpreparer                             ; Tabber's X-Pixmap to prepare tab items
 222   xpix-copy                             ; Tabber's X-Pixmap used to copy to xwin
 223
 224   ;; Margins
 225   margins                               ; list of margins
 226
 227   plist                                 ; props list
 228   )
 229
 230 ;;; Macros
 231 (defmacro xwem-frame-tabber (frame)
 232   `(xwem-frame-get-prop ,frame 'xwem-tabber))
 233 (defsetf xwem-frame-tabber (frame) (tabber)
 234   `(xwem-frame-put-prop ,frame 'xwem-tabber ,tabber))
 235
 236 (defmacro xwem-cl-tabber (cl)
 237   `(let ((win (xwem-cl-win ,cl)))
 238      (and win (xwem-frame-tabber (xwem-win-frame win)))))
 239
 240 (defmacro xwem-cl-tab-rect (cl)
 241   `(xwem-cl-get-sys-prop ,cl 'xwem-tab-rect))
 242 (defsetf xwem-cl-tab-rect (cl) (tab-rect)
 243   `(xwem-cl-put-sys-prop ,cl 'xwem-tab-rect ,tab-rect))
 244
 245 (defmacro xwem-cl-tab-face (cl)
 246   `(or (and cl (xwem-client-property ,cl 'xwem-tab-face))
 247        'xwem-tabber-face))
 248 (defsetf xwem-cl-tab-face (cl) (tab-face)
 249   `(xwem-client-set-property ,cl 'xwem-tab-face ,tab-face))
 250
 251 (define-xwem-client-property xwem-tab-format nil
 252   "Tab format."
 253   :type 'string
 254   :get 'xwem-tab-get-xwem-tab-format
 255   :set 'xwem-tab-set-xwem-tab-format)
 256
 257 (defun xwem-tab-get-xwem-tab-format (cl tprop)
 258   "Get tab format for CL."
 259   (or (xwem-cl-get-prop cl 'xwem-tab-format)
 260       xwem-tab-default-format))
 261
 262 (defun xwem-tab-set-xwem-tab-format (cl tprop tval)
 263   "Set CL's tab format property TPROP to TVAL."
 264   (xwem-cl-put-prop cl tprop tval)
 265   (xwem-tabber-on-cl-change cl))
 266
 267 \f
 268 ;;; Functions
 269
 270 (defsubst xwem-tabber-put-prop (tabber prop val)
 271   (setf (xwem-tabber-plist tabber)
 272         (plist-put (xwem-tabber-plist tabber) prop val)))
 273 (put 'xwem-tabber-put-prop 'lisp-indent-function 2)
 274
 275 (defsubst xwem-tabber-get-prop (tabber prop)
 276   (plist-get (xwem-tabber-plist tabber) prop))
 277
 278 (defsubst xwem-tabber-rm-prop (tabber prop)
 279   (setf (xwem-tabber-plist tabber)
 280         (plist-remprop (xwem-tabber-plist tabber) prop)))
 281
 282 (defun xwem-tabber-init ()
 283   "Initialize tabbing."
 284   (xwem-message 'init "Initializing tabbing ...")
 285
 286   ;; Frame hooks
 287   (add-hook 'xwem-frame-creation-hook 'xwem-tabber-on-frame-creation)
 288   (add-hook 'xwem-frame-resize-hook 'xwem-tabber-on-frame-resize)
 289   (add-hook 'xwem-frame-select-hook 'xwem-tabber-on-frame-select-deselect)
 290   (add-hook 'xwem-frame-deselect-hook 'xwem-tabber-on-frame-select-deselect)
 291
 292   ;; Frame properties notifier
 293   (xwem-frame-add-property-notifier 'title-height 'xwem-tabber-frame-prop-notifier)
 294   (xwem-frame-add-property-notifier 'title-layout 'xwem-tabber-frame-prop-notifier)
 295   (xwem-frame-add-property-notifier 'inner-border-width 'xwem-tabber-frame-prop-notifier)
 296
 297   ;; Window hooks
 298   (add-hook 'xwem-win-switch-hook 'xwem-tabber-on-win-switch)
 299   (add-hook 'xwem-win-clients-change-hook 'xwem-tabber-on-win-change)
 300
 301   ;; Client hooks
 302   (add-hook 'xwem-cl-create-hook 'xwem-tabber-on-cl-creation)
 303   (add-hook 'xwem-cl-state-change-hook 'xwem-tabber-on-cl-change)
 304   (add-hook 'xwem-cl-change-hook 'xwem-tabber-on-cl-change)
 305
 306   (xwem-message 'init "Initializing tabbing ... done"))
 307
 308 ;;;###autoload(autoload 'xwem-tabber-switch-cl "xwem-tabber" "" t)
 309 (define-xwem-command xwem-tabber-switch-cl ()
 310   "Switch to client which tab item was clicked."
 311   (xwem-interactive)
 312
 313   (when (xwem-cl-alive-p xwem-tabber-click-cl)
 314     (xwem-activate xwem-tabber-click-cl)
 315     ;; Select client only if switching in current window.
 316     (when (eq (xwem-cl-win xwem-tabber-click-cl) (xwem-win-selected))
 317       (xwem-select-client xwem-tabber-click-cl))
 318
 319     (when xwem-tab-show-cl-info-on-click
 320       (xwem-client-info xwem-tabber-click-cl))
 321     ))
 322
 323 (define-xwem-command xwem-tabber-drag-frame ()
 324   "Interactively move frame."
 325   (xwem-interactive)
 326
 327   (xwem-frame-imove-internal
 328    xwem-tabber-click-frame
 329    (X-Event-xbutton-root-x xwem-last-xevent)
 330    (X-Event-xbutton-root-y xwem-last-xevent)))
 331
 332 (define-xwem-command xwem-tabber-smart-drag-frame ()
 333   "Interactively move dedicated client.
 334 Move frame.  If no moving occured and button is released, bypass it as
 335 command event."
 336   (xwem-interactive)
 337
 338   (let ((xev (xwem-next-event nil (list X-ButtonRelease X-MotionNotify))))
 339     (X-Event-CASE xev
 340       (:X-MotionNotify
 341        (xwem-frame-imove-internal
 342         xwem-tabber-click-frame
 343         (X-Event-xmotion-root-x xev)
 344         (X-Event-xmotion-root-y xev)))
 345       (:X-ButtonRelease
 346        (xwem-dispatch-command-xevent xev)))))
 347 (put 'xwem-tabber-smart-drag-frame 'xwem-frame-command t)
 348
 349 ;;;###autoload(autoload 'xwem-tabber-popup-cl-menu "xwem-tabber" "" t)
 350 (define-xwem-command xwem-tabber-popup-cl-menu ()
 351   "Popup clients menu."
 352   (xwem-interactive)
 353
 354   (if (xwem-cl-alive-p xwem-tabber-click-cl)
 355       (xwem-popup-menu (xwem-generate-cl-menu xwem-tabber-click-cl))
 356     ;; TODO
 357 ;    (xwem-popup-menu nil
 358      ))
 359
 360 (defun xwem-tabber-cl-at (tabber x y)
 361   "Return client of TABBER which rectangle covers point at X Y."
 362   (let ((clients (xwem-tabber-clients tabber))
 363         (tmp-rect (xwem-tabber-rect->xpix-rect
 364                    tabber (make-X-Rect :x x :y y :width 0 :height 0)))
 365         rect ret-cl)
 366     ;; Adjust X and Y
 367     (setq x (X-Rect-x tmp-rect)
 368           y (X-Rect-y tmp-rect))
 369     (while clients
 370       (setq rect (xwem-cl-tab-rect (car clients)))
 371       (if (and rect
 372                  (<= (X-Rect-x rect) x)
 373                  (>= (+ (X-Rect-x rect) (X-Rect-width rect)) x)
 374                  (<= (X-Rect-y rect) y)
 375                  (>= (+ (X-Rect-y rect) (X-Rect-height rect)) y))
 376         (setq ret-cl (car clients)
 377               clients nil)
 378         (setq clients (cdr clients))))
 379     ret-cl))
 380
 381 (defun xwem-tabber-regeom (tabber)
 382   "Adjust tab items geometries in TABBER."
 383   ;; TODO: handle margins
 384   (let* ((twidth (X-Geom-width (xwem-tabber-xgeom tabber)))
 385          (theight (X-Geom-height (xwem-tabber-xgeom tabber)))
 386          (clients (xwem-tabber-clients tabber))
 387          (clsn (length clients ))       ; number of clients
 388          (off 0)
 389          tiw twrem rect)
 390
 391     (when clients
 392       (setq tiw (/ twidth clsn)
 393             twrem (% twidth clsn))
 394
 395       (while clients
 396         ;; Setup CL's tab rectangle rectangle
 397         (unless (xwem-cl-tab-rect (car clients))
 398           (setf (xwem-cl-tab-rect (car clients))
 399                 (make-X-Rect :x 0 :y 0 :width 0 :height 0)))
 400         (setq rect (xwem-cl-tab-rect (car clients)))
 401         (setf (X-Rect-x rect) off)
 402         (setf (X-Rect-width rect) (+ tiw (if (cdr clients) 0 twrem)))
 403         (setf (X-Rect-height rect) theight)
 404
 405         (setq off (+ off (X-Rect-width rect)))
 406         (setq clients (cdr clients))))))
 407
 408 (defsubst xwem-tabber-safe-regeom (tabber &optional draw-p)
 409   "Saf variant of `xwem-tabber-regeom'."
 410   (and (xwem-tabber-p tabber)
 411        (xwem-tabber-regeom tabber)))
 412
 413 ;; Drawings
 414 (defun xwem-tabber-xpix-rect->rect (tabber rect)
 415   (let ((x0 (X-Rect-x rect))
 416         (y0 (X-Rect-y rect))
 417         (w0 (X-Rect-width rect))
 418         (h0 (X-Rect-height rect))
 419         x y w h)
 420     (case (xwem-frame-property (xwem-tabber-frame tabber) 'title-layout)
 421       (left
 422        (setq y x0
 423              x (- (X-Geom-width (xwem-tabber-xgeom tabber)) y0 h0)
 424              h w0
 425              w h0))
 426       (right
 427        (setq x y0
 428              y (- (X-Geom-height (xwem-tabber-xgeom tabber)) x0 w0)
 429              w h0
 430              h w0))
 431       (t (setq x x0
 432                y y0
 433                w w0
 434                h h0)))
 435     (make-X-Rect :x x :y y :width w :height h)))
 436
 437 (defun xwem-tabber-rect->xpix-rect (tabber rect)
 438   (xwem-tabber-xpix-rect->rect tabber rect))
 439
 440 (define-xwem-deffered xwem-tabber-redraw (tabber &optional  x y width height)
 441   "Redraw TABBER's rectangle specified by X, Y, WIDTH and HEIGHT.
 442 If one of optional arguments ommited, full redraw."
 443   (when (xwem-tabber-p tabber)
 444     (let* ((xgeom (xwem-tabber-xgeom tabber))
 445            (x (or x 0))
 446            (y (or y 0))
 447            (width (or width (X-Geom-width xgeom)))
 448            (height (or height (X-Geom-height xgeom)))
 449            (tl (xwem-frame-property (xwem-tabber-frame tabber) 'title-layout)))
 450       (cond ((memq tl '(top bottom))
 451              (XCopyArea (xwem-dpy) (xwem-tabber-xpix-copy tabber)
 452                         (xwem-tabber-xwin tabber)
 453                         (XDefaultGC (xwem-dpy)) x y width height x y))
 454             ((memq tl '(left right))
 455              (let* ((ximg (XGetImage (xwem-dpy) (xwem-tabber-xpix-copy tabber)
 456                                      x y width height X-AllPlanes X-ZPixmap))
 457                     (rxd (xwem-misc-rotate-data
 458                           (nth 4 ximg) width height
 459                           (XGetDepth (xwem-dpy) (xwem-tabber-xpix-copy tabber))
 460                           (if (eq tl 'left) 'left 'right)))
 461                     (dst-height width)
 462                     (dst-width height)
 463                     dst-x dst-y)
 464                (if (eq tl 'left)
 465                    (setq dst-x y
 466                          dst-y (- (X-Geom-width xgeom) x width))
 467                  (setq dst-x  (- (X-Geom-height xgeom) y height)
 468                        dst-y x))
 469                (XPutImage (xwem-dpy) (xwem-tabber-xwin tabber)
 470                           (XDefaultGC (xwem-dpy))
 471                           (XGetDepth (xwem-dpy) (xwem-tabber-xpix-copy tabber))
 472                           dst-width dst-height
 473                           dst-x dst-y nil X-ZPixmap rxd)))))))
 474
 475 (define-xwem-deffered xwem-tabber-redraw-xrect (tabber &optional xrect)
 476   "Redraw part of TABBER.
 477 XRECT specifies geometry to redraw.
 478 Defaultly full redraw."
 479   (when (xwem-tabber-p tabber)
 480     (unless xrect
 481       (setq xrect (X-Geom-to-X-Rect (xwem-tabber-xgeom tabber))))
 482
 483     (xwem-tabber-redraw tabber
 484                         (X-Rect-x xrect) (X-Rect-y xrect)
 485                         (X-Rect-width xrect) (X-Rect-height xrect))))
 486
 487 (defsubst xwem-tabber-frame-win-clients (tabber)
 488   "Return list of managed clients in TABBER's window."
 489   (delq nil (mapcar #'(lambda (cl)
 490                         (and (xwem-cl-managed-p cl '(active inactive)) cl))
 491                     (xwem-win-clients
 492                      (xwem-frame-selwin (xwem-tabber-frame tabber))))))
 493
 494 (defsubst xwem-tabber-clients-equal (cls1 cls2)
 495   "Return non-nil if each element of CLS1 and CLS2 is `eq'."
 496   (and (= (length cls1) (length cls2))
 497        (not (memq nil (or (mapcar* 'eq cls1 cls2))))))
 498
 499 (define-xwem-deffered xwem-tabber-draw-format (cl &optional tabber force-update)
 500   "Draw CL's tab.
 501 If FORCE-UPDATE is non-nil also copy to TABBER x window."
 502   (when (or (null cl) (xwem-cl-alive-p cl))
 503     ;; Either empty or valid client
 504     (let* ((tabber (or tabber (xwem-cl-tabber cl)))
 505            (rect (or (and (xwem-cl-p cl) (xwem-cl-tab-rect cl))
 506                      (let ((xgeom (xwem-tabber-xgeom tabber)))
 507                        (make-X-Rect :x 0 :y 0 :width (X-Geom-width xgeom)
 508                                     :height (X-Geom-height xgeom)))))
 509            (fmt (or (and (xwem-cl-p cl)
 510                          (xwem-client-property cl 'xwem-tab-format))
 511                     xwem-tab-empty-format))
 512            (xprep (xwem-tabber-xpreparer tabber))
 513            (xpcop (xwem-tabber-xpix-copy tabber))
 514            (xoff (X-Rect-x rect))
 515            (yoff (X-Rect-y rect))
 516            tag-set currgc fi item fmt-index sfg)
 517
 518       ;; Setup TAG-SET
 519       (if (xwem-frame-selected-p (xwem-tabber-frame tabber))
 520           (if (xwem-cl-p cl)
 521               (if (xwem-win-cl-current-p cl)
 522                   (setq tag-set (list 'frame-selected 'tab-selected))
 523                 (setq tag-set (list 'frame-selected 'tab-nonselected)))
 524
 525             ;; Empty tab item
 526             (setq tag-set (list 'frame-selected 'tab-selected)))
 527
 528         (if (xwem-cl-p cl)
 529             (if (xwem-win-cl-current-p cl)
 530                 (setq tag-set (list 'frame-nonselected 'tab-selected))
 531               (setq tag-set (list 'frame-nonselected 'tab-nonselected)))
 532
 533           ;; Empty tab item
 534           (setq tag-set (list 'frame-nonselected 'tab-selected))))
 535
 536       ;; Setup currgc, xprep, tabxwin
 537       (setq currgc (xwem-face-get-gc (xwem-cl-tab-face cl) tag-set cl))
 538       (XSetClipRectangles (xwem-dpy) currgc 0 0 (list rect))
 539
 540       (setq sfg (X-Gc-foreground currgc))
 541       (xwem-unwind-protect
 542           (progn
 543             (setf (X-Gc-foreground currgc) (X-Gc-background currgc))
 544             (XChangeGC (xwem-dpy) currgc)
 545             (XFillRectangles (xwem-dpy) xprep currgc (list rect))
 546             (XFillRectangles (xwem-dpy) xpcop currgc (list rect)))
 547         (setf (X-Gc-foreground currgc) sfg)
 548         (XChangeGC (xwem-dpy) currgc))
 549
 550       ;; Process format string
 551       (setq fmt-index 0)
 552       (while (and (< xoff (+ (X-Rect-x rect) (X-Rect-width rect)))
 553                   (< fmt-index (length fmt)))
 554
 555         ;; Extract ITEM
 556         (setq fi (aref fmt fmt-index))
 557         (incf fmt-index)
 558         (if (eq fi ?%)
 559             (progn
 560               (setq fi (aref fmt fmt-index))
 561               (setq item
 562                     (cond ((= fi ?n) (xwem-client-name cl))
 563                           ((= fi ?c) (car (xwem-hints-wm-class
 564                                            (xwem-cl-hints cl))))
 565                           ((= fi ?C) (cdr (xwem-hints-wm-class
 566                                            (xwem-cl-hints cl))))
 567                           ((= fi ?i) (xwem-icons-cl-icon
 568                                       cl (and (not (xwem-frame-selected-p
 569                                                     (xwem-cl-frame cl)))
 570                                               '(shade))))
 571                           ((= fi ?s) (xwem-cl-get-psize cl))
 572                           ((= fi ?S) (xwem-cl-get-usize cl))
 573                           ((= fi ?u) (xwem-cl-get-uptime cl))
 574                           ((= fi ?U) (xwem-cl-get-uptime cl))
 575                           ((= fi ?f) (int-to-string
 576                                       (xwem-frame-num (xwem-cl-frame cl))))
 577                           ((= fi ?F) (xwem-frame-name (xwem-cl-frame cl)))
 578                           ((= fi ?*) (if (xwem-cl-marked-p cl) "*" "-"))
 579                           ((= fi ?#) (if (XWMProtocol-set-p
 580                                           (xwem-dpy)
 581                                           (xwem-hints-wm-protocols
 582                                            (xwem-cl-hints cl))
 583                                           "WM_DELETE_WINDOW")
 584                                          "#" "-"))
 585                           ((= fi ?I) (let ((ip (X-WMHints-input-p
 586                                                 (xwem-hints-wm-hints
 587                                                  (xwem-cl-hints cl))))
 588                                            (tf (XWMProtocol-set-p
 589                                                 (xwem-dpy)
 590                                                 (xwem-hints-wm-protocols
 591                                                  (xwem-cl-hints cl))
 592                                                 "WM_TAKE_FOCUS")))
 593                                        (cond ((and ip tf) "L")
 594                                              (ip "P")
 595                                              (tf "G")
 596                                              (t "-"))))
 597                           ((= fi ?%) "%")
 598
 599                           ;; Emacs lisp
 600                           ((= fi ?{)
 601                            (let ((substr (substring fmt (1+ fmt-index)))
 602                                  elstr)
 603                              (unless (string-match
 604                                       "\\(\\([^%]\\|%[^}]\\)*\\)%}" substr)
 605                                (signal 'search-failed fmt "%}"))
 606
 607                              ;; extract lisp code and update fmt indexer
 608                              (setq elstr (match-string 1 substr))
 609                              (incf fmt-index (match-end 0))
 610
 611                              ;; Now time to run emacs lisp.
 612
 613                              ;; NOTE:
 614                              ;;
 615                              ;;  - Due to dynamic scoping, emacs
 616                              ;;    lisp code that is in ELSTR can
 617                              ;;    access any locally bounded
 618                              ;;    variable for example `cl'.
 619                              ;;
 620                              ;; - It should return string, cons
 621                              ;;   cell(image) or nil.
 622                              (eval (read elstr))))
 623
 624                           ;; Ditig is number of aditional GC
 625                           ((and (> (Xforcenum fi) 47) (< (Xforcenum fi) 57))
 626                            (let* ((n (string-to-int (char-to-string fi)))
 627                                   (gc (xwem-face-get-gc
 628                                           (if (zerop n)
 629                                               (xwem-cl-tab-face cl)
 630                                             (intern-soft
 631                                              (concat "xwem-tabber-face"
 632                                                      (int-to-string n))))
 633                                         tag-set cl)))
 634                              (when (X-Gc-p gc)
 635                                (setq currgc gc)
 636                                (XSetClipRectangles (xwem-dpy) currgc
 637                                                    0 0 (list rect))))
 638                            'skip)
 639
 640                           (t (error 'xwem-error "Unknown token in tabi format"))))
 641               ;; size fix
 642               (when (and (consp item)
 643                          (numberp (car item))
 644                          (numberp (cdr item)))
 645                 (setq item (concat (int-to-string (car item))
 646                                    "x"
 647                                    (int-to-string (cdr item)))))
 648               (incf fmt-index))
 649
 650           ;; Not %
 651           (setq item (char-to-string fi))
 652           (while (and (< fmt-index (length fmt))
 653                       (not (= (aref fmt fmt-index) ?%)))
 654             (setq item (concat item (char-to-string (aref fmt fmt-index))))
 655             (incf fmt-index)))
 656
 657         ;; Display ITEM
 658         (cond ((stringp item)
 659                ;; Draw text
 660                (let* ((font (X-Gc-font currgc))
 661                       (ta (X-Text-ascent (xwem-dpy) font item))
 662                       (td (X-Text-descent (xwem-dpy) font item))
 663                       (hei (X-Rect-height rect))
 664                       (ty (+ yoff (/ (- hei (+ ta td)) 2) ta)))
 665
 666                  (XDrawString (xwem-dpy) xprep currgc xoff ty item)
 667                  (setq xoff (+ xoff (X-Text-width
 668                                      (xwem-dpy) (X-Gc-font currgc) item)))
 669                  ))
 670
 671               ((and (consp item)
 672                     (X-Pixmap-p (car item))
 673                     (X-Pixmap-p (cdr item)))
 674                ;; Draw icon
 675                (let ((ty (/ (- (X-Rect-height rect)
 676                                (X-Pixmap-height (car item))) 2)))
 677 ;                  (ximg-mask (X-Pixmap-get-prop (cdr item) 'ximg)))
 678                  (xwem-unwind-protect
 679                      (progn
 680                        (setf (X-Gc-clip-mask currgc) (cdr item))
 681                        (setf (X-Gc-clip-x-origin currgc) xoff)
 682                        (setf (X-Gc-clip-y-origin currgc) (+ yoff ty))
 683                        (XChangeGC (xwem-dpy) currgc)
 684
 685                        (XCopyArea (xwem-dpy) (car item) xprep currgc 0 0
 686                                   (X-Pixmap-width (car item))
 687                                   (X-Pixmap-height (car item))
 688                                   xoff (+ yoff ty)))
 689                    (setf (X-Gc-clip-mask currgc) X-None)
 690                    (setf (X-Gc-clip-x-origin currgc) 0)
 691                    (setf (X-Gc-clip-y-origin currgc) 0)
 692                    (XChangeGC (xwem-dpy) currgc)
 693                    (XSetClipRectangles (xwem-dpy) currgc 0 0 (list rect)))
 694
 695                  (setq xoff (+ xoff (X-Pixmap-width (car item))))))
 696
 697               ((or (null item)
 698                    (eq item 'skip)) nil)
 699
 700               (t (error 'xwem-error "Unknown Item" item)))
 701         )                               ;  while
 702
 703       ;; Compose xpreparer
 704       (when (> xoff (+ (X-Rect-x rect) (X-Rect-width rect)))
 705         (setq xoff (+ (X-Rect-x rect) (X-Rect-width rect))))
 706
 707       (XCopyArea (xwem-dpy) xprep xpcop currgc
 708                  (X-Rect-x rect) (X-Rect-y rect)
 709                  (X-Rect-width rect) (X-Rect-height rect)
 710                  (+ (X-Rect-x rect)
 711                     (/ (- (+ (X-Rect-x rect) (X-Rect-width rect)) xoff) 2))
 712                  (X-Rect-y rect))
 713
 714       (let ((ldgc (xwem-face-get-gc (xwem-cl-tab-face cl)
 715                     (cons 'delimiter-left tag-set) cl))
 716             (rdgc (xwem-face-get-gc (xwem-cl-tab-face cl)
 717                     (cons 'delimiter-right tag-set) cl)))
 718         (XDrawLine (xwem-dpy) xpcop ldgc
 719                    (X-Rect-x rect) (X-Rect-y rect)
 720                    (X-Rect-x rect) (+ (X-Rect-y rect) (X-Rect-height rect)))
 721         (XDrawLine (xwem-dpy) xpcop rdgc
 722                    (+ -1 (X-Rect-x rect) (X-Rect-width rect))
 723                    (X-Rect-y rect)
 724                    (+ -1 (X-Rect-x rect) (X-Rect-width rect))
 725                    (+ (X-Rect-y rect) (X-Rect-height rect))))
 726
 727       ;; Finally apply change to xwin
 728       (when force-update
 729         (xwem-tabber-redraw-xrect-1 tabber rect))
 730
 731       ;; Unmark client as need to be redrawed
 732       (when (xwem-cl-p cl)
 733         (xwem-cl-rem-sys-prop cl 'xwem-tab-need-redraw))
 734       )))
 735
 736 (defun xwem-tabber-regeom-p (tabber)
 737   "Return non-nil if TABBER is regeomed."
 738   (let ((old-clients (xwem-tabber-clients tabber))
 739         (new-clients (xwem-tabber-frame-win-clients tabber)))
 740     (unless (xwem-tabber-clients-equal old-clients new-clients)
 741       (setf (xwem-tabber-clients tabber) new-clients)
 742       (when new-clients
 743         (xwem-tabber-regeom tabber))
 744       t)))
 745
 746 (define-xwem-deffered xwem-tabber-draw (tabber &optional force-draw)
 747   "On TABBER draw client's tabs.
 748 If FORCE-DRAW is non-nil redraw tabber even if it logically does not
 749 need to be redrawed."
 750   (when (and (xwem-tabber-p tabber)
 751              (xwem-frame-p (xwem-tabber-frame tabber))
 752              ;; none layout does not need to be redrawn
 753              (not (eq (xwem-frame-property
 754                        (xwem-tabber-frame tabber) 'title-layout)
 755                       'none)))
 756     (let ((cls-to-draw nil)
 757           (need-draw-p nil))
 758
 759       (unless (eq (xwem-tabber-get-prop tabber 'xwem-frame-selected-p)
 760                   (xwem-frame-selected-p (xwem-tabber-frame tabber)))
 761         (xwem-tabber-put-prop tabber 'xwem-frame-selected-p
 762           (xwem-frame-selected-p (xwem-tabber-frame tabber)))
 763         (setq force-draw t))
 764
 765       (if (or (xwem-tabber-regeom-p tabber) force-draw)
 766           (setq cls-to-draw (or (xwem-tabber-clients tabber) (list nil))
 767                 need-draw-p t)          ; all clients
 768         (setq cls-to-draw
 769               (delq nil (mapcar #'(lambda (cl)
 770                                     (and (xwem-cl-get-sys-prop
 771                                           cl 'xwem-tab-need-redraw) cl))
 772                                 (xwem-tabber-clients tabber)))
 773               need-draw-p cls-to-draw))
 774
 775       (when need-draw-p
 776         (mapc #'(lambda (cl)
 777                   (xwem-tabber-draw-format-1 cl tabber))
 778               cls-to-draw)
 779         (xwem-tabber-redraw-1 tabber)))))
 780
 781 (defun xwem-tabber-event-handler (xdpy xwin xev)
 782   "On display XDPY and window XWIN handle event XEV."
 783   (let ((tabber (X-Win-get-prop xwin 'xwem-tabber)))
 784     (when (xwem-tabber-p tabber)
 785       (X-Event-CASE xev
 786         (:X-Expose
 787          (xwem-tabber-redraw-xrect
 788           tabber (xwem-tabber-rect->xpix-rect
 789                   tabber
 790                   (make-X-Rect :x (X-Event-xexpose-x xev)
 791                                :y (X-Event-xexpose-y xev)
 792                                :width (X-Event-xexpose-width xev)
 793                                :height (X-Event-xexpose-height xev)))))
 794
 795         (:X-DestroyNotify
 796          (when (xwem-tabber-p tabber)
 797            (XFreePixmap (xwem-dpy) (xwem-tabber-xpreparer tabber))
 798            (XFreePixmap (xwem-dpy) (xwem-tabber-xpix-copy tabber))
 799            (X-invalidate-cl-struct tabber)))
 800
 801         ((:X-ButtonPress :X-ButtonRelease)
 802          ;; Handle button press/release event
 803          (let* ((x (X-Event-xbutton-event-x xev))
 804                 (y (X-Event-xbutton-event-y xev))
 805                 (xwem-tabber-click-frame (xwem-tabber-frame tabber))
 806                 (xwem-tabber-click-cl (xwem-tabber-cl-at tabber x y))
 807                 (xwem-keyboard-echo-keystrokes nil)) ; XXX
 808            (xwem-overriding-local-map
 809              (if (xwem-frame-dedicated-p (xwem-tabber-frame tabber))
 810                  xwem-tabber-dedicated-map
 811                xwem-tabber-map)
 812              (xwem-dispatch-command-xevent xev))))
 813         ))))
 814
 815 (defun xwem-tabber-create (frame)
 816   "Create new tabber for FRAME."
 817   (let* ((xgeom (make-X-Geom :x 0 :y 0
 818                              :width 1 :height 1
 819                              :border-width 0)) ; XXX
 820          (tabber (make-xwem-tabber :frame frame
 821                                    :xgeom xgeom))
 822          (xdpy (xwem-dpy))
 823          (w (XCreateWindow
 824              xdpy
 825              (xwem-frame-xwin frame)
 826              (X-Geom-x xgeom) (X-Geom-y xgeom)
 827              (X-Geom-width xgeom) (X-Geom-height xgeom)
 828              (X-Geom-border-width xgeom)
 829              nil nil nil                ;X-InputOutput nil
 830              (make-X-Attr :background-pixel (XWhitePixel (xwem-dpy))
 831                           :bit-gravity X-StaticGravity
 832                           :backing-store X-Always))))
 833
 834     (setf (xwem-tabber-xwin tabber) w)
 835     (X-Win-put-prop w 'xwem-tabber tabber)
 836
 837     (XSelectInput xdpy w
 838                   (Xmask-or XM-Exposure XM-StructureNotify
 839                             XM-ButtonPress XM-ButtonRelease XM-ButtonMotion))
 840     (X-Win-EventHandler-add w 'xwem-tabber-event-handler 0
 841                             (list X-Expose X-DestroyNotify X-ButtonPress
 842                                   X-ButtonRelease X-MotionNotify))
 843
 844     ;; Adjust XGEOM and create Preparer and xpix-copy
 845 ;    (setf (xwem-tabber-xpreparer tabber)
 846 ;          (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy))
 847 ;                         w (XDefaultDepth xdpy) (X-Geom-width xgeom) (X-Geom-height xgeom)))
 848 ;    (setf (xwem-tabber-xpix-copy tabber)
 849 ;          (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy))
 850 ;                         w (XDefaultDepth xdpy) (X-Geom-width xgeom) (X-Geom-height xgeom)))
 851     (xwem-tabber-resize tabber)
 852
 853     ;; Draw tabber contents and map its window
 854     (xwem-tabber-draw-1 tabber t)
 855     (XMapWindow (X-Win-dpy w) w)
 856     tabber))
 857
 858 (defun xwem-tabber-move-resize (tabber)
 859   "Move TABBER to its place according to title-layout, etc,"
 860   (let* ((frame (xwem-tabber-frame tabber))
 861          (th (xwem-frame-property frame 'title-height))
 862          (ibw (xwem-frame-property frame 'inner-border-width))
 863          (xgeom (xwem-tabber-xgeom tabber))
 864          x y w h)
 865     (when (xwem-frame-p frame)
 866       (case (xwem-frame-property frame 'title-layout)
 867         (top
 868          (setf (X-Geom-width xgeom) (- (xwem-frame-width frame) ibw ibw)
 869                (X-Geom-height xgeom) th)
 870          (setq x ibw
 871                y ibw
 872                w (X-Geom-width xgeom)
 873                h (X-Geom-height xgeom)))
 874         (bottom
 875          (setf (X-Geom-width xgeom) (- (xwem-frame-width frame) ibw ibw)
 876                (X-Geom-height xgeom) th)
 877          (setq x ibw
 878                y (- (xwem-frame-height frame) th ibw)
 879                w (X-Geom-width xgeom)
 880                h (X-Geom-height xgeom)))
 881         (left
 882          (setf (X-Geom-width xgeom) (- (xwem-frame-height frame) ibw ibw)
 883                (X-Geom-height xgeom) th)
 884          (setq x ibw
 885                y ibw
 886                w (X-Geom-height xgeom)
 887                h (X-Geom-width xgeom)))
 888
 889         (right
 890          (setf (X-Geom-width xgeom) (- (xwem-frame-height frame) ibw ibw)
 891                (X-Geom-height xgeom) th)
 892          (setq x (- (xwem-frame-width frame) th ibw)
 893                y ibw
 894                w (X-Geom-height xgeom)
 895                h (X-Geom-width xgeom))))
 896
 897       (XMoveResizeWindow (xwem-dpy) (xwem-tabber-xwin tabber) x y w h))))
 898
 899 (defun xwem-tabber-resize (tabber)
 900   "Resize TABBER to WIDTH, HEIGHT."
 901   (let* ((xgeom (xwem-tabber-xgeom tabber))
 902          (owidth (X-Geom-width xgeom))
 903          (oheight (X-Geom-height xgeom)))
 904
 905     (xwem-tabber-move-resize tabber)
 906
 907     (when (or (> (X-Geom-width xgeom) owidth)
 908               (> (X-Geom-height xgeom) oheight))
 909       ;; Recreate xpreparer
 910       (when (X-Pixmap-p (xwem-tabber-xpreparer tabber))
 911         (XFreePixmap (xwem-dpy) (xwem-tabber-xpreparer tabber)))
 912       (when (X-Pixmap-p (xwem-tabber-xpix-copy tabber))
 913         (XFreePixmap (xwem-dpy) (xwem-tabber-xpix-copy tabber)))
 914       (setf (xwem-tabber-xpreparer tabber)
 915             (XCreatePixmap (xwem-dpy)
 916                            (make-X-Pixmap :dpy (xwem-dpy)
 917                                           :id (X-Dpy-get-id (xwem-dpy)))
 918                            (xwem-tabber-xwin tabber) (XDefaultDepth (xwem-dpy))
 919                            (X-Geom-width xgeom) (X-Geom-height xgeom)))
 920       (setf (xwem-tabber-xpix-copy tabber)
 921             (XCreatePixmap (xwem-dpy)
 922                            (make-X-Pixmap :dpy (xwem-dpy)
 923                                           :id (X-Dpy-get-id (xwem-dpy)))
 924                            (xwem-tabber-xwin tabber) (XDefaultDepth (xwem-dpy))
 925                            (X-Geom-width xgeom) (X-Geom-height xgeom)))
 926           (when xwem-misc-turbo-mode
 927             (XSetWindowBackgroundPixmap (xwem-dpy) (xwem-tabber-xwin tabber)
 928                                         (xwem-tabber-xpix-copy tabber))))
 929     (xwem-tabber-regeom tabber)))
 930
 931 ;;; Frame Hooks
 932 (defun xwem-tabber-on-frame-select-deselect ()
 933   "Redraw tabbers when switching frames."
 934   (when (xwem-frame-p (xwem-frame-selected))
 935     (xwem-tabber-draw (xwem-frame-tabber (xwem-frame-selected)))))
 936
 937 (defun xwem-tabber-on-frame-resize (frame)
 938   "FRAME just resized, apply changes to tabber, if any."
 939   (let ((tabber (xwem-frame-tabber frame)))
 940     (when (xwem-tabber-p tabber)
 941       (xwem-tabber-resize tabber)
 942       (xwem-tabber-draw tabber t))))
 943
 944 (defun xwem-tabber-on-frame-creation (frame)
 945   "FRAME just created."
 946   (setf (xwem-frame-tabber frame) (xwem-tabber-create frame)))
 947
 948 (defun xwem-tabber-frame-prop-notifier (frame prop value)
 949   "FRAME just changed property PROP to VALUE."
 950   (let ((tabber (xwem-frame-tabber frame)))
 951     (when (xwem-tabber-p tabber)
 952       (case prop
 953         (title-layout
 954          (if (eq value 'none)
 955              (XUnmapWindow (xwem-dpy) (xwem-tabber-xwin tabber))
 956            (XMapWindow (xwem-dpy) (xwem-tabber-xwin tabber))))
 957         )
 958       (xwem-tabber-on-frame-resize frame))))
 959
 960 ;; Win hooks
 961 (defun xwem-tabber-on-win-switch (owin nwin)
 962   "Window switch occured OWIN -> NWIN."
 963   (and (xwem-win-selwin-p nwin)
 964        (xwem-tabber-draw (xwem-frame-tabber (xwem-win-frame nwin)))))
 965
 966 (defun xwem-tabber-on-win-change (win)
 967   "WIN's clients list changed."
 968   (and (xwem-win-selwin-p win)
 969        (xwem-tabber-draw (xwem-frame-tabber (xwem-win-frame win)))))
 970
 971 (defun xwem-tabber-on-win-ccl-change (win old-cl new-cl)
 972   "WIN's current client just changed."
 973   (when (xwem-cl-p old-cl)
 974     (xwem-tabber-on-cl-change old-cl))
 975   (when (xwem-cl-p new-cl)
 976     (xwem-tabber-on-cl-change new-cl)))
 977
 978 ;; CL hooks
 979 (defun xwem-tabber-on-cl-creation (cl)
 980   "CL just created."
 981   ;; Make tab rect for CL
 982   (unless (xwem-cl-tab-rect cl)
 983     (setf (xwem-cl-tab-rect cl)
 984           (make-X-Rect :x 0 :y 0 :width 0 :height 0)))
 985   )
 986
 987 (defun xwem-tabber-on-cl-change (cl &rest args)
 988   "CL just changed its component."
 989   (let ((tabber (xwem-cl-tabber cl)))
 990     (when (and tabber
 991                (memq cl (xwem-tabber-clients tabber))
 992                (xwem-win-selwin-p (xwem-cl-win cl)))
 993       ;; mark cl as need to be redraw
 994       (xwem-cl-put-sys-prop cl 'xwem-tab-need-redraw t)
 995       (xwem-tabber-draw tabber))))
 996
 997 \f
 998 (provide 'xwem-tabbing)
 999
1000 ;;;; On-load actions:
1001 ;; - Initialize tabber
1002 (xwem-tabber-init)
1003
1004 ;;; xwem-tabbing.el ends here