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."
`(progn
(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)))))
(:_NET_WM_DESKTOP
(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 @@
"~/"))
directory))
;;;; 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)
`(unwind-protect
......@@ -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))
"incognito"))
(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
:client-message
nil
......@@ -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."
`(progn
(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 @@
"GET-SCREEN-CONTENT" ;function
"GET-VISIBLE-WINDOWS" ;function
"GIVE-FOCUS-TO-NEXT-WIDGET-IN-DESKTOP" ;function
"GNOME-DESKTOP-NUM" ;function
"HIGHLIGHT" ;function
"HOME-SUBDIRECTORY" ;function
"ICON-BOX-UPDATE" ;function
......@@ -202,7 +201,7 @@
"UPDATE-TITLE-BAR-SIZES" ;function
"WHERE-IS-POINTER" ;function
"WIDGET->FRAME-ITEM-KEY" ;function
"WINDOW-DESKTOP-NUM" ;setf function
"WINDOW-DESKTOP-NUM" ;function, setf
"WINDOW-NOT-DECORABLE-P" ;function
"WINDOW-PRIORITY" ;setf function
"WINDOW-TRANSIENT-P" ;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 : hatchond@yahoo.fr
......@@ -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