Commit a5552880 authored by hatchond's avatar hatchond
Browse files

- misc.lisp:

  lots documentation added
  gnome-desktop-num turned in window-desktop-num
- input.lisp, wm.lisp, virtual-screen.lisp, package.lisp, global.lisp
  gnome-desktop-num -> window-desktop-num
parent f6ee0e64
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: global.lisp,v 1.8 2003/05/14 08:56:17 hatchond Exp $
;;; $Id: global.lisp,v 1.9 2003/08/28 14:50:35 hatchond Exp $
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
......@@ -100,7 +100,7 @@ NIL corresponds to the default which is to sort on order of creation
(defmacro deftypedparameter (type symbol value &optional documentation)
"define a parameter with the same syntax and behavior as defparameter
except that its type must be given first."
except that its type must be given first."
(defparameter ,symbol ,value ,documentation)
(declaim (type ,type ,symbol))))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.13 2003/09/12 01:29:57 hatchond Exp $
;;; $Id: input.lisp,v 1.14 2003/09/12 09:10:02 hatchond Exp $
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -219,37 +219,37 @@
(defmethod event-process ((event configure-notify) (master decoration))
(when (application-p (lookup-widget (event-window event)))
(with-slots ((ev-win event-window) window x y) event
(with-slots ((master-win event-window) (app-window window) x y) event
(with-slots (left-margin top-margin) (decoration-frame-style master)
(multiple-value-bind (old-x old-y) (window-position window)
(multiple-value-bind (old-x old-y) (window-position app-window)
(when (eql (decoration-application-gravity master) :static)
(decf x left-margin) (decf y top-margin))
(unless (= old-x left-margin) (setf (xlib:drawable-x ev-win) x))
(unless (= old-y top-margin) (setf (xlib:drawable-y ev-win) y)))
(resize-from (get-child master :application))
(with-event-mask (ev-win)
(unless (= old-x left-margin) (setf (xlib:drawable-x master-win) x))
(unless (= old-y top-margin) (setf (xlib:drawable-y master-win) y)))
(resize-from (lookup-widget app-window))
(with-event-mask (master-win)
(update-edges-geometry master)
(setf (window-position window) (values left-margin top-margin))
(send-configuration-notify window))))))
(setf (window-position app-window) (values left-margin top-margin))
(send-configuration-notify app-window))))))
(defmethod event-process ((event reparent-notify) (master decoration))
(unless (xlib:window-equal (event-event-window event) (event-parent event))
(event-process (make-event :destroy-notify) master)))
(defmethod event-process ((event unmap-notify) (master decoration))
(with-slots (event-window) event
(xlib:unmap-window event-window)))
(with-slots (window) master
(xlib:unmap-window window)))
(defmethod event-process ((event map-notify) (master decoration))
(with-slots (window event-window) event
(when (application-p (lookup-widget window))
(unless (eq (xlib:window-map-state window) :unmapped)
(with-slots ((app-window window) (master-window event-window)) event
(when (application-p (lookup-widget app-window))
(unless (eq (xlib:window-map-state app-window) :unmapped)
(unmap-icon-window (get-child master :icon))
(xlib:map-window event-window)
(setf (window-priority event-window) :above
(wm-state window) 1)
(setf (window-desktop-num window)
(if (stick-p window) +any-desktop+ (current-desk)))))))
(xlib:map-window master-window)
(setf (window-priority master-window) :above
(wm-state app-window) 1)
(setf (window-desktop-num app-window)
(if (stick-p app-window) +any-desktop+ (current-desk)))))))
(defmethod event-process ((event destroy-notify) (master decoration))
(with-event-mask (*root-window*)
......@@ -363,7 +363,7 @@
(when (or-eql :_net_wm_state_below p1 p2)
(put-on-bottom application)))))
(let* ((cur-desk (gnome-desktop-num window))
(let* ((cur-desk (window-desktop-num window))
(new-desk (aref data 0))
(master-window (and master (widget-window master))))
(unless (= cur-desk new-desk)
......@@ -441,14 +441,14 @@
(with-slots (active-p) (button-master edge)
(if active-p (setf active-p nil) (event-process event *root*))))
;; initialize the move process.
;; Initialize the move process.
(defmethod event-process ((event button-press) (title title-bar))
(with-slots (master armed active-p) title
(setf (window-priority (widget-window master)) :above)
(unless (event-send-event-p event)
(initialize-move master event))))
;; start the movement.
;; Start the movement.
(defmethod event-process ((event motion-notify) (title title-bar))
(with-slots (move-status resize-status current-active-decoration) *root*
(with-slots (window gcontext active-p) (button-master title)
......@@ -475,7 +475,7 @@
(with-slots (input-model window) (get-child master :application)
(set-focus input-model window (event-time event))))))
;;; events for an icon
;;; Events for an icon
(defmethod event-process ((event exposure) (icon icon))
(repaint icon (theme-name (root-decoration-theme *root*)) nil))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.8 2003/09/10 23:56:19 hatchond Exp $
;;; $Id: misc.lisp,v 1.9 2003/09/12 01:15:16 hatchond Exp $
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -29,12 +29,20 @@
;;;; Helpers macros.
(defmacro screen-width ()
`(xlib:screen-width (xlib:display-default-screen *display*)))
(defmacro screen-height ()
`(xlib:screen-height (xlib:display-default-screen *display*)))
(defmacro id->atom-name (id) `(xlib:atom-name *display* ,id))
(defmacro atom-name->id (name) `(xlib:find-atom *display* ,name))
(defmacro id->atom-name (id)
`(xlib:atom-name *display* ,id))
(defmacro atom-name->id (name)
`(xlib:find-atom *display* ,name))
(defmacro with-root-cursor ((new-cursor) &body body)
......@@ -60,14 +68,11 @@
(make-error-handler (wrong-name :verbose nil)
(timed-message-box *root-window* "Wrong application name"))
(defun run-application (program &rest arguments)
(lambda ()
(catch 'wrong-name
(handler-bind ((error #'handle-wrong-name-condition))
(%run-program% program arguments)))))
(defun make-viewport-property (n)
(make-list (* 2 n) :initial-element 0))
;;;; Property readers.
;; They are not defined in the clx-ext package, because we customize them
;; to allow a single manipulation for all properties that appears in the
;; gnome and netwm protocols, or because it partially reads a property to
;; returns the part that is interesting in a window manager point of view.
(defun window-transient-p (app-window)
(or (xlib:transient-for app-window)
......@@ -107,7 +112,7 @@
(ignore-errors (xlib:wm-icon-name window))
(defun gnome-desktop-num (window)
(defun window-desktop-num (window)
(or (netwm:net-wm-desktop window) (gnome:win-workspace window)))
(defsetf window-desktop-num (window) (n)
......@@ -115,14 +120,20 @@
(netwm:net-wm-desktop ,window) ,n))
(defun motif-wm-decoration (window)
"Returns the state (or :on :off) of the :_MOTIF_WM_HINT property that
indicates the application wants or not to be decorated."
(let ((prop (xlib:get-property window :_MOTIF_WM_HINTS)))
(or (and prop (logbitp 1 (first prop)) (zerop (third prop)) :OFF) :ON)))
(defun stick-p (window)
(or (= (or (gnome-desktop-num window) -1) +any-desktop+)
(or (= (or (window-desktop-num window) -1) +any-desktop+)
(logbitp 0 (or (gnome:win-state window :result-type t) 0))))
;;;; Miscellenious functions.
(defun send-wm-protocols-client-message (window atom &rest data)
"Send a client-message of type :wm-protocol to the specified window
with data being the given atom plus the rest of the function args."
(xlib:send-event window
......@@ -132,6 +143,9 @@
:data (cons (atom-name->id atom) data)))
(defsetf window-priority (window &optional sibling) (priority)
"Set the window priority such as (setf xlib:window-priority) but
also invoke update-client-list-stacking to reflect the priority
change in all the root properties that are involved in."
(setf (xlib:window-priority ,window ,sibling) ,priority)
(update-client-list-stacking *root*)))
......@@ -145,6 +159,9 @@
:owner-p owner-p))
(defun query-application-tree (root-window)
"Returns the children of the specified root-window as if all applications
where undecorated. The children are returned as a sequence of windows in
current stacking order, from bottom-most (first) to top-most (last)."
(loop for window in (xlib:query-tree root-window)
for obj = (lookup-widget window)
for appw = (typecase obj
......@@ -153,8 +170,23 @@
when appw collect appw))
(defun delete-properties (window properties)
"Delete a list of properties on the specified window."
(mapc #'(lambda (prop) (xlib:delete-property window prop)) properties))
(defun run-application (program &rest arguments)
"Returns a lambda of zero arguments which when funcalled will try to
run the program named `program' with arguments `arguments'. If the
invocation failed a pop-up window will appear reporting the error."
(lambda ()
(catch 'wrong-name
(handler-bind ((error #'handle-wrong-name-condition))
(%run-program% program arguments)))))
(defun make-viewport-property (n)
(make-list (* 2 n) :initial-element 0))
;;;; Geometry structure and accessors.
(defstruct geometry
(x 0 :type (signed-byte 16))
(y 0 :type (signed-byte 16))
;;; -*- Mode: Lisp; Package: User -*-
;;; $Id: package.lisp,v 1.5 2003/09/07 01:35:44 hatchond Exp $
;;; $Id: package.lisp,v 1.6 2003/09/12 01:16:10 hatchond Exp $
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -118,7 +118,6 @@
"HIGHLIGHT" ;function
"ICON-BOX-UPDATE" ;function
......@@ -202,7 +201,7 @@
"WHERE-IS-POINTER" ;function
"WINDOW-DESKTOP-NUM" ;setf function
"WINDOW-DESKTOP-NUM" ;function, setf
"WINDOW-PRIORITY" ;setf function
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: virtual-screen.lisp,v 1.6 2003/09/11 00:01:31 hatchond Exp $
;;; $Id: virtual-screen.lisp,v 1.7 2003/09/12 09:10:02 hatchond Exp $
;;;Copyright (C) 2002 Iban HATCHONDO
;;; contact :
......@@ -24,7 +24,7 @@
;;;; Private
(defun window-belongs-to-vscreen-p (window scr-num iconify-p)
(let ((n (or (gnome-desktop-num window) -1))
(let ((n (or (window-desktop-num window) -1))
(wm-state (car (wm-state window)))
(netwm-type (netwm:net-wm-window-type window)))
(and (or (= n scr-num) (= n +any-desktop+))
......@@ -38,7 +38,7 @@
(loop for widget being each hash-value in *widget-table*
when (application-p widget) do
(with-slots (window master) widget
(when (and (eq (gnome-desktop-num window) scr-num)
(when (and (eq (window-desktop-num window) scr-num)
(eq (car (wm-state window)) 1))
(funcall fun (if master (widget-window master) window))))))
......@@ -65,7 +65,7 @@
(loop for widget being each hash-value in *widget-table*
when (application-p widget) do
(with-slots ((win window)) widget
(let ((i (or (ignore-errors (gnome-desktop-num win)) -1)))
(let ((i (or (ignore-errors (window-desktop-num win)) -1)))
(when (and (>= i ,n) (/= i +any-desktop+))
(setf (window-desktop-num win) (1- ,n)))))))
(cond ((> cur (1- ,n)) (change-vscreen *root* :n (1- ,n)))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.16 2003/09/08 15:40:31 hatchond Exp $
;;; $Id: wm.lisp,v 1.17 2003/09/12 09:10:02 hatchond Exp $
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -566,7 +566,7 @@
(defun raise-window (window)
(lambda ()
(case (first (wm-state window))
(1 (change-vscreen *root* :n (gnome-desktop-num window)))
(1 (change-vscreen *root* :n (window-desktop-num window)))
(3 (uniconify (slot-value (lookup-widget window) 'icon))))
(put-on-top (lookup-widget window))))
......@@ -598,7 +598,7 @@
(add (cons "Close " (lambda () (close-widget appli))))
(add (cons (%shade%) (lambda () (shade master))))
(add (cons (%maximize%) (lambda () (maximize-window appli 1))))
(if (= (or (gnome-desktop-num window) -1) +any-desktop+)
(if (= (or (window-desktop-num window) -1) +any-desktop+)
(add (cons "Un-pin" (%send-message% (current-desk))))
(add (cons "Pin " (%send-message% +any-desktop+))))
(add (cons "Send to" (%sendTO%))))))
......@@ -654,7 +654,7 @@
(defun procede-decoration (window)
(let ((scr-num (current-desk))
(application (create-application window nil))
(win-workspace (or (gnome-desktop-num window) +any-desktop+))
(win-workspace (or (window-desktop-num window) +any-desktop+))
(stick-p (stick-p window))
(netwm-type (netwm:net-wm-window-type window)))
(xlib:add-to-save-set window)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment