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

   1 ;;; xwem-struct.el --- Core XWEM structures.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Tue Aug 24 12:43:45 MSD 2004
   7 ;; Keywords: xwem
   8 ;; X-CVS: $Id: xwem-struct.el,v 1.5 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 ;;
  32
  33 ;;; Code:
  34 \f
  35 (require 'xlib-xc)
  36
  37 (eval-when-compile
  38   ;; Shut up compiler
  39   (defvar xwem-current-cl)
  40   (defvar xwem-last-cl)
  41   (defvar xwem-frames-list)
  42   (defvar xwem-clients)
  43   (defvar xwem-client-ev-mask))
  44
  45 (define-error 'xwem-error "XWEM error")
  46
  47 \f
  48 ;;;; Root window
  49 (defvar xwem-root-display nil
  50   "Default X Display for XWEM.
  51 Use `xwem-dpy' to get it.")
  52 (defvar xwem-root-window nil
  53   "Default root window of `xwem-dpy'.")
  54 (defvar xwem-root-geometry nil
  55   "Geometry of `xwem-rootwin'.")
  56
  57 ;;;###xwem-autoload
  58 (defmacro xwem-dpy ()
  59   "Return default X display for XWEM."
  60   'xwem-root-display)
  61 ;;;###xwem-autoload
  62 (defmacro xwem-rootwin ()
  63   "Return default root window of `xwem-dpy'."
  64   'xwem-root-window)
  65 ;;;###xwem-autoload
  66 (defmacro xwem-rootgeom ()
  67   'xwem-root-geometry)
  68
  69 (defsetf xwem-dpy () (xdpy)
  70   "Set default X display for XWEM."
  71   `(progn
  72      (setq xwem-root-display ,xdpy)
  73      (unless (X-Dpy-p (xwem-dpy))
  74        (error 'xwem-error "Can't open display"))
  75      (setq xwem-root-window (XDefaultRootWindow (xwem-dpy)))
  76      (setq xwem-root-geometry (XGetGeometry (xwem-dpy) (xwem-rootwin)))))
  77
  78 ;;;; Frame structures
  79 (defstruct xwem-frame
  80   type                                  ; frame type (desktop, embedded, dedicated, embedded-desktop, etc)
  81   xwin                                  ; X window
  82   xgeom                                 ; frame geometry
  83   (name "default")                      ; frame name
  84   rootwin                               ; XWEM's root window for frame
  85   selwin                                ; XWEM's selected window
  86   link-next                             ; Link to next xwem's frame in linkage
  87   link-prev                             ; Link to prev xwem's frame in linkage
  88   state                                 ; 'mapped, 'unmapped, 'destroyed
  89
  90   plist)                                ; User defined plist
  91
  92 (defstruct xwem-frame-saved
  93   frame                                 ; nil or `xwem-frame'
  94   selected-p                            ; non-nil if frame was selected
  95   type
  96   name
  97   xgeom
  98   state                                 ;
  99   plist                                 ; as in xwem-frame
 100   winconfig)
 101
 102 (defsubst xwem-frame-get-prop (frame prop)
 103   (plist-get (xwem-frame-plist frame) prop))
 104
 105 (defsubst xwem-frame-rem-prop (frame prop)
 106   "From FRAME's plist remove property PROP."
 107   (setf (xwem-frame-plist frame)
 108         (plist-remprop (xwem-frame-plist frame) prop)))
 109
 110 (defsubst xwem-frame-put-prop (frame prop val)
 111   "Put PROP with VAL to FRAME's properties list."
 112   (if prop
 113       (setf (xwem-frame-plist frame)
 114             (plist-put (xwem-frame-plist frame) prop val))
 115     (xwem-frame-rem-prop frame prop)))
 116 (put 'xwem-frame-put-prop 'lisp-indent-function 2)
 117
 118 (defvar xwem-current-frame nil
 119   "Currently selected frame.
 120 Do not access/modify this variable directly, use `xwem-frame-selected'.")
 121
 122 (defmacro xwem-frame-selected ()
 123   "Return selected frame."
 124   'xwem-current-frame)
 125 (defsetf xwem-frame-selected () (frame)
 126   `(setq xwem-current-frame ,frame))
 127
 128 (defsubst xwem-frame-selected-p (frame)
 129   "Return non-nil if FRAME is selected."
 130   (eq frame (xwem-frame-selected)))
 131
 132 (defsubst xwem-frame-desktop-p (frame)
 133   "Return non-nil if FRAME is desktop."
 134   (memq (xwem-frame-type frame)
 135         '(desktop embedded-desktop)))
 136
 137 (defsubst xwem-frame-embedded-p (frame)
 138   "Return non-nil if FRAME is embedded frame."
 139   (memq (xwem-frame-type frame)
 140         '(embedded embedded-desktop)))
 141
 142 (defsubst xwem-frame-dedicated-p (frame)
 143   "Return non-nil if FRAME is dedicated frame."
 144   (memq (xwem-frame-type frame)
 145         '(dedicated)))
 146
 147 (defmacro xwem-frame-x (frame)
 148   `(X-Geom-x (xwem-frame-xgeom ,frame)))
 149 (defsetf xwem-frame-x (frame) (x)
 150   `(setf (X-Geom-x (xwem-frame-xgeom ,frame)) ,x))
 151
 152 (defmacro xwem-frame-y (frame)
 153   `(X-Geom-y (xwem-frame-xgeom ,frame)))
 154 (defsetf xwem-frame-y (frame) (y)
 155   `(setf (X-Geom-y (xwem-frame-xgeom ,frame)) ,y))
 156
 157 (defmacro xwem-frame-width (frame)
 158   `(X-Geom-width (xwem-frame-xgeom ,frame)))
 159 (defsetf xwem-frame-width (frame) (width)
 160   `(setf (X-Geom-width (xwem-frame-xgeom ,frame)) ,width))
 161
 162 (defmacro xwem-frame-height (frame)
 163   `(X-Geom-height (xwem-frame-xgeom ,frame)))
 164 (defsetf xwem-frame-height (frame) (height)
 165   `(setf (X-Geom-height (xwem-frame-xgeom ,frame)) ,height))
 166
 167 (defmacro xwem-frame-border-width (frame)
 168   `(X-Geom-border-width (xwem-frame-xgeom ,frame)))
 169 (defsetf xwem-frame-border-width (frame) (height)
 170   `(setf (X-Geom-border-width (xwem-frame-xgeom ,frame)) ,height))
 171
 172 (defmacro xwem-frame-title-height (frame)
 173   "Return FRAME's title height."
 174   `(xwem-frame-property ,frame 'title-height))
 175 (defsetf xwem-frame-title-height (frame) (new-title-height)
 176   "Set FRAME's title height to NEW-TITLE-HEIGHT."
 177   `(xwem-frame-set-property ,frame 'title-height ,new-title-height))
 178
 179 (defmacro xwem-frame-inner-border-width (frame)
 180   "Return FRAME's inner border width."
 181   `(xwem-frame-property ,frame 'inner-border-width))
 182 (defsetf xwem-frame-inner-border-width (frame) (new-inner-border-width)
 183   "Set FRAME's inner border width to be NEW-INNER-BORDER-WIDTH."
 184   `(xwem-frame-set-property ,frame 'inner-border-width ,new-inner-border-width))
 185
 186 (defsubst xwem-frame-alive-p (frame)
 187   "Return non-nil if FRAME is alive XWEM frame."
 188   (and (xwem-frame-p frame)
 189        (memq frame xwem-frames-list)
 190        (not (eq (xwem-frame-type frame) 'destroyed))))
 191
 192 (defsubst xwem-frame-mapped-p (frame)
 193   "Return non-nil if xwem FRAME is mapped."
 194   (and (xwem-frame-p frame)
 195        (eq (xwem-frame-state frame) 'mapped)))
 196
 197 (defsubst xwem-frame-cl (frame)
 198   "Return currently active xwem client in FRAME."
 199   (xwem-win-cl (xwem-frame-selwin frame)))
 200
 201 \f
 202 ;;;; Win structures
 203 (defstruct xwem-win
 204   id                                    ; unique window id
 205   geom                                  ; window geometry (border width is internal window width)
 206   clients                               ; xwem clients list managed in window
 207   cl                                    ; Current window's client
 208   frame                                 ; xwem frame
 209   dead                                  ; non-nil if window is dead
 210   deleted                               ; non-nil if window was deleted
 211   next                                  ; next window in windows chain
 212   prev                                  ; previous window in windows chain
 213   hchild                                ; horisontal child (if any)
 214   vchild                                ; vertical child (if any)
 215   parent                                ; parent window
 216
 217   plist)                                ; User defined plist
 218
 219 (defstruct (xwem-win-saved (:predicate xwem-iswinsaved-p))
 220   id                                    ; saved window id
 221   geom                                  ; saved window geometry
 222   clients                               ; clients managed in window
 223   cl                                    ; Current window's client
 224   plist                                 ; properties
 225   selwin-p                              ; non-nil if window is selected in frame
 226   first-hchild first-vchild
 227   next prev)
 228
 229 (defstruct (xwem-win-config (:predicate xwem-iswinconfig-p))
 230   frame                                 ; window's frame
 231   frame-xgeom                           ; saved frame X-Geom
 232   frame-properties                      ; saved frame properties
 233   current-cl                            ; cl in selected window
 234   min-width min-height
 235   saved-root-window)
 236
 237 (defsubst xwem-win-alive-p (window)
 238   "Return non-nil if WINDOW is alive."
 239   (and (xwem-win-p window)
 240        (xwem-frame-alive-p (xwem-win-frame window))
 241        (not (xwem-win-deleted window))
 242        (not (xwem-win-dead window))))
 243
 244 (defmacro xwem-win-x (win)
 245   `(X-Geom-x (xwem-win-geom ,win)))
 246 (defsetf xwem-win-x (win) (x)
 247   `(setf (X-Geom-x (xwem-win-geom ,win)) ,x))
 248
 249 (defmacro xwem-win-y (win)
 250   `(X-Geom-y (xwem-win-geom ,win)))
 251 (defsetf xwem-win-y (win) (y)
 252   `(setf (X-Geom-y (xwem-win-geom ,win)) ,y))
 253
 254 (defmacro xwem-win-width (win)
 255   `(X-Geom-width (xwem-win-geom ,win)))
 256 (defsetf xwem-win-width (win) (width)
 257   `(setf (X-Geom-width (xwem-win-geom ,win)) ,width))
 258
 259 (defmacro xwem-win-height (win)
 260   `(X-Geom-height (xwem-win-geom ,win)))
 261 (defsetf xwem-win-height (win) (height)
 262   `(setf (X-Geom-height (xwem-win-geom ,win)) ,height))
 263
 264 (defmacro xwem-win-border-width (win)
 265   `(X-Geom-border-width (xwem-win-geom ,win)))
 266 (defsetf xwem-win-border-width (win) (border-width)
 267   `(setf (X-Geom-border-width (xwem-win-geom ,win)) ,border-width))
 268
 269 (defsubst xwem-win-get-prop (win prop)
 270   "Get WIN's property PROP."
 271   (plist-get (xwem-win-plist win) prop))
 272
 273 (defsubst xwem-win-rem-prop (win prop)
 274   "Remove WIN's property PROP."
 275   (setf (xwem-win-plist win)
 276         (plist-remprop (xwem-win-plist win) prop)))
 277
 278 (defsubst xwem-win-put-prop (win prop val)
 279   "Set WIN's property PROP to VAL."
 280   (if val
 281       (setf (xwem-win-plist win)
 282             (plist-put (xwem-win-plist win) prop val))
 283     (xwem-win-rem-prop win prop)))
 284 (put 'xwem-win-put-prop 'lisp-indent-function 2)
 285
 286 (defmacro xwem-win-selected ()
 287   "Return selected window."
 288   '(and (xwem-frame-alive-p (xwem-frame-selected))
 289         (xwem-frame-selwin (xwem-frame-selected))))
 290
 291 (defmacro xwem-win-selected-p (win)
 292   "Return non-nil if WIN is currently selected window."
 293   `(eq ,win (xwem-win-selected)))
 294
 295 (defsubst xwem-win-selwin-p (win)
 296   "Return non-nil if WIN is localy selected window in WIN's frame."
 297   (and (xwem-win-p win)
 298        (eq win (xwem-frame-selwin (xwem-win-frame win)))))
 299
 300 (defsubst xwem-win-cl-current-p (cl &optional win)
 301   "Return non-nil if CL is current WIN's client."
 302   (unless win
 303     (setq win (xwem-cl-win cl)))
 304   (when (xwem-win-p win)
 305     (eq cl (xwem-win-cl win))))
 306
 307 \f
 308 ;;;; Client structures
 309 (defstruct xwem-hints
 310   ;; TODO: add more
 311   wm-normal-hints
 312   wm-hints
 313   wm-class
 314   wm-command
 315   wm-name
 316   wm-icon-name
 317   wm-transient-for
 318   wm-protocols)
 319
 320 (defstruct xwem-cl
 321   xwin                                  ; CL's X window
 322   (ev-mask 0)                           ; CL's event maks
 323   initial-xattrs                        ; X-Attr when CL just initialized
 324   initial-xgeom                         ; X-Geom when CL just initialized
 325
 326   xgeom                                 ; Current CL's X-Geom
 327   new-xgeom                             ; Wishable CL's X-Geom (for refiting)
 328
 329   hints                                 ; xwem-hints
 330   transient-for                         ; non-nil if client is transient for window
 331
 332   manage-spec                           ; MANAGE-SPEC which was used to manage client.
 333   win                                   ; xwem-win now (only for windowing manage types)
 334   translist                             ; list of transient-for windows for this client
 335
 336   (state 'unknown)                      ; state of client, 'active, 'inactive, 'iconified, 'unknown, etc
 337   start-time                            ; start-time
 338   recency                               ; last time when CL was active
 339
 340   local-variables                       ; client local variables list
 341   sys-plist                             ; system plist
 342   plist                                 ; user defined plist
 343   )
 344
 345 (defmacro xwem-cl-destroyed-p (cl)
 346   "Return non-nil if CL has already destroyed xwin."
 347   `(eq (xwem-cl-state ,cl) 'destroyed))
 348
 349 (defmacro xwem-cl-win-geom (cl)
 350   "Get geometry for client CL. Actually return xwem window geometry."
 351   `(xwem-win-geom (xwem-cl-win ,cl)))
 352
 353 ;; User plist
 354 (defsubst xwem-cl-get-prop (cl prop)
 355   "From CL's property list get property PROP."
 356   (plist-get (xwem-cl-plist cl) prop))
 357
 358 (defsubst xwem-cl-rem-prop (cl prop)
 359   "From CL's property list remove property PROP."
 360   (setf (xwem-cl-plist cl) (plist-remprop (xwem-cl-plist cl) prop)))
 361
 362 (defsubst xwem-cl-put-prop (cl prop val)
 363   "In CL's property list put property PROP with value VAL.
 364 If VAL is nil - remove property."
 365   (if val
 366       (setf (xwem-cl-plist cl) (plist-put (xwem-cl-plist cl) prop val))
 367     (xwem-cl-rem-prop cl prop)))
 368 (put 'xwem-cl-put-prop 'lisp-indent-function 2)
 369
 370 ;; System plist
 371 (defsubst xwem-cl-get-sys-prop (cl prop)
 372   "From CL's system property list get property PROP."
 373   (plist-get (xwem-cl-sys-plist cl) prop))
 374
 375 (defsubst xwem-cl-rem-sys-prop (cl prop)
 376   "From CL's system property list remove property PROP."
 377   (setf (xwem-cl-sys-plist cl) (plist-remprop (xwem-cl-sys-plist cl) prop)))
 378
 379 (defsubst xwem-cl-put-sys-prop (cl prop val)
 380   "In CL's system property list put property PROP with value VAL.
 381 If VAL is nil - remove property."
 382   (if val
 383       (setf (xwem-cl-sys-plist cl) (plist-put (xwem-cl-sys-plist cl) prop val))
 384     (xwem-cl-rem-sys-prop cl val)))
 385 (put 'xwem-cl-put-sys-prop 'lisp-indent-function 2)
 386
 387 (defmacro xwem-cl-manage-type (cl)
 388   "Return CL's manage type name."
 389   `(car (xwem-cl-manage-spec ,cl)))
 390 (defsetf xwem-cl-manage-type (cl) (new-type)
 391   `(setf (xwem-cl-manage-spec ,cl) (list ,new-type)))
 392
 393 (defmacro xwem-cl-selected ()
 394   "Return currently selected Client.
 395 May be nil if no current client."
 396   'xwem-current-cl)
 397 (defsetf xwem-cl-selected () (cl)
 398   `(setq xwem-current-cl ,cl))
 399
 400 (defmacro xwem-last-client ()
 401   "Return last selected client."
 402   'xwem-last-cl)
 403 (defsetf xwem-last-client () (cl)
 404   `(setq xwem-last-cl ,cl))
 405
 406 (defsubst xwem-cl-selected-p (cl)
 407   "Return non-nil if CL is selected client.
 408 If CL is not valid `xwem-cl' structure, nill will be returned."
 409   (and (xwem-cl-p cl) (eq cl (xwem-cl-selected))))
 410
 411 (defsubst xwem-cl-frame (cl)
 412   "Return frame where CL."
 413   (let ((win (xwem-cl-win cl)))
 414     (and (xwem-win-p win) (xwem-win-frame win))))
 415
 416 (defsubst xwem-cl-alive-p (cl)
 417   "Return non-nil if CL is alive i.e. not in 'destroyed state."
 418   (and (xwem-cl-p cl) (not (eq (xwem-cl-state cl) 'destroyed))))
 419
 420 (defsubst xwem-cl-managed-p (cl &optional states)
 421   "Return non-nil if CL ins't in withdrawn state."
 422   (and (xwem-cl-p cl)
 423        (memq (xwem-cl-state cl) (or states '(active inactive iconified)))))
 424
 425 (defsubst xwem-cl-active-p (cl)
 426   "Return non-nil if CL is in active state."
 427   (eq (xwem-cl-state cl) 'active))
 428
 429 ;; wm accessors
 430 (defsubst xwem-cl-wm-name (cl)
 431   "Return cl's WM_NAME."
 432   (xwem-hints-wm-name (xwem-cl-hints cl)))
 433 (defsetf xwem-cl-wm-name (cl) (name)
 434   "Set CL's WM_NAME to NAME."
 435   `(setf (xwem-hints-wm-name (xwem-cl-hints ,cl)) ,name))
 436
 437 (defsubst xwem-cl-wm-icon-name (cl)
 438   "Return cl's WM_ICON_NAME."
 439   (xwem-hints-wm-icon-name (xwem-cl-hints cl)))
 440 (defsetf xwem-cl-wm-icon-name (cl) (icon-name)
 441   "Set CL's WM_ICON_NAME to ICON-NAME."
 442   `(setf (xwem-hints-wm-icon-name (xwem-cl-hints ,cl)) ,icon-name))
 443
 444 (defsubst xwem-cl-wm-hints (cl)
 445   "Return cl's WM_HINTS."
 446   (xwem-hints-wm-hints (xwem-cl-hints cl)))
 447 (defsetf xwem-cl-wm-hints (cl) (hints)
 448   "Set CL's WM_HINTS to HINTS."
 449   `(setf (xwem-hints-wm-hints (xwem-cl-hints ,cl)) ,hints))
 450
 451 (defsubst xwem-cl-wm-normal-hints (cl)
 452   "Return cl's WM_NORMAL_HINTS."
 453   (xwem-hints-wm-normal-hints (xwem-cl-hints cl)))
 454 (defsetf xwem-cl-wm-normal-hints (cl) (wnh)
 455   "Set CL's WM_NORMAL_HINTS to WNH."
 456   `(setf (xwem-hints-wm-normal-hints (xwem-cl-hints ,cl)) ,wnh))
 457
 458 (defsubst xwem-cl-wm-class (cl)
 459   "Return cl's WM_CLASS."
 460   (xwem-hints-wm-class (xwem-cl-hints cl)))
 461 (defsetf xwem-cl-wm-class (cl) (class)
 462   "Set CL's WM_CLASS to CLASS."
 463   `(setf (xwem-hints-wm-class (xwem-cl-hints ,cl)) ,class))
 464
 465 (defsubst xwem-cl-wm-command (cl)
 466   "Return cl's WM_COMMAND."
 467   (xwem-hints-wm-command (xwem-cl-hints cl)))
 468 (defsetf xwem-cl-wm-command (cl) (command)
 469   "Set CL's WM_COMMAND to COMMAND."
 470   `(setf (xwem-hints-wm-command (xwem-cl-hints ,cl)) ,command))
 471
 472 (defsubst xwem-cl-wm-transient-for (cl)
 473   "Return cl's WM_TRANSIENT_FOR."
 474   (xwem-hints-wm-command (xwem-cl-hints cl)))
 475 (defsetf xwem-cl-wm-transient-for (cl) (wtf)
 476   "Set CL's WM_TRANSIENT_FOR to WTF."
 477   `(setf (xwem-hints-wm-transient-for (xwem-cl-hints ,cl)) ,wtf))
 478
 479 (defsubst xwem-cl-wm-protocols (cl)
 480   "Return cl's WM_PROTOCOLS."
 481   (xwem-hints-wm-command (xwem-cl-hints cl)))
 482 (defsetf xwem-cl-wm-protocols (cl) (protocols)
 483   "Set CL's WM_PROTOCOLS to PROTOCOLS."
 484   `(setf (xwem-hints-wm-protocols (xwem-cl-hints ,cl)) ,protocols))
 485
 486 \f
 487 ;;;; Minibuffer
 488 (defstruct xwem-minib
 489   frame                                 ; Emacs frame
 490   cl                                    ; Corresponding xwem client
 491
 492   xgeom                                 ; parent geometry
 493   xwin                                  ; parent xwindow
 494
 495   plist                                 ; User defined plist
 496   )
 497
 498 (defmacro xwem-minib-get-prop (m prop)
 499   `(plist-get (xwem-minib-plist ,m) ,prop))
 500
 501 (defmacro xwem-minib-put-prop (m prop val)
 502   `(setf (xwem-minib-plist ,m)
 503          (plist-put (xwem-minib-plist ,m) ,prop ,val)))
 504 (put 'xwem-minib-put-prop 'lisp-indent-function 2)
 505
 506 (defmacro xwem-minib-rem-prop (m prop)
 507   `(setf (xwem-minib-plist ,m)
 508          (plist-remprop (xwem-minib-plist ,m) ,prop)))
 509
 510 (defmacro xwem-minib-cl-xgeom (m)
 511   "Return client's X geometry of minibuffer M."
 512   `(xwem-cl-xgeom (xwem-minib-cl ,m)))
 513 (defsetf xwem-minib-cl-xgeom (m) (xgeom)
 514   `(setf (xwem-cl-xgeom (xwem-minib-cl ,m)) ,xgeom))
 515
 516 (defmacro xwem-minib-cl-xwin (m)
 517   "Return clien's X window of minibuffe M."
 518   `(xwem-cl-xwin (xwem-minib-cl ,m)))
 519 (defsetf xwem-minib-cl-xwin (m) (xwin)
 520   `(setf (xwem-cl-xwin (xwem-minib-cl ,m)) ,xwin))
 521
 522 \f
 523 ;;; Various macros
 524
 525 ;; Defining deffered funcalls
 526 ;;; Deffering related stuff
 527 (require 'dll)
 528
 529 (defvar xwem-pre-deffering-hook nil
 530   "*Hooks to run before deffering.")
 531 (defvar xwem-post-deffering-hook nil
 532   "*Hooks to run after deffering complete.
 533 `xwem-post-deffering-hook' clears every time it runs.")
 534
 535 (defvar xwem-deffered-dll (dll-create)
 536   "Double linked list of deffered things.")
 537
 538 (defvar xwem-deffering-p nil
 539   "Non-nil mean we are running deffered function.")
 540
 541 (defun xwem-deffered-push (fun &rest args)
 542   (let*  ((dummy (dll-get-dummy-node xwem-deffered-dll))
 543           (node  (elib-node-right dummy))
 544           (exists nil))
 545     (while (and (not (eq node dummy))
 546                 (not (and (funcall
 547                            #'(lambda (e1 e2)
 548                                (and (eq (car e1) (car e2))
 549                                     (if (and (listp (cdr e1)) (listp (cdr e2))
 550                                              (= (length (cdr e1))
 551                                                 (length (cdr e2))))
 552                                         (not (memq nil (mapcar*
 553                                                         'eq (cdr e1) (cdr e2))))
 554                                       (eq (cdr e1) (cdr e2)))))
 555                            (cons fun args)
 556                            (dll-element xwem-deffered-dll node))
 557                           (setq exists t))))
 558       (setq node (elib-node-right node)))
 559
 560     (if exists
 561         (dll-delete xwem-deffered-dll node)
 562       (enqueue-eval-event 'xwem-deffered-process nil))
 563
 564     (xwem-debug 'xwem-deffered "---------> IN %S" 'fun)
 565     (dll-enter-last xwem-deffered-dll (cons fun args))))
 566
 567 (defun xwem-deffered-process (obj-notused)
 568   "Process deffering commands."
 569   (declare (special xwem-deffering-p))
 570
 571   (unless xwem-deffering-p
 572     (let ((xwem-deffering-p t))
 573       (run-hooks 'xwem-pre-deffering-hook)
 574       (setq xwem-pre-deffering-hook nil)))
 575
 576   (while (not (dll-empty xwem-deffered-dll))
 577     (let ((el (dll-first xwem-deffered-dll))
 578           (xwem-deffering-p t))
 579       (xwem-debug 'xwem-deffered "<--------- OUT %S" '(car el))
 580       (dll-delete-first xwem-deffered-dll)
 581       (apply (car el) (cdr el))))
 582
 583   (unless xwem-deffering-p
 584     (let ((xwem-deffering-p t))
 585       (run-hooks 'xwem-post-deffering-hook)
 586       (setq xwem-post-deffering-hook nil))))
 587
 588 (defun xwem-add-hook-post-deffering (hook &optional append)
 589   "Add HOOK to `xwem-post-deffering-hook'."
 590   (add-hook 'xwem-post-deffering-hook hook append)
 591   ;; Run it to be sure to enter deffering
 592   (xwem-deffered-push 'ignore))
 593
 594 ;; Dont know where to put this macro, so putten here.
 595 (defmacro define-xwem-deffered
 596   (deff-name normal-name arglist docstring &rest body)
 597   "Define new deffered function with function name DEFF-NAME.
 598 Deffered function is function which is called when XEmacs is about to became idle.
 599
 600 Another advantage of deffered function is that only one instance of
 601 function will be called with same arguments.  For example if you have
 602 `my-defffun' deffered function and you call twice `(my-defffun 1)',
 603 `(my-defffun 1)' - then when XEmacs will be about idle only one call
 604 occurs to `my-defffun'.  However if you pass different arguments, all
 605 calls with different arguments are called.  Arguments are equal if
 606 they are either `eq' or both are lists, where each element is `eq'.
 607
 608 NAME, ARGLIST, DOCSTRING and BODY argument have same meaning as for `defun'.
 609 If NORMAL-NAME is specified, also define non-deffered variant of DEFF-NAME function.
 610 If NORMAL-NAME is ommited, then normal-name constructed by
 611 concatination of DEFF-NAME and \"-1\"."
 612   (unless (and (not (null normal-name))
 613                (symbolp normal-name))
 614     ;; If NORMAL-NAME ommited
 615     (setq body (cons docstring body))
 616     (setq docstring arglist)
 617     (setq arglist normal-name)
 618     (setq normal-name (intern (concat (symbol-name deff-name) "-1"))))
 619
 620   `(progn
 621      (defun ,normal-name ,arglist
 622        ,docstring
 623        ,@body)
 624
 625      (defun ,deff-name (&rest args)
 626        ,(concat "Deffered variant of `" (symbol-name normal-name) "'.")
 627        (apply (quote xwem-deffered-push) (quote ,normal-name) args))))
 628
 629 (defmacro xwem-deffered-funcall (fun &rest args)
 630   "Call FUN with ARGS, deffering funcall to FUN."
 631   `(xwem-deffered-push ,fun ,@args))
 632
 633 (defmacro xwem-unwind-protect (body-form &rest unwind-forms)
 634   "Execute BODY-FORM protecting it in safe more with UNWIND-FORMS.
 635 `xwem-unwind-protect' differs from `unwind-protect' that
 636 `xwem-unwind-protect' executes UNWIND-FORMS even when debugging."
 637   `(prog1
 638     (condition-case xwem-unwind-error
 639         ,body-form
 640       (t ,@unwind-forms
 641          (apply 'error (car xwem-unwind-error) (cdr xwem-unwind-error))))
 642     ,@unwind-forms))
 643 (put 'xwem-unwind-protect 'lisp-indent-function 1)
 644
 645 (defmacro xwem-overriding-local-map (nlm &rest forms)
 646   "Execute FORMS installing `xwem-overriding-local-map' to NLM.
 647 Do it in safe manner."
 648   `(xwem-unwind-protect
 649        (let ((xwem-override-local-map ,nlm))
 650          ,@forms)))
 651 (put 'xwem-overriding-local-map 'lisp-indent-function 'defun)
 652
 653 ;;; X Properties
 654 (defmacro xwem-XProperty-get (xwin prop-atom-string)
 655   `(ignore-errors (read (XGetPropertyString
 656                          (xwem-dpy) ,xwin
 657                          (XInternAtom (xwem-dpy) ,prop-atom-string)))))
 658 (defmacro xwem-XProperty-set (xwin prop-atom-string prop-val)
 659   `(if ,prop-val
 660        (XSetPropertyString (xwem-dpy) ,xwin
 661                            (XInternAtom (xwem-dpy) ,prop-atom-string)
 662                            (format "%S" ,prop-val))
 663      (XDeleteProperty (xwem-dpy) ,xwin
 664                       (XInternAtom (xwem-dpy) ,prop-atom-string))))
 665
 666 \f
 667 (provide 'xwem-struct)
 668
 669 ;;; xwem-struct.el ends here