;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- ;;; $Id: wm.lisp,v 1.45 2004/03/19 15:09:45 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO ;;; Copyright (C) 2000 ;;; Julien BONINFANTE, ;;; Aymeric LACORTE, ;;; Jocelyn FRECHOT ;;; contact : hatchond@yahoo.fr ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;; usefull for having a quick and short garbage collection. #+:cmu (setf extensions:*bytes-consed-between-gcs* 400000 extensions:*gc-verbose* nil) (in-package :ECLIPSE-INTERNALS) ;;;; Decoration (defclass decoration (base-widget) ((children :initarg :children :accessor decoration-children) (active-p :initform nil :accessor decoration-active-p) (wm-size-hints :initarg :wm-size-hints :reader decoration-wm-size-hints) (frame-style :initarg :frame-style :accessor decoration-frame-style) (old-frame-style :initform nil :initarg :old-frame-style) (application-gravity :initarg :application-gravity :initform :north-west :accessor decoration-application-gravity) )) (defun decoration-p (widget) (typep widget 'decoration)) (defconstant +decoration-event-mask+ '(:substructure-redirect :substructure-notify :visibility-change :enter-window :owner-grab-button)) (defmethod get-child ((master decoration) label &key window) "Return the child widget/window labeled `label' or nil if no such child exists. label is a keyword." (let ((widget (getf (decoration-children master) label))) (if (and widget window) (widget-window widget) widget))) (defmethod decoration-wm-hints ((master decoration)) "return as a multiple value: minw minh maxw maxh incw inch basew baseh." (with-slots (frame-style (wmsh wm-size-hints)) master (declare (type (vector integer 8) wmsh)) (with-slots ((hm hmargin) (vm vmargin)) frame-style (values (+ hm (svref wmsh 0)) (+ vm (svref wmsh 1)) (+ hm (svref wmsh 2)) (+ vm (svref wmsh 3)) (svref wmsh 4) (svref wmsh 5) (+ hm (svref wmsh 6)) (+ vm (svref wmsh 7)))))) (defmethod focus-widget ((master decoration) timestamp) (with-slots (window input-model) (get-child master :application) (set-focus input-model window timestamp))) (defmethod focused-p ((master decoration)) (focused-p (get-child master :application))) (defmethod widget-position-fix-p ((master decoration)) (widget-position-fix-p (get-child master :application))) (defmethod shaded-p ((widget decoration)) (with-slots (window) (get-child widget :application) (member :_net_wm_state_shaded (netwm:net-wm-state window)))) (defmethod shade ((master decoration)) (with-slots (window frame-style) master (let* ((app-win (get-child master :application :window t)) (netwm-prop (netwm:net-wm-state app-win)) (gnome-prop (or (gnome:win-state app-win :result-type t) 0))) (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded (if (member :_net_wm_state_shaded netwm-prop) (with-event-mask (window) ;; unshade. (xlib:map-window app-win) (xlib:map-window window) (resize-from (get-child master :application)) (setf netwm-prop (remove :_net_wm_state_shaded netwm-prop)) (setf netwm-prop (remove :_net_wm_state_hidden netwm-prop)) (unless (stick-p app-win) (setf (window-desktop-num app-win) (current-desk)))) (with-event-mask (window) ;; shade. (with-slots ((vm vmargin) (hm hmargin)) frame-style (if (title-bar-horizontal-p master) (unless (= 0 vm) (setf (xlib:drawable-height window) vm)) (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))) (xlib:unmap-window app-win) (pushnew :_net_wm_state_shaded netwm-prop) (pushnew :_net_wm_state_hidden netwm-prop) (incf gnome-prop 32))) ; add win_state_shaded (setf (netwm:net-wm-state app-win) netwm-prop (gnome:win-state app-win) gnome-prop)))) (defmethod (setf decoration-frame-style) :after (astyle (master decoration)) (with-slots (window children wm-size-hints) master (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) astyle (with-event-mask (window) (let* ((application (getf children :application)) (icon (slot-value application 'icon)) (app-win (slot-value application 'window))) (loop for (key val) on children by #'cddr unless (or (eq key :application) (eq key :icon)) do (when (typep val 'edge) (xlib:destroy-window (widget-window val))) (remove-widget val)) (setf children (list :application application :icon icon) wm-size-hints (recompute-wm-normal-hints app-win hm vm)) (let ((width (+ (xlib:drawable-width app-win) hm)) (height (+ (xlib:drawable-height app-win) vm))) (setf (xlib:window-background window) (style-background astyle) (window-position app-win) (values left-margin top-margin) (drawable-sizes window) (values width height)) (make-frame-parts master) (make-title-bar master (wm-name app-win)) (update-edges-geometry master) (xlib:map-subwindows window)) (cond ((shaded-p application) (if (title-bar-horizontal-p master) (unless (= 0 vm) (setf (xlib:drawable-height window) vm)) (unless (= 0 hm) (setf (xlib:drawable-width window) hm))) (xlib:unmap-window app-win)) ((application-iconic-p application) (xlib:unmap-window app-win)))))))) (defmethod close-widget ((widget decoration)) (close-widget (get-child widget :application))) (defmethod put-on-top ((widget decoration)) (put-on-top (get-child widget :application))) (defmethod put-on-bottom ((widget decoration)) (put-on-bottom (get-child widget :application))) (defmethod dispatch-repaint ((master decoration) &key (focus (focused-p master))) (declare (optimize (speed 3) (safety 1))) (with-slots (parts-to-redraw-on-focus name) (decoration-frame-style master) (declare (type string name)) (mapc #'(lambda (k) (repaint (get-child master k) name focus)) parts-to-redraw-on-focus))) (defun title-bar-horizontal-p (master) (eq :horizontal (style-title-bar-direction (decoration-frame-style master)))) (defun recompute-wm-normal-hints (window hmargin vmargin) (let ((hints (or (ignore-errors (xlib:wm-normal-hints window)) (xlib:make-wm-size-hints))) (max-ww (screen-width)) (max-hh (screen-height))) (symbol-macrolet ((min-w (xlib:wm-size-hints-min-width hints)) (min-h (xlib:wm-size-hints-min-height hints)) (max-w (xlib:wm-size-hints-max-width hints)) (max-h (xlib:wm-size-hints-max-height hints)) (inc-w (xlib:wm-size-hints-width-inc hints)) (inc-h (xlib:wm-size-hints-height-inc hints)) (base-w (xlib:wm-size-hints-base-width hints)) (base-h (xlib:wm-size-hints-base-height hints)) (g (xlib:wm-size-hints-win-gravity hints))) (unless (eq g :static) (decf max-ww hmargin) (decf max-hh vmargin)) (setf min-w (max (or (or min-w base-w) 1) 1) min-h (max (or (or min-h base-h) 1) 1) base-w (max (or (or base-w min-w) 1) 1) base-h (max (or (or base-h min-h) 1) 1) inc-w (or inc-w 1) inc-h (or inc-h 1)) (setf max-ww (- max-ww (mod (- max-ww base-w) inc-w)) max-hh (- max-hh (mod (- max-hh base-h) inc-h))) (unless (and max-w (<= min-w max-w max-ww)) (setf max-w max-ww)) (unless (and max-h (<= min-h max-h max-hh)) (setf max-h max-hh)) (setf min-w (min min-w max-w) min-h (min min-h max-h) base-w (min base-w max-w) base-h (min base-h max-h)) (multiple-value-bind (w h) (drawable-sizes window) (unless (<= min-w w max-w) (setf (xlib:drawable-width window) (min (max min-w w) max-w))) (unless (<= min-h h max-h) (setf (xlib:drawable-height window) (min (max min-h h) max-h)))) (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g)))) ;;;; Decoration creation tools. (defun make-menu-button (master parent-window) (with-slots (children frame-style) master (when (frame-item-exist-p frame-style :menu-button) (let ((pixmaps (frame-item-pixmaps frame-style :menu-button)) (horizontal-p (title-bar-horizontal-p master))) (declare (type pixmaps pixmaps)) (multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0)) (multiple-value-bind (tw th) (drawable-sizes parent-window) (setf (getf children :menu-button) (create-button 'menu-button :parent parent-window :master master :background (aref pixmaps 0) :item (aref pixmaps 1) :width width :height height :event-mask '(:owner-grab-button . #.+push-button-mask+) :y (if horizontal-p (ash (- th height) -1) (- th height)) :x (if horizontal-p 0 (ash (- tw width) -1)))))))))) (defun make-buttons-bar (master parent-window) (with-slots (children (astyle frame-style)) master (flet ((make-container (horizontal-p) (xlib:create-window :parent parent-window :x 0 :y 0 :width 1 :height 1 :background :parent-relative :gravity (if horizontal-p :north-east :north-west)))) (loop initially (when (zerop (style-nb-buttons astyle)) (return)) with horizontal-p = (title-bar-horizontal-p master) with container = (make-container horizontal-p) and (x y width height) = '(0 0 0 0) for type in '(iconify-button maximize-button close-button) for child in '(:icon-b :maximize :close) for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child) for bkgrd = (aref pixmaps 0) when (frame-item-exist-p astyle child) do (multiple-value-setq (width height) (drawable-sizes bkgrd)) (setf (getf children child) (create-button type :parent container :master master :background bkgrd :item (aref pixmaps 1) :x x :y y :width width :height height :event-mask +push-button-mask+)) (if horizontal-p (incf x width) (incf y height)) finally (multiple-value-bind (w h) (drawable-sizes parent-window) (if (zerop x) (incf x width) (incf y height)) (setf (drawable-sizes container) (values x y) (window-position container) (if horizontal-p (values (- w x) (ash (- h y) -1)) (values (ash (- w x) -1) 0))) (xlib:map-subwindows container) (return container)))))) (defun make-title-bar (master name) (with-slots (children frame-style) master (unless (eq :none (style-title-bar-position frame-style)) (let* ((title-pos (style-title-bar-position frame-style)) (horizontal-p (case title-pos ((:top :bottom) t))) (parent-widget (getf children title-pos)) (parent-window (widget-window parent-widget)) (button-container (make-buttons-bar master parent-window)) (menu-button (make-menu-button master parent-window)) (pixmaps (frame-item-pixmaps frame-style title-pos)) (bcw 0) (bch 0) (mbw 0) (mbh 0) (title)) (declare (type pixmaps pixmaps)) (when button-container (multiple-value-setq (bcw bch) (drawable-sizes button-container))) (when menu-button (multiple-value-setq (mbw mbh) (drawable-sizes (widget-window menu-button)))) (setf title (create-button 'title-bar :parent parent-window :master master :width 1 :height 1 :x (if horizontal-p mbw 0) :y (if horizontal-p 0 bch) :event-mask +push-button-mask+ :background (aref pixmaps 0) :item name) (slot-value title 'parent) parent-window (getf children :title-bar) title (xlib:window-background parent-window) :parent-relative (xlib:window-event-mask parent-window) 0) (if horizontal-p (setf (slot-value title 'hmargin) (+ bcw mbw)) (setf (slot-value title 'vmargin) (+ bch mbh))) (xlib:map-subwindows parent-window) title)))) (defun edge-position (style edge-key width height) (with-slots (top-left-w top-left-h top-right-h bottom-left-w) style (multiple-value-bind (w h) (frame-item-sizes style edge-key) (case edge-key (:top (values top-left-w 0)) (:right (values (- width w) top-right-h)) (:bottom (values bottom-left-w (- height h))) (:left (values 0 top-left-h)) (:top-left (values 0 0)) (:top-right (values (- width w) 0)) (:bottom-right (values (- width w) (- height h))) (:bottom-left (values 0 (- height h))))))) (defvar *frame-parts* '(:right :left :top :bottom :top-left :top-right :bottom-left :bottom-right)) (defun make-frame-parts (master) (with-slots (children window (astyle frame-style)) master (multiple-value-bind (width height) (drawable-sizes window) (loop for child in *frame-parts* for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child) for hilighted = (aref pixmaps 1) for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+) when (frame-item-exist-p astyle child) do (multiple-value-bind (x y) (edge-position astyle child width height) (multiple-value-bind (w h) (frame-item-sizes astyle child) (setf (getf children child) (create-button (intern (symbol-name child) :eclipse) :parent window :master master :background (aref pixmaps 0) :item hilighted :event-mask event-mask :x x :y y :width w :height h)))))))) ;; Public. (defun update-edges-geometry (master) (declare (optimize (speed 3) (safety 0))) (declare (inline update-edges-geometry)) (macrolet ((update (edge size &rest frame-style-slots-size) `(when ,edge (setf (,(intern (format nil "DRAWABLE-~a" (symbol-name size)) :xlib) (widget-window ,edge)) (with-slots (,@frame-style-slots-size) frame-style (declare (type xlib:card16 ,@frame-style-slots-size)) (max 1 (- ,size ,@frame-style-slots-size))))))) (with-slots (frame-style window) master (multiple-value-bind (width height) (drawable-sizes window) (declare (type xlib:card16 width height)) (update (get-child master :top) width top-left-w top-right-w) (update (get-child master :left) height top-left-h bottom-left-h) (update (get-child master :right) height top-right-h bottom-right-h) (update (get-child master :bottom) width bottom-left-w bottom-right-w) (update-title-bar-sizes (get-child master :title-bar)))))) (defun update-title-bar-sizes (title-bar) (declare (optimize (speed 3) (safety 0))) (when title-bar (with-slots (parent window (vm vmargin) (hm hmargin)) title-bar (declare (type xlib:card16 vm hm)) (multiple-value-bind (width height) (drawable-sizes parent) (declare (type xlib:card16 width height)) (setf (drawable-sizes window) (values (max 1 (- width hm)) (max 1 (- height vm)))))))) (defun initial-coordinates (app-window frame-style) "Returns as multiple values the decoration initial coordinates." (let ((hint (ignore-errors (xlib:wm-normal-hints app-window)))) (with-slots (top-margin left-margin vmargin hmargin) frame-style (if (and hint (xlib:wm-size-hints-user-specified-position-p hint)) (let ((x (xlib:wm-size-hints-x hint)) (y (xlib:wm-size-hints-y hint))) (case (xlib:wm-size-hints-win-gravity hint) (:north-east (values (- x hmargin) y)) (:south-east (values (- x hmargin) (- y vmargin))) (:south-west (values x (- y vmargin))) (:static (values (- x left-margin) (- y top-margin))) (t (values x y)))) (multiple-value-bind (x y) (window-position app-window) (values (max 0 (- x left-margin)) (max 0 (- y top-margin)))))))) (defun make-decoration (app-window application &key theme) (unless theme (setf theme (root-decoration-theme *root*))) (let* ((dstyle (find-decoration-frame-style theme app-window)) (style dstyle)) (when (member :_net_wm_state_fullscreen (netwm:net-wm-state app-window)) (setf style (theme-default-style (lookup-theme "no-decoration")))) (with-slots (hmargin vmargin left-margin top-margin background) style (multiple-value-bind (wm-sizes gravity) (recompute-wm-normal-hints app-window hmargin vmargin) (multiple-value-bind (width height) (drawable-sizes app-window) (multiple-value-bind (x y) (initial-coordinates app-window style) (let* ((window (xlib:create-window :parent (xlib:drawable-root app-window) :x x :y y :width (+ width hmargin) :height (+ height vmargin) :background background :event-mask +decoration-event-mask+ :do-not-propagate-mask '(:button-press :button-release))) (master (make-instance 'decoration :window window :old-frame-style dstyle :frame-style style :children (list :application application) :application-gravity gravity :wm-size-hints wm-sizes))) (make-frame-parts master) (make-title-bar master (wm-name app-window)) (update-edges-geometry master) (with-slots (icon) application (setf (getf (decoration-children master) :icon) icon (slot-value icon 'master) master (slot-value application 'master) master (xlib:drawable-border-width app-window) 0)) master))))))) (defun decore-application (window application &key (map t) theme) "Decore an application and map the resulting decoration as indicated by the :map keyword argument. (default value is T). Return the newly created decoration." (let* ((master (make-decoration window application :theme theme)) (master-window (widget-window master)) (left-margin (style-left-margin (decoration-frame-style master))) (top-margin (style-top-margin (decoration-frame-style master)))) (with-event-mask (master-window) (xlib:map-subwindows master-window)) (with-event-mask (master-window (when map +decoration-event-mask+)) (xlib:reparent-window window master-window left-margin top-margin)) (when map (xlib:map-window window)) master)) ;;;; Maximization tools. (defun find-max-geometry (application direction fill-p &key x y w h) (multiple-value-bind (ulx uly lrx lry) (find-largest-empty-area application :area-include-me-p (or (/= 1 direction) fill-p) :panels-only-p (not fill-p) :direction (case direction (2 :vertical) (3 :horizontal) (t :both))) (with-slots (window master) application (with-slots ((hm hmargin) (vm vmargin)) (if master (decoration-frame-style master) (theme-default-style (lookup-theme "no-decoration"))) (symbol-macrolet ((minw (aref wmsh 0)) (minh (aref wmsh 1)) (maxw (aref wmsh 2)) (maxh (aref wmsh 3)) (incw (aref wmsh 4)) (inch (aref wmsh 5)) (basew (aref wmsh 6)) (baseh (aref wmsh 7))) (let* ((wmsh (recompute-wm-normal-hints window hm vm)) (ww (or w (check-size (- lrx ulx hm) basew incw minw maxw))) (hh (or h (check-size (- lry uly vm) baseh inch minh maxh)))) (when (> (+ ww hm) (- lrx ulx)) (decf ww incw)) (when (> (+ hh vm) (- lry uly)) (decf hh inch)) (make-geometry :w ww :h hh :x (or x ulx) :y (or y uly)))))))) (defun compute-max-geometry (application x y w h direction fill-p vert-p horz-p) (symbol-macrolet ((ix (geometry-x initial-geometry)) (iy (geometry-y initial-geometry)) (iw (geometry-w initial-geometry)) (ih (geometry-h initial-geometry))) (with-slots (initial-geometry) application (case direction ;; Unmaximize or Maximize in both directions (1 (if (or horz-p vert-p) (copy-geometry initial-geometry) (find-max-geometry application direction fill-p))) ;; Unmaximize or Maximize Vertically (2 (if vert-p (make-geometry :x x :y iy :w w :h ih) (find-max-geometry application direction fill-p :x x :w w))) ;; Unmaximize or Maximize Horizontally (3 (if horz-p (make-geometry :x ix :y y :w iw :h h) (find-max-geometry application direction fill-p :y y :h h))))))) ;; Public. (defun maximize-window (application code &key (fill-p *maximize-fill*)) (with-slots ((app-window window) initial-geometry full-geometry master) application (when (shaded-p master) (shade master)) (let* ((new-g) (m-window (if master (widget-window master) app-window)) (prop (netwm:net-wm-state app-window)) (fullscreen-p (member :_net_wm_state_fullscreen prop)) (vert-p (car (member :_net_wm_state_maximized_vert prop))) (horz-p (car (member :_net_wm_state_maximized_horz prop)))) (multiple-value-bind (x y) (window-position m-window) (multiple-value-bind (w h) (drawable-sizes app-window) (unless (or horz-p vert-p) (if fullscreen-p (setf initial-geometry (copy-geometry full-geometry)) (setf (geometry initial-geometry) (values x y w h)))) (setf new-g (compute-max-geometry application x y w h code fill-p vert-p horz-p)))) (when (and (= 1 code) (or horz-p vert-p)) (setf (values horz-p vert-p) (values t t))) (unless (= 3 code) (if vert-p (setf prop (delete :_net_wm_state_maximized_vert prop)) (pushnew :_net_wm_state_maximized_vert prop))) (unless (= 2 code) (if horz-p (setf prop (delete :_net_wm_state_maximized_horz prop)) (pushnew :_net_wm_state_maximized_horz prop))) (if fullscreen-p (setf full-geometry new-g) (setf (window-position m-window) (geometry-coordinates new-g) (drawable-sizes app-window) (geometry-sizes new-g))) (setf (netwm:net-wm-state app-window) prop)))) ;;;; Focus management. According to ICCCM (defgeneric set-focus (input-model window timestamp) (:documentation "Set focus to the given window according to the input model. Input model can be :globally-active :locally-active :passive :no-input. For more information on the input-model sementic see ICCCM 4.1.7")) (defmethod set-focus ((input-model (eql :globally-active)) window timestamp) (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))) (defmethod set-focus ((input-model (eql :locally-active)) window timestamp) (when (eql (xlib:window-map-state window) :viewable) (xlib:set-input-focus *display* window :pointer-root) (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0)))) (defmethod set-focus ((input-model (eql :passive)) window timestamp) (declare (ignorable timestamp)) (when (eql (xlib:window-map-state window) :viewable) (xlib:set-input-focus *display* window :pointer-root))) (defmethod set-focus ((input-model (eql :no-input)) window timestamp) (declare (ignorable window timestamp)) (values)) ;; Next is methods for menu-3 who permit to manage any window : ;; choose an action in the menu and click on a window ;; to perform this action. ;; protocol for treating events (defgeneric menu-3-process (event widget &rest rest)) (defmethod menu-3-process (event widget &rest rest) (declare (ignorable rest)) (event-process event widget) nil) (defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest) (declare (ignorable event w rest)) (xlib:ungrab-pointer *display*) t) (defmethod menu-3-process ((event button-release) (app application) &key key) (declare (ignorable event)) (cond ((eql key :move) (finish-move app *verbose-move* *move-mode*))) (call-next-method)) (defmethod menu-3-process ((ev button-release) (dec decoration) &key key) (cond ((eql key :resize) (finish-resize dec *verbose-resize* *resize-mode*)) ((eql key :move) (finish-move dec *verbose-resize* *resize-mode*))) (call-next-method)) (defmethod menu-3-process ((ev motion-notify) (app application) &key key) (when (eql key :move) (activate-move-resize app *root* 'move-status *move-mode* *verbose-move*) (application-active-p app))) (defmethod menu-3-process ((ev motion-notify) (master decoration) &key key) (when (or (eql key :resize) (eql key :move)) (multiple-value-call #'activate-move-resize master *root* (cond ((eql key :resize) (values 'resize-status *resize-mode* *verbose-resize*)) ((eql key :move) (values 'move-status *move-mode* *verbose-move*)))) (decoration-active-p master))) (defmethod menu-3-process ((event enter-notify) (app application) &rest rest) (declare (ignorable event rest)) (with-slots (window) (or (application-master app) app) (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*)) nil) (defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest) (declare (ignorable event rest)) (with-slots (window) master (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*)) nil) (defmethod menu-3-process ((event leave-notify) (app application) &rest rest) (declare (ignore event rest)) (unless (application-master app) (xlib:ungrab-pointer *display*)) nil) (defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest) (declare (ignore event master rest)) (xlib:ungrab-pointer *display*) nil) (defmethod menu-3-process ((ev button-press) (app application) &key key) (with-slots (master window) app (case key (:kill (kill-client-window window)) (:close (close-widget app)) (:resize (when master (initialize-resize master nil ev))) (:move (initialize-move (or master app) ev))) (when (member key '(:close :kill)) (xlib:ungrab-pointer *display*)))) (defmethod menu-3-process ((ev button-press) (master decoration) &key key) (menu-3-process ev (get-child master :application) :key key)) (defun define-menu-3 (action) (lambda () (with-root-cursor (*cursor-2*) (destroy-substructure (slot-value *root* 'menu3)) (loop for event = (get-next-event *display* :force-output-p t) for widget = (lookup-widget (event-event-window event)) until (menu-3-process event widget :key action))))) ;;;; Misc. (defun make-desktop-menu (root callback-maker &key realize) "Realize a root pop-up menu with as many entry as existing desktop. It attach to each entry a callback realized with the given `callback-maker' function. The callback-maker function should be a function of one argument of type integer that will be the index of the desktop entry. It may return a lambda or sub menu entries. If :realize is nil (the default value) it returns the menu entries otherwise a pop-up-menu object is return." (declare (type function callback-maker)) (loop with root-window = (widget-window root) with names = (workspace-names root-window) for i from 0 below (number-of-virtual-screens root-window) for name = (or (pop names) (format nil "workspace ~D" i)) collect (cons name (funcall callback-maker i)) into entries finally (return (if realize (apply #'make-pop-up root entries) entries)))) (defun make-running-menu (root) "Realize the root pop-up menu that shows all applications ordered by desktop." (labels ((raise (window index) (lambda () (case (first (wm-state window)) (1 (change-vscreen root :n index)) (3 (uniconify (slot-value (lookup-widget window) 'icon)))) (put-on-top (lookup-widget window)))) (make-desktop-entries (i) (loop for w in (screen-content i :iconify-p t) for state = (= 1 (first (wm-state w))) for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w)) collect (cons name (raise w i)) into entries finally (return (or entries (lambda () (change-vscreen root :n i))))))) (make-desktop-menu root #'make-desktop-entries :realize t))) (defun make-menu-button-menu (master) (let* ((app (get-child master :application)) (appw (widget-window app)) (net-wm-state (netwm:net-wm-state appw)) (data (make-array 1 :element-type 'xlib:card32)) (xc-msg (make-event :client-message :data data :type :_net_wm_desktop)) (shade-str (if (shaded-p app) "Un-shade" "Shade")) (max-str (if (or (member :_net_wm_state_maximized_vert net-wm-state) (member :_net_wm_state_maximized_horz net-wm-state)) "Un-maximize" "Maximize"))) (declare (type (simple-array xlib:card32 (1)) data)) (flet ((send-message (n) (lambda () (setf (aref data 0) n) (event-process xc-msg app)))) (make-pop-up *root* (cons "Send to" (make-desktop-menu *root* #'send-message)) (if (stick-p appw) (cons "Un-pin" (send-message (current-desk))) (cons "Pin " (send-message +any-desktop+))) (cons max-str (lambda () (maximize-window app 1))) (cons shade-str (lambda () (shade master))) (cons "Close " (lambda () (close-widget app))) (cons "Destroy" (lambda () (kill-client-window appw))) (cons "Iconify" (lambda () (iconify app))))))) (defun remove-window-from-client-lists (window root) "Removes a window from the client lists root properties." (with-slots ((rw window) client-list) root (remhash window client-list) (setf (netwm:net-client-list-stacking rw :mode :remove) window (gnome:win-client-list rw :mode :remove) window (netwm:net-client-list rw :mode :remove) window))) (defun add-window-in-client-lists (window root) "Add a window in the client lists root properties." (with-slots ((rw window) client-list) root (let ((up2date (gethash window client-list))) (setf (gethash window client-list) window) (update-client-list-stacking root) (unless up2date (setf (netwm:net-client-list rw :mode :append) window)) (if (member :win_hints_skip_winlist (gnome:win-hints window)) (setf (gnome:win-client-list rw :mode :remove) window) (unless up2date (setf (gnome:win-client-list rw :mode :append) window)))))) (defun update-client-list-stacking (root) "Recompute ans set the root property net_client_list_stacking." (with-slots (window client-list) root (loop for win in (query-application-tree window) when (gethash win client-list) collect win into wins finally (setf (netwm:net-client-list-stacking window) wins)))) (defun update-lists (app state root) "Update root properties win_client_list, net_client_list(_stacking), by adjoining or removing the given application depending of state." (with-slots ((appw window) iconic-p) app (with-slots ((rw window) client-list) root (case (if (and (= state 3) (not iconic-p)) 0 state) (0 (remove-window-from-client-lists appw root)) (1 (add-window-in-client-lists appw root)))))) (defun window-not-decorable-p (window &optional type) "Return T if a window `should' not be decorated. Typically, a splash screen, a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as non-decorable windows, as well as windows holding the motif_wm_hints with the flag `no decoration at all'." (let ((netwm-type (or type (netwm:net-wm-window-type window)))) (or (eql (motif-wm-decoration window) :OFF) (member :_net_wm_window_type_splash netwm-type) (member :_net_wm_window_type_desktop netwm-type) (member :_net_wm_window_type_dock netwm-type)))) (defun procede-decoration (window) "Decore, if necessary, add/update properties, map or not, etc a window." (let* ((rw (xlib:drawable-root window)) (scr-num (current-vscreen rw)) (application (create-application window nil)) (win-workspace (or (window-desktop-num window) +any-desktop+)) (stick-p (stick-p window))) (xlib:add-to-save-set window) (unless (or stick-p (< -1 win-workspace (number-of-virtual-screens rw))) (setf win-workspace scr-num)) (setf (window-desktop-num window) win-workspace) (cond ((not (or (= win-workspace scr-num) stick-p)) (with-event-mask (rw) (setf (wm-state window) 1) (xlib:unmap-window window) (unless (window-not-decorable-p window) (decore-application window application :map nil)) (update-lists application 1 *root*))) ((window-not-decorable-p window (application-type application)) (setf (wm-state window) 1) (xlib:map-window window)) (t (decore-application window application :map t))) (with-slots (wants-focus-p input-model type) application (unless (member :_net_wm_window_type_desktop type) (unless (eq input-model :no-input) (setf wants-focus-p *focus-new-mapped-window*))) (when (member :_net_wm_window_type_dock type) (update-workarea-property *root*))))) ;;;; The main loop. (define-condition exit-eclipse (error) ((close-application-p :initform nil :initarg :close-application-p :type boolean :reader close-application-p))) (defun eclipse-internal-loop () (let* ((exit 0) time) ;; Sets the root window pop-up menu (when *menu-1-exit-p* (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '()))) (with-slots (menu1 menu3) *root* (setf menu1 (apply #'make-pop-up *root* *menu-1-items*) menu3 (make-pop-up *root* (cons "Move" (define-menu-3 :move)) (cons "Resize" (define-menu-3 :resize)) (cons "Close" (define-menu-3 :close)) (cons "Kill" (define-menu-3 :kill))))) ;; Dress windows already displayed at start time. (flet ((ignorable-window-p (window) (let* ((wmh (xlib:get-property window :WM_HINTS)) (initial-state (and wmh (logbitp 1 (car wmh)) (third wmh))) (wm-state (car (wm-state window)))) (or (eql (xlib:window-override-redirect window) :ON) (when (or (eq initial-state 0) (eq wm-state 0)) (xlib:unmap-window window) t) (and (not wm-state) (eq (xlib:window-map-state window) :unmapped)))))) (xlib:with-server-grabbed (*display*) (mapc (lambda (w) (unless (ignore-errors (ignorable-window-p w)) (procede-decoration w))) (xlib:query-tree *root-window*)))) ;; Main loop (loop (catch 'general-error (handler-case (let ((event (get-next-event *display* :discard-p t :timeout 2))) (when event (with-slots (event-window) event (event-process event (lookup-widget event-window))) (xlib:display-finish-output *display*)) (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks)) (with-slots (sm-conn) *root* (when sm-conn (handle-session-manager-request sm-conn *root*))) (case exit (1 (loop for val being each hash-value in *widget-table* when (application-p val) if *close-display-p* do (close-widget val) else do (undecore-application val)) (setf time 10 exit 2)) (2 (when (root-sm-conn *root*) (close-sm-connection *root* :exit-p nil)) (xlib:display-finish-output *display*) (setf (xlib:window-event-mask *root-window*) 0) (let ((win (netwm:net-supporting-wm-check *root-window*))) (xlib:destroy-window win)) (xlib:display-finish-output *display*) (return)))) (exit-eclipse (c) (setf *close-display-p* (close-application-p c) exit 1)) (end-of-file (c) (handle-end-of-file-condition c)) (already-handled-xerror () nil) (error (c) (handle-error-condition c))))) (format t "~%Main loop exited~%")))