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

   1 ;;; xwem-misc.el --- Misc stuff for XWEM.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 21 Mar 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xwem-misc.el,v 1.18 2005-04-04 19:54:14 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 ;; This file used for misc purposes.
  32 ;;
  33 ;; If you have troubles with C-g key in Emacs, try to eval:
  34 ;;
  35 ;;    (set-input-mode nil nil nil ?\xff)
  36 ;;
  37 ;; I dont know where is bug, but sometimes my XEmacs behaves very
  38 ;; strange.  Especially after M-x C-h k.
  39
  40 ;;; Code:
  41 ;;
  42 \f
  43 (require 'xlib-xlib)
  44 (require 'xlib-img)
  45
  46 (require 'xwem-load)
  47 (require 'advice)
  48
  49 (eval-and-compile
  50   (defvar iswitchb-buflist nil)         ; shutup compiler
  51   (defvar x-emacs-application-class nil)
  52   (autoload 'iswitchb-read-buffer "iswitchb") ; shutup compiler
  53
  54   (defvar elp-function-list nil)        ; shut up compiler
  55   (autoload 'elp-instrument-list "elp" nil t)
  56   (autoload 'elp-results "elp" nil t)
  57
  58   (autoload 'calc-eval "calc"))
  59
  60 (defmacro xwem-gc-function-choice ()
  61   "Return choice dialog to select GC function."
  62   `(`(choice (const :tag "None" nil)
  63              (const :tag "Clear" X-GXClear)
  64              (const :tag "And" X-GXAnd)
  65              (const :tag "Reverse And" X-GXAndReverse)
  66              (const :tag "Inverted And" X-GXAndInverted)
  67              (const :tag "Xor" X-GXXor)
  68              (const :tag "Or" X-GXOr)
  69              (const :tag "Reverse Or" X-GXOrReverse)
  70              (const :tag "Inverted Or" X-GXOrInverted)
  71              (const :tag "Nor" X-GXNor)
  72              (const :tag "Equive" X-GXEquiv)
  73              (const :tag "Invert" X-GXInvert)
  74              (const :tag "Copy" X-GXCopy)
  75              (const :tag "Inverted Copy" X-GXCopyInverted)
  76              (const :tag "Set" X-GXSet))))
  77
  78 (defmacro xwem-cursor-shape-choice ()
  79   "Return choice dialog to select cursor shape."
  80   `(`(choice (const :tag "Left" X-XC-left_ptr)
  81              (const :tag "Left w/mask" (X-XC-left_ptr))
  82              (const :tag "Right" X-XC-right_ptr )
  83              (const :tag "Right w/mask" (X-XC-right_ptr ))
  84              (const :tag "Cross" X-XC-cross)
  85              (const :tag "Cross w/mask" (X-XC-cross))
  86              (const :tag "Reverse Cross" X-XC-cross_reverse)
  87              (const :tag "Reverse Cross w/mask" (X-XC-cross_reverse))
  88              (const :tag "Crosshair" X-XC-crosshair)
  89              (const :tag "Crosshair w/mask" (X-XC-crosshair))
  90              (const :tag "Daimond cross" X-XC-diamond_cross)
  91              (const :tag "Daimond cross w/mask" (X-XC-diamond_cross))
  92              ;; TODO: add more, take a look at Cursors section in
  93              ;; xlib-const.el
  94              (const :tag "Dot" X-XC-dot)
  95              (const :tag "Dot w/mask" (X-XC-dot))
  96              (const :tag "Square Icon" X-XC-icon)
  97              (const :tag "Square Icon w/mask" (X-XC-icon))
  98              (const :tag "Fluer" X-XC-fleur)
  99              (const :tag "Fluer w/mask" (X-XC-fleur))
 100
 101              ;; Arrows
 102              (const :tag "Down Arrow" X-XC-sb_down_arrow)
 103              (const :tag "Down Arrow w/mask" (X-XC-sb_down_arrow))
 104              (const :tag "Question Arrow" X-XC-question_arrow)
 105              (const :tag "Question Arrow w/mask" (X-XC-question_arrow))
 106
 107              (const :tag "TopLeft Arrow" X-XC-top_left_arrow)
 108              (const :tag "TopLeft Arrow w/mask" (X-XC-top_left_arrow))
 109              (const :tag "Draft large" X-XC-draft_large)
 110              (const :tag "Draft large w/mask" (X-XC-draft_large))
 111              (const :tag "Draft small" X-XC-draft_small)
 112              (const :tag "Draft small w/mask" (X-XC-draft_small))
 113
 114              ;; Corners
 115              (const :tag "Bottom Left corner" X-XC-bottom_left_corner)
 116              (const :tag "Bottom Left corner w/mask" (X-XC-bottom_left_corner))
 117              (const :tag "Bottom Right corner" X-XC-bottom_right_corner)
 118              (const :tag "Bottom Right corner w/mask" (X-XC-bottom_right_corner))
 119              (const :tag "Top Left corner" X-XC-top_left_corner)
 120              (const :tag "Top Left corner w/mask" (X-XC-top_left_corner))
 121              (const :tag "Top Right corner" X-XC-top_right_corner)
 122              (const :tag "Top Right corner w/mask" (X-XC-top_right_corner))
 123
 124              (const :tag "Gumby guy" X-XC-gumby)
 125              (const :tag "Gumby guy w/mask" (X-XC-gumby))
 126              )))
 127
 128 (defmacro xwem-cus-set-cursor-foreground (cursor)
 129   "Generate :set function to change CURSOR's foreground"
 130   `(lambda (sym val)
 131      (set sym val)
 132      (when ,cursor
 133        (xwem-cursor-recolorize ,cursor val))))
 134
 135 (defmacro xwem-cus-set-cursor-background (cursor)
 136   "Generate :set function to change CURSOR's background"
 137   `(lambda (sym val)
 138      (set sym val)
 139      (when ,cursor
 140        (xwem-cursor-recolorize ,cursor nil val))))
 141
 142 (defmacro xwem-cus-set-cursor-shape (cursor &optional xwin)
 143   "Generate :set function to change CURSOR's background"
 144   `(lambda (sym val)
 145      (set sym val)
 146      (when ,cursor
 147        (let ((ncur (copy-X-Cursor ,cursor))
 148              src-char msk-char)
 149          (cond ((listp val)
 150                 (setq src-char (eval (car val))
 151                       msk-char (1+ src-char)))
 152                (t (setq src-char (eval val)
 153                         msk-char src-char)))
 154          (setf (X-Cursor-id ncur) (X-Dpy-get-id (X-Cursor-dpy ,cursor)))
 155          (setf (X-Cursor-src-char ncur) src-char)
 156          (setf (X-Cursor-msk-char ncur) msk-char)
 157          (XFreeCursor (X-Cursor-dpy ,cursor) ,cursor)
 158          (XCreateGlyphCursor (X-Cursor-dpy ncur) ncur)
 159          (setq ,cursor ncur)))
 160      (if (listp ,xwin)
 161          (mapc #'(lambda (xw)
 162                    (when (and xw (X-Win-p xw))
 163                      (XSetWindowCursor (X-Win-dpy xw) xw ,cursor)))
 164                ,xwin)
 165        (when (and ,xwin (X-Win-p ,xwin))
 166          (XSetWindowCursor (X-Win-dpy ,xwin) ,xwin ,cursor)))))
 167
 168 (define-error 'xwem-internal-error
 169   "Internal XWEM error.")
 170
 171 (defgroup xwem-misc nil
 172   "Group to customize miscellaneous options."
 173   :prefix "xwem-"
 174   :group 'xwem)
 175
 176 (defcustom xwem-messages-buffer-name " *xwem-messages*"
 177   "*Buffer name for xwem messages."
 178   :type 'string
 179   :group 'xwem-misc)
 180
 181 (defcustom xwem-messages-buffer-lines 1000
 182   "*Maximum lines in xwem messages buffer."
 183   :type 'number
 184   :group 'xwem-misc)
 185
 186 (defconst xwem-messages-builtin-labels
 187   '(info note error warning alarm todo prompt progress nolog asis)
 188   "List of builtin labels.")
 189
 190 ;;;###autoload
 191 (defcustom xwem-messages-ignore-labels
 192   '(prompt progress nolog)
 193   "*List of message labels to ignore putting them into xwem message log buffer."
 194   :type '(repeat (choice (symbol :tag "Custom label")
 195                          (const :tag "Alarm" alarm)
 196                          (const :tag "Error" error)
 197                          (const :tag "Warning" warning)
 198                          (const :tag "Info" info)
 199                          (const :tag "Note" note)
 200                          (const :tag "TODO" todo)
 201                          (const :tag "Prompt" prompt)
 202                          (const :tag "Progress" progress)
 203                          (const :tag "NoLog" nolog)))
 204   :group 'xwem-misc)
 205
 206 (defcustom xwem-messages-beeps-alist
 207   '((warning . warning)
 208     (error . error)
 209     (alarm . alarm))
 210   "*Alist in form (MSG-LABEL . SOUND).
 211 Where SOUND is element of `xwem-sound-alist'."
 212   :type `(repeat (cons (symbol :tag "Message Label")
 213                        ,(nconc '(choice)
 214                                (mapcar #'(lambda (ss)
 215                                            (list 'const :tag (symbol-name (car ss)) (car ss)))
 216                                        xwem-sound-alist)
 217                                '((symbol :tag "Sound type")))))
 218   :group 'xwem-misc)
 219
 220 (defcustom xwem-messages-label-prefixes
 221   '((warning "Warning" (red))
 222     (error "Erorr" (red bold))
 223     (alarm "Alarm" (red bold italic))
 224     (note "Note" (yellow))
 225     (info "Info" (default))
 226     (todo "TODO" (bold)))
 227   "List of prefixes for certain labels.
 228 CAR is label."
 229   :type '(list (symbol :tag "Message label") string (repeat face))
 230   :group 'xwem-misc)
 231
 232 ;;;###xwem-autoload
 233 (defcustom xwem-misc-turbo-mode nil
 234   "*Non-nil mean xwem will work as fast as it can.
 235 In this case, some color related customizations may not apply on fly.
 236 So on-fly theming will not work, etc.
 237 However seting its value to non-nil is most convinient for most users."
 238   :type 'boolean
 239   :group 'xwem-misc)
 240
 241 (defcustom xwem-misc-functions-to-profile nil
 242   "List of functions to profile using xwem profiler."
 243   :type (list
 244          'repeat
 245          (cons 'choice
 246                (delq nil
 247                      (mapcar
 248                       #'(lambda (fun)
 249                           (and (symbolp fun)
 250                                (fboundp fun)
 251                                (> (length (symbol-name fun)) 4)
 252                                (string= "xwem" (substring (symbol-name fun) 0 4))
 253                                (list 'function-item fun)))
 254                       obarray))))
 255   :group 'xwem-misc)
 256
 257 ;;; Cursors
 258 (defgroup xwem-cursor nil
 259   "Group to customize cursors in XWEM."
 260   :prefix "xwem-cursor-"
 261   :group 'xwem)
 262
 263 ;; Default cursor
 264 (defcustom xwem-cursor-default-shape 'X-XC-left_ptr
 265   "*Shape of default xwem cursor."
 266   :type (xwem-cursor-shape-choice)
 267   :set (xwem-cus-set-cursor-shape xwem-cursor-default)
 268   :initialize 'custom-initialize-default
 269   :group 'xwem-cursor)
 270
 271 (defcustom xwem-cursor-default-foreground-color "#002800"
 272   "*Default cursor's foreground color."
 273   :type 'color
 274   :set (xwem-cus-set-cursor-foreground xwem-cursor-default)
 275   :initialize 'custom-initialize-default
 276   :group 'xwem-cursor)
 277
 278 (defcustom xwem-cursor-default-background-color "#000000"
 279   "*Default cursor's background color."
 280   :type 'color
 281   :set (xwem-cus-set-cursor-background xwem-cursor-default)
 282   :initialize 'custom-initialize-default
 283   :group 'xwem-cursor)
 284
 285 ;; wait cursor
 286 (defcustom xwem-cursor-wait-shape 'X-XC-icon
 287   "*Shape of cursor, when XWEM wait for something."
 288   :type (xwem-cursor-shape-choice)
 289   :set (xwem-cus-set-cursor-shape xwem-cursor-wait)
 290   :initialize 'custom-initialize-default
 291   :group 'xwem-cursor)
 292
 293 (defcustom xwem-cursor-wait-foreground-color "#ea0000"
 294   "*Cursor's foreground color when XWEM wait for something."
 295   :type 'color
 296   :set (xwem-cus-set-cursor-foreground xwem-cursor-wait)
 297   :initialize 'custom-initialize-default
 298   :group 'xwem-cursor)
 299
 300 (defcustom xwem-cursor-wait-background-color "#280000"
 301   "*Cursor's background color when XWEM waiit for something."
 302   :type 'color
 303   :set (xwem-cus-set-cursor-background xwem-cursor-wait)
 304   :initialize 'custom-initialize-default
 305   :group 'xwem-cursor)
 306
 307 ;; move cursor
 308 (defcustom xwem-cursor-move-shape 'X-XC-fleur
 309   "*Shape of cursor, when moving something."
 310   :type (xwem-cursor-shape-choice)
 311   :set (xwem-cus-set-cursor-shape xwem-cursor-move)
 312   :initialize 'custom-initialize-default
 313   :group 'xwem-cursor)
 314
 315 (defcustom xwem-cursor-move-foreground-color "#777777"
 316   "*Cursor's foreground color when moving something."
 317   :type 'color
 318   :set (xwem-cus-set-cursor-foreground xwem-cursor-move)
 319   :initialize 'custom-initialize-default
 320   :group 'xwem-cursor)
 321
 322 (defcustom xwem-cursor-move-background-color "#280000"
 323   "*Cursor's background color when moving something."
 324   :type 'color
 325   :set (xwem-cus-set-cursor-background xwem-cursor-move)
 326   :initialize 'custom-initialize-default
 327   :group 'xwem-cursor)
 328
 329 ;; Resize cursor
 330 (defcustom xwem-cursor-resize-shape 'X-XC-sizing
 331   "*Shape of cursor, when resizing something."
 332   :type (xwem-cursor-shape-choice)
 333   :set (xwem-cus-set-cursor-shape xwem-cursor-resize)
 334   :initialize 'custom-initialize-default
 335   :group 'xwem-cursor)
 336
 337 (defcustom xwem-cursor-resize-foreground-color "#777777"
 338   "*Cursor's foreground color when resizing something."
 339   :type 'color
 340   :set (xwem-cus-set-cursor-foreground xwem-cursor-resize)
 341   :initialize 'custom-initialize-default
 342   :group 'xwem-cursor)
 343
 344 (defcustom xwem-cursor-resize-background-color "#280000"
 345   "*Cursor's background color when resizing something."
 346   :type 'color
 347   :set (xwem-cus-set-cursor-background xwem-cursor-resize)
 348   :initialize 'custom-initialize-default
 349   :group 'xwem-cursor)
 350
 351 ;; quote cursor
 352 (defcustom xwem-cursor-quote-shape 'X-XC-sb_down_arrow
 353   "*Shape of cursor, when XWEM quoting keyboard or mouse."
 354   :type (xwem-cursor-shape-choice)
 355   :set (xwem-cus-set-cursor-shape xwem-cursor-quote)
 356   :initialize 'custom-initialize-default
 357   :group 'xwem-cursor)
 358
 359 (defcustom xwem-cursor-quote-foreground-color "#0000BB"
 360   "*Cursor's foreground color when XWEM quoting keyboard/mouse."
 361   :type 'color
 362   :set (xwem-cus-set-cursor-foreground xwem-cursor-quote)
 363   :initialize 'custom-initialize-default
 364   :group 'xwem-cursor)
 365
 366 (defcustom xwem-cursor-quote-background-color "#000099"
 367   "*Cursor's background color when XWEM quoting keyboard/mouse."
 368   :type 'color
 369   :set (xwem-cus-set-cursor-background xwem-cursor-quote)
 370   :initialize 'custom-initialize-default
 371   :group 'xwem-cursor)
 372
 373 ;; help cursor
 374 (defcustom xwem-cursor-help-shape '(X-XC-question_arrow)
 375   "*Shape of cursor, when getting help with XWEM."
 376   :type (xwem-cursor-shape-choice)
 377   :set (xwem-cus-set-cursor-shape xwem-cursor-help)
 378   :initialize 'custom-initialize-default
 379   :group 'xwem-cursor)
 380
 381 (defcustom xwem-cursor-help-foreground-color "#00BB00"
 382   "*Cursor's foreground color when quering XWEM for help."
 383   :type 'color
 384   :set (xwem-cus-set-cursor-foreground xwem-cursor-help)
 385   :initialize 'custom-initialize-default
 386   :group 'xwem-cursor)
 387
 388 (defcustom xwem-cursor-help-background-color "#009900"
 389   "*Cursor's background color when quering XWEM for help."
 390   :type 'color
 391   :set (xwem-cus-set-cursor-background xwem-cursor-help)
 392   :initialize 'custom-initialize-default
 393   :group 'xwem-cursor)
 394
 395 ;;; Internal variables
 396
 397 ;; cursor storages
 398 (defvar xwem-cursor-fnt nil "Font for \"cursor\" series.")
 399
 400 (defvar xwem-cursor-default nil "Default cursor.")
 401 (defvar xwem-cursor-left nil "Left cursor.")
 402 (defvar xwem-cursor-right nil "Right cursor.")
 403 (defvar xwem-cursor-wait nil "Cursor when we are wait.")
 404 (defvar xwem-cursor-drag nil "Cursor when we drag.  Drug is a bad idea.")
 405 (defvar xwem-cursor-move nil "Cursor when we move something.")
 406 (defvar xwem-cursor-rsz-vert nil)
 407 (defvar xwem-cursor-rsz-horz nil)
 408 (defvar xwem-cursor-resize nil "Cursor when we resize.")
 409 (defvar xwem-cursor-quote nil "Cursor when quoting key.")
 410 (defvar xwem-cursor-help nil "Cursor when in help mode.")
 411
 412 (defvar xwem-misc-mask-pixmap nil "Pixmap with depth 1.")
 413 ;;;###xwem-autoload
 414 (defvar xwem-misc-mask-fgc nil
 415   "X-Gc with foreground 1.0 destination drawable has depth 1.")
 416 ;;;###xwem-autoload
 417 (defvar xwem-misc-mask-bgc nil
 418   "X-Gc with foreground 1.0 destination drawable has depth 1.")
 419
 420 ;;; Macros
 421 (defmacro xwem-xwin-frame (xwin)
 422   "Return XWEM frame, which X window is XWIN."
 423   `(X-Win-get-prop ,xwin 'xwem-frame))
 424
 425 ;;;###xwem-autoload
 426 (defmacro xwem-xwin-cl (xwin)
 427   "Return CL, which X window is XWIN."
 428   `(X-Win-get-prop ,xwin 'xwem-cl))
 429 (defsetf xwem-xwin-cl (xwin) (cl)
 430   `(if (not ,cl)
 431        (X-Win-rem-prop ,xwin 'xwem-cl)
 432      (X-Win-put-prop ,xwin 'xwem-cl ,cl)))
 433
 434 (defadvice XCreateWindow (after xwin-created-by-xwem activate)
 435   "Mark window's created on xwem-dpy as window created by xwem."
 436   (let ((dpy (ad-get-arg 0))
 437         (xwin ad-return-value))
 438     (when (eq dpy (xwem-dpy))
 439       (X-Win-put-prop xwin 'xwin-created-by-xwem t))))
 440
 441 ;;; Functions
 442 ;;;###xwem-autoload
 443 (defun xwem-misc-colorspec->rgb-vector (colspec)
 444   "Conver color specification COLSPEC to internal representation.
 445 COLSPEC maybe in form: #RRGGBB or name like 'green4'."
 446   (let ((col (color-instance-rgb-components
 447               (make-color-instance colspec (default-x-device)))))
 448     (and col (vconcat col))))
 449
 450 ;;;###xwem-autoload
 451 (defun xwem-misc-colorspec->rgb-vector-safe (colspec &optional defret)
 452   "Validate COLSPEC to be color specification in safe manner.
 453 Return DEFRET or [0 0 0] if there was error."
 454   (condition-case nil
 455       (xwem-misc-colorspec->rgb-vector colspec)
 456     (t (or defret [0 0 0]))))
 457
 458 ;;;###xwem-autoload
 459 (defun xwem-misc-colorspec-valid-p (colspec)
 460   "Return non-nil if COLSPEC is valid color specification.
 461 Valid colorspecification is spec in form: #RRGGBB or name like 'green4'."
 462   (condition-case nil
 463       (xwem-misc-colorspec->rgb-vector colspec)
 464     (t nil)))
 465
 466 ;;;###xwem-autoload
 467 (defun xwem-make-color (colorspec &optional cmap)
 468   "Create X-Color according to COLORSPEC."
 469   (let ((ccol (xwem-misc-colorspec->rgb-vector-safe colorspec [0 0 0])))
 470     (make-X-Color :red (aref ccol 0)
 471                   :green (aref ccol 1)
 472                   :blue (aref ccol 2))))
 473
 474 ;;;###xwem-autoload
 475 (defun xwem-make-cursor (type &optional fgcol bgcol)
 476   "Make new cursor of TYPE and store it in WHERE-STORE.
 477 BGCOL maybe nil, that mean masking will not be done."
 478   (xwem-cursors-init)                   ; make sure cursor font loaded
 479
 480   (let ((fgc (xwem-misc-colorspec->rgb-vector-safe fgcol [0 0 0]))
 481         (bgc (xwem-misc-colorspec->rgb-vector-safe bgcol 'invalid-bgcol))
 482         src-char msk-char cursor)
 483     (cond ((listp type)
 484            (setq src-char (eval (car type))
 485                  msk-char (1+ src-char)))
 486           (t (setq src-char (eval type)
 487                    msk-char src-char)))
 488     (setq cursor (make-X-Cursor
 489                   :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
 490                   :source xwem-cursor-fnt
 491                   :mask xwem-cursor-fnt
 492                   :src-char src-char
 493                   :msk-char msk-char
 494                   :fgred (aref fgc 0)
 495                   :fggreen (aref fgc 1)
 496                   :fgblue (aref fgc 2)))
 497     (unless (eq bgc 'invalid-bgcol)
 498       (setf (X-Cursor-bgred cursor) (aref bgc 0))
 499       (setf (X-Cursor-bggreen cursor) (aref bgc 1))
 500       (setf (X-Cursor-bgblue cursor) (aref bgc 2)))
 501
 502     (XCreateGlyphCursor (xwem-dpy) cursor)
 503     cursor))
 504
 505 ;;;###xwem-autoload
 506 (defun xwem-cursor-recolorize (cursor new-fg &optional new-bg)
 507   "Recolorize CURSOR to use NEW-FG foreground and NEW-BG background."
 508   (let ((fgc (xwem-misc-colorspec->rgb-vector-safe
 509               new-fg (vector (X-Cursor-fgred cursor)
 510                              (X-Cursor-fggreen cursor)
 511                              (X-Cursor-fgblue cursor))))
 512         (bgc (xwem-misc-colorspec->rgb-vector-safe
 513               new-bg (vector (X-Cursor-bgred cursor)
 514                              (X-Cursor-bggreen cursor)
 515                              (X-Cursor-bgblue cursor)))))
 516     (XRecolorCursor (xwem-dpy) cursor
 517                     (aref fgc 0) (aref fgc 1) (aref fgc 2)
 518                     (aref bgc 0) (aref bgc 1) (aref bgc 2))))
 519
 520 (defun xwem-cursors-init ()
 521   "Initialize cursors."
 522   (unless xwem-cursor-fnt
 523     ;; Make cursors
 524     (xwem-message 'init "Initializing cursors ...")
 525
 526     (setq xwem-cursor-fnt (make-X-Font :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
 527                                        :name "cursor"))
 528     (XOpenFont (xwem-dpy) xwem-cursor-fnt)
 529
 530     (setq xwem-cursor-default (xwem-make-cursor
 531                                xwem-cursor-default-shape
 532                                xwem-cursor-default-foreground-color
 533                                xwem-cursor-default-background-color)
 534           xwem-cursor-left (xwem-make-cursor
 535                             X-XC-left_ptr
 536                             xwem-cursor-default-foreground-color
 537                             xwem-cursor-default-background-color)
 538           xwem-cursor-right (xwem-make-cursor
 539                              X-XC-right_ptr
 540                              xwem-cursor-default-foreground-color
 541                              xwem-cursor-default-background-color)
 542           xwem-cursor-wait (xwem-make-cursor
 543                             xwem-cursor-wait-shape
 544                             xwem-cursor-wait-foreground-color
 545                             xwem-cursor-wait-background-color)
 546           xwem-cursor-move (xwem-make-cursor
 547                             xwem-cursor-move-shape
 548                             xwem-cursor-move-foreground-color
 549                             xwem-cursor-move-background-color)
 550           xwem-cursor-resize (xwem-make-cursor
 551                               xwem-cursor-resize-shape
 552                               xwem-cursor-resize-foreground-color
 553                               xwem-cursor-resize-background-color)
 554           xwem-cursor-quote (xwem-make-cursor
 555                              xwem-cursor-quote-shape
 556                              xwem-cursor-quote-foreground-color
 557                              xwem-cursor-quote-background-color)
 558           xwem-cursor-help (xwem-make-cursor
 559                             xwem-cursor-help-shape
 560                             xwem-cursor-help-foreground-color
 561                             xwem-cursor-help-background-color))
 562
 563     (xwem-message 'init "Initializing cursors ... done")))
 564
 565 ;;; Misc drawing
 566 ;;;###xwem-autoload
 567 (defun xwem-misc-draw-shadow (dpy win gc1 gc2 x y w h thick)
 568   "Draw shadow."
 569   (let ((offset 0)
 570         s1 s2)
 571     (if (or (> (* thick 2) h) (> (* thick 2) w))
 572         nil                             ; undrawable
 573       (while (not (= thick offset))
 574         (setq s1 (cons (cons (make-X-Point :xx (+ x offset)
 575                                            :yy (+ y offset))
 576                              (make-X-Point :xx (+ x offset)
 577                                            :yy (- (+ y h) offset 1)))
 578                        s1))
 579         (setq s1 (cons (cons (make-X-Point :xx (+ x offset)
 580                                            :yy (+ y offset))
 581                              (make-X-Point :xx (- (+ x w) offset 1)
 582                                            :yy (+ y offset)))
 583                        s1))
 584
 585         (setq s2 (cons (cons (make-X-Point :xx (+ x offset)
 586                                            :yy (- (+ y h) offset 1))
 587                              (make-X-Point :xx (- (+ x w) offset 1)
 588                                            :yy (- (+ y h) offset 1)))
 589                        s2))
 590         (setq s2 (cons (cons (make-X-Point :xx (- (+ x w) offset 1)
 591                                            :yy (+ y offset 1))
 592                              (make-X-Point :xx (- (+ x w) offset 1)
 593                                            :yy (- (+ y h) offset 1)))
 594                        s2))
 595
 596         (setq offset (+ offset 1)))
 597
 598       (when s1
 599         (XDrawSegments dpy win gc1 s1))
 600       (when s2
 601         (XDrawSegments dpy win gc2 s2))
 602       )))
 603
 604 ;;;###xwem-autoload
 605 (defun xwem-misc-draw-bar (dpy win gc1 gc2 gc3 x y w h th)
 606   "Draw shadowed bar.
 607 Bar filled with GC1.
 608 Shadow thickness is TH and it is drawed with GC2 and GC3."
 609   (xwem-debug 'xwem-misc "Draw bar .. x=%d y=%d w=%d h=%d" 'x 'y 'w 'h)
 610
 611   (xwem-misc-draw-shadow dpy win gc2 gc3 x y w h th)
 612   (XFillRectangle dpy win gc1 (+ x th) (+ y th)
 613                   (- w (* th 2)) (- h (* th 2))))
 614
 615 ;;;###xwem-autoload
 616 (defun xwem-misc-find-frame (name &optional frames-list)
 617   "Find Emacs frame by its NAME."
 618   (let ((fl (or frames-list (frame-list)))
 619         (rf nil))
 620
 621     (while fl
 622       (when (string= (frame-name (car fl)) name)
 623         ;; Found
 624         (setq rf (car fl))
 625         (setq fl nil))
 626       (setq fl (cdr fl)))
 627     rf))
 628
 629 ;;;###xwem-autoload
 630 (defun xwem-misc-find-emacs-frame (cl)
 631   "Return Emacs frame that corresponds CL.
 632 HACK, DO NOT USE."
 633   (let ((fr (xwem-cl-get-sys-prop cl 'emacs-frame)))
 634     (if fr
 635         (if (framep fr) fr nil)
 636
 637       ;; Not yet in cl's plist
 638       (let ((frames (frame-list))
 639             xtr)
 640
 641         (setq xtr (XQueryTree (xwem-dpy) (xwem-cl-xwin cl)))
 642         (if (car xtr)
 643             (setq xtr (mapcar 'X-Win-id (cdr (cdr (cdr (cdr xtr))))))
 644           (setq xtr nil))
 645
 646         (while (and frames
 647                     (not (member
 648                           (float (- (string-to-int
 649                                      (or (frame-property
 650                                           (car frames) 'window-id) "0")) 2))
 651                           xtr)))
 652           (setq frames (cdr frames)))
 653
 654         (if (framep (car frames))
 655             (xwem-cl-put-sys-prop cl 'emacs-frame (car frames))
 656           (xwem-cl-put-sys-prop cl 'emacs-frame 'no-emacs-frame))
 657         (car frames)))))
 658
 659 (defun xwem-misc-find-cl-by-emacs-frame (frame)
 660   "Return xwem client that holds Emacs FRAME."
 661   (let ((fid (float (- (string-to-int
 662                         (or (frame-property frame 'window-id) "0"))
 663                        2)))
 664         (clients xwem-clients)
 665         wm-class xtr rcl)
 666     (while clients
 667       (setq wm-class (xwem-hints-wm-class (xwem-cl-hints (car clients))))
 668       (when (string= (cdr wm-class) x-emacs-application-class)
 669         (setq xtr (XQueryTree (xwem-dpy) (xwem-cl-xwin (car clients))))
 670         (if (car xtr)
 671             (setq xtr (mapcar 'X-Win-id (cdr (cdr (cdr (cdr xtr))))))
 672           (setq xtr nil))
 673
 674         (when (member fid xtr)
 675           (setq rcl (car clients))
 676           (setq clients nil)))
 677
 678       (setq clients (cdr clients)))
 679     rcl))
 680
 681 ;;;###xwem-autoload
 682 (defun xwem-misc-xwin-valid-p (xwin)
 683   "Return non-nil if XWIN is valid X window.
 684 Do it in safe manner."
 685   (let (attrs)
 686     (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win t)
 687     (xwem-unwind-protect
 688         (setq attrs (XGetWindowAttributes (X-Win-dpy xwin) xwin))
 689       (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win nil))
 690     attrs))
 691
 692 (defun xwem-misc-xerr-hook (xdpy xev)
 693   "Display X errors in `xwem-minibuffer'.
 694 Error hook must not performe any interaction with X server!
 695 XDPY - X-Dpy.
 696 XEV  - X-Event of error type."
 697   (let* ((err (X-Event-xerror-code xev))
 698          (badth (X-Event-xerror-resourceid xev))
 699          (seq (X-Event-seq xev))
 700          (maj (X-Event-xerror-maj-op xev))
 701          (opfun (cdr (assq maj xlib-opcodes-alist)))
 702          (min (X-Event-xerror-min-op xev))
 703          (bstr (cond ((= err 1) "Request")
 704                      ((= err 2) "Value")
 705                      ((= err 3) "Window")
 706                      ((= err 4) "Pixmap")
 707                      ((= err 5) "Atom")
 708                      ((= err 6) "Cursor")
 709                      ((= err 7) "Font")
 710                      ((= err 8) "Match")
 711                      ((= err 9) "Drawable")
 712                      ((= err 10) "Access")
 713                      ((= err 11) "Alloc")
 714                      ((= err 12) "Color")
 715                      ((= err 13) "GC")
 716                      ((= err 14) "IDChoice")
 717                      ((= err 15) "Name")
 718                      ((= err 16) "Length")
 719                      ((= err 17) "Implementation")
 720                      ((= err 128) "FirstExtension")
 721                      ((= err 255) "LastExtension")
 722                      (t "Unknown"))))
 723     (unless (and (X-Dpy-get-property xdpy 'xwem-ignore-bad-win)
 724                  (eq err 3))
 725       (xwem-message 'error "X error - Bad %s %f seq=%f:%d ops=%d:%d/%S"
 726                     bstr badth seq (X-Dpy-rseq-id (xwem-dpy)) maj min opfun)
 727     )))
 728
 729 (defun xwem-misc-init ()
 730   "Miscellaneous initializations."
 731   (pushnew 'xwem-misc-xerr-hook (X-Dpy-error-hooks (xwem-dpy)))
 732   (xwem-cursors-init)
 733
 734   (xwem-message 'init "Initializing masking ...")
 735   ;; Depth 1 pixmap, gcs
 736   (setq xwem-misc-mask-pixmap
 737         (XCreatePixmap (xwem-dpy)
 738                        (make-X-Pixmap :dpy (xwem-dpy)
 739                                       :id (X-Dpy-get-id (xwem-dpy)))
 740                        (xwem-rootwin) 1 1 1)
 741         xwem-misc-mask-fgc
 742         (XCreateGC (xwem-dpy) xwem-misc-mask-pixmap
 743                    (make-X-Gc :dpy (xwem-dpy)
 744                               :id (X-Dpy-get-id (xwem-dpy))
 745                               :foreground 1.0
 746                               :background 0.0))
 747         xwem-misc-mask-bgc
 748         (XCreateGC (xwem-dpy) xwem-misc-mask-pixmap
 749                    (make-X-Gc :dpy (xwem-dpy)
 750                               :id (X-Dpy-get-id (xwem-dpy))
 751                               :foreground 0.0
 752                               :background 1.0)))
 753   (xwem-message 'init "Initializing masking ... done"))
 754
 755 ;;; Stuff for debugging
 756 (defun xwem-misc-str2hexstr (str)
 757   "Convert STR to hexidecimal string representation."
 758   (substring (mapconcat #'(lambda (el) (format "%x " el)) str "") 0 -1))
 759
 760 ;;; Messaging
 761 (defun xwem-str-with-faces (str face-list)
 762   "Return STR with applied FACE-LIST."
 763   (let ((ext (make-extent 0 (length str) str)))
 764
 765     (set-extent-property ext 'duplicable t)
 766     (set-extent-property ext 'unique t)
 767     (set-extent-property ext 'start-open t)
 768     (set-extent-property ext 'end-open t)
 769     (set-extent-property ext 'face face-list))
 770   str)
 771
 772 (defun xwem-format-faces (fmt def-face &rest args)
 773   "Accepts format FMT and ARGS in form `((arg . face) ...)'.
 774 DEF-FACE is default face. Returns string with faces."
 775   (let ((flst (string-to-list fmt))
 776         (chr nil)
 777         (rstr ""))
 778     (while flst
 779       (setq chr (car flst))
 780       (cond ((= chr ?%)
 781              (setq flst (cdr flst))
 782              (setq chr (car flst))
 783              (let ((arg (if (consp (car args)) (caar args) (car args)))
 784                    (fcs (if (consp (car args)) (cdr (car args)) nil)))
 785                (cond ((= chr ?s)
 786                       (setq rstr (concat
 787                                   rstr
 788                                   (xwem-str-with-faces
 789                                    arg
 790                                    (if fcs
 791                                        (list fcs def-face)
 792                                      (list def-face)))))
 793                       (setq args (cdr args)))
 794
 795                      ((= chr ?d)
 796                       (setq rstr (concat
 797                                   rstr
 798                                   (xwem-str-with-faces
 799                                    (int-to-string arg)
 800                                    (if fcs
 801                                        (list fcs def-face)
 802                                      (list def-face)))))
 803                       (setq args (cdr args)))
 804                      (t nil))))
 805             (t
 806              (setq rstr
 807                    (concat rstr
 808                            (xwem-str-with-faces
 809                             (char-to-string chr) (list def-face))))))
 810       (setq flst (cdr flst)))
 811     rstr))
 812
 813 (defun xwem-message-log (label message)
 814   "Log MESSAGE in `xwem-messages-buffer-name' buffer."
 815   (unless (memq label xwem-messages-ignore-labels)
 816     (with-current-buffer (get-buffer-create xwem-messages-buffer-name)
 817       (let ((inhibit-read-only t))
 818         ;; Remove all messages from buffer if it exided maximum value
 819         (when (> (count-lines (point-min) (point-max))
 820                  xwem-messages-buffer-lines)
 821           (delete-region (point-min) (point-max)))
 822
 823         (goto-char (point-max))
 824         (insert (format-time-string "%D %T: "))
 825         (insert message)
 826         (insert "\n")))))
 827
 828 ;;;###xwem-autoload
 829 (defun xwem-clear-message (&optional label)
 830   "Clear xwem minibuffer's buffer."
 831   (clear-message label (xwem-minib-frame xwem-minibuffer)))
 832
 833 (defun xwem-message-insert (label msg &optional append-p)
 834   "Insert message MSG into xwem minibuffer's buffer."
 835   ;; Workaround XEmacs ''feature''.  When minibuffer is activated,
 836   ;; and someone uses echo are, XEmacs will wait 2 seconds, so we
 837   ;; will got lag! (see DEFUN `command-loop-1' in cmdloop.c) --lg
 838   ;;
 839   ;;   However in newer XEmacsen there is
 840   ;;   `minibuffer-echo-wait-function' variable, which controls
 841   ;;   behaviour. --lg
 842   (when (zerop (minibuffer-depth))
 843     ;; Activate minibuffer, if not ignoring this label
 844     (when (and xwem-minibuffer
 845                (xwem-minib-cl xwem-minibuffer)
 846                (not (memq label xwem-messages-ignore-labels)))
 847       (xwem-activate (xwem-minib-cl xwem-minibuffer)))
 848     (add-to-list 'log-message-ignore-labels label) ; avoid logging in *Messages*
 849     (if append-p
 850         (append-message label msg
 851                         (and xwem-minibuffer
 852                              (xwem-minib-frame xwem-minibuffer)))
 853       (display-message label msg
 854                        (and xwem-minibuffer
 855                             (xwem-minib-frame xwem-minibuffer))))))
 856
 857 (defun xwem-message-label-prefix (label)
 858   "Return prefix string, according to LABEL.
 859 Return nil if no prefix required for label."
 860   (let ((lp (assq label xwem-messages-label-prefixes)))
 861     (when lp
 862         (concat "XWEM" (if (and (stringp (cadr lp))
 863                                 (not (zerop (length (cadr lp)))))
 864                            "-" "")
 865                 (funcall 'xwem-str-with-faces (cadr lp) (caddr lp))
 866                 ": "))))
 867
 868 (defun xwem-message-maybe-beep (label)
 869   "If LABEL is beepable, then beep."
 870   ;; Beep if needed
 871   (let ((snd (assq label xwem-messages-beeps-alist)))
 872     (when snd
 873       (xwem-play-sound (cdr snd)))))
 874
 875 (defun xwem-message-1 (label fmt append-p &rest args)
 876   (let* ((print-level 3)                ; XXX limit print level
 877          (msg (if (eq label 'asis) fmt (apply 'format fmt args)))
 878         (lp (xwem-message-label-prefix label)))
 879     (when lp
 880       (setq msg (concat lp msg)))
 881     (xwem-message-log label msg)
 882     (xwem-message-maybe-beep label)
 883
 884     (xwem-message-insert label msg append-p)))
 885
 886 (defun xwem-message-append (label fmt &rest args)
 887   "Append message of LABEL type.
 888 Message formatted using FTM and ARGS."
 889   (apply 'xwem-message-1 label fmt t args))
 890
 891 ;;;###xwem-autoload
 892 (defun xwem-message (label fmt &rest args)
 893   "Display xwem message of TYPE using FMT format."
 894   (apply 'xwem-message-1 label fmt nil args))
 895
 896 ;;;###autoload(autoload 'xwem-show-message-log "xwem-misc" nil t)
 897 (define-xwem-command xwem-show-message-log (arg)
 898   "Show `xwem-messages-buffer-name'.
 899 If prefix ARG is given, than behaviour is undefined."
 900   (xwem-interactive "P")
 901
 902   (let ((mbuf (get-buffer-create xwem-messages-buffer-name)))
 903     (xwem-special-popup-frame mbuf)
 904     (with-current-buffer mbuf
 905       (setq mode-name "XWEM-log")
 906       (local-set-key (kbd "q") 'delete-frame)
 907       (xwem-message 'msg "Press `q' to eliminate buffer.")
 908       )))
 909
 910 (defun xwem-list-to-string (list len)
 911   "Convert LIST of characterters to string with length LEN."
 912   (let ((rstr ""))
 913     (while (and list (> len 0))
 914       (setq rstr (concat rstr (string (car list))))
 915       (setq list (cdr list))
 916       (setq len (1- len)))
 917     rstr))
 918
 919 ;;;; Misc commands.
 920 ;;;###autoload(autoload 'xwem-ignore-command "xwem-misc" nil t)
 921 (define-xwem-command xwem-ignore-command (&rest args)
 922   "Generic ignore command."
 923   (xwem-interactive))
 924
 925 (defvar xwem-read-expression-history nil
 926   "*History of expressions evaled using `xwem-eval-expression'.")
 927
 928 ;;;###autoload(autoload 'xwem-eval-expression "xwem-misc" nil t)
 929 (define-xwem-command xwem-eval-expression (expr &optional arg)
 930   "Eval Lisp expression interactively.
 931 When used with prefix ARG, then insert the result into selected client."
 932   (xwem-interactive
 933    (list
 934     (xwem-read-from-minibuffer (if xwem-prefix-arg
 935                                    "XWEM (insert) Eval: "
 936                                  "XWEM Eval: ")
 937                                nil read-expression-map
 938                                t 'xwem-read-expression-history)
 939     xwem-prefix-arg))
 940
 941   (setq values (cons (eval expr) values))
 942   (if arg
 943       (xwem-kbd-add-pending-keys (prin1-to-string (car values)))
 944     (xwem-deffered-funcall
 945      'xwem-message 'info "%S => %S" expr (car values))))
 946
 947 ;;;###autoload(autoload 'xwem-execute-extended-command "xwem-misc" nil t)
 948 (define-xwem-command xwem-execute-extended-command (arg)
 949   "Execute Emacs command.
 950 Prefix ARG is passed to extended command."
 951   (xwem-interactive "P")
 952
 953   (with-xwem-read-from-minibuffer
 954    (let ((xwem-prefix-arg arg))
 955      (execute-extended-command arg))))
 956
 957 ;;;###autoload(autoload 'xwem-shell-command "xwem-misc" nil t)
 958 (define-xwem-command xwem-shell-command (command arg)
 959   "Execute shell command, just as `shell-command' do.
 960 If prefix ARG is given insert result to current client.
 961 If output of COMMAND fits to one string it is displayed in
 962 `xwem-minibuffer', if not Emacs special frame will be poped up with
 963 contents of COMMAND output.
 964 If double prefix ARG \(i.e. \\<xwem-global-map>\\[xwem-universal-argument] \\<xwem-global-map>\\[xwem-universal-argument]\) supplied, then last
 965 '\\n' character will be cuted in output to current client."
 966   (xwem-interactive (list (xwem-read-external-command
 967                            (if xwem-prefix-arg
 968                                (if (> (prefix-numeric-value xwem-prefix-arg) 4)
 969                                    "XWEM (insert-nonl) shell command: "
 970                                  "XWEM (insert) shell command: ")
 971                              "XWEM shell command: "))
 972                           xwem-prefix-arg))
 973
 974   ;; Create temporary buffer for shell command output
 975   (let ((tbuf (get-buffer-create (generate-new-buffer-name " *temp-buf*")))
 976         (dontkill nil)
 977         status)
 978     (unwind-protect
 979         (with-current-buffer tbuf
 980           (setq status (call-process shell-file-name nil tbuf nil
 981                                      shell-command-switch command))
 982           (cond (arg
 983                  (xwem-kbd-add-pending-keys
 984                   (buffer-substring
 985                    (point-min) (- (point-max)
 986                                   (if (> (prefix-numeric-value arg) 4) 1 0)))))
 987                 ((= (point-max) (point-min))
 988                  (xwem-message 'info "Process exit status: %d" status))
 989                 ((= 1 (count-lines (point-min) (point-max)))
 990                  (xwem-message 'info (buffer-substring (point-min) (point-max))))
 991                 (t
 992                  (xwem-special-popup-frame tbuf)
 993                  (setq dontkill t))))
 994       (unless dontkill
 995         (kill-buffer tbuf)))))
 996
 997 ;;;###autoload(autoload 'xwem-mini-calc "xwem-misc" nil t)
 998 (define-xwem-command xwem-mini-calc (expr &optional arg)
 999   "Calculate expression EXPR.
1000 If prefix ARG is given, insert the result to current client."
1001   (xwem-interactive
1002    (list (xwem-read-from-minibuffer (if xwem-prefix-arg
1003                                         "XWEM (insert) Calc: "
1004                                       "XWEM Calc: "))
1005          xwem-prefix-arg))
1006
1007   (let ((result (calc-eval expr)))
1008     (if arg
1009         (xwem-kbd-add-pending-keys result)
1010       (xwem-message 'info "%s = %s" expr result))))
1011
1012 ;;;###autoload(autoload 'xwem-misc-make-screenshot "xwem-misc" nil t)
1013 (define-xwem-command xwem-misc-make-screenshot (file-name &optional arg)
1014   "Make screen screenshot and save it to file with NAME.
1015 If used with prefix ARG - import screenshot of current client window.
1016
1017 With double ARG (H-u H-u) - import screenshot of current client with
1018 frame included.
1019
1020 NOTE: `xwem-misc-make-screenshot' uses \"import\" utility from
1021 ImageMagic package, which you can obtain at
1022 http://imagemagick.sourceforge.net/."
1023   (xwem-interactive "FImport screen to file: \nP")
1024
1025   (flet ((message (fmt &rest args) nil)) ; XXX shutup messaging
1026     (xwem-message 'info
1027                   (format "Importing screenshot to %s." file-name))
1028     (xwem-add-hook-post-deffering
1029      `(lambda ()
1030         (xwem-execute-program
1031          (format "import -window 0x%x %s %s"
1032                  ,(X-Win-id (if arg
1033                                 (xwem-cl-xwin (xwem-cl-selected))
1034                               (xwem-rootwin)))
1035                  ,(if (equal arg '(16)) "-frame" "")
1036                  ,(expand-file-name file-name)))))))
1037
1038 ;;;###autoload(autoload 'xwem-misc-pause "xwem-misc" nil t)
1039 (define-xwem-command xwem-misc-pause (arg)
1040   "Pause for ARG decaseconds(0.1 sec).
1041 This command is usefull, when recording keyboard macro, and there need
1042 to wait for something, f.e. window mapping."
1043   (xwem-interactive "p")
1044
1045   (add-timeout (* 0.1 arg) (lambda (&rest args) (exit-recursive-edit)) nil)
1046   (recursive-edit))
1047
1048 ;;; Some useful operations on lists
1049 (defun xwem-insert-after (list aft-el el)
1050   "In LIST after AFT-EL insert EL."
1051   (push el (cdr (member aft-el list)))
1052   list)
1053
1054 (defun xwem-insert-before (list bef-el el)
1055   "In LIST before BEF-EL insert EL."
1056   (nreverse (xwem-insert-after (nreverse list) bef-el el)))
1057
1058 (defun xwem-list-set-element (list old-el new-el)
1059   "In LIST set OLD-EL to NEW-EL."
1060   (setcar (memq old-el list) new-el)
1061   list)
1062
1063 ;;;###xwem-autoload
1064 (defun xwem-list-exchange-els (list el1 el2)
1065   "In LIST exchange places of EL1 and EL2."
1066   (when (and (memq el1 list)
1067              (memq el2 list)
1068              (not (eq el1 el2)))
1069     (xwem-list-set-element list el1 'this-fake-name1-should-not-be-in-list)
1070     (xwem-list-set-element list el2 el1)
1071     (xwem-list-set-element list 'this-fake-name1-should-not-be-in-list el2))
1072   list)
1073
1074 ;;; Profiling support
1075 ;;;###autoload
1076 (defun xwem-misc-start-profiling ()
1077   "Start profiling critical xlib/xwem functions."
1078   (interactive)
1079
1080   (setq elp-function-list
1081         (or xwem-misc-functions-to-profile
1082             ;; Profile all X-Dpy-XXX functions
1083             (delq nil (mapcar #'(lambda (el)
1084                                   (when (and (symbolp el)
1085                                              (functionp el)
1086                                              (string-match "X-Dpy-"
1087                                                            (symbol-name el)))
1088                                     el))
1089                               obarray))))
1090   (elp-instrument-list))
1091
1092 ;;;###autoload
1093 (defun xwem-misc-profiling-results ()
1094   "Show xlib/xwem profiling results."
1095   (interactive)
1096
1097   (elp-results))
1098
1099 ;;;###xwem-autoload
1100 (defun xwem-recursive-edit ()
1101   "Enter recursive edit."
1102   (recursive-edit))
1103
1104 ;;;###xwem-autoload
1105 (defun xwem-exit-recursive-edit ()
1106   "Exit from recursive edit."
1107   (if (> (recursion-depth) 0)
1108       (throw 'exit nil))
1109   (xwem-message 'warning "No recursive edit is in progress"))
1110
1111
1112 ;;; Text Specifications operations
1113
1114 ;; TextSpec is list of vectors:
1115 ;; - vectors elements is cons cells in form (face . "text")
1116 ;; - each vector specifies line
1117 ;; - empty vector specifies newline
1118
1119 (defun xwem-misc-line->linesp (default-face)
1120   "Convert current line in selected buffer to element of text spec - line spec.
1121 DEFAULT-FACE is the default face."
1122   (let (tsp cpnt npnt face str)
1123     (save-excursion
1124       (narrow-to-region (point-at-bol) (point-at-eol))
1125       (goto-char (point-at-bol))
1126       (while (not (eolp))
1127         (setq cpnt (point)
1128               npnt (or (next-single-property-change cpnt 'face) (point-at-eol))
1129               face (or (get-char-property cpnt 'face) default-face)
1130               str (buffer-substring cpnt npnt))
1131         (when (consp face)
1132           (setq face (car face)))       ; XXX need face merging
1133
1134         ;; XXX Untabify
1135         (setq str (replace-in-string str "\t" (make-string tab-width ?\x20)))
1136
1137         (setq tsp (cons (cons face str) tsp))
1138         (goto-char npnt))
1139       (widen))
1140     (vconcat (nreverse (or tsp (list (cons default-face "")))))))
1141
1142 (defun xwem-misc-buffer->textsp (default-face &optional buffer start end)
1143   "Convert BUFFER to text specification.
1144 DEFAULT-FACE is the default face.
1145 If BUFFER is omitted, selected buffer assumed."
1146   (let (rlst)
1147     (save-excursion
1148       (when buffer
1149         (set-buffer buffer))
1150
1151       (goto-char (or start (point-min)))
1152       (while (and (not (eobp))
1153                   (< (point) (or end (point-max))))
1154         (setq rlst (cons (xwem-misc-line->linesp default-face) rlst))
1155         (forward-line 1))
1156       )
1157     (nreverse rlst)))
1158
1159 (defun xwem-misc-linesp-width (linesp)
1160   "Return width of line spec LINESP."
1161   (apply '+ (mapcar #'(lambda (el)
1162                         (X-Text-width
1163                          (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
1164                          (cdr el)))
1165                     linesp)))
1166
1167 (defun xwem-misc-linesp-height (linesp)
1168   "Return height of line spec LINESP."
1169   (apply 'max (mapcar #'(lambda (el)
1170                           (X-Text-height
1171                            (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
1172                            (cdr el)))
1173                       linesp)))
1174
1175 (defun xwem-misc-linesp-show (d x y linesp &optional type default-background)
1176   "In X drawable D at X and Y coordinates show line spec LINESP.
1177 TYPE is one of XImageString or XDrawString, default is XImageString."
1178   (let ((cxoff 0))
1179     (mapc #'(lambda (el)
1180               (funcall (cond ((and (eq type 'XDrawString)
1181                                    (stringp default-background)
1182                                    (not (string= default-background
1183                                                  (face-background-name (car el)))))
1184                               'XImageString)
1185                              ((not (null type)) type)
1186                              (t 'XImageString))
1187                        (X-Drawable-dpy d) d
1188                        (xwem-face-get-gc (car el))
1189                        (+ x cxoff) y (cdr el))
1190               (setq cxoff (+ cxoff (X-Text-width
1191                                     (X-Drawable-dpy d)
1192                                     (X-Gc-font (xwem-face-get-gc (car el)))
1193                                     (cdr el)))))
1194           linesp)))
1195
1196 (defun xwem-misc-textsp-show (xwin x y textsp &optional type default-background)
1197   "In x window XWIN at X and Y coordinates show text spec TEXTSP.
1198 TYPE is one of XImageString or XDrawString, default is XImageString.
1199 If TYPE is XDrawString and DEFAULT-BACKGROUND is specifed, characters
1200 that have different than DEFAULT-BACKGROUND baground color are drawed
1201 using XImageString."
1202   (let ((yoff 0))
1203     (mapc #'(lambda (el)
1204               (xwem-misc-linesp-show xwin x (+ y yoff) el type default-background)
1205               (setq yoff (+ yoff (xwem-misc-linesp-height el))))
1206           textsp)
1207     ))
1208
1209 ;;; Outlining
1210 (define-xwem-face xwem-misc-outline-face1
1211   `((t (:foreground "white" :background "black"
1212         :function X-GXXor :subwindow-mode X-IncludeInferiors
1213         :line-width 4)))
1214   "Face used to outline something."
1215   :group 'xwem-misc
1216   :group 'xwem-faces)
1217
1218 (define-xwem-face xwem-misc-outline-face2
1219   `((t (:foreground "white" :background "black"
1220         :function X-GXXor :subwindow-mode X-IncludeInferiors
1221         :line-width 2)))
1222   "Face used to outline something."
1223   :group 'xwem-misc
1224   :group 'xwem-faces)
1225
1226 (defun xwem-misc-outline (xrect how &optional xwin)
1227   "Outline XRECT using HOW method in XWIN.
1228 Valid HOW is 'normal, ...
1229 If XWIN is not specified, X root window is used."
1230   (unless xwin
1231     (setq xwin (xwem-rootwin)))
1232
1233   (let ((x (X-Rect-x xrect))
1234         (y (X-Rect-y xrect))
1235         (w (X-Rect-width xrect))
1236         (h (X-Rect-height xrect)))
1237     (cond ((eq how 'normal)
1238            (XDrawRectangles
1239             (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face1)
1240             (list xrect)))
1241
1242           ((eq how 'contiguous)
1243            (xwem-misc-outline xrect 'normal)
1244            (XDrawSegments
1245             (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face2)
1246             (list (cons (cons x 0)
1247                         (cons x (X-Geom-height (xwem-rootgeom))))
1248                   (cons (cons (+ x w) 0)
1249                         (cons (+ x w) (X-Geom-height (xwem-rootgeom))))
1250                   (cons (cons 0 y)
1251                         (cons (X-Geom-width (xwem-rootgeom)) y))
1252                   (cons (cons 0 (+ y h))
1253                         (cons (X-Geom-width (xwem-rootgeom)) (+ y h)))
1254                   )))
1255
1256           ((eq how 'corners)
1257            (let* ((cornw (/ w 8))
1258                   (cornh (/ h 8))
1259                   (crw (/ (+ cornh cornw) 2)))
1260              (XDrawSegments
1261               (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face1)
1262               (list
1263                ;; Top left
1264                (cons (cons x y) (cons (+ x cornw) y))
1265                (cons (cons x y) (cons x (+ y cornh)))
1266
1267                ;; Top right
1268                (cons (cons (+ x w) y) (cons (+ x w (- cornw)) y))
1269                (cons (cons (+ x w) y) (cons (+ x w) (+ y cornh)))
1270
1271                ;; Bottom left
1272                (cons (cons x (+ y h)) (cons (+ x cornw) (+ y h)))
1273                (cons (cons x (+ y h)) (cons x (+ y h (- cornh))))
1274
1275                ;; Bottom right
1276                (cons (cons (+ x w) (+ y h)) (cons (+ x w (- cornw)) (+ y h)))
1277                (cons (cons (+ x w) (+ y h)) (cons (+ x w) (+ y h (- cornh))))
1278
1279                ;; Crosshair
1280                (cons (cons (+ x (/ (- w crw) 2)) (+ y (/ h 2)))
1281                      (cons (+ x (/ (+ w crw) 2)) (+ y (/ h 2))))
1282                (cons (cons (+ x (/ w 2)) (+ y (/ (- h crw) 2)))
1283                      (cons (+ x (/ w 2)) (+ y (/ (+ h crw) 2))))
1284                ))))
1285
1286           ((eq how 'grid)
1287            (xwem-misc-outline xrect 'normal)
1288            (XDrawSegments
1289             (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face2)
1290             (nconc (funcall
1291                     #'(lambda ()
1292                         (let ((off 0) rl)
1293                           (while (< off (+ x w))
1294                             (when (> off x)
1295                               (setq rl (cons (cons (cons off y)
1296                                                    (cons off (+ y h)))
1297                                              rl)))
1298                             (setq off (+ off 64)))
1299                           rl)))
1300                    (funcall #'(lambda ()
1301                                 (let ((off 0)
1302                                       rl)
1303                                   (while (< off (+ y h))
1304                                     (when (> off y)
1305                                       (setq rl (cons (cons (cons x off)
1306                                                            (cons (+ x w) off))
1307                                                      rl)))
1308                                     (setq off (+ off 64)))
1309                                   rl)))))
1310            )
1311
1312           ;; TODO: add others
1313           )))
1314
1315 (defun xwem-misc-move-outline (rect1 rect2 &optional steps)
1316   "Move RECT1 to RECT2 by STEPS redraws.
1317 Somekind of animation.  XEmacs will block while moving.
1318 Default STEPS is 40."
1319   (unless steps
1320     (setq steps 40))
1321
1322   (xwem-misc-outline rect1 'normal)
1323   (let ((crect rect1) tcrect
1324         factor x-step y-step w-step h-step
1325         done)
1326
1327     ;; Setup steps
1328     (setq x-step (/ (- (X-Rect-x rect2) (X-Rect-x rect1))
1329                     steps)
1330           y-step (/ (- (X-Rect-y rect2) (X-Rect-y rect1))
1331                     steps)
1332           w-step (/ (- (X-Rect-width rect2) (X-Rect-width rect1))
1333                     steps)
1334           h-step (/ (- (X-Rect-height rect2) (X-Rect-height rect1))
1335                     steps)
1336           factor (max x-step y-step w-step h-step))
1337
1338     (while (not done)
1339       ;; Remember CRECT before modification
1340       (setq tcrect (copy-X-Rect crect))
1341
1342       ;; Transforme CRECT
1343       (incf (X-Rect-x crect) x-step)
1344       (incf (X-Rect-width crect) w-step)
1345       (incf (X-Rect-y crect) y-step)
1346       (incf (X-Rect-height crect) h-step)
1347
1348       ;; break condition
1349       (when (and (<= (abs (- (X-Rect-width crect)
1350                              (X-Rect-width rect2))) factor))
1351         (setq done t))
1352
1353       ;; Outline CRECT
1354       (xwem-misc-outline tcrect 'normal)
1355       (xwem-misc-outline crect 'normal))
1356     (xwem-misc-outline crect 'normal)))
1357
1358 ;;;###xwem-autoload
1359 (defun xwem-misc-xwin-background-mode (xwin x y &optional width height)
1360   "Return XWIN's background mode in rectange WIDTHxHEIGHT+X+y.
1361 Background mode is one of `light' or `dark'."
1362   (let ((xgeom (XGetGeometry (xwem-dpy) xwin)))
1363     ;; Adjust x/y/width/height
1364     (when (< x 0)
1365       (setq x 0))
1366     (when (< y 0)
1367       (setq y 0))
1368     (when (and width (< width 0))
1369       (setq width nil))
1370     (when (and height (< height 0))
1371       (setq height nil))
1372
1373     (unless width
1374       (setq width 10))
1375     (unless height
1376       (setq height 10))
1377     (when (> width (X-Geom-width xgeom))
1378       (setq width (X-Geom-width xgeom)))
1379     (when (> height (X-Geom-height xgeom))
1380       (setq height (X-Geom-height xgeom)))
1381     (when (> x (X-Geom-width xgeom))
1382       (setq x (- (X-Geom-width xgeom) width)))
1383     (when (> y (X-Geom-height xgeom))
1384       (setq y (- (X-Geom-height xgeom) height))))
1385
1386   (let* ((ximg (XImageGet (xwem-dpy) xwin x y width height))
1387          (cv (nth 3 (XQueryColors (xwem-dpy) (XDefaultColormap (xwem-dpy))
1388                                   (mapcan 'identity (X-Image-get-prop ximg 'px-layout)))))
1389          (vv (/ (apply '+ (apply 'nconc cv)) (length cv))))
1390
1391     (XDestroyImage ximg)
1392     (if (< vv xwem-background-mode-bound)
1393         'dark 'light)))
1394
1395 ;;;###xwem-autoload
1396 (defun xwem-misc-completing-read-using-iswitchb
1397   (prompt table &optional predicate require-match)
1398   "Read a string in the xwem minibuffer using iswitchb package.
1399 PROMPT is a string to prompt with.
1400 TABLE is a list of strings to select.
1401 PREDICATE is a function that limits completion to a subset of TABLE."
1402   (require 'iswitchb)
1403
1404   (flet ((iswitchb-make-buflist
1405            (default)
1406            (setq iswitchb-buflist table)))
1407     (iswitchb-read-buffer prompt)))
1408
1409 ;;;###xwem-autoload
1410 (defun xwem-misc-xbutton-cl (xev)
1411   "Return client where button event XEV occured."
1412   (or (xwem-xwin-cl (X-Event-xbutton-event xev))
1413       (and (X-Win-p (X-Event-xbutton-child xwem-last-xevent))
1414            (xwem-xwin-cl (X-Event-xbutton-child xwem-last-xevent)))))
1415
1416 \f
1417 (defun xwem-misc-iresize-or-imove (xwin xevent function argument)
1418   "Interactively resize of move window XWIN according to X event XEVENT.
1419 FUNCTION called each time with three
1420 arguments - ARGUMENT, NEW-X, NEW-Y."
1421   (let* ((nh (XGetWMNormalHints (xwem-dpy) xwin))
1422          (min-pnt (or (and (X-WMSize-pminsize-p nh)
1423                            (cons (X-WMSize-min-width nh)
1424                                  (X-WMSize-min-height nh)))
1425                       (cons 0 0)))
1426          (base-pnt (or (and (X-WMSize-pbasesize-p nh)
1427                             (cons (X-WMSize-base-width nh)
1428                                   (X-WMSize-base-height nh)))
1429                        min-pnt))
1430          (step-pnt (or (and (X-WMSize-presizeinc-p nh)
1431                             (cons (X-WMSize-width-inc nh)
1432                                   (X-WMSize-height-inc nh)))
1433                        (cons 1 1)))
1434
1435          (srx (X-Event-xbutton-root-x xevent))
1436          (sry (X-Event-xbutton-root-y xevent))
1437
1438          (done nil)
1439          need-call xev
1440          last-x last-y new-x new-y)
1441
1442     (xwem-mouse-grab xwem-cursor-move xwin
1443                      (Xmask-or XM-ButtonRelease XM-ButtonMotion))
1444     (xwem-unwind-protect
1445         (while (not done)
1446           (setq need-call nil)
1447           (X-Event-CASE (setq xev (xwem-next-event))
1448             (:X-ButtonRelease (setq done t))
1449
1450             (:X-MotionNotify
1451              ;; Update curr-xrect
1452              (setq new-x (X-Event-xmotion-root-x xev)
1453                    new-y (X-Event-xmotion-root-y xev))
1454
1455              (when (zerop (% (- (- new-x srx)
1456                                 (car base-pnt))
1457                              (car step-pnt)))
1458                ;; Can resize
1459                (setq last-x (- new-x srx)
1460                      need-call t))
1461
1462              (when (zerop (% (- (- new-y sry)
1463                                 (cdr base-pnt))
1464                              (cdr step-pnt)))
1465                (setq last-y (- new-y sry)
1466                      need-call t))
1467
1468              ;; Call function
1469              (when need-call
1470                (funcall function argument last-x last-y)))))
1471       (xwem-mouse-ungrab))))
1472
1473 ;;;###xwem-autoload
1474 (defun xwem-misc-fixup-string (str &optional max-width)
1475   "Fixup STR to be no-more than MAX-WIDTH chars."
1476   (if (and max-width (> (length str) max-width))
1477       (substring str 0 max-width)
1478     str))
1479
1480 ;;;###xwem-autoload
1481 (defun xwem-misc-merge-plists (plist1 merg-plist)
1482   "Merge plist entries on MERG-PLIST to PLIST1 and return resulting plist."
1483   (while merg-plist
1484     (setq plist1 (plist-put plist1 (car merg-plist) (cadr merg-plist)))
1485     (setq merg-plist (cddr merg-plist)))
1486   plist1)
1487
1488
1489 ;;; Huge hack, since non-mule XEmacs 21.4 does not know anything about
1490 ;;; UTF-8 :(
1491 (defvar xwem-misc-utf8-koi8-table
1492  (list [#x10 ?á] [#x11 ?â] [#x12 ?÷] [#x13 ?ç] [#x14 ?ä] [#x15 ?å]
1493        [#x16 ?ö] [#x17 ?ú] [#x18 ?é] [#x19 ?ê] [#x1A ?ë] [#x1B ?ì]
1494        [#x1C ?í] [#x1D ?î] [#x1E ?ï] [#x1F ?ð]
1495
1496        [#x20 ?ò] [#x21 ?ó] [#x22 ?ô] [#x23 ?õ] [#x24 ?æ] [#x25 ?è]
1497        [#x26 ?ã] [#x27 ?þ] [#x28 ?û] [#x29 ?ý] [#x2A ??] [#x2B ?ù]
1498        [#x2C ?ø] [#x2D ?ü] [#x2E ?à] [#x2F ?ñ]
1499
1500        [#x30 ?Á] [#x31 ?Â] [#x32 ?×] [#x33 ?Ç] [#x34 ?Ä] [#x35 ?Å]
1501        [#x36 ?Ö] [#x37 ?Ú] [#x38 ?É] [#x39 ?Ê] [#x3A ?Ë] [#x3B ?Ì]
1502        [#x3C ?Í] [#x3D ?Î] [#x3E ?Ï] [#x3F ?Ð]
1503
1504        [#x40 ?Ò] [#x41 ?Ó] [#x42 ?Ô] [#x43 ?Õ] [#x44 ?Æ] [#x45 ?È]
1505        [#x46 ?Ã] [#x47 ?Þ] [#x48 ?Û] [#x49 ?ý] [#x4A ??] [#x4B ?Ù]
1506        [#x4C ?Ø] [#x4D ?Ü] [#x4E ?À] [#x4F ?Ñ]))
1507
1508 (defun xwem-misc-utf8-to-koi8-char (utf8-char)
1509   (let  ((ukl xwem-misc-utf8-koi8-table))
1510     (while (and ukl
1511                 (not (= (aref (car ukl) 0) utf8-char)))
1512       (setq ukl (cdr ukl)))
1513     (or (and ukl
1514              (aref (car ukl) 1))
1515         ??)))
1516
1517 (defun xwem-misc-utf8-to-koi8 (utf8-string)
1518   "Convert UTF8-STRING to KOI8 string.
1519
1520 Here is how UTF-8 looks like
1521
1522 1:  0xxxxxxx
1523 2:  110xxxxx 10xxxxxx
1524 3:  1110xxxx 10xxxxxx 10xxxxxx
1525 4:  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
1526 5:  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1527 6:  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1528
1529 Supported types:
1530
1531 1:  0xxxxxxx
1532 2:  110000xx 10xxxxxx
1533
1534 \\0400 - cyrillic
1535 "
1536   (let ((rstr "") fc ulen)
1537     (while (not (string= utf8-string ""))
1538       (setq fc (aref utf8-string 0))
1539       (when (= (logand #xa0 fc) #xa0)
1540         (error "unsupported utf8 character type %d" fc))
1541       (setq ulen (if (zerop (logand #x80 fc)) 1 2))
1542
1543       (if (= ulen 1)
1544           (setq rstr (concat rstr (char-to-string fc))
1545                 utf8-string (substring utf8-string 1))
1546         (setq rstr (concat rstr
1547                            (char-to-string
1548                             (xwem-misc-utf8-to-koi8-char
1549                              (logior (lsh (logand #xf fc) 6)
1550                                      (logand #x3f (aref utf8-string 1))))))
1551               utf8-string (substring utf8-string 2))))
1552     rstr))
1553
1554 ;;; Image rotator
1555 (defun xwem-misc-rotidx-left (i w h depth)
1556   (setq i (/ i depth))
1557   (let* ((y (/ i w))
1558          (x (% i w))
1559          (x1 y)
1560          (y1 (- w x 1)))
1561     (* (+ (* y1 h) x1) depth)))
1562
1563 (defun xwem-misc-rotidx-right (i w h depth)
1564   (setq i (/ i depth))
1565   (let* ((y (/ i w))
1566          (x (% i w))
1567          (x1 (- h y 1))
1568          (y1 x))
1569     (* (+ (* y1 h) x1) depth)))
1570
1571 ;;;###xwem-autoload
1572 (defun xwem-misc-rotate-data (data w h depth &optional rotate)
1573   "Rotate DATA obtained from XGetImage for use by XPutImage."
1574   (unless (member depth '(8 16 24 32))
1575     (error 'xwem-error (format "Unsupported depth %d, use one of (8 16 24 32)" depth)))
1576   (setq depth (truncate (/ depth 8)))
1577
1578   (unless rotate
1579     (setq rotate 'left))
1580   (setq rotate
1581         (if (eq rotate 'left)
1582             'xwem-misc-rotidx-left
1583           'xwem-misc-rotidx-right))
1584
1585   (let* ((gc-cons-threshold most-positive-fixnum) ; inhibit GCing
1586         (dstr (make-string (* w h depth) ?\x00))
1587         (dlen (length data))
1588         (i 0)
1589         off j)
1590     (while (< i dlen)
1591       (setq off (funcall rotate i w h depth))
1592       (setq j 0)
1593       (while (< j depth)
1594         (aset dstr (+ off j) (aref data (+ i j)))
1595         (incf j))
1596       (setq i (incf i depth)))
1597     dstr))
1598
1599 ;;;###xwem-autoload
1600 (defun xwem-debug (routine fmt &rest fmt-args)
1601   (let ((print-level 3))                ; XXX Restrict huge output
1602     (apply 'X-Dpy-log (xwem-dpy) routine fmt fmt-args)))
1603
1604
1605 ;;; Raise/lower stuff
1606 (defvar xwem-misc-always-on-top-stack nil
1607   "List of always-on-top windows.")
1608
1609 (defmacro xwem-xwin-rank (xwin)
1610   `(X-Win-get-prop ,xwin 'always-on-top-rank))
1611 (defsetf xwem-xwin-rank (xwin) (rank)
1612   `(xwem-misc-set-xwin-always-on-top ,xwin ,rank))
1613
1614 ;;;###xwem-autoload
1615 (defun xwem-misc-set-xwin-always-on-top (xwin &optional rank)
1616   "Mark xwin as always on top window.
1617 If number RANK is given, it denotes rank of always on top window.
1618 Higher RANK mean XWIN is above windows with lower RANK.
1619 By default RANK is 10."
1620   (X-Win-put-prop xwin 'always-on-top-rank (or rank 10))
1621
1622   ;; Sort `xwem-misc-always-on-top-stack' by rank after adding XWIN,
1623   ;; higher rank are at the end.
1624   (pushnew xwin xwem-misc-always-on-top-stack :test 'X-Win-equal)
1625   (setq xwem-misc-always-on-top-stack
1626         (sort xwem-misc-always-on-top-stack
1627               #'(lambda (xwin1 xwin2)
1628                   (< (xwem-xwin-rank xwin1)
1629                      (xwem-xwin-rank xwin2)))))
1630
1631   ;; Finnaly apply RANK to life
1632   (xwem-misc-raise-xwin xwin))
1633
1634 ;;;###xwem-autoload
1635 (defun xwem-misc-unset-always-on-top (xwin)
1636   "Unmark XWIN as always on top window."
1637   (X-Win-rem-prop xwin 'always-on-top-rank)
1638   (setq xwem-misc-always-on-top-stack
1639         (delq xwin xwem-misc-always-on-top-stack)))
1640
1641 (defun xwem-misc-find-below-sibling (operation rank)
1642   "Select appropriate below sibling from `xwem-misc-always-on-top-stack'."
1643   (let ((sibs xwem-misc-always-on-top-stack)
1644         (rsib nil))
1645     (while sibs
1646       (unless (X-Win-p (car sibs))
1647         ;; Remove broken sibling
1648         (setq xwem-misc-always-on-top-stack
1649               (delq (car sibs) xwem-misc-always-on-top-stack)
1650               sibs (cdr sibs)))
1651       (when (funcall operation (xwem-xwin-rank (car sibs)) rank)
1652         (setq rsib (car sibs)
1653               sibs nil))
1654       (setq sibs (cdr sibs)))
1655     rsib))
1656
1657 ;;;###xwem-autoload
1658 (defun xwem-misc-raise-xwin (xwin)
1659   "Raise XWIN reguarding always on top windows."
1660   (let* ((rank (or (xwem-xwin-rank xwin) 0))
1661          (bsib (and rank (xwem-misc-find-below-sibling '> rank))))
1662     (cond ((not bsib)
1663            (when (memq xwin xwem-misc-always-on-top-stack)
1664              (setq xwem-misc-always-on-top-stack
1665                    (nconc (delq xwin xwem-misc-always-on-top-stack)
1666                           (list xwin))))
1667            (XRaiseWindow (xwem-dpy) xwin))
1668           ((not (X-Win-equal xwin bsib))
1669            ;; Adjust rank stack in case if ranks are equal
1670            (when (memq xwin xwem-misc-always-on-top-stack)
1671              (setq xwem-misc-always-on-top-stack
1672                    (xwem-insert-before
1673                     (delq xwin xwem-misc-always-on-top-stack)
1674                     bsib xwin)))
1675            (XConfigureWindow (xwem-dpy) xwin
1676                              (make-X-Conf :stackmode X-Below
1677                                           :sibling bsib))))))
1678
1679 ;;;###xwem-autoload
1680 (defun xwem-misc-lower-xwin (xwin)
1681   "Lower XWIN according to its always on top rank."
1682   (let* ((rank (xwem-xwin-rank xwin))
1683          (bsib (and rank (xwem-misc-find-below-sibling '>= rank))))
1684     (cond ((not bsib)
1685            (when (memq xwin xwem-misc-always-on-top-stack)
1686              (setq xwem-misc-always-on-top-stack
1687                    (cons xwin (delq xwin xwem-misc-always-on-top-stack))))
1688            (XLowerWindow (xwem-dpy) xwin))
1689           ((not (X-Win-equal xwin bsib))
1690            ;; Adjust rank stack in case if ranks are equal
1691            (when (and (memq xwin xwem-misc-always-on-top-stack)
1692                       (= rank (xwem-xwin-rank bsib)))
1693              (setq xwem-misc-always-on-top-stack
1694                    (xwem-insert-before
1695                     (delq xwin xwem-misc-always-on-top-stack)
1696                     bsib xwin)))
1697            (XConfigureWindow (xwem-dpy) xwin
1698                              (make-X-Conf :stackmode X-Below
1699                                           :sibling bsib))))))
1700
1701 \f
1702 (provide 'xwem-misc)
1703
1704 ;;; xwem-misc.el ends here