From pbrochard at common-lisp.net Sat Sep 4 11:31:09 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 04 Sep 2010 07:31:09 -0400 Subject: [clfswm-cvs] r310 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 4 07:31:08 2010 New Revision: 310 Log: src/xlib-util.lisp (handle-event): use with-xlib-protect only in handle-event. Add a with-simple-restart to prevent a clisp/new-lisp infinite loop. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 4 07:31:08 2010 @@ -1,3 +1,9 @@ +2010-09-04 Philippe Brochard + + * src/xlib-util.lisp (handle-event): use with-xlib-protect only in + handle-event. Add a with-simple-restart to prevent a + clisp/new-lisp infinite loop. + 2010-08-30 Philippe Brochard * src/clfswm-corner.lisp (present-clfswm-terminal): Make the Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Sep 4 07:31:08 2010 @@ -135,12 +135,14 @@ (if (frame-p frame) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) frame - (and (not (child-member window unmanaged)) - (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) - (or (member :all (frame-managed-type frame)) - (member (window-type window) (frame-managed-type frame)) - (child-member window managed) - (member (xlib:wm-name window) managed :test #'string-equal-p)))) + (xlib:display-finish-output *display*) + (let ((ret (and (not (child-member window unmanaged)) + (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) + (or (member :all (frame-managed-type frame)) + (member (window-type window) (frame-managed-type frame)) + (child-member window managed) + (member (xlib:wm-name window) managed :test #'string-equal-p))))) + ret)) t)) @@ -486,41 +488,39 @@ (defgeneric adapt-child-to-parent (child parent)) (defmethod adapt-child-to-parent ((window xlib:window) parent) - (with-xlib-protect - (when (managed-window-p window parent) - (multiple-value-bind (nx ny nw nh) - (get-parent-layout window parent) - (setf nw (max nw 1) nh (max nh 1)) - (let ((change (or (/= (xlib:drawable-x window) nx) - (/= (xlib:drawable-y window) ny) - (/= (xlib:drawable-width window) nw) - (/= (xlib:drawable-height window) nh)))) - (setf (xlib:drawable-x window) nx - (xlib:drawable-y window) ny - (xlib:drawable-width window) nw - (xlib:drawable-height window) nh) - (xlib:display-finish-output *display*) - change))))) + (when (managed-window-p window parent) + (multiple-value-bind (nx ny nw nh) + (get-parent-layout window parent) + (setf nw (max nw 1) nh (max nh 1)) + (let ((change (or (/= (xlib:drawable-x window) nx) + (/= (xlib:drawable-y window) ny) + (/= (xlib:drawable-width window) nw) + (/= (xlib:drawable-height window) nh)))) + (setf (xlib:drawable-x window) nx + (xlib:drawable-y window) ny + (xlib:drawable-width window) nw + (xlib:drawable-height window) nh) + (xlib:display-finish-output *display*) + change)))) (defmethod adapt-child-to-parent ((frame frame) parent) - (with-xlib-protect - (multiple-value-bind (nx ny nw nh) - (get-parent-layout frame parent) - (with-slots (rx ry rw rh window) frame - (setf rx nx ry ny - rw (max nw 1) - rh (max nh 1)) - (let ((change (or (/= (xlib:drawable-x window) rx) - (/= (xlib:drawable-y window) ry) - (/= (xlib:drawable-width window) rw) - (/= (xlib:drawable-height window) rh)))) - (setf (xlib:drawable-x window) rx - (xlib:drawable-y window) ry - (xlib:drawable-width window) rw - (xlib:drawable-height window) rh) - (xlib:display-finish-output *display*) - change))))) + (multiple-value-bind (nx ny nw nh) + (get-parent-layout frame parent) + (with-slots (rx ry rw rh window) frame + (setf rx nx ry ny + rw (max nw 1) + rh (max nh 1)) + (let ((change (or (/= (xlib:drawable-x window) rx) + (/= (xlib:drawable-y window) ry) + (/= (xlib:drawable-width window) rw) + (/= (xlib:drawable-height window) rh)))) + (setf (xlib:drawable-x window) rx + (xlib:drawable-y window) ry + (xlib:drawable-width window) rw + (xlib:drawable-height window) rh) + (xlib:display-finish-output *display*) + change)))) (defmethod adapt-child-to-parent (child parent) (declare (ignore child parent)) @@ -533,25 +533,23 @@ (defmethod show-child ((frame frame) parent raise-p) (declare (ignore parent)) - (with-xlib-protect - (with-slots (window show-window-p) frame - (if show-window-p - (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) - (setf (xlib:window-background window) (get-color "Black")) - (map-window window) - (when raise-p (raise-window window))) - (hide-window window))) - (display-frame-info frame))) + (with-slots (window show-window-p) frame + (if show-window-p + (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) + (setf (xlib:window-background window) (get-color "Black")) + (map-window window) + (when raise-p (raise-window window))) + (hide-window window))) + (display-frame-info frame)) (defmethod show-child ((window xlib:window) parent raise-p) - (with-xlib-protect - (if (or (managed-window-p window parent) - (child-equal-p parent *current-child*)) - (progn - (map-window window) - (when raise-p (raise-window window))) - (hide-window window)))) + (if (or (managed-window-p window parent) + (child-equal-p parent *current-child*)) + (progn + (map-window window) + (when raise-p (raise-window window))) + (hide-window window))) (defmethod show-child (child parent raise-p) (declare (ignore child parent raise-p)) @@ -561,9 +559,8 @@ (defgeneric hide-child (child)) (defmethod hide-child ((frame frame)) - (with-xlib-protect - (with-slots (window) frame - (xlib:unmap-window window)))) + (with-slots (window) frame + (xlib:unmap-window window))) (defmethod hide-child ((window xlib:window)) (hide-window window)) @@ -598,20 +595,18 @@ (defgeneric select-child (child selected)) (defmethod select-child ((frame frame) selected) - (with-xlib-protect - (when (and (frame-p frame) (frame-window frame)) - (setf (xlib:window-border (frame-window frame)) - (get-color (cond ((equal selected :maybe) *color-maybe-selected*) - ((equal selected nil) *color-unselected*) - (selected *color-selected*))))))) - -(defmethod select-child ((window xlib:window) selected) - (with-xlib-protect - (setf (xlib:window-border window) + (when (and (frame-p frame) (frame-window frame)) + (setf (xlib:window-border (frame-window frame)) (get-color (cond ((equal selected :maybe) *color-maybe-selected*) ((equal selected nil) *color-unselected*) (selected *color-selected*)))))) +(defmethod select-child ((window xlib:window) selected) + (setf (xlib:window-border window) + (get-color (cond ((equal selected :maybe) *color-maybe-selected*) + ((equal selected nil) *color-unselected*) + (selected *color-selected*))))) + (defmethod select-child (child selected) (declare (ignore child selected)) ()) @@ -905,20 +900,19 @@ (defun place-window-from-hints (window) "Place a window from its hints" - (with-xlib-protect - (let* ((hints (xlib:wm-normal-hints window)) - (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)) - (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)) - (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (xlib:drawable-width *root*))) - (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (xlib:drawable-height *root*))) - (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints))) - (xlib:drawable-width window))) - (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints))) - (xlib:drawable-height window)))) - (setf (xlib:drawable-width window) (min (max min-width rwidth *default-window-width*) max-width) - (xlib:drawable-height window) (min (max min-height rheight *default-window-height*) max-height)) - (setf (xlib:drawable-x window) (truncate (/ (- (xlib:screen-width *screen*) (+ (xlib:drawable-width window) 2)) 2)) - (xlib:drawable-y window) (truncate (/ (- (xlib:screen-height *screen*) (+ (xlib:drawable-height window) 2)) 2)))))) + (let* ((hints (xlib:wm-normal-hints window)) + (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)) + (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)) + (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (xlib:drawable-width *root*))) + (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (xlib:drawable-height *root*))) + (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints))) + (xlib:drawable-width window))) + (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints))) + (xlib:drawable-height window)))) + (setf (xlib:drawable-width window) (min (max min-width rwidth *default-window-width*) max-width) + (xlib:drawable-height window) (min (max min-height rheight *default-window-height*) max-height)) + (setf (xlib:drawable-x window) (truncate (/ (- (xlib:screen-width *screen*) (+ (xlib:drawable-width window) 2)) 2)) + (xlib:drawable-y window) (truncate (/ (- (xlib:screen-height *screen*) (+ (xlib:drawable-height window) 2)) 2))))) @@ -937,19 +931,18 @@ "When a new window is created (or when we are scanning initial windows), this function dresses the window up and gets it ready to be managed." - (with-xlib-protect - (setf (xlib:window-event-mask window) *window-events*) - (set-window-state window +normal-state+) - (setf (xlib:drawable-border-width window) (case (window-type window) - (:normal 1) - (:maxsize 1) - (:transient 1) - (t 1))) - (grab-all-buttons window) - (unless (never-managed-window-p window) - (unless (do-all-frames-nw-hook window) - (call-hook *default-nw-hook* (list *root-frame* window)))) - (netwm-add-in-client-list window))) + (setf (xlib:window-event-mask window) *window-events*) + (set-window-state window +normal-state+) + (setf (xlib:drawable-border-width window) (case (window-type window) + (:normal 1) + (:maxsize 1) + (:transient 1) + (t 1))) + (grab-all-buttons window) + (unless (never-managed-window-p window) + (unless (do-all-frames-nw-hook window) + (call-hook *default-nw-hook* (list *root-frame* window)))) + (netwm-add-in-client-list window)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 4 07:31:08 2010 @@ -134,11 +134,10 @@ (defun unhide-all-windows-in-current-child () "Unhide all hidden windows into the current child" - (with-xlib-protect - (dolist (window (get-hidden-windows)) - (unhide-window window) - (process-new-window window) - (map-window window))) + (dolist (window (get-hidden-windows)) + (unhide-window window) + (process-new-window window) + (map-window window)) (show-all-children)) @@ -146,36 +145,34 @@ (defun find-window-under-mouse (x y) "Return the child window under the mouse" - (with-xlib-protect - (let ((win *root*)) - (with-all-windows-frames-and-parent (*current-root* child parent) - (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) - (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) - (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) - (setf win child)) - (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child))) - (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child)))) - (setf win (frame-window child)))) - win))) + (let ((win *root*)) + (with-all-windows-frames-and-parent (*current-root* child parent) + (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) + (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) + (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) + (setf win child)) + (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child))) + (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child)))) + (setf win (frame-window child)))) + win)) (defun find-child-under-mouse (x y &optional first-foundp) "Return the child under the mouse" - (with-xlib-protect - (let ((ret nil)) - (with-all-windows-frames-and-parent (*current-root* child parent) - (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) - (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) - (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) - (if first-foundp - (return-from find-child-under-mouse child) - (setf ret child))) - (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child))) - (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child)))) - (if first-foundp - (return-from find-child-under-mouse child) - (setf ret child)))) - ret))) + (let ((ret nil)) + (with-all-windows-frames-and-parent (*current-root* child parent) + (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) + (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) + (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) + (if first-foundp + (return-from find-child-under-mouse child) + (setf ret child))) + (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child))) + (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child)))) + (if first-foundp + (return-from find-child-under-mouse child) + (setf ret child)))) + ret)) @@ -933,9 +930,8 @@ "Force the current window to move in the frame (Useful only for unmanaged windows)" (with-current-window (let ((parent (find-parent-frame window))) - (with-xlib-protect - (setf (xlib:drawable-x window) (frame-rx parent) - (xlib:drawable-y window) (frame-ry parent))))) + (setf (xlib:drawable-x window) (frame-rx parent) + (xlib:drawable-y window) (frame-ry parent)))) (leave-second-mode)) @@ -943,13 +939,12 @@ "Force the current window to move in the center of the frame (Useful only for unmanaged windows)" (with-current-window (let ((parent (find-parent-frame window))) - (with-xlib-protect - (setf (xlib:drawable-x window) (truncate (+ (frame-rx parent) - (/ (- (frame-rw parent) - (xlib:drawable-width window)) 2))) - (xlib:drawable-y window) (truncate (+ (frame-ry parent) - (/ (- (frame-rh parent) - (xlib:drawable-height window)) 2))))))) + (setf (xlib:drawable-x window) (truncate (+ (frame-rx parent) + (/ (- (frame-rw parent) + (xlib:drawable-width window)) 2))) + (xlib:drawable-y window) (truncate (+ (frame-ry parent) + (/ (- (frame-rh parent) + (xlib:drawable-height window)) 2)))))) (leave-second-mode)) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Sep 4 07:31:08 2010 @@ -55,28 +55,27 @@ (when (has-y value-mask) (setf (xlib:drawable-y window) y)) (when (has-h value-mask) (setf (xlib:drawable-height window) height)) (when (has-w value-mask) (setf (xlib:drawable-width window) width)))) - (with-xlib-protect - (xlib:with-state (window) - (when (has-bw value-mask) - (setf (xlib:drawable-border-width window) border-width)) - (if (find-child window *current-root*) - (let ((parent (find-parent-frame window *current-root*))) - (if (and parent (managed-window-p window parent)) - (adapt-child-to-parent window parent) - (adjust-from-request))) - (adjust-from-request)) - (send-configuration-notify window (xlib:drawable-x window) (xlib:drawable-y window) - (xlib:drawable-width window) (xlib:drawable-height window) - (xlib:drawable-border-width window)) - (when (has-stackmode value-mask) - (case stack-mode - (:above - (unless (null-size-window-p window) - (when (or (child-equal-p window *current-child*) - (is-in-current-child-p window)) - (raise-window window) - (focus-window window) - (focus-all-children window (find-parent-frame window *current-root*))))))))))) + (xlib:with-state (window) + (when (has-bw value-mask) + (setf (xlib:drawable-border-width window) border-width)) + (if (find-child window *current-root*) + (let ((parent (find-parent-frame window *current-root*))) + (if (and parent (managed-window-p window parent)) + (adapt-child-to-parent window parent) + (adjust-from-request))) + (adjust-from-request)) + (send-configuration-notify window (xlib:drawable-x window) (xlib:drawable-y window) + (xlib:drawable-width window) (xlib:drawable-height window) + (xlib:drawable-border-width window)) + (when (has-stackmode value-mask) + (case stack-mode + (:above + (unless (null-size-window-p window) + (when (or (child-equal-p window *current-child*) + (is-in-current-child-p window)) + (raise-window window) + (focus-window window) + (focus-all-children window (find-parent-frame window *current-root*)))))))))) (define-handler main-mode :map-request (window send-event-p) @@ -129,13 +128,12 @@ (defun main-loop () (loop - (with-xlib-protect - (call-hook *loop-hook*) - (xlib:display-finish-output *display*) - (when (xlib:event-listen *display* *loop-timeout*) - (xlib:process-event *display* :handler #'handle-event)) - (xlib:display-finish-output *display*)))) -;;(dbg "Main loop finish" c))))) + (call-hook *loop-hook*) + (xlib:display-finish-output *display*) + (when (xlib:event-listen *display* *loop-timeout*) + (xlib:process-event *display* :handler #'handle-event)) + (xlib:display-finish-output *display*))) + (defun open-display (display-str protocol) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Sep 4 07:31:08 2010 @@ -63,22 +63,15 @@ "Alist mapping NETWM window types to keywords.") + (defmacro with-xlib-protect (&body body) "Prevent Xlib errors" `(handler-case (progn , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) - ;;(dbg c)))) - ;;(declare (ignore c))))) - (format t "~&Xlib-error: ~A~%Body:~%~A~%" c ',body) - (force-output)))) - ;;(dbg c ',body)))) - -;;(defmacro with-xlib-protect (&body body) -;; "Prevent Xlib errors" -;; `(progn -;; , at body)) + (dbg 'Ignore-xlib-error c)))) + @@ -153,10 +146,12 @@ , at body)) + (defun handle-event (&rest event-slots &key event-key &allow-other-keys) (with-xlib-protect (if (fboundp event-key) - (apply event-key event-slots) + (with-simple-restart (top-level "Return to clfswm's top level") + (apply event-key event-slots)) #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) t) @@ -217,19 +212,17 @@ (defun unhide-window (window) (when window - (with-xlib-protect - (when (window-hidden-p window) - (xlib:map-window window) - (setf (window-state window) +normal-state+ - (xlib:window-event-mask window) *window-events*)))) + (when (window-hidden-p window) + (xlib:map-window window) + (setf (window-state window) +normal-state+ + (xlib:window-event-mask window) *window-events*))) (xlib:display-finish-output *display*)) (defun map-window (window) (when window - (with-xlib-protect - (xlib:map-window window) - (xlib:display-finish-output *display*)))) + (xlib:map-window window) + (xlib:display-finish-output *display*))) (defun delete-window (window) (send-client-message window :WM_PROTOCOLS @@ -333,11 +326,10 @@ (defun hide-window (window) (when window - (with-xlib-protect - (setf (window-state window) +iconic-state+ - (xlib:window-event-mask window) (remove :structure-notify *window-events*)) - (xlib:unmap-window window) - (setf (xlib:window-event-mask window) *window-events*))) + (setf (window-state window) +iconic-state+ + (xlib:window-event-mask window) (remove :structure-notify *window-events*)) + (xlib:unmap-window window) + (setf (xlib:window-event-mask window) *window-events*)) (xlib:display-finish-output *display*)) @@ -394,17 +386,15 @@ (defun raise-window (window) "Map the window if needed and bring it to the top of the stack. Does not affect focus." (when window - (with-xlib-protect - (when (window-hidden-p window) - (unhide-window window)) - (setf (xlib:window-priority window) :top-if))) + (when (window-hidden-p window) + (unhide-window window)) + (setf (xlib:window-priority window) :top-if)) (xlib:display-finish-output *display*)) (defun focus-window (window) "Give the window focus." (when window - (with-xlib-protect - (xlib:set-input-focus *display* window :parent))) + (xlib:set-input-focus *display* window :parent)) (xlib:display-finish-output *display*)) @@ -465,6 +455,7 @@ "Remove the grab on the cursor and restore the cursor shape." (setf pointer-grabbed nil) (xlib:ungrab-pointer *display*) + (xlib:display-finish-output *display*) (free-grab-pointer))) From pbrochard at common-lisp.net Sat Sep 4 16:32:56 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 04 Sep 2010 12:32:56 -0400 Subject: [clfswm-cvs] r311 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 4 12:32:56 2010 New Revision: 311 Log: src/clfswm.lisp (main-loop): Protect all xlib functions with an with-xlib-protect. Modified: clfswm/ChangeLog clfswm/load.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 4 12:32:56 2010 @@ -1,5 +1,8 @@ 2010-09-04 Philippe Brochard + * src/clfswm.lisp (main-loop): Protect all xlib functions with an + with-xlib-protect. + * src/xlib-util.lisp (handle-event): use with-xlib-protect only in handle-event. Add a with-simple-restart to prevent a clisp/new-lisp infinite loop. Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Sat Sep 4 12:32:56 2010 @@ -32,10 +32,13 @@ #+SBCL (require :asdf) -#+SBCL -(require :sb-posix) +;;#+SBCL +;;(require :sb-posix) + +;;#+SBCL +;; (require :clx) -#+(or CMU SBCL ECL) +#+(or CMU ECL) (require :clx) #-ASDF Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Sep 4 12:32:56 2010 @@ -129,10 +129,14 @@ (defun main-loop () (loop (call-hook *loop-hook*) - (xlib:display-finish-output *display*) - (when (xlib:event-listen *display* *loop-timeout*) - (xlib:process-event *display* :handler #'handle-event)) - (xlib:display-finish-output *display*))) + (with-xlib-protect + (xlib:display-finish-output *display*)) + (when (with-xlib-protect + (xlib:event-listen *display* *loop-timeout*)) + (with-xlib-protect + (xlib:process-event *display* :handler #'handle-event))) + (with-xlib-protect + (xlib:display-finish-output *display*)))) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Sep 4 12:32:56 2010 @@ -70,7 +70,7 @@ (progn , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) - (dbg 'Ignore-xlib-error c)))) + (dbg "Ignore Xlib Error" c ',body)))) From pbrochard at common-lisp.net Sun Sep 5 12:48:00 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 05 Sep 2010 08:48:00 -0400 Subject: [clfswm-cvs] r312 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Sep 5 08:47:59 2010 New Revision: 312 Log: with-xlib-protect: Add a with-simple-restart on top of body execution. Modified: clfswm/ChangeLog clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Sep 5 08:47:59 2010 @@ -1,3 +1,8 @@ +2010-09-05 Philippe Brochard + + * src/xlib-util.lisp (with-xlib-protect): Add a + with-simple-restart on top of body execution. + 2010-09-04 Philippe Brochard * src/clfswm.lisp (main-loop): Protect all xlib functions with an Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sun Sep 5 08:47:59 2010 @@ -67,7 +67,7 @@ (defmacro with-xlib-protect (&body body) "Prevent Xlib errors" `(handler-case - (progn + (with-simple-restart (top-level "Return to clfswm's top level") , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) (dbg "Ignore Xlib Error" c ',body)))) @@ -150,8 +150,7 @@ (defun handle-event (&rest event-slots &key event-key &allow-other-keys) (with-xlib-protect (if (fboundp event-key) - (with-simple-restart (top-level "Return to clfswm's top level") - (apply event-key event-slots)) + (apply event-key event-slots) #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) t) From pbrochard at common-lisp.net Tue Sep 7 20:18:34 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 07 Sep 2010 16:18:34 -0400 Subject: [clfswm-cvs] r313 - in clfswm: . src Message-ID: Author: pbrochard Date: Tue Sep 7 16:18:34 2010 New Revision: 313 Log: src/clfswm.lisp (error-handler): New function do handle asynchronous errors and ignore them. (open-display): Install the new error-handler on display. Modified: clfswm/ChangeLog clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Sep 7 16:18:34 2010 @@ -1,3 +1,9 @@ +2010-09-07 Philippe Brochard + + * src/clfswm.lisp (error-handler): New function do handle + asynchronous errors and ignore them. + (open-display): Install the new error-handler on display. + 2010-09-05 Philippe Brochard * src/xlib-util.lisp (with-xlib-protect): Add a Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Tue Sep 7 16:18:34 2010 @@ -41,7 +41,6 @@ (loop (call-hook loop-hook) (nfuncall loop-function) - (xlib:display-finish-output *display*) (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-event)) (xlib:display-finish-output *display*)) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Tue Sep 7 16:18:34 2010 @@ -135,14 +135,12 @@ (if (frame-p frame) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) frame - (xlib:display-finish-output *display*) - (let ((ret (and (not (child-member window unmanaged)) - (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) - (or (member :all (frame-managed-type frame)) - (member (window-type window) (frame-managed-type frame)) - (child-member window managed) - (member (xlib:wm-name window) managed :test #'string-equal-p))))) - ret)) + (and (not (child-member window unmanaged)) + (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) + (or (member :all (frame-managed-type frame)) + (member (window-type window) (frame-managed-type frame)) + (child-member window managed) + (member (xlib:wm-name window) managed :test #'string-equal-p)))) t)) @@ -326,7 +324,8 @@ x (x-px->fl prx parent) y (y-px->fl pry parent) w (w-px->fl prw parent) - h (h-px->fl prh parent))))) + h (h-px->fl prh parent)) + (xlib:display-finish-output *display*)))) (defun fixe-real-size (frame parent) "Fixe real (pixel) coordinates in float coordinates" @@ -912,7 +911,8 @@ (setf (xlib:drawable-width window) (min (max min-width rwidth *default-window-width*) max-width) (xlib:drawable-height window) (min (max min-height rheight *default-window-height*) max-height)) (setf (xlib:drawable-x window) (truncate (/ (- (xlib:screen-width *screen*) (+ (xlib:drawable-width window) 2)) 2)) - (xlib:drawable-y window) (truncate (/ (- (xlib:screen-height *screen*) (+ (xlib:drawable-height window) 2)) 2))))) + (xlib:drawable-y window) (truncate (/ (- (xlib:screen-height *screen*) (+ (xlib:drawable-height window) 2)) 2))) + (xlib:display-finish-output *display*))) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Tue Sep 7 16:18:34 2010 @@ -316,7 +316,6 @@ (force-output) (unwind-protect (loop until done do - (xlib:display-finish-output *display*) (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-identify)) (xlib:display-finish-output *display*)) @@ -931,7 +930,8 @@ (with-current-window (let ((parent (find-parent-frame window))) (setf (xlib:drawable-x window) (frame-rx parent) - (xlib:drawable-y window) (frame-ry parent)))) + (xlib:drawable-y window) (frame-ry parent)) + (xlib:display-finish-output *display*))) (leave-second-mode)) @@ -944,7 +944,8 @@ (xlib:drawable-width window)) 2))) (xlib:drawable-y window) (truncate (+ (frame-ry parent) (/ (- (frame-rh parent) - (xlib:drawable-height window)) 2)))))) + (xlib:drawable-height window)) 2)))) + (xlib:display-finish-output *display*))) (leave-second-mode)) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Tue Sep 7 16:18:34 2010 @@ -126,16 +126,29 @@ (display-frame-info it))) +(defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) + "Handle X errors" + (cond + ;; ignore asynchronous window errors + ((and asynchronous + (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))) + (format t "Ignoring XLib asynchronous error: ~s~%" error-key)) + ((eq error-key 'xlib:access-error) + (write-line "Another window manager is running.") + (throw :exit-clfswm nil)) + ;; all other asynchronous errors are printed. + (asynchronous + (format t "Caught Asynchronous X Error: ~s ~s" error-key key-vals)) + (t + (apply 'error error-key :display display :error-key error-key key-vals)))) + + (defun main-loop () (loop (call-hook *loop-hook*) (with-xlib-protect - (xlib:display-finish-output *display*)) - (when (with-xlib-protect - (xlib:event-listen *display* *loop-timeout*)) - (with-xlib-protect - (xlib:process-event *display* :handler #'handle-event))) - (with-xlib-protect + (when (xlib:event-listen *display* *loop-timeout*) + (xlib:process-event *display* :handler #'handle-event)) (xlib:display-finish-output *display*)))) @@ -143,6 +156,7 @@ (defun open-display (display-str protocol) (multiple-value-bind (host display-num) (parse-display-string display-str) (setf *display* (xlib:open-display host :display display-num :protocol protocol) + (xlib:display-error-handler *display*) 'error-handler (getenv "DISPLAY") display-str))) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Tue Sep 7 16:18:34 2010 @@ -63,7 +63,6 @@ "Alist mapping NETWM window types to keywords.") - (defmacro with-xlib-protect (&body body) "Prevent Xlib errors" `(handler-case @@ -77,6 +76,8 @@ + + ;;; ;;; Events management functions. ;;; @@ -151,7 +152,8 @@ (with-xlib-protect (if (fboundp event-key) (apply event-key event-slots) - #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) + #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)) + (xlib:display-finish-output *display*)) t) From pbrochard at common-lisp.net Thu Sep 9 19:12:49 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 09 Sep 2010 15:12:49 -0400 Subject: [clfswm-cvs] r314 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Sep 9 15:12:49 2010 New Revision: 314 Log: src/clfswm-util.lisp (update-menus): Follow XDG specifications instead of the non-portable Debian update-menu. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-menu.lisp clfswm/src/clfswm-util.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Sep 9 15:12:49 2010 @@ -1,3 +1,8 @@ +2010-09-09 Philippe Brochard + + * src/clfswm-util.lisp (update-menus): Follow XDG specifications + instead of the non-portable Debian update-menu. + 2010-09-07 Philippe Brochard * src/clfswm.lisp (error-handler): New function do handle Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Thu Sep 9 15:12:49 2010 @@ -7,12 +7,15 @@ =============== Should handle these soon. -Nothing here :) +- Use xdg menu spec instead of the Debian specific update-menu command. + +- Add a data slot to tell if a frame must hide or not its floating windows when its not selected. + MAYBE ===== -- cd/pwd a la shell to navigate through frames. [Philippe] +- cd/pwd a la shell to navigate through frames. - Zoom Modified: clfswm/src/clfswm-menu.lisp ============================================================================== --- clfswm/src/clfswm-menu.lisp (original) +++ clfswm/src/clfswm-menu.lisp Thu Sep 9 15:12:49 2010 @@ -53,6 +53,14 @@ (equal name (menu-name item))) (return-from find-menu item)))) +(defun find-toplevel-menu (name &optional (root *menu*)) + (when (menu-p root) + (dolist (item (menu-item root)) + (when (and (menu-item-p item) + (menu-p (menu-item-value item))) + (when (equal name (menu-name (menu-item-value item))) + (return (menu-item-value item))))))) + (defun find-item-by-key (key &optional (root *menu*)) (with-all-menu (root item) @@ -87,9 +95,13 @@ (let ((menu (find-menu menu-name root))) (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root)))) -(defun add-sub-menu (menu-name key sub-menu-name &optional (doc "Sub menu") (root *menu*)) - (let ((menu (find-menu menu-name root))) - (add-item (make-menu-item :key (find-next-menu-key key menu) :value (make-menu :name sub-menu-name :doc doc)) menu))) +(defun add-sub-menu (menu-or-name key sub-menu-name &optional (doc "Sub menu") (root *menu*)) + (let ((menu (if (or (stringp menu-or-name) (symbolp menu-or-name)) + (find-menu menu-or-name root) + menu-or-name)) + (submenu (make-menu :name sub-menu-name :doc doc))) + (add-item (make-menu-item :key (find-next-menu-key key menu) :value submenu) menu) + submenu)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Thu Sep 9 15:12:49 2010 @@ -1209,55 +1209,71 @@ -;;; Standard menu functions - Based on the 'update-menus' command -(defun um-extract-value (name line) - (let* ((fullname (format nil "~A=\"" name)) - (pos (search fullname line))) - (when (numberp pos) - (let* ((start (+ pos (length fullname))) - (end (position #\" line :start start))) - (when (numberp end) - (subseq line start end)))))) - - -(defun um-create-section (menu section-list) - (if section-list - (let* ((sec (intern (string-upcase (first section-list)) :clfswm)) - (submenu (find-menu sec menu))) - (if submenu - (um-create-section submenu (rest section-list)) - (progn - (add-sub-menu (menu-name menu) :next sec (format nil "~A" sec) menu) - (um-create-section (find-menu sec menu) (rest section-list))))) - menu)) +;;; Standard menu functions - Based on the XDG specifications +(defparameter *xdg-section-list* (nconc '(TextEditor FileManager WebBrowser) + '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility) + '(TerminalEmulator Archlinux)) + "Config(Menu group): Standard menu sections") + + +(defun um-create-xdg-section-list (menu) + (dolist (section *xdg-section-list*) + (add-sub-menu menu :next section (format nil "~A" section) menu))) + +(defun um-find-submenu (menu section-list) + (let ((acc nil)) + (dolist (section section-list) + (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu) + (push it acc))) + (if acc + acc + (list (find-toplevel-menu 'Utility menu))))) + + +(defun um-extract-value (line) + (second (split-string line #\=))) + + +(defun um-add-desktop (desktop menu) + (let (name exec categories comment) + (when (probe-file desktop) + (with-open-file (stream desktop :direction :input) + (loop for line = (read-line stream nil nil) + while line + do + (cond ((first-position "Name=" line) (setf name (um-extract-value line))) + ((first-position "Exec=" line) (setf exec (um-extract-value line))) + ((first-position "Categories=" line) (setf categories (um-extract-value line))) + ((first-position "Comment=" line) (setf comment (um-extract-value line)))) + (when (and name exec categories) + (let* ((sub-menu (um-find-submenu menu (split-string categories #\;))) + (fun-name (intern name :clfswm))) + (setf (symbol-function fun-name) (let ((do-exec exec)) + (lambda () + (do-shell do-exec) + (leave-second-mode))) + (documentation fun-name 'function) (format nil "~A~A" name (if comment + (format nil " - ~A" comment) + ""))) + (dolist (m sub-menu) + (add-menu-key (menu-name m) :next fun-name m))) + (setf name nil exec nil categories nil comment nil))))))) (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu"))) - (let ((output (do-shell "update-menus --stdout"))) - (loop for line = (read-line output nil nil) - while line - do (let ((command (um-extract-value "command" line))) - (when command - (let* ((sub-menu (um-create-section menu (split-string (um-extract-value "section" line) #\/))) - (title (um-extract-value " title" line)) - (doc (um-extract-value "description" line)) - (name (intern title :clfswm))) - (setf (symbol-function name) (lambda () - (do-shell command) - (leave-second-mode)) - (documentation name 'function) (format nil "~A~A" title (if doc (format nil " - ~A" doc) ""))) - (add-menu-key (menu-name sub-menu) :next name sub-menu))))) + (um-create-xdg-section-list menu) + (let ((count 0) + (found (make-hash-table :test #'equal))) + (dolist (dir (remove-duplicates + (split-string (getenv "XDG_DATA_DIRS") #\:) :test #'string-equal)) + (dolist (desktop (directory (concatenate 'string dir "/applications/*.desktop"))) + (unless (gethash (file-namestring desktop) found) + (setf (gethash (file-namestring desktop) found) t) + (um-add-desktop desktop menu) + (incf count)))) menu)) -(defun show-standard-menu () - "< Standard menu >" - (let ((menu (update-menus))) - (if (menu-item menu) - (open-menu menu) - (info-mode '("Command 'update-menus' not found"))))) - - ;;; Close/Kill focused window Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Thu Sep 9 15:12:49 2010 @@ -311,7 +311,9 @@ (intern (string-upcase (apply #'concatenate 'string names)))) (defun number->char (number) - (code-char (+ (char-code #\a) number))) + (if (< number 26) + (code-char (+ (char-code #\a) number)) + #\|)) (defun simple-type-of (object) (let ((type (type-of object))) From pbrochard at common-lisp.net Fri Sep 10 21:02:16 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 10 Sep 2010 17:02:16 -0400 Subject: [clfswm-cvs] r315 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Sep 10 17:02:16 2010 New Revision: 315 Log: src/clfswm-corner.lisp (generate-present-body): New macro. (present-clfswm-terminal, present-virtual-keyboard): Use generate-present-body. Modified: clfswm/ChangeLog clfswm/src/clfswm-corner.lisp clfswm/src/clfswm.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Fri Sep 10 17:02:16 2010 @@ -1,3 +1,9 @@ +2010-09-10 Philippe Brochard + + * src/clfswm-corner.lisp (generate-present-body): New macro. + (present-clfswm-terminal, present-virtual-keyboard): Use + generate-present-body. + 2010-09-09 Philippe Brochard * src/clfswm-util.lisp (update-menus): Follow XDG specifications Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Fri Sep 10 17:02:16 2010 @@ -110,35 +110,50 @@ t) -(defun present-virtual-keyboard () - "Present a virtual keyboard" - (stop-button-event) - (do-shell (if *vt-keyboard-on* - *virtual-keyboard-kill-cmd* - *virtual-keyboard-cmd*)) - (setf *vt-keyboard-on* (not *vt-keyboard-on*)) - t) + +(defun find-window-in-query-tree (target-win) + (dolist (win (xlib:query-tree *root*)) + (when (child-equal-p win target-win) + (return t)))) + +(defun wait-window-in-query-tree (wait-test) + (loop + (dolist (win (xlib:query-tree *root*)) + (when (funcall wait-test win) + (return-from wait-window-in-query-tree win))))) + + +(defmacro generate-present-body (cmd wait-test win &optional focus-p) + `(progn + (stop-button-event) + (unless (find-window-in-query-tree ,win) + (do-shell ,cmd) + (setf ,win (wait-window-in-query-tree ,wait-test)) + (hide-window ,win)) + (cond ((window-hidden-p ,win) (unhide-window ,win) + (when ,focus-p + (focus-window ,win)) + (raise-window ,win)) + (t (hide-window ,win) + (show-all-children nil))) + t)) + + +(let (win) + (defun present-virtual-keyboard () + "Present a virtual keyboard" + (generate-present-body *virtual-keyboard-cmd* + (lambda (win) + (string-equal (xlib:get-wm-class win) "xvkbd")) + win))) -(defun present-clfswm-terminal () - "Hide/Unhide a terminal" - (labels ((find-clfswm-terminal () - (dolist (win (xlib:query-tree *root*)) - (when (child-equal-p win *clfswm-terminal*) - (return t))))) - (stop-button-event) - (unless (find-clfswm-terminal) - (do-shell *clfswm-terminal-cmd*) - (loop :with done = nil :until done - :do (dolist (win (xlib:query-tree *root*)) - (when (string-equal (xlib:wm-name win) *clfswm-terminal-name*) - (setf *clfswm-terminal* win - done t)))) - (hide-window *clfswm-terminal*)) - (cond ((window-hidden-p *clfswm-terminal*) (unhide-window *clfswm-terminal*) - (focus-window *clfswm-terminal*) - (raise-window *clfswm-terminal*)) - (t (hide-window *clfswm-terminal*) - (show-all-children nil))) - t)) +(let (win) + (defun present-clfswm-terminal () + "Hide/Unhide a terminal" + (generate-present-body *clfswm-terminal-cmd* + (lambda (win) + (string-equal (xlib:wm-name win) *clfswm-terminal-name*)) + win + t))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Fri Sep 10 17:02:16 2010 @@ -135,7 +135,7 @@ (format t "Ignoring XLib asynchronous error: ~s~%" error-key)) ((eq error-key 'xlib:access-error) (write-line "Another window manager is running.") - (throw :exit-clfswm nil)) + (throw 'exit-clfswm nil)) ;; all other asynchronous errors are printed. (asynchronous (format t "Caught Asynchronous X Error: ~s ~s" error-key key-vals)) @@ -179,7 +179,6 @@ :depth (xlib:screen-root-depth *screen*) :drawable *root*) *in-second-mode* nil - *clfswm-terminal* nil *vt-keyboard-on* nil) (init-modifier-list) (xgrab-init-pointer) Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Fri Sep 10 17:02:16 2010 @@ -185,8 +185,7 @@ (defparameter *in-second-mode* nil) -(defparameter *vt-keyboard-on* nil) -(defparameter *clfswm-terminal* nil) +;;(defparameter *vt-keyboard-on* nil) PHIL here ;;; Placement variables. A list of two absolute coordinates From pbrochard at common-lisp.net Fri Sep 10 21:03:33 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 10 Sep 2010 17:03:33 -0400 Subject: [clfswm-cvs] r316 - clfswm/src Message-ID: Author: pbrochard Date: Fri Sep 10 17:03:33 2010 New Revision: 316 Log: Remove useless comment Modified: clfswm/src/package.lisp Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Fri Sep 10 17:03:33 2010 @@ -185,9 +185,6 @@ (defparameter *in-second-mode* nil) -;;(defparameter *vt-keyboard-on* nil) PHIL here - - ;;; Placement variables. A list of two absolute coordinates ;;; or a function: 'Y-X-placement' for absolute placement or ;;; 'Y-X-child-placement' for child relative placement. From pbrochard at common-lisp.net Sat Sep 11 12:22:10 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 08:22:10 -0400 Subject: [clfswm-cvs] r317 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 11 08:22:09 2010 New Revision: 317 Log: src/clfswm-util.lisp (update-menus): List all directories and subdirectories in /usr/share:/usr/local/share:/usr/share:/usr/local/share:/usr/share:/usr/local/share:/usr/share:/usr/local/share:/usr/share:/usr/local/share/applications. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-corner.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/config.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 11 08:22:09 2010 @@ -1,3 +1,12 @@ +2010-09-11 Philippe Brochard + + * src/clfswm-corner.lisp (present-clfswm-terminal) + (present-virtual-keyboard): Use a function (generic-present-body) + instead of a macro (generate-present-body). + + * src/clfswm-util.lisp (update-menus): List all directories and + subdirectories in $XDG_DATA_DIRS/applications. + 2010-09-10 Philippe Brochard * src/clfswm-corner.lisp (generate-present-body): New macro. Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Sep 11 08:22:09 2010 @@ -7,8 +7,6 @@ =============== Should handle these soon. -- Use xdg menu spec instead of the Debian specific update-menu command. - - Add a data slot to tell if a frame must hide or not its floating windows when its not selected. @@ -17,7 +15,7 @@ - cd/pwd a la shell to navigate through frames. -- Zoom +- Zoom: Concept: * zoom out: Behave as if the application window is bigger for the application but completely drawn in a small amount of space (miniature). The zoom factor is inferior to 100% Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Sat Sep 11 08:22:09 2010 @@ -123,37 +123,39 @@ (return-from wait-window-in-query-tree win))))) -(defmacro generate-present-body (cmd wait-test win &optional focus-p) - `(progn - (stop-button-event) - (unless (find-window-in-query-tree ,win) - (do-shell ,cmd) - (setf ,win (wait-window-in-query-tree ,wait-test)) - (hide-window ,win)) - (cond ((window-hidden-p ,win) (unhide-window ,win) - (when ,focus-p - (focus-window ,win)) - (raise-window ,win)) - (t (hide-window ,win) - (show-all-children nil))) - t)) +(defun generic-present-body (cmd wait-test win &optional focus-p) + (stop-button-event) + (unless (find-window-in-query-tree win) + (do-shell cmd) + (setf win (wait-window-in-query-tree wait-test)) + (hide-window win)) + (cond ((window-hidden-p win) (unhide-window win) + (when focus-p + (focus-window win)) + (raise-window win)) + (t (hide-window win) + (show-all-children nil))) + win) + (let (win) (defun present-virtual-keyboard () "Present a virtual keyboard" - (generate-present-body *virtual-keyboard-cmd* - (lambda (win) - (string-equal (xlib:get-wm-class win) "xvkbd")) - win))) + (setf win (generic-present-body *virtual-keyboard-cmd* + (lambda (win) + (string-equal (xlib:get-wm-class win) "xvkbd")) + win)) + t)) (let (win) (defun present-clfswm-terminal () "Hide/Unhide a terminal" - (generate-present-body *clfswm-terminal-cmd* - (lambda (win) - (string-equal (xlib:wm-name win) *clfswm-terminal-name*)) - win - t))) + (setf win (generic-present-body *clfswm-terminal-cmd* + (lambda (win) + (string-equal (xlib:wm-name win) *clfswm-terminal-name*)) + win + t)) + t)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 11 08:22:09 2010 @@ -1266,7 +1266,7 @@ (found (make-hash-table :test #'equal))) (dolist (dir (remove-duplicates (split-string (getenv "XDG_DATA_DIRS") #\:) :test #'string-equal)) - (dolist (desktop (directory (concatenate 'string dir "/applications/*.desktop"))) + (dolist (desktop (directory (concatenate 'string dir "/applications/**/*.desktop"))) (unless (gethash (file-namestring desktop) found) (setf (gethash (file-namestring desktop) found) t) (um-add-desktop desktop menu) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Sep 11 08:22:09 2010 @@ -178,8 +178,7 @@ :height (xlib:screen-height *screen*) :depth (xlib:screen-root-depth *screen*) :drawable *root*) - *in-second-mode* nil - *vt-keyboard-on* nil) + *in-second-mode* nil) (init-modifier-list) (xgrab-init-pointer) (xgrab-init-keyboard) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sat Sep 11 08:22:09 2010 @@ -123,8 +123,6 @@ xvkbd.customization: -french xvkbd.keypad: false And make it always on top") -(defparameter *virtual-keyboard-kill-cmd* "pkill xvkbd" - "Config(Corner group): The command to stop the virtual keyboard") (defparameter *clfswm-terminal-name* "clfswm-terminal" "Config(Corner group): The clfswm terminal name") From pbrochard at common-lisp.net Sat Sep 11 12:27:15 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 08:27:15 -0400 Subject: [clfswm-cvs] r318 - clfswm/src Message-ID: Author: pbrochard Date: Sat Sep 11 08:27:15 2010 New Revision: 318 Log: Add a Screensaver section in standard menu Modified: clfswm/src/clfswm-util.lisp Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 11 08:27:15 2010 @@ -1212,7 +1212,7 @@ ;;; Standard menu functions - Based on the XDG specifications (defparameter *xdg-section-list* (nconc '(TextEditor FileManager WebBrowser) '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility) - '(TerminalEmulator Archlinux)) + '(TerminalEmulator Archlinux Screensaver)) "Config(Menu group): Standard menu sections") From pbrochard at common-lisp.net Sat Sep 11 21:38:01 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 17:38:01 -0400 Subject: [clfswm-cvs] r319 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 11 17:38:01 2010 New Revision: 319 Log: set-hide-unmanaged-window, set-show-unmanaged-window, set-default-hide-unmanaged-window: New functions and menu entry to hide or not unmanaged windows. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-util.lisp clfswm/src/config.lisp clfswm/src/menu-def.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 11 17:38:01 2010 @@ -1,5 +1,14 @@ 2010-09-11 Philippe Brochard + * src/clfswm-util.lisp (set-hide-unmanaged-window) + (set-show-unmanaged-window, set-default-hide-unmanaged-window): + New functions and menu entry. + + * src/clfswm-internal.lisp (hide-unmanager-window-p): New + function. + (show-child): Add a data slot on frame to hide or not unmanaged + windows. + * src/clfswm-corner.lisp (present-clfswm-terminal) (present-virtual-keyboard): Use a function (generic-present-body) instead of a macro (generate-present-body). Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Sep 11 17:38:01 2010 @@ -542,8 +542,18 @@ (display-frame-info frame)) + +(defun hide-unmanager-window-p (parent) + (let ((action (frame-data-slot parent :unmanaged-window-action))) + (case action + (:hide t) + (:show nil) + (t *hide-unmanaged-window*)))) + + (defmethod show-child ((window xlib:window) parent raise-p) (if (or (managed-window-p window parent) + (not (hide-unmanager-window-p parent)) (child-equal-p parent *current-child*)) (progn (map-window window) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 11 17:38:01 2010 @@ -1347,3 +1347,23 @@ (do-run-other-window-manager wm))) +;;; Hide or show unmanaged windows utility. +(defun set-hide-unmanaged-window () + "Hide unmanaged windows when frame is not selected" + (when (frame-p *current-child*) + (setf (frame-data-slot *current-child* :unmanaged-window-action) :hide) + (leave-second-mode))) + +(defun set-show-unmanaged-window () + "Show unmanaged windows when frame is not selected" + (when (frame-p *current-child*) + (setf (frame-data-slot *current-child* :unmanaged-window-action) :show) + (leave-second-mode))) + +(defun set-default-hide-unmanaged-window () + "Set default behaviour to hide or not unmanaged windows when frame is not selected" + (when (frame-p *current-child*) + (setf (frame-data-slot *current-child* :unmanaged-window-action) nil) + (leave-second-mode))) + + Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sat Sep 11 17:38:01 2010 @@ -55,6 +55,9 @@ A list of (predicate-function-on-window expected-string)") +(defparameter *hide-unmanaged-window* t + "Config(): Hide or not unmanaged windows when a child is deselected.") + ;;; CONFIG - Screen size (defun get-fullscreen-size () "Return the size of root child (values rx ry rw rh) Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Sat Sep 11 17:38:01 2010 @@ -95,6 +95,7 @@ (add-sub-menu 'frame-menu "m" 'frame-movement-menu "Frame movement menu") (add-sub-menu 'frame-menu "f" 'frame-focus-policy "Frame focus policy menu") (add-sub-menu 'frame-menu "w" 'frame-managed-window-menu "Managed window type menu") +(add-sub-menu 'frame-menu "u" 'frame-unmanaged-window-menu "Unmanaged window behaviour") (add-sub-menu 'frame-menu "s" 'frame-miscellaneous-menu "Frame miscallenous menu") (add-menu-key 'frame-menu "x" 'frame-toggle-maximize) @@ -155,6 +156,10 @@ (add-menu-key 'frame-managed-window-menu "n" 'current-frame-manage-only-normal-window-type) (add-menu-key 'frame-managed-window-menu "u" 'current-frame-manage-no-window-type) +(add-menu-key 'frame-unmanaged-window-menu "s" 'set-show-unmanaged-window) +(add-menu-key 'frame-unmanaged-window-menu "h" 'set-hide-unmanaged-window) +(add-menu-key 'frame-unmanaged-window-menu "d" 'set-default-hide-unmanaged-window) + (add-menu-key 'frame-miscellaneous-menu "s" 'show-all-frames-info) (add-menu-key 'frame-miscellaneous-menu "i" 'hide-all-frames-info) From pbrochard at common-lisp.net Sat Sep 11 21:42:25 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 17:42:25 -0400 Subject: [clfswm-cvs] r320 - clfswm/doc Message-ID: Author: pbrochard Date: Sat Sep 11 17:42:25 2010 New Revision: 320 Log: Documentation update Modified: clfswm/doc/menu.html clfswm/doc/menu.txt Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Sat Sep 11 17:42:25 2010 @@ -85,6 +85,1956 @@

Standard-Menu

+

+ a: < TEXTEDITOR > +

+

+ b: < FILEMANAGER > +

+

+ c: < WEBBROWSER > +

+

+ d: < AUDIOVIDEO > +

+

+ e: < AUDIO > +

+

+ f: < VIDEO > +

+

+ g: < DEVELOPMENT > +

+

+ h: < EDUCATION > +

+

+ i: < GAME > +

+

+ j: < GRAPHICS > +

+

+ k: < NETWORK > +

+

+ l: < OFFICE > +

+

+ m: < SETTINGS > +

+

+ n: < SYSTEM > +

+

+ o: < UTILITY > +

+

+ p: < TERMINALEMULATOR > +

+

+ q: < ARCHLINUX > +

+

+ r: < SCREENSAVER > +

+
+

+ Texteditor +

+

+ a: Emacs Text Editor - Edit text +

+

+ b: gVim - GTK2 enhanced vim text editor +

+

+ c: Kate +

+

+ d: Snippets datafile editor +

+

+ e: KWrite +

+

+ f: Mousepad - Simple text editor +

+

+ g: Xfw - A simple text editor for Xfe +

+
+

+ Filemanager +

+

+ a: Open Folder with Thunar - Open the specified folders in Thunar +

+

+ b: Thunar File Manager - Browse the filesystem with the file manager +

+

+ c: Dolphin +

+

+ d: Krusader +

+

+ e: File Manager +

+

+ f: ROX Filer - ROX Filer +

+

+ g: Xfe - A lightweight file manager for X Window +

+
+

+ Webbrowser +

+

+ a: Arora - Browse the World Wide Web +

+

+ b: Chromium - Access the Internet +

+

+ c: Epiphany - Browse the web +

+

+ d: Firefox - Safe Mode +

+

+ e: Firefox +

+

+ f: IcedTea Web Start - IcedTea Application Launcher +

+

+ g: Konqueror +

+

+ h: Midori - Lightweight web browser +

+

+ i: Opera - A fast and secure web browser and Internet suite +

+
+

+ Audiovideo +

+

+ a: AcidRip DVD Ripper - DVD Ripper +

+

+ b: Ardour - Multitrack hard disk recorder +

+

+ c: Audacity - Record and edit audio files +

+

+ d: Beep Media Player - Play music +

+

+ e: Brasero - Create and copy CDs and DVDs +

+

+ f: Gnome Music Player Client - A gnome frontend for the mpd daemon +

+

+ g: Sound Recorder - Record sound clips +

+

+ h: Volume Control - Change sound volume and sound events +

+

+ i: Grip - CD player/ripper +

+

+ j: gtk-recordMyDesktop - Frontend for recordMyDesktop +

+

+ k: Hydrogen Drum Machine - Create drum sequences +

+

+ l: Dragon Player +

+

+ m: JuK +

+

+ n: K3b - Disk writing program +

+

+ o: KMix +

+

+ p: KsCD +

+

+ q: Mixxx - A digital DJ interface +

+

+ r: MPlayer Media Player - Play movies and songs +

+

+ s: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface +

+

+ t: qt-recordMyDesktop - Frontend for recordMyDesktop +

+

+ u: Sonata - An elegant GTK+ MPD client +

+

+ v: Audio CD Extractor - Copy music from your CDs +

+

+ w: VLC media player - Read, capture, broadcast your multimedia streams +

+

+ x: Mixer - Audio mixer for the Xfce Desktop Environment +

+

+ y: XMMS - X Multimedia System +

+

+ z: zynaddsubfx - An opensource software synthesizer +

+
+

+ Audio +

+

+ a: Ardour - Multitrack hard disk recorder +

+

+ b: Audacity - Record and edit audio files +

+

+ c: Sound Recorder - Record sound clips +

+

+ d: Hydrogen Drum Machine - Create drum sequences +

+

+ e: KMix +

+

+ f: Mixxx - A digital DJ interface +

+

+ g: MPlayer Media Player - Play movies and songs +

+

+ h: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface +

+

+ i: Audio CD Extractor - Copy music from your CDs +

+

+ j: Mixer - Audio mixer for the Xfce Desktop Environment +

+
+

+ Video +

+

+ a: Ardour - Multitrack hard disk recorder +

+

+ b: MPlayer Media Player - Play movies and songs +

+
+

+ Development +

+

+ a: CMake - Cross-platform buildsystem +

+

+ b: Qt Assistant +

+

+ c: Data Display Debugger - Graphical debugger frontend +

+

+ d: Qt Designer +

+

+ e: Emacs Text Editor - Edit text +

+

+ f: Factor - Factor is a general purpose, dynamically typed, stack-based programming language +

+

+ g: OpenJDK Monitoring & Management Console - Monitor and manage OpenJDK applications +

+

+ h: Akonadi Console - Akonadi Management and Debugging Console +

+

+ i: Cervisia +

+

+ j: KAppTemplate +

+

+ k: KBugBuster +

+

+ l: KCachegrind - Visualization of Performance Profiling Data +

+

+ m: KDE SVN Build +

+

+ n: KImageMapEditor +

+

+ o: KLinkStatus +

+

+ p: Kompare +

+

+ q: KUIViewer +

+

+ r: Lokalize +

+

+ s: Umbrello +

+

+ t: Qt Linguist +

+

+ u: OpenJDK Policy Tool - Manage OpenJDK policy files +

+
+

+ Education +

+

+ a: Blinken - A memory enhancement game +

+

+ b: Cantor +

+

+ c: KAlgebra - Math Expression Solver and Plotter +

+

+ d: Kalzium - KDE Periodic Table of Elements +

+

+ e: Kanagram - KDE Letter Order Game +

+

+ f: KBruch - Practice exercises with fractions +

+

+ g: KGeography - A Geography Learning Program +

+

+ h: KHangMan - KDE Hangman Game +

+

+ i: Kig - Explore Geometric Constructions +

+

+ j: Kiten - Japanese Reference and Study Tool +

+

+ k: KLettres - a KDE program to learn the alphabet +

+

+ l: KmPlot - Function Plotter +

+

+ m: KStars - Desktop Planetarium +

+

+ n: KTouch +

+

+ o: KTurtle +

+

+ p: KWordQuiz - A flashcard and vocabulary learning program +

+

+ q: Marble +

+

+ r: Parley +

+

+ s: Rocs - Graph Theory Tool for Professors and Students. +

+

+ t: Step - Simulate physics experiments +

+
+

+ Game +

+

+ a: 0 A.D. Editor +

+

+ b: 0 A.D. +

+

+ c: AssaultCube +

+

+ d: DROD - Simple puzzle game. +

+

+ e: Foobillard - A 3D billiards game using OpenGL +

+

+ f: Frasse - Frasse and the Peas of Kejick adventure game +

+

+ g: Frogatto - Old-school 2D platformer +

+

+ h: GGoban - Play go and review game records +

+

+ i: KGoldrunner - A game of action and puzzle-solving +

+

+ j: AMOR +

+

+ k: Blinken - A memory enhancement game +

+

+ l: Bomber +

+

+ m: Bovo +

+

+ n: Granatier +

+

+ o: Kanagram - KDE Letter Order Game +

+

+ p: Kapman - Eat pills escaping ghosts +

+

+ q: KAtomic +

+

+ r: KBattleship +

+

+ s: KBlackBox +

+

+ t: KBlocks +

+

+ u: KBounce +

+

+ v: KBreakOut +

+

+ w: KSnake +

+

+ x: KDiamond +

+

+ y: KFourInLine +

+

+ z: KHangMan - KDE Hangman Game +

+

+ |: Kigo +

+

+ |: Killbots +

+

+ |: Kiriki +

+

+ |: KJumpingCube +

+

+ |: Kolor Lines +

+

+ |: KMahjongg +

+

+ |: KMines +

+

+ |: KNetWalk +

+

+ |: Kolf +

+

+ |: Kollision - A simple ball dodging game +

+

+ |: Konquest +

+

+ |: KPatience +

+

+ |: KReversi +

+

+ |: SameGame +

+

+ |: Shisen-Sho +

+

+ |: KsirK +

+

+ |: KsirK Skin Editor +

+

+ |: KSpaceDuel +

+

+ |: KSquares +

+

+ |: KSudoku - KSudoku, Sudoku game & more for KDE +

+

+ |: KTeaTime +

+

+ |: KTron +

+

+ |: Potato Guy +

+

+ |: Kubrick +

+

+ |: LSkat +

+

+ |: Palapeli +

+

+ |: Neverball - A 3D arcade game with a ball +

+

+ |: Neverputt - A 3D mini golf game +

+

+ |: OpenArena - A Quake3-based FPS Game +

+

+ |: SolarWolf +

+

+ |: SuperTux 2 - Play a classic 2D platform game +

+

+ |: Trackballs - Simple game similar to the classical game Marble Madness +

+

+ |: Battle for Wesnoth - A fantasy turn-based strategy game +

+

+ |: Battle for Wesnoth Map Editor - A map editor for Battle for Wesnoth maps +

+

+ |: Xmoto +

+

+ |: XSpaceWarp - Live long and prosper! +

+
+

+ Graphics +

+

+ a: Image Viewer +

+

+ b: PostScript Viewer - View PostScript files +

+

+ c: GNU Image Manipulation Program - Create images and edit photographs +

+

+ d: Image Viewer +

+

+ e: GV +

+

+ f: Inkscape - Create and edit Scalable Vector Graphics images +

+

+ g: Gwenview - A simple image viewer +

+

+ h: KColorChooser +

+

+ i: KolourPaint +

+

+ j: KRuler +

+

+ k: KSnapshot +

+

+ l: Okular +

+

+ m: Okular +

+

+ n: Okular +

+

+ o: Okular +

+

+ p: Okular +

+

+ q: Okular +

+

+ r: Okular +

+

+ s: Okular +

+

+ t: Okular +

+

+ u: Okular +

+

+ v: Okular +

+

+ w: Okular +

+

+ x: Okular +

+

+ y: Okular +

+

+ z: Okular +

+

+ |: Okular +

+

+ |: Xfig +

+
+

+ Network +

+

+ a: Arora - Browse the World Wide Web +

+

+ b: Epiphany Web Bookmarks - Browse and organize your bookmarks +

+

+ c: Avahi SSH Server Browser - Browse for Zeroconf-enabled SSH Servers +

+

+ d: Avahi VNC Server Browser - Browse for Zeroconf-enabled VNC Servers +

+

+ e: Chromium - Access the Internet +

+

+ f: Epiphany - Browse the web +

+

+ g: Minefield - Safe Mode +

+

+ h: Minefield +

+

+ i: Firefox - Safe Mode +

+

+ j: Firefox +

+

+ k: Gnaughty - Porn downloader +

+

+ l: Gwget Download Manager - Download files from the Internet +

+

+ m: JAP - JAP makes it possible to surf the internet anonymously and unobservably. +

+

+ n: IcedTea Web Start - IcedTea Application Launcher +

+

+ o: KMail +

+

+ p: KNode +

+

+ q: KPPP +

+

+ r: Akregator - A Feed Reader for KDE +

+

+ s: Blogilo +

+

+ t: KGet +

+

+ u: KNetAttach +

+

+ v: Konqueror +

+

+ w: Kopete - Instant Messenger +

+

+ x: KPPPLogview +

+

+ y: KRDC +

+

+ z: Krfb +

+

+ |: Midori - Lightweight web browser +

+

+ |: MultiGet +

+

+ |: OpenArena Server - Run an OpenArena server +

+

+ |: Opera - A fast and secure web browser and Internet suite +

+

+ |: SeaMonkey internet suite +

+

+ |: Thunderbird - Mail & News Reader +

+

+ |: Transmission - Download and share files over BitTorrent +

+

+ |: Tucan Manager - Download and upload manager for hosting sites. +

+

+ |: Wicd - Manage Wired/Wireless Networks +

+

+ |: wireshark - Network protocol analyzer +

+
+

+ Office +

+

+ a: AbiWord +

+

+ b: OpenOffice.org 3.2 Base +

+

+ c: OpenOffice.org 3.2 Calc +

+

+ d: OpenOffice.org 3.2 Draw +

+

+ e: ePDFViewer - Lightweight PDF document viewer +

+

+ f: GV +

+

+ g: OpenOffice.org 3.2 Impress +

+

+ h: Kontact +

+

+ i: KAddressBook +

+

+ j: KOrganizer - Calendar and Scheduling Program +

+

+ k: KTimeTracker +

+

+ l: KWord - Write text documents +

+

+ m: Lokalize +

+

+ n: Okular +

+

+ o: OpenOffice.org 3.2 Math +

+

+ p: OpenOffice.org 3.2 Printer Administration +

+

+ q: OpenOffice.org 3.2 +

+

+ r: OpenOffice.org 3.2 Writer +

+

+ s: Orage - Desktop calendar +

+

+ t: Xpdf - Views Adobe PDF (acrobat) files +

+
+

+ Settings +

+

+ a: Assistive Technologies - Choose which accessibility features to enable when you log in +

+

+ b: Preferred Applications +

+

+ c: Monitors - Change resolution and position of monitors +

+

+ d: Preferred Applications +

+

+ e: Keyboard Indicator plugins - Enable/disable installed plugins +

+

+ f: Privilege granting - Configure behavior of the privilege-granting tool +

+

+ g: About Me - Set your personal information +

+

+ h: Appearance - Customize the look of your desktop +

+

+ i: Network Proxy - Set your network proxy preferences +

+

+ j: Screensaver - Change screensaver properties +

+

+ k: Mouse - Configure pointer device behavior and appearance +

+

+ l: Volume Control - Change sound volume and sound events +

+

+ m: Control Center +

+

+ n: Multimedia Systems Selector - Configure defaults for GStreamer applications +

+

+ o: Touchpad - Set your touchpad preferences +

+

+ p: Menu Updating Tool +

+

+ q: Change Password +

+

+ r: Menu Editor +

+

+ s: System Settings +

+

+ t: Keyboard Shortcuts - Assign shortcut keys to commands +

+

+ u: Keyboard - Edit keyboard settings and application shortcuts +

+

+ v: Preferred Applications +

+

+ w: Appearance - Customize the look of your desktop +

+

+ x: Monitor Settings - Change screen resolution and configure external monitors +

+

+ y: File Management - Change the behaviour and appearance of file manager windows +

+

+ z: Pop-Up Notifications - Set your pop-up notification preferences +

+

+ |: Opera Widget Manager +

+

+ |: Qt Config - Configure Qt behavior, styles, fonts +

+

+ |: Startup Applications - Choose what applications to start when you log in +

+

+ |: File Manager +

+

+ |: Windows - Set your window properties +

+

+ |: Desktop - Set desktop background and menu and icon behaviour +

+

+ |: Display - Configure screen settings and layout +

+

+ |: Keyboard - Edit keyboard settings and application shortcuts +

+

+ |: Mouse - Configure pointer device behavior and appearance +

+

+ |: Session and Startup - Customize desktop startup and splash screen +

+

+ |: Xfce 4 Settings Manager - Graphical Settings Manager for Xfce 4 +

+

+ |: Appearance - Customize the look of your desktop +

+

+ |: Window Manager - Configure window behavior and shortcuts +

+

+ |: Window Manager Tweaks - Fine-tune window behaviour and effects +

+

+ |: Workspaces - Set number and names of workspaces +

+

+ |: Xfce 4 Calendar Settings - Settings for the Xfce 4 Calendar Application +

+

+ |: Accessibility - Improve keyboard and mouse accessibility +

+

+ |: Panel - Customize the panel settings +

+

+ |: Settings Editor - Graphical settings editor for Xfconf +

+

+ |: Xfce 4 Printing System Settings - Allow you to select the printing system backend that xfprint will use +

+

+ |: Screensaver - Change screensaver properties +

+
+

+ System +

+

+ a: Terminal +

+

+ b: Bulk Rename - Rename Multiple Files +

+

+ c: Open Folder with Thunar - Open the specified folders in Thunar +

+

+ d: Thunar File Manager - Browse the filesystem with the file manager +

+

+ e: Avahi Zeroconf Browser - Browse for Zeroconf services available on your network +

+

+ f: CD/DVD Creator - Create CDs and DVDs +

+

+ g: Manage Printing +

+

+ h: System Monitor +

+

+ i: GParted - Create, reorganize, and delete partitions +

+

+ j: Dolphin +

+

+ k: KDiskFree +

+

+ l: Konqueror +

+

+ m: Konqueror +

+

+ n: Konqueror +

+

+ o: Konqueror +

+

+ p: KInfoCenter +

+

+ q: File Manager - Super User Mode +

+

+ r: Konsole +

+

+ s: KRandRTray - A panel applet for resizing and reorientating X screens. +

+

+ t: Krfb +

+

+ u: Krusader - root-mode +

+

+ v: System Monitor +

+

+ w: KSystemLog +

+

+ x: KUser +

+

+ y: KWalletManager +

+

+ z: KwikDisk +

+

+ |: Task Manager - Manage running processes +

+

+ |: File Browser - Browse the file system with the file manager +

+

+ |: Disk Utility - Manage Drives and Media +

+

+ |: UNetbootin - Tool for creating Live USB drives +

+

+ |: Oracle VM VirtualBox +

+

+ |: Xfe - A lightweight file manager for X Window +

+

+ |: XNC - Graphical File manager, X Northern Captain +

+
+

+ Utility +

+

+ a: Terminal +

+

+ b: Bulk Rename - Rename Multiple Files +

+

+ c: Open Folder with Thunar - Open the specified folders in Thunar +

+

+ d: Thunar File Manager - Browse the filesystem with the file manager +

+

+ e: dosbox Emulator - An emulator to run old DOS games +

+

+ f: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password +

+

+ g: About GNOME - Learn more about GNOME +

+

+ h: Panel - Customize the panel settings +

+

+ i: Theme Installer - Installs themes packages for various parts of the desktop +

+

+ j: Image Viewer +

+

+ k: Character Map - Insert special characters into documents +

+

+ l: gVim - GTK2 enhanced vim text editor +

+

+ m: Help - Get help with GNOME +

+

+ n: Home +

+

+ o: KCharSelect +

+

+ p: KFloppy +

+

+ q: KJots +

+

+ r: Akonaditray +

+

+ s: Ark +

+

+ t: KDE Groupware Wizard +

+

+ u: KAlarm +

+

+ v: Kate +

+

+ w: KCalc +

+

+ x: KFileReplace +

+

+ y: Find Files/Folders +

+

+ z: KFontView +

+

+ |: KGpg - A GnuPG frontend +

+

+ |: Kleopatra +

+

+ |: Kleopatra +

+

+ |: Klipper +

+

+ |: KMag +

+

+ |: KMouseTool - Clicks the mouse for you, reducing the effects of RSI +

+

+ |: KMouth +

+

+ |: KNotes +

+

+ |: KonsoleKalendar +

+

+ |: Krusader +

+

+ |: Snippets datafile editor +

+

+ |: KTimer +

+

+ |: KTimeTracker +

+

+ |: KWrite +

+

+ |: Okteta +

+

+ |: SuperKaramba - An engine for cool desktop eyecandy. +

+

+ |: Sweeper +

+

+ |: LXTerminal - Use the command line +

+

+ |: Mousepad - Simple text editor +

+

+ |: File Browser - Browse the file system with the file manager +

+

+ |: Computer - Browse all local and remote disks and folders accessible from this computer +

+

+ |: Home Folder - Open your personal folder +

+

+ |: Network - Browse bookmarked and local network locations +

+

+ |: File Manager +

+

+ |: Scilab - A scientific software package for numerical computations +

+

+ |: About Xfce +

+

+ |: Application Finder - Find and launch applications installed on your system +

+

+ |: File Manager +

+

+ |: Help - Get help with GNOME +

+

+ |: Log Out +

+

+ |: Run Program... +

+

+ |: Terminal +

+

+ |: Web Browser +

+

+ |: Xfi - A simple image viewer for Xfe +

+

+ |: Xfp - A simple package manager for Xfe +

+

+ |: Xfce 4 Print Manager - Show the printer list and allow you to manage their jobs +

+

+ |: Xfce 4 Print Dialog - Print a file and allow you to set up its layout +

+

+ |: Xfv - A simple text viewer for Xfe +

+

+ |: Xfw - A simple text editor for Xfe +

+

+ |: XNC - Graphical File manager, X Northern Captain +

+

+ |: Help - Get help with GNOME +

+
+

+ Terminalemulator +

+

+ a: Terminal +

+

+ b: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password +

+

+ c: Konsole +

+

+ d: LXTerminal - Use the command line +

+
+

+ Archlinux +

+

+ a: AUR - Archlinux AUR +

+

+ b: Bugs - Archlinux Bugtracker +

+

+ c: Developers - Archlinux development team +

+

+ d: Documentation - Archlinux Documentation +

+

+ e: Donate - Archlinux Donations +

+

+ f: Forum - Archlinux Forum +

+

+ g: Homepage - Archlinux homepage +

+

+ h: SVN - Archlinux SVN +

+

+ i: Schwag - Archlinux goodie shopping +

+

+ j: Wiki - Archlinux Wiki +

+
+

+ Screensaver +

+

+ a: Abstractile - Generates mosaic patterns of interlocking tiles. Written by Steve Sundstrom; 2004. +

+

+ b: Anemone - Wiggling tentacles. Written by Gabriel Finch; 2002. +

+

+ c: Anemotaxis - Anemotaxis demonstrates a search algorithm designed for locating a source of odor in turbulent atmosphere. The searcher is able to sense the odor and determine local instantaneous wind direction. The goal is to find the source in the shortest mean time. http://en.wikipedia.org/wiki/Anemotaxis Written by Eugene Balkovsky; 2004. +

+

+ d: AntInspect - Draws a trio of ants moving their spheres around a circle. Written by Blair Tennessy; 2004. +

+

+ e: AntMaze - Draws a few views of a few ants walking around in a simple maze. Written by Blair Tennessy; 2005. +

+

+ f: AntSpotlight - Draws an ant (with a headlight) who walks on top of an image of your desktop or other image. Written by Blair Tennessy; 2003. +

+

+ g: Apollonian - Draws an Apollonian gasket: a fractal packing of circles with smaller circles, demonstrating Descartes's theorem. http://en.wikipedia.org/wiki/Apollonian_gasket http://en.wikipedia.org/wiki/Descartes%27_theorem Written by Allan R. Wilks and David Bagley; 2002. +

+

+ h: Apple2 - Simulates an original Apple ][ Plus computer in all its 1979 glory. It also reproduces the appearance of display on a color television set of the period. In "Basic Programming Mode", a simulated user types in a BASIC program and runs it. In "Text Mode", it displays the output of a program, or the contents of a file or URL. In "Slideshow Mode", it chooses random images and displays them within the limitations of the Apple ][ display hardware. (Six available colors in hi-res mode!) On X11 systems, This program is also a fully-functional VT100 emulator. http://en.wikipedia.org/wiki/Apple_II_series Written by Trevor Blackwell; 2003. +

+

+ i: Atlantis - A 3D animation of a number of sharks, dolphins, and whales. Written by Mark Kilgard; 1998. +

+

+ j: Attraction - Uses a simple simple motion model to generate many different display modes. The control points attract each other up to a certain distance, and then begin to repel each other. The attraction/repulsion is proportional to the distance between any two particles, similar to the strong and weak nuclear forces. Written by Jamie Zawinski and John Pezaris; 1992. +

+

+ k: Atunnel - Draws an animation of a textured tunnel in GL. Written by Eric Lassauge and Roman Podobedov; 2003. +

+

+ l: Barcode - Draws a random sequence of colorful barcodes scrolling across your screen. CONSUME! The barcodes follow the UPC-A, UPC-E, EAN-8 or EAN-13 standards. http://en.wikipedia.org/wiki/Universal_Product_Code http://en.wikipedia.org/wiki/European_Article_Number Written by Dan Bornstein; 2003. +

+

+ m: Blaster - Draws a simulation of flying space-combat robots (cleverly disguised as colored circles) doing battle in front of a moving star field. Written by Jonathan Lin; 1999. +

+

+ n: BlinkBox - Shows a ball contained inside of a bounding box. Colored blocks blink in when the ball hits the sides. Written by Jeremy English; 2003. +

+

+ o: BlitSpin - Repeatedly rotates a bitmap by 90 degrees by using logical operations: the bitmap is divided into quadrants, and the quadrants are shifted clockwise. Then the same thing is done again with progressively smaller quadrants, except that all sub-quadrants of a given size are rotated in parallel. As you watch it, the image appears to dissolve into static and then reconstitute itself, but rotated. Written by Jamie Zawinski; 1992. +

+

+ p: BlockTube - Draws a swirling, falling tunnel of reflective slabs. They fade from hue to hue. Written by Lars R. Damerow; 2003. +

+

+ q: Boing - This bouncing ball is a clone of the first graphics demo for the Amiga 1000, which was written by Dale Luck and RJ Mical during a break at the 1984 Consumer Electronics Show (or so the legend goes.) This looks like the original Amiga demo if you turn off "smoothing" and "lighting" and turn on "scanlines", and is somewhat more modern otherwise. http://en.wikipedia.org/wiki/Amiga#Boing_Ball Written by Jamie Zawinski; 2005. +

+

+ r: Bouboule - This draws what looks like a spinning, deforming balloon with varying-sized spots painted on its invisible surface. Written by Jeremie Petit; 1997. +

+

+ s: BouncingCow - A Cow. A Trampoline. Together, they fight crime. Written by Jamie Zawinski; 2003. +

+

+ t: Boxed - Draws a box full of 3D bouncing balls that explode. Written by Sander van Grieken; 2002. +

+

+ u: BoxFit - Packs the screen with growing squares or circles, colored according to a horizontal or vertical gradient, or according to the colors of the desktop or a loaded image file. The objects grow until they touch, then stop. When the screen is full, they shrink away and the process restarts. Written by Jamie Zawinski; 2005. +

+

+ v: Braid - Draws random color-cycling inter-braided concentric circles. Written by John Neil; 1997. +

+

+ w: BSOD - BSOD stands for "Blue Screen of Death". The finest in personal computer emulation, BSOD simulates popular screen savers from a number of less robust operating systems. Written by Jamie Zawinski; 1998. +

+

+ x: Bubble3D - Draws a stream of rising, undulating 3D bubbles, rising toward the top of the screen, with transparency and specular reflections. Written by Richard Jones; 1998. +

+

+ y: Bumps - A spotlight roams across an embossed version of your desktop or other picture. Written by Shane Smit; 1999. +

+

+ z: Cage - This draws Escher's "Impossible Cage", a 3d analog of a moebius strip, and rotates it in three dimensions. http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo Vianna; 1998. +

+

+ |: Carousel - Loads several random images, and displays them flying in a circular formation. The formation changes speed and direction randomly, and images periodically drop out to be replaced by new ones. Written by Jamie Zawinski; 2005. +

+

+ |: CCurve - Generates self-similar linear fractals, including the classic "C Curve". http://en.wikipedia.org/wiki/Levy_C_curve Written by Rick Campbell; 1999. +

+

+ |: Celtic - Repeatedly draws random Celtic cross-stitch patterns. http://en.wikipedia.org/wiki/Celtic_knot Written by Max Froumentin; 2005. +

+

+ |: Circuit - Animates a number of 3D electronic components. Written by Ben Buxton; 2001. +

+

+ |: CloudLife - Generates cloud-like formations based on a variant of Conway's Life. The difference is that cells have a maximum age, after which they count as 3 for populating the next generation. This makes long-lived formations explode instead of just sitting there. http://en.wikipedia.org/wiki/Conway%27s_Game_of_Life Written by Don Marti; 2003. +

+

+ |: Compass - This draws a compass, with all elements spinning about randomly, for that "lost and nauseous" feeling. Written by Jamie Zawinski; 1999. +

+

+ |: Coral - Simulates coral growth, albeit somewhat slowly. Written by Frederick Roeber; 1997. +

+

+ |: Cosmos - Display a slideshow of pictures of the cosmos +

+

+ |: Crackberg - Flies through height maps, optionally animating the creation and destruction of generated tiles; tiles `grow' into place. Written by Matus Telgarsky; 2005. +

+

+ |: Crystal - Moving polygons, similar to a kaleidoscope. See also the "Kaleidescope" and "GLeidescope" screen savers. http://en.wikipedia.org/wiki/Kaleidoscope Written by Jouk Jansen; 1998. +

+

+ |: Cube21 - Animates a Rubik-like puzzle known as Cube 21 or Square-1. The rotations are chosen randomly. See also the "Rubik", "RubikBlocks" and "GLSnake" screen savers. http://en.wikipedia.org/wiki/Square_One_%28puzzle%29 Written by Vasek Potocek; 2005. +

+

+ |: Cubenetic - Draws a pulsating set of overlapping boxes with ever-chaning blobby patterns undulating across their surfaces. It's sort of a cubist Lavalite. Written by Jamie Zawinski; 2002. +

+

+ |: CubeStorm - Draws a series of rotating 3D boxes that intersect each other and eventually fill space. Written by Jamie Zawinski; 2003. +

+

+ |: CubicGrid - Draws the view of an observer located inside a rotating 3D lattice of colored points. Written by Vasek Potocek; 2007. +

+

+ |: CWaves - This generates a languidly-scrolling vertical field of sinusoidal colors. Written by Jamie Zawinski; 2007. +

+

+ |: Cynosure - Random dropshadowed rectangles pop onto the screen in lockstep. Written by Ozymandias G. Desiderata, Jamie Zawinski, and Stephen Linhart; 1998. +

+

+ |: DangerBall - Draws a ball that periodically extrudes many random spikes. Ouch! Written by Jamie Zawinski; 2001. +

+

+ |: DecayScreen - This takes an image and makes it melt. You've no doubt seen this effect before, but no screensaver would really be complete without it. It works best if there's something colorful visible. Warning, if the effect continues after the screen saver is off, seek medical attention. Written by David Wald, Vivek Khera, Jamie Zawinski, and Vince Levey; 1993. +

+

+ |: Deco - Subdivides and colors rectangles randomly. It looks kind of like Brady-Bunch-era rec-room wall paneling. http://en.wikipedia.org/wiki/Piet_Mondrian#Paris_1919.E2.80.931938 Written by Jamie Zawinski and Michael Bayne; 1997. +

+

+ |: Deluxe - Draws a pulsing sequence of transparent stars, circles, and lines. Written by Jamie Zawinski; 1999. +

+

+ |: Demon - A cellular automaton that starts with a random field, and organizes it into stripes and spirals. http://en.wikipedia.org/wiki/Maxwell%27s_demon Written by David Bagley; 1999. +

+

+ |: Discrete - More "discrete map" systems, including new variants of Hopalong and Julia, and a few others. See also the "Hopalong" and "Julia" screen savers. Written by Tim Auckland; 1998. +

+

+ |: Distort - Grabs an image of the screen, and then lets a transparent lens wander around the screen, magnifying whatever is underneath. Written by Jonas Munsin; 1998. +

+

+ |: Drift - Drifting recursive fractal cosmic flames. Written by Scott Draves; 1997. +

+

+ |: Endgame - Black slips out of three mating nets, but the fourth one holds him tight! A brilliant composition! See also the "Queens" screen saver. http://en.wikipedia.org/wiki/Chess_endgame Written by Blair Tennessy; 2002. +

+

+ |: Engine - Draws a simple model of an engine that floats around the screen. http://en.wikipedia.org/wiki/Internal_combustion_engine#Operation Written by Ben Buxton and Ed Beroset; 2001. +

+

+ |: Epicycle - This draws the path traced out by a point on the edge of a circle. That circle rotates around a point on the rim of another circle, and so on, several times. These were the basis for the pre-heliocentric model of planetary motion. http://en.wikipedia.org/wiki/Deferent_and_epicycle Written by James Youngman; 1998. +

+

+ |: Eruption - Exploding fireworks. See also the "Fireworkx", "XFlame" and "Pyro" screen savers. Written by W.P. van Paassen; 2003. +

+

+ |: Euler2D - Simulates two dimensional incompressible inviscid fluid flow. http://en.wikipedia.org/wiki/Euler_equations_%28fluid_dynamics%29 http://en.wikipedia.org/wiki/Inviscid_flow Written by Stephen Montgomery-Smith; 2002. +

+

+ |: Extrusion - Draws various rotating extruded shapes that twist around, lengthen, and turn inside out. Written by Linas Vepstas, David Konerding, and Jamie Zawinski; 1999. +

+

+ |: FadePlot - Draws what looks like a waving ribbon following a sinusoidal path. Written by Bas van Gaalen and Charles Vidal; 1997. +

+

+ |: Fiberlamp - Draws a groovy rotating fiber optic lamp. Written by Tim Auckland; 2005. +

+

+ |: Fireworkx - Exploding fireworks. See also the "Eruption", "XFlame" and "Pyro" screen savers. Written by Rony B Chandran; 2004. +

+

+ |: Flame - Iterative fractals. Written by Scott Draves; 1993. +

+

+ |: FlipFlop - Draws a grid of 3D colored tiles that change positions with each other. Written by Kevin Ogden and Sergio Gutierrez; 2003. +

+

+ |: FlipScreen3D - Grabs an image of the desktop, turns it into a GL texture map, and spins it around and deforms it in various ways. Written by Ben Buxton and Jamie Zawinski; 2001. +

+

+ |: FlipText - Draws successive pages of text. The lines flip in and out in a soothing 3D pattern. Written by Jamie Zawinski; 2005. +

+

+ |: Flow - Strange attractors formed of flows in a 3D differential equation phase space. Features the popular attractors described by Lorentz, Roessler, Birkhoff and Duffing, and can discover entirely new attractors by itself. http://en.wikipedia.org/wiki/Attractor#Strange_attractor Written by Tim Auckland; 1998. +

+

+ |: FluidBalls - Models the physics of bouncing balls, or of particles in a gas or fluid, depending on the settings. If "Shake Box" is selected, then every now and then, the box will be rotated, changing which direction is down (in order to keep the settled balls in motion.) Written by Peter Birtles and Jamie Zawinski; 2002. +

+

+ |: Flurry - This X11 port of the OSX screensaver of the same name draws a colourful star(fish)like flurry of particles. Original Mac version: http://homepage.mac.com/calumr Written by Calum Robinson and Tobias Sargeant; 2002. +

+

+ |: FlyingToasters - A fleet of 3d space-age jet-powered flying toasters (and toast!) Inspired by the ancient Berkeley Systems After Dark flying toasters. http://en.wikipedia.org/wiki/After_Dark_%28software%29#Flying_Toasters Written by Jamie Zawinski and Devon Dossett; 2003. +

+

+ |: FontGlide - Puts text on the screen using large characters that glide in from the edges, assemble, then disperse. Alternately, it can simply scroll whole sentences from right to left. Written by Jamie Zawinski; 2003. +

+

+ |: Floating Feet - Bubbles the GNOME foot logo around the screen +

+

+ |: FuzzyFlakes - Falling colored snowflake/flower shapes. http://en.wikipedia.org/wiki/Snowflake Written by Barry Dmytro; 2004. +

+

+ |: Galaxy - This draws spinning galaxies, which then collide and scatter their stars to the, uh, four winds or something. Written by Uli Siegmund, Harald Backert, and Hubert Feyrer; 1997. +

+

+ |: Gears - This draws sets of turning, interlocking gears, rotating in three dimensions. See also the "Pinion" and "MoebiusGears" screen savers. http://en.wikipedia.org/wiki/Involute_gear http://en.wikipedia.org/wiki/Epicyclic_gearing Written by Jamie Zawinski; 2007. +

+

+ |: GFlux - Draws a rippling waves on a rotating wireframe grid. Written by Josiah Pease; 2000. +

+

+ |: GLBlur - This draws a box and a few line segments, and generates a radial blur outward from it. This creates flowing field effects. This is done by rendering the scene into a small texture, then repeatedly rendering increasingly-enlarged and increasingly-transparent versions of that texture onto the frame buffer. As such, it's quite GPU-intensive: if you don't have a very good graphics card, it will hurt your machine bad. Written by Jamie Zawinski; 2002. +

+

+ |: GLCells - Cells growing, dividing and dying on your screen. Written by Matthias Toussaint; 2007. +

+

+ |: Gleidescope - A kaleidoscope that operates on your desktop image, or on image files loaded from disk. http://en.wikipedia.org/wiki/Kaleidoscope Written by Andrew Dean; 2003. +

+

+ |: GLHanoi - Solves the Towers of Hanoi puzzle. Move N disks from one pole to another, one disk at a time, with no disk ever resting on a disk smaller than itself. http://en.wikipedia.org/wiki/Tower_of_Hanoi Written by Dave Atkinson; 2005. +

+

+ |: GLKnots - Generates some twisting 3d knot patterns. Spins 'em around. http://en.wikipedia.org/wiki/Knot_theory Written by Jamie Zawinski; 2003. +

+

+ |: GLMatrix - Draws 3D dropping characters similar to what is seen in the title sequence of "The Matrix". See also "xmatrix" for a 2D rendering of the similar effect that appeared on the computer monitors actually *in* the movie. Written by Jamie Zawinski; 2003. +

+

+ |: GLPlanet - Draws a planet bouncing around in space. The built-in image is a map of the earth (extracted from `xearth'), but you can wrap any texture around the sphere, e.g., the planetary textures that come with `ssystem'. Written by David Konerding; 1998. +

+

+ |: GLSchool - Uses Craig Reynolds' Boids algorithm to simulate a school of fish. http://en.wikipedia.org/wiki/Boids Written by David C. Lambert; 2006. +

+

+ |: GLSlideshow - Loads a random sequence of images and smoothly scans and zooms around in each, fading from pan to pan. Written by Jamie Zawinski and Mike Oliphant; 2003. +

+

+ |: GLSnake - Draws a simulation of the Rubik's Snake puzzle. See also the "Rubik" and "Cube21" screen savers. http://en.wikipedia.org/wiki/Rubik%27s_Snake Written by Jamie Wilkinson, Andrew Bennetts, and Peter Aylett; 2002. +

+

+ |: GLText - Displays a few lines of text spinning around in a solid 3D font. The text can use strftime() escape codes to display the current date and time. Written by Jamie Zawinski; 2001. +

+

+ |: Goop - This draws set of animating, transparent, amoeba-like blobs. The blobs change shape as they wander around the screen, and they are translucent, so you can see the lower blobs through the higher ones, and when one passes over another, their colors merge. I got the idea for this from a mouse pad I had once, which achieved the same kind of effect in real life by having several layers of plastic with colored oil between them. Written by Jamie Zawinski; 1997. +

+

+ |: Grav - This draws a simple orbital simulation. With trails enabled, it looks kind of like a cloud-chamber photograph. Written by Greg Bowering; 1997. +

+

+ |: Greynetic - Draws random colored, stippled and transparent rectangles. Written by Jamie Zawinski; 1992. +

+

+ |: Halftone - Draws the gravity force in each point on the screen seen through a halftone dot pattern. The gravity force is calculated from a set of moving mass points. View it from a distance for best effect. http://en.wikipedia.org/wiki/Halftone Written by Peter Jaric; 2002. +

+

+ |: Halo - Draws trippy psychedelic circular patterns that hurt to look at. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 1993. +

+

+ |: Helix - Spirally string-art-ish patterns. Written by Jamie Zawinski; 1992. +

+

+ |: Hopalong - This draws lacy fractal patterns based on iteration in the imaginary plane, from a 1986 Scientific American article. See also the "Discrete" screen saver. Written by Patrick Naughton; 1992. +

+

+ |: Hypertorus - This shows a rotating Clifford Torus: a torus lying on the "surface" of a 4D hypersphere. Inspired by Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/N-sphere http://en.wikipedia.org/wiki/Clifford_torus http://en.wikipedia.org/wiki/Regular_polytope Written by Carsten Steger; 2003. +

+

+ |: Hypnowheel - Draws a series of overlapping, translucent spiral patterns. The tightness of their spirals fluctuates in and out. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 2008. +

+

+ |: IFS - This one draws spinning, colliding iterated-function-system images. Note that the "Detail" parameter is exponential. Number of points drawn is functions^detail. http://en.wikipedia.org/wiki/Iterated_function_system Written by Chris Le Sueur and Robby Griffin; 1997. +

+

+ |: IMSMap - This generates random cloud-like patterns. The idea is to take four points on the edge of the image, and assign each a random "elevation". Then find the point between them, and give it a value which is the average of the other four, plus some small random offset. Coloration is done based on elevation. Written by Juergen Nickelsen and Jamie Zawinski; 1992. +

+

+ |: Interaggregate - A surface is filled with a hundred medium to small sized circles. Each circle has a different size and direction, but moves at the same slow rate. Displays the instantaneous intersections of the circles as well as the aggregate intersections of the circles. Though actually it doesn't look like circles at all! Written by Casey Reas, William Ngan, Robert Hodgin, and Jamie Zawinski; 2004. +

+

+ |: Interference - Color field based on computing decaying sinusoidal waves. Written by Hannu Mallat; 1998. +

+

+ |: Intermomentary - A surface is filled with a hundred medium to small sized circles. Each circle has a different size and direction, but moves at the same slow rate. Displays the instantaneous intersections of the circles as well as the aggregate intersections of the circles. The circles begin with a radius of 1 pixel and slowly increase to some arbitrary size. Circles are drawn with small moving points along the perimeter. The intersections are rendered as glowing orbs. Glowing orbs are rendered only when a perimeter point moves past the intersection point. Written by Casey Reas, William Ngan, Robert Hodgin, and Jamie Zawinski; 2004. +

+

+ |: JigglyPuff - This does bad things with quasi-spherical objects. You have a tetrahedron with tesselated faces. The vertices on these faces have forces on them: one proportional to the distance from the surface of a sphere; and one proportional to the distance from the neighbors. They also have inertia. The resulting effect can range from a shape that does nothing, to a frenetic polygon storm. Somewhere in between there it usually manifests as a blob that jiggles in a kind of disturbing manner. Written by Keith Macleod; 2003. +

+

+ |: Jigsaw - This grabs a screen image, carves it up into a jigsaw puzzle, shuffles it, and then solves the puzzle. http://en.wikipedia.org/wiki/Jigsaw_puzzle http://en.wikipedia.org/wiki/Tessellation Written by Jamie Zawinski; 1997. +

+

+ |: Juggler3D - Draws a 3D juggling stick-man. http://en.wikipedia.org/wiki/Siteswap Written by Tim Auckland and Jamie Zawinski; 2002. +

+

+ |: Julia - Animates the Julia set (a close relative of the Mandelbrot set). The small moving dot indicates the control point from which the rest of the image was generated. See also the "Discrete" screen saver. http://en.wikipedia.org/wiki/Julia_set Written by Sean McCullough; 1997. +

+

+ |: Kaleidescope - A simple kaleidoscope. See also "GLeidescope". http://en.wikipedia.org/wiki/Kaleidoscope Written by Ron Tapia; 1997. +

+

+ |: Klein - This shows a 4D Klein bottle. You can walk on the Klein bottle or rotate it in 4D or walk on it while it rotates in 4D. Inspired by Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/Klein_bottle Written by Carsten Steger; 2008. +

+

+ |: Kumppa - Spiraling, spinning, and very, very fast splashes of color rush toward the screen. Written by Teemu Suutari; 1998. +

+

+ |: Lament - Animates a simulation of Lemarchand's Box, the Lament Configuration, repeatedly solving itself. Warning: occasionally opens doors. http://en.wikipedia.org/wiki/Lemarchand%27s_box Written by Jamie Zawinski; 1998. +

+

+ |: Lavalite - Draws a 3D Simulation a Lava Lite(r). Odd-shaped blobs of a mysterious substance are heated, slowly rise to the top of the bottle, and then drop back down as they cool. This simulation requires a fairly fast machine (both CPU and 3D performance.) "LAVA LITE(r) and the configuration of the LAVA(r) brand motion lamp are registered trademarks of Haggerty Enterprises, Inc. The configuration of the globe and base of the motion lamp are registered trademarks of Haggerty Enterprises, Inc. in the U.S.A. and in other countries around the world." http://en.wikipedia.org/wiki/Lava_lamp http://en.wikipedia.org/wiki/Metaballs Written by Jamie Zawinski; 2002. +

+

+ |: LCDscrub - This screen saver is not meant to look pretty, but rather, to repair burn-in on LCD monitors. Believe it or not, screen burn is not a thing of the past. It can happen to LCD screens pretty easily, even in this modern age. However, leaving the screen on and displaying high contrast images can often repair the damage. That's what this screen saver does. See also: http://docs.info.apple.com/article.html?artnum +

+

+ |: Lockward - A translucent spinning, blinking thing. Sort of a cross between the wards in an old combination lock and those old backlit information displays that animated and changed color via polarized light. Written by Leo L. Schwab; 2007. +

+

+ |: Loop - Generates loop-shaped colonies that spawn, age, and eventually die. http://en.wikipedia.org/wiki/Langton%27s_loops Written by David Bagley; 1999. +

+

+ |: m6502 - This emulates a 6502 microprocessor. The family of 6502 chips were used throughout the 70's and 80's in machines such as the Atari 2600, Commodore PET, VIC20 and C64, Apple ][, and the NES. Some example programs are included, and it can also read in an assembly file as input. Original JavaScript Version by Stian Soreng: http://www.6502asm.com/. Ported to XScreenSaver by Jeremy English. Written by Stian Soreng and Jeremy English; 2007. +

+

+ |: Maze - This generates random mazes (with three different maze-generation algorithms), and then solves them. Backtracking and look-ahead paths are displayed in different colors. http://en.wikipedia.org/wiki/Maze_generation_algorithm Written by Martin Weiss, Dave Lemke, Jim Randell, Jamie Zawinski, Johannes Keukelaar, and Zack Weinberg; 1985. +

+

+ |: MemScroller - This draws a dump of its own process memory scrolling across the screen in three windows at three different rates. Written by Jamie Zawinski; 2004. +

+

+ |: Menger - This draws the three-dimensional variant of the recursive Menger Gasket, a cube-based fractal object analagous to the Sierpinski Tetrahedron. http://en.wikipedia.org/wiki/Menger_sponge http://en.wikipedia.org/wiki/Sierpinski_carpet Written by Jamie Zawinski; 2001. +

+

+ |: MetaBalls - Draws two dimensional metaballs: overlapping and merging balls with fuzzy edges. http://en.wikipedia.org/wiki/Metaballs Written by W.P. van Paassen; 2003. +

+

+ |: MirrorBlob - Draws a wobbly blob that distorts the image behind it. Written by Jon Dowdall; 2003. +

+

+ |: Moebius - This animates a 3D rendition M.C. Escher's "Moebius Strip II", an image of ants walking along the surface of a moebius strip. http://en.wikipedia.org/wiki/Moebius_strip http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo F. Vianna; 1997. +

+

+ |: MoebiusGears - Draws a closed, interlinked chain of rotating gears. The layout of the gears follows the path of a moebius strip. See also the "Pinion" and "Gears" screen savers. http://en.wikipedia.org/wiki/Involute_gear http://en.wikipedia.org/wiki/Moebius_strip Written by Jamie Zawinski; 2007. +

+

+ |: Moire - When the lines on the screen Make more lines in between, That's a moire'! http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski and Michael Bayne; 1997. +

+

+ |: Moire2 - Generates fields of concentric circles or ovals, and combines the planes with various operations. The planes are moving independently of one another, causing the interference lines to spray. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 1998. +

+

+ |: Molecule - Draws several different representations of molecules. Some common molecules are built in, and it can also read PDB (Protein Data Bank) files as input. http://en.wikipedia.org/wiki/Protein_Data_Bank_%28file_format%29 Written by Jamie Zawinski; 2001. +

+

+ |: Morph3D - Platonic solids that turn inside out and get spikey. http://en.wikipedia.org/wiki/Platonic_solid Written by Marcelo Vianna; 1997. +

+

+ |: Mountain - Generates random 3D plots that look vaguely mountainous. Written by Pascal Pensa; 1997. +

+

+ |: Munch - DATAI 2 ADDB 1,2 ROTC 2,-22 XOR 1,2 JRST .-4 As reported by HAKMEM (MIT AI Memo 239, 1972), Jackson Wright wrote the above PDP-1 code in 1962. That code still lives on here, some 46 years later. In "mismunch" mode, it displays a creatively broken misimplementation of the classic munching squares algorithm instead. http://en.wikipedia.org/wiki/HAKMEM http://en.wikipedia.org/wiki/Munching_square Written by Jackson Wright, Tim Showalter, Jamie Zawinski and Steven Hazel; 1997. +

+

+ |: NerveRot - Draws different shapes composed of nervously vibrating squiggles, as if seen through a camera operated by a monkey on crack. Written by Dan Bornstein; 2000. +

+

+ |: Noof - Draws some rotatey patterns, using OpenGL. Written by Bill Torzewski; 2004. +

+

+ |: NoseGuy - A little man with a big nose wanders around your screen saying things. Written by Dan Heller and Jamie Zawinski; 1992. +

+

+ |: Pacman - Simulates a game of Pac-Man on a randomly-created level. http://en.wikipedia.org/wiki/Pac-Man Written by Edwin de Jong; 2004. +

+

+ |: Pedal - This is sort of a combination spirograph/string-art. It generates a large, complex polygon, and renders it by filling using an even/odd winding rule. Written by Dale Moore; 1995. +

+

+ |: Penetrate - Simulates (something like) the classic arcade game Missile Command. http://en.wikipedia.org/wiki/Missile_Command Written by Adam Miller; 1999. +

+

+ |: Penrose - Draws quasiperiodic tilings; think of the implications on modern formica technology. In April 1997, Sir Roger Penrose, a British math professor who has worked with Stephen Hawking on such topics as relativity, black holes, and whether time has a beginning, filed a copyright-infringement lawsuit against the Kimberly-Clark Corporation, which Penrose said copied a pattern he created (a pattern demonstrating that "a nonrepeating pattern could exist in nature") for its Kleenex quilted toilet paper. Penrose said he doesn't like litigation but, "When it comes to the population of Great Britain being invited by a multinational to wipe their bottoms on what appears to be the work of a Knight of the Realm, then a last stand must be taken." As reported by News of the Weird #491, 4-Jul-1997. http://en.wikipedia.org/wiki/Penrose_tiling Written by Timo Korvola; 1997. +

+

+ |: Pictures folder - Display a slideshow from your Pictures folder +

+

+ |: Petri - This simulates colonies of mold growing in a petri dish. Growing colored circles overlap and leave spiral interference in their wake. Written by Dan Bornstein; 1999. +

+

+ |: Phosphor - Draws a simulation of an old terminal, with large pixels and long-sustain phosphor. On X11 systems, This program is also a fully-functional VT100 emulator! Written by Jamie Zawinski; 1999. +

+

+ |: Photopile - Loads several random images, and displays them as if lying in a random pile. The pile is periodically reshuffled, with new images coming in and old ones being thrown out. Written by Jens Kilian; 2008. +

+

+ |: Piecewise - This draws a bunch of moving circles which switch from visibility to invisibility at intersection points. Written by Geoffrey Irving; 2003. +

+

+ |: Pinion - Draws an interconnected set of gears moving across the screen. See also the "Gears" and "MoebiusGears" screen savers. http://en.wikipedia.org/wiki/Involute_gear Written by Jamie Zawinski; 2004. +

+

+ |: Pipes - A growing plumbing system, with bolts and valves. Written by Marcelo Vianna; 1997. +

+

+ |: Polyhedra - Displays different 3D solids and some information about each. A new solid is chosen every few seconds. There are 75 uniform polyhedra, plus 5 infinite sets of prisms and antiprisms; including their duals brings the total to 160. http://en.wikipedia.org/wiki/Uniform_polyhedra Written by Dr. Zvi Har'El and Jamie Zawinski; 2004. +

+

+ |: Polyominoes - Repeatedly attempts to completely fill a rectangle with irregularly-shaped puzzle pieces. http://en.wikipedia.org/wiki/Polyomino Written by Stephen Montgomery-Smith; 2002. +

+

+ |: Polytopes - This shows one of the six regular 4D polytopes rotating in 4D. Inspired by H.S.M Coxeter's book "Regular Polytopes", 3rd Edition, Dover Publications, Inc., 1973, and Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/Hypercube http://en.wikipedia.org/wiki/Regular_polytope Written by Carsten Steger; 2003. +

+

+ |: Pong - This simulates the 1971 Pong home video game, as well as various artifacts from displaying it on a color TV set. In clock mode, the score keeps track of the current time. http://en.wikipedia.org/wiki/Pong Written by Jeremy English and Trevor Blackwell; 2003. +

+

+ |: PopSquares - This draws a pop-art-ish looking grid of pulsing colors. Written by Levi Burton; 2003. +

+

+ |: Providence - "A pyramid unfinished. In the zenith an eye in a triangle, surrounded by a glory, proper." http://en.wikipedia.org/wiki/Eye_of_Providence Written by Blair Tennessy; 2004. +

+

+ |: Pulsar - Draws some intersecting planes, making use of alpha blending, fog, textures, and mipmaps. Written by David Konerding; 1999. +

+

+ |: Pyro - Exploding fireworks. See also the "Fireworkx", "Eruption", and "XFlame" screen savers. Written by Jamie Zawinski; 1992. +

+

+ |: Qix - Bounces a series of line segments around the screen, and uses variations on this basic motion pattern to produce all sorts of different presentations: line segments, filled polygons, and overlapping translucent areas. http://en.wikipedia.org/wiki/Qix Written by Jamie Zawinski; 1992. +

+

+ |: Queens - Solves the N-Queens problem (where N is between 5 and 10 queens). The problem is: how may one place N queens on an NxN chessboard such that no queen can attack a sister? See also the "Endgame" screen saver. http://en.wikipedia.org/wiki/Eight_queens_puzzle Written by Blair Tennessy; 2002. +

+

+ |: RDbomb - Draws a grid of growing square-like shapes that, once they overtake each other, react in unpredictable ways. "RD" stands for reaction-diffusion. Written by Scott Draves; 1997. +

+

+ |: Ripples - This draws rippling interference patterns like splashing water, overlayed on the desktop or an image. Written by Tom Hammersley; 1999. +

+

+ |: Rocks - This draws an animation of flight through an asteroid field, with changes in rotation and direction. Written by Jamie Zawinski; 1992. +

+

+ |: Rorschach - This generates random inkblot patterns via a reflected random walk. Any deep-seated neurotic tendencies which this program reveals are your own problem. http://en.wikipedia.org/wiki/Rorschach_inkblot_test http://en.wikipedia.org/wiki/Random_walk Written by Jamie Zawinski; 1992. +

+

+ |: RotZoomer - Creates a collage of rotated and scaled portions of the screen. Written by Claudio Matsuoka; 2001. +

+

+ |: Rubik - Draws a Rubik's Cube that rotates in three dimensions and repeatedly shuffles and solves itself. See also the "GLSnake" and "Cube21" screen savers. http://en.wikipedia.org/wiki/Rubik%27s_Cube Written by Marcelo Vianna; 1997. +

+

+ |: RubikBlocks - Animates the Rubik's Mirror Blocks puzzle. See also the "Rubik", "Cube21", and "GLSnake" screen savers. http://en.wikipedia.org/wiki/Combination_puzzles#Irregular_Cuboids Written by Vasek Potocek; 2009. +

+

+ |: SBalls - Draws an animation of textured balls spinning like crazy. Written by Eric Lassauge; 2002. +

+

+ |: ShadeBobs - This draws smoothly-shaded oscillating oval patterns that look something like vapor trails or neon tubes. Written by Shane Smit; 1999. +

+

+ |: Sierpinski - This draws the two-dimensional variant of the recursive Sierpinski triangle fractal. See also the "Sierpinski3D" screen saver. http://en.wikipedia.org/wiki/Sierpinski_triangle Written by Desmond Daignault; 1997. +

+

+ |: Sierpinski3D - This draws the Sierpinski tetrahedron fractal, the three-dimensional variant of the recursive Sierpinski triangle. http://en.wikipedia.org/wiki/Sierpinski_triangle#Analogs_in_higher_dimension Written by Jamie Zawinski and Tim Robinson; 1999. +

+

+ |: SkyTentacles - There is a tentacled abomination in the sky. From above you it devours. Written by Jamie Zawinski; 2008. +

+

+ |: SlideScreen - This takes an image, divides it into a grid, and then randomly shuffles the squares around as if it was one of those "fifteen-puzzle" games where there is a grid of squares, one of which is missing. http://en.wikipedia.org/wiki/Fifteen_puzzle Written by Jamie Zawinski; 1994. +

+

+ |: Slip - This throws some random bits on the screen, then sucks them through a jet engine and spews them out the other side. To avoid turning the image completely to mush, every now and then it will it interject some splashes of color into the scene, or go into a spin cycle, or stretch the image like taffy. Written by Scott Draves and Jamie Zawinski; 1997. +

+

+ |: Sonar - This draws a sonar screen that pings (get it?) the hosts on your local network, and plots their distance (response time) from you. The three rings represent ping times of approximately 2.5, 70 and 2,000 milliseconds respectively. Alternately, it can run a simulation that doesn't involve hosts. (If pinging doesn't work, you may need to make the executable be setuid.) http://en.wikipedia.org/wiki/Ping#History Written by Jamie Zawinski and Stephen Martin; 1998. +

+

+ |: SpeedMine - Simulates speeding down a rocky mineshaft, or a funky dancing worm. Written by Conrad Parker; 2001. +

+

+ |: Spheremonics - These closed objects are commonly called spherical harmonics, although they are only remotely related to the mathematical definition found in the solution to certain wave functions, most notably the eigenfunctions of angular momentum operators. http://en.wikipedia.org/wiki/Spherical_harmonics#Visualization_of_the_spherical_harmonics Written by Paul Bourke and Jamie Zawinski; 2002. +

+

+ |: Spotlight - Draws a spotlight scanning across a black screen, illuminating the underlying desktop (or a picture) when it passes. Written by Rick Schultz and Jamie Zawinski; 1999. +

+

+ |: Sproingies - Slinky-like creatures walk down an infinite staircase and occasionally explode! http://en.wikipedia.org/wiki/Slinky http://en.wikipedia.org/wiki/Q%2Abert http://en.wikipedia.org/wiki/Marble_Madness Written by Ed Mackey; 1997. +

+

+ |: Squiral - Draws a set of interacting, square-spiral-producing automata. The spirals grow outward until they hit something, then they go around it. Written by Jeff Epler; 1999. +

+

+ |: Stairs - Escher's infinite staircase. http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo Vianna; 1998. +

+

+ |: Starfish - This generates a sequence of undulating, throbbing, star-like patterns which pulsate, rotate, and turn inside out. Another display mode uses these shapes to lay down a field of colors, which are then cycled. The motion is very organic. Written by Jamie Zawinski; 1997. +

+

+ |: StarWars - Draws a stream of text slowly scrolling into the distance at an angle, over a star field, like at the beginning of the movie of the same name. http://en.wikipedia.org/wiki/Star_Wars_opening_crawl Written by Jamie Zawinski and Claudio Matauoka; 2001. +

+

+ |: StonerView - Chains of colorful squares dance around each other in complex spiral patterns. Inspired by David Tristram's `electropaint' screen saver, originally written for SGI computers in the late 1980s or early 1990s. Written by Andrew Plotkin; 2001. +

+

+ |: Strange - This draws iterations to strange attractors: it's a colorful, unpredictably-animating swarm of dots that swoops and twists around. http://en.wikipedia.org/wiki/Attractor#Strange_attractor Written by Massimino Pascal; 1997. +

+

+ |: Substrate - Crystalline lines grow on a computational substrate. A simple perpendicular growth rule creates intricate city-like structures. Written by J. Tarbell and Mike Kershaw; 2004. +

+

+ |: Superquadrics - Morphing 3D shapes. Written by Ed Mackey; 1987, 1997. +

+

+ |: Surfaces - This draws a visualization of several interesting parametric surfaces. http://mathworld.wolfram.com/DinisSurface.html http://en.wikipedia.org/wiki/Enneper_surface http://mathworld.wolfram.com/EnnepersMinimalSurface.html http://mathworld.wolfram.com/KuenSurface.html http://en.wikipedia.org/wiki/Moebius_strip http://mathworld.wolfram.com/Seashell.html http://mathworld.wolfram.com/SwallowtailCatastrophe.html http://mathworld.wolfram.com/BohemianDome.html http://en.wikipedia.org/wiki/Whitney_umbrella http://mathworld.wolfram.com/PlueckersConoid.html http://mathworld.wolfram.com/HennebergsMinimalSurface.html http://mathworld.wolfram.com/CatalansSurface.html http://mathworld.wolfram.com/CorkscrewSurface.html Written by Andrey Mirtchovski and Carsten Steger; 2003. +

+

+ |: Swirl - Flowing, swirly patterns. Written by M. Dobie and R. Taylor; 1997. +

+

+ |: Tangram - Solves tangram puzzles. http://en.wikipedia.org/wiki/Tangram Written by Jeremy English; 2005. +

+

+ |: Thornbird - Displays a view of the "Bird in a Thornbush" fractal. Written by Tim Auckland; 2002. +

+

+ |: TimeTunnel - Draws an animation similar to the opening and closing effects on the Dr. Who TV show. Written by Sean P. Brennan; 2005. +

+

+ |: TopBlock - Creates a 3D world with dropping blocks that build up and up. Written by rednuht; 2006. +

+

+ |: Triangle - Generates random mountain ranges using iterative subdivision of triangles. Written by Tobias Gloth; 1997. +

+

+ |: Truchet - This draws line- and arc-based truchet patterns that tile the screen. http://en.wikipedia.org/wiki/Tessellation Written by Adrian Likins; 1998. +

+

+ |: Twang - Divides the screen into a grid, and plucks them. Written by Dan Bornstein; 2002. +

+

+ |: Vermiculate - Draws squiggly worm-like paths. Written by Tyler Pierce; 2001. +

+

+ |: VidWhacker - This is a shell script that grabs a frame of video from the system's video input, and then uses some PBM filters (chosen at random) to manipulate and recombine the video frame in various ways (edge detection, subtracting the image from a rotated version of itself, etc.) Then it displays that image for a few seconds, and does it again. This works really well if you just feed broadcast television into it. Written by Jamie Zawinski; 1998. +

+

+ |: Voronoi - Draws a randomly-colored Voronoi tessellation, and periodically zooms in and adds new points. The existing points also wander around. There are a set of control points on the plane, each at the center of a colored cell. Every pixel within that cell is closer to that cell's control point than to any other control point. That is what determines the cell's shapes. http://en.wikipedia.org/wiki/Voronoi_diagram Written by Jamie Zawinski; 2007. +

+

+ |: Wander - Draws a colorful random-walk, in various forms. http://en.wikipedia.org/wiki/Random_walk Written by Rick Campbell; 1999. +

+

+ |: WebCollage - This makes collages out of random images pulled off of the World Wide Web. It finds these images by doing random web searches, and then extracting images from the returned pages. WARNING: THE INTERNET SOMETIMES CONTAINS PORNOGRAPHY. The Internet being what it is, absolutely anything might show up in the collage including -- quite possibly -- pornography, or even nudity. Please act accordingly. See also http://www.jwz.org/webcollage/ Written by Jamie Zawinski; 1999. +

+

+ |: WhirlWindWarp - Floating stars are acted upon by a mixture of simple 2D forcefields. The strength of each forcefield changes continuously, and it is also switched on and off at random. Written by Paul 'Joey' Clark; 2001. +

+

+ |: Wormhole - Flying through a colored wormhole in space. Written by Jon Rafkind; 2004. +

+

+ |: XAnalogTV - XAnalogTV shows a detailed simulation of an old TV set showing various test patterns, with various picture artifacts like snow, bloom, distortion, ghosting, and hash noise. It also simulates the TV warming up. It will cycle through 12 channels, some with images you give it, and some with color bars or nothing but static. Written by Trevor Blackwell; 2003. +

+

+ |: XFlame - Draws a simulation of pulsing fire. It can also take an arbitrary image and set it on fire too. Written by Carsten Haitzler and many others; 1999. +

+

+ |: XJack - This behaves schizophrenically and makes a lot of typos. Written by Jamie Zawinski; 1997. +

+

+ |: XLyap - This generates pretty fractal pictures via the Lyapunov exponent. http://en.wikipedia.org/wiki/Lyapunov_exponent Written by Ron Record; 1997. +

+

+ |: XMatrix - Draws dropping characters similar to what is seen on the computer monitors in "The Matrix". See also "GLMatrix" for a 3D rendering of the similar effect that appeared in the movie's title sequence. Written by Jamie Zawinski; 1999. +

+

+ |: XRaySwarm - Draws a few swarms of critters flying around the screen, with faded color trails behind them. Written by Chris Leger; 2000. +

+

+ |: XSpirograph - Simulates that pen-in-nested-plastic-gears toy from your childhood. http://en.wikipedia.org/wiki/Spirograph Written by Rohit Singh; 2000. +

+

+ |: Zoom - Zooms in on a part of the screen and then moves around. With the "Lenses" option, the result is like looking through many overlapping lenses rather than just a simple zoom. Written by James Macnicol; 2001. +


Child-Menu @@ -145,6 +2095,9 @@ w: < Managed window type menu >

+ u: < Unmanaged window behaviour > +

+

s: < Frame miscallenous menu >

@@ -485,6 +2438,19 @@


+ Frame-Unmanaged-Window-Menu +

+

+ s: Show unmanaged windows when frame is not selected +

+

+ h: Hide unmanaged windows when frame is not selected +

+

+ d: Set default behaviour to hide or not unmanaged windows when frame is not selected +

+
+

Frame-Miscellaneous-Menu

@@ -651,16 +2617,16 @@ c: < Query string group >

- d: < Menu group > + d: < Identify key group >

- e: < Identify key group > + e: < Main mode group >

- f: < Main mode group > + f: < Info mode group >

- g: < Info mode group > + g: < Menu group >

h: < Corner group > @@ -688,50 +2654,53 @@ a: Configure FRAME-FOREGROUND-ROOT

- b: Configure FRAME-FOREGROUND-HIDDEN + b: Configure FRAME-FOREGROUND

- c: Configure FRAME-FOREGROUND + c: Configure FRAME-BACKGROUND

- d: Configure FRAME-BACKGROUND + d: Configure FRAME-FOREGROUND-HIDDEN


Conf-Miscellaneous-Group

- a: Configure CREATE-FRAME-ON-ROOT + a: Configure NEVER-MANAGED-WINDOW-LIST +

+

+ b: Configure CREATE-FRAME-ON-ROOT

- b: Configure NEVER-MANAGED-WINDOW-LIST + c: Configure DEFAULT-FRAME-DATA

- c: Configure DEFAULT-FONT-STRING + d: Configure DEFAULT-FONT-STRING

- d: Configure DEFAULT-MODIFIERS + e: Configure HIDE-UNMANAGED-WINDOW

- e: Configure DEFAULT-FOCUS-POLICY + f: Configure DEFAULT-MODIFIERS

- f: Configure DEFAULT-FRAME-DATA + g: Configure DEFAULT-FOCUS-POLICY

- g: Configure LOOP-TIMEOUT + h: Configure LOOP-TIMEOUT

- h: Configure HAVE-TO-COMPRESS-NOTIFY + i: Configure HAVE-TO-COMPRESS-NOTIFY

- i: Configure DEFAULT-WINDOW-WIDTH + j: Configure DEFAULT-WINDOW-WIDTH

- j: Configure DEFAULT-MANAGED-TYPE + k: Configure DEFAULT-MANAGED-TYPE

- k: Configure DEFAULT-WINDOW-HEIGHT + l: Configure DEFAULT-WINDOW-HEIGHT


@@ -751,22 +2720,6 @@


- Conf-Menu-Group -

-

- a: Configure MENU-COLOR-SUBMENU -

-

- b: Configure MENU-COLOR-COMMENT -

-

- c: Configure MENU-COLOR-MENU-KEY -

-

- d: Configure MENU-COLOR-KEY -

-
-

Conf-Identify-Key-Group

@@ -802,37 +2755,56 @@ a: Configure INFO-BACKGROUND

- b: Configure INFO-FOREGROUND + b: Configure INFO-COLOR-FIRST

- c: Configure INFO-BORDER + c: Configure INFO-FOREGROUND

- d: Configure INFO-SELECTED-BACKGROUND + d: Configure INFO-BORDER

- e: Configure INFO-FONT-STRING + e: Configure INFO-SELECTED-BACKGROUND

- f: Configure INFO-COLOR-UNDERLINE + f: Configure INFO-FONT-STRING

- g: Configure INFO-COLOR-FIRST + g: Configure INFO-COLOR-UNDERLINE

- h: Configure INFO-LINE-CURSOR + h: Configure INFO-COLOR-TITLE

- i: Configure INFO-COLOR-TITLE + i: Configure INFO-CLICK-TO-SELECT

- j: Configure INFO-CLICK-TO-SELECT + j: Configure INFO-LINE-CURSOR

k: Configure INFO-COLOR-SECOND


+ Conf-Menu-Group +

+

+ a: Configure MENU-COLOR-SUBMENU +

+

+ b: Configure MENU-COLOR-COMMENT +

+

+ c: Configure MENU-COLOR-MENU-KEY +

+

+ d: Configure MENU-COLOR-KEY +

+

+ e: Configure XDG-SECTION-LIST +

+
+

Conf-Corner-Group

@@ -842,31 +2814,28 @@ b: Configure CORNER-MAIN-MODE-LEFT-BUTTON

- c: Configure VIRTUAL-KEYBOARD-KILL-CMD -

-

- d: Configure CLFSWM-TERMINAL-CMD + c: Configure CLFSWM-TERMINAL-CMD

- e: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON + d: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON

- f: Configure VIRTUAL-KEYBOARD-CMD + e: Configure VIRTUAL-KEYBOARD-CMD

- g: Configure CORNER-SECOND-MODE-LEFT-BUTTON + f: Configure CORNER-SECOND-MODE-LEFT-BUTTON

- h: Configure CORNER-SIZE + g: Configure CORNER-SIZE

- i: Configure CORNER-MAIN-MODE-RIGHT-BUTTON + h: Configure CORNER-MAIN-MODE-RIGHT-BUTTON

- j: Configure CLFSWM-TERMINAL-NAME + i: Configure CLFSWM-TERMINAL-NAME

- k: Configure CORNER-SECOND-MODE-RIGHT-BUTTON + j: Configure CORNER-SECOND-MODE-RIGHT-BUTTON


Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Sat Sep 11 17:42:25 2010 @@ -26,6 +26,668 @@ v: Show the current CLFSWM version Standard-Menu +a: < TEXTEDITOR > +b: < FILEMANAGER > +c: < WEBBROWSER > +d: < AUDIOVIDEO > +e: < AUDIO > +f: < VIDEO > +g: < DEVELOPMENT > +h: < EDUCATION > +i: < GAME > +j: < GRAPHICS > +k: < NETWORK > +l: < OFFICE > +m: < SETTINGS > +n: < SYSTEM > +o: < UTILITY > +p: < TERMINALEMULATOR > +q: < ARCHLINUX > +r: < SCREENSAVER > + +Texteditor +a: Emacs Text Editor - Edit text +b: gVim - GTK2 enhanced vim text editor +c: Kate +d: Snippets datafile editor +e: KWrite +f: Mousepad - Simple text editor +g: Xfw - A simple text editor for Xfe + +Filemanager +a: Open Folder with Thunar - Open the specified folders in Thunar +b: Thunar File Manager - Browse the filesystem with the file manager +c: Dolphin +d: Krusader +e: File Manager +f: ROX Filer - ROX Filer +g: Xfe - A lightweight file manager for X Window + +Webbrowser +a: Arora - Browse the World Wide Web +b: Chromium - Access the Internet +c: Epiphany - Browse the web +d: Firefox - Safe Mode +e: Firefox +f: IcedTea Web Start - IcedTea Application Launcher +g: Konqueror +h: Midori - Lightweight web browser +i: Opera - A fast and secure web browser and Internet suite + +Audiovideo +a: AcidRip DVD Ripper - DVD Ripper +b: Ardour - Multitrack hard disk recorder +c: Audacity - Record and edit audio files +d: Beep Media Player - Play music +e: Brasero - Create and copy CDs and DVDs +f: Gnome Music Player Client - A gnome frontend for the mpd daemon +g: Sound Recorder - Record sound clips +h: Volume Control - Change sound volume and sound events +i: Grip - CD player/ripper +j: gtk-recordMyDesktop - Frontend for recordMyDesktop +k: Hydrogen Drum Machine - Create drum sequences +l: Dragon Player +m: JuK +n: K3b - Disk writing program +o: KMix +p: KsCD +q: Mixxx - A digital DJ interface +r: MPlayer Media Player - Play movies and songs +s: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface +t: qt-recordMyDesktop - Frontend for recordMyDesktop +u: Sonata - An elegant GTK+ MPD client +v: Audio CD Extractor - Copy music from your CDs +w: VLC media player - Read, capture, broadcast your multimedia streams +x: Mixer - Audio mixer for the Xfce Desktop Environment +y: XMMS - X Multimedia System +z: zynaddsubfx - An opensource software synthesizer + +Audio +a: Ardour - Multitrack hard disk recorder +b: Audacity - Record and edit audio files +c: Sound Recorder - Record sound clips +d: Hydrogen Drum Machine - Create drum sequences +e: KMix +f: Mixxx - A digital DJ interface +g: MPlayer Media Player - Play movies and songs +h: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface +i: Audio CD Extractor - Copy music from your CDs +j: Mixer - Audio mixer for the Xfce Desktop Environment + +Video +a: Ardour - Multitrack hard disk recorder +b: MPlayer Media Player - Play movies and songs + +Development +a: CMake - Cross-platform buildsystem +b: Qt Assistant +c: Data Display Debugger - Graphical debugger frontend +d: Qt Designer +e: Emacs Text Editor - Edit text +f: Factor - Factor is a general purpose, dynamically typed, stack-based programming language +g: OpenJDK Monitoring & Management Console - Monitor and manage OpenJDK applications +h: Akonadi Console - Akonadi Management and Debugging Console +i: Cervisia +j: KAppTemplate +k: KBugBuster +l: KCachegrind - Visualization of Performance Profiling Data +m: KDE SVN Build +n: KImageMapEditor +o: KLinkStatus +p: Kompare +q: KUIViewer +r: Lokalize +s: Umbrello +t: Qt Linguist +u: OpenJDK Policy Tool - Manage OpenJDK policy files + +Education +a: Blinken - A memory enhancement game +b: Cantor +c: KAlgebra - Math Expression Solver and Plotter +d: Kalzium - KDE Periodic Table of Elements +e: Kanagram - KDE Letter Order Game +f: KBruch - Practice exercises with fractions +g: KGeography - A Geography Learning Program +h: KHangMan - KDE Hangman Game +i: Kig - Explore Geometric Constructions +j: Kiten - Japanese Reference and Study Tool +k: KLettres - a KDE program to learn the alphabet +l: KmPlot - Function Plotter +m: KStars - Desktop Planetarium +n: KTouch +o: KTurtle +p: KWordQuiz - A flashcard and vocabulary learning program +q: Marble +r: Parley +s: Rocs - Graph Theory Tool for Professors and Students. +t: Step - Simulate physics experiments + +Game +a: 0 A.D. Editor +b: 0 A.D. +c: AssaultCube +d: DROD - Simple puzzle game. +e: Foobillard - A 3D billiards game using OpenGL +f: Frasse - Frasse and the Peas of Kejick adventure game +g: Frogatto - Old-school 2D platformer +h: GGoban - Play go and review game records +i: KGoldrunner - A game of action and puzzle-solving +j: AMOR +k: Blinken - A memory enhancement game +l: Bomber +m: Bovo +n: Granatier +o: Kanagram - KDE Letter Order Game +p: Kapman - Eat pills escaping ghosts +q: KAtomic +r: KBattleship +s: KBlackBox +t: KBlocks +u: KBounce +v: KBreakOut +w: KSnake +x: KDiamond +y: KFourInLine +z: KHangMan - KDE Hangman Game +|: Kigo +|: Killbots +|: Kiriki +|: KJumpingCube +|: Kolor Lines +|: KMahjongg +|: KMines +|: KNetWalk +|: Kolf +|: Kollision - A simple ball dodging game +|: Konquest +|: KPatience +|: KReversi +|: SameGame +|: Shisen-Sho +|: KsirK +|: KsirK Skin Editor +|: KSpaceDuel +|: KSquares +|: KSudoku - KSudoku, Sudoku game & more for KDE +|: KTeaTime +|: KTron +|: Potato Guy +|: Kubrick +|: LSkat +|: Palapeli +|: Neverball - A 3D arcade game with a ball +|: Neverputt - A 3D mini golf game +|: OpenArena - A Quake3-based FPS Game +|: SolarWolf +|: SuperTux 2 - Play a classic 2D platform game +|: Trackballs - Simple game similar to the classical game Marble Madness +|: Battle for Wesnoth - A fantasy turn-based strategy game +|: Battle for Wesnoth Map Editor - A map editor for Battle for Wesnoth maps +|: Xmoto +|: XSpaceWarp - Live long and prosper! + +Graphics +a: Image Viewer +b: PostScript Viewer - View PostScript files +c: GNU Image Manipulation Program - Create images and edit photographs +d: Image Viewer +e: GV +f: Inkscape - Create and edit Scalable Vector Graphics images +g: Gwenview - A simple image viewer +h: KColorChooser +i: KolourPaint +j: KRuler +k: KSnapshot +l: Okular +m: Okular +n: Okular +o: Okular +p: Okular +q: Okular +r: Okular +s: Okular +t: Okular +u: Okular +v: Okular +w: Okular +x: Okular +y: Okular +z: Okular +|: Okular +|: Xfig + +Network +a: Arora - Browse the World Wide Web +b: Epiphany Web Bookmarks - Browse and organize your bookmarks +c: Avahi SSH Server Browser - Browse for Zeroconf-enabled SSH Servers +d: Avahi VNC Server Browser - Browse for Zeroconf-enabled VNC Servers +e: Chromium - Access the Internet +f: Epiphany - Browse the web +g: Minefield - Safe Mode +h: Minefield +i: Firefox - Safe Mode +j: Firefox +k: Gnaughty - Porn downloader +l: Gwget Download Manager - Download files from the Internet +m: JAP - JAP makes it possible to surf the internet anonymously and unobservably. +n: IcedTea Web Start - IcedTea Application Launcher +o: KMail +p: KNode +q: KPPP +r: Akregator - A Feed Reader for KDE +s: Blogilo +t: KGet +u: KNetAttach +v: Konqueror +w: Kopete - Instant Messenger +x: KPPPLogview +y: KRDC +z: Krfb +|: Midori - Lightweight web browser +|: MultiGet +|: OpenArena Server - Run an OpenArena server +|: Opera - A fast and secure web browser and Internet suite +|: SeaMonkey internet suite +|: Thunderbird - Mail & News Reader +|: Transmission - Download and share files over BitTorrent +|: Tucan Manager - Download and upload manager for hosting sites. +|: Wicd - Manage Wired/Wireless Networks +|: wireshark - Network protocol analyzer + +Office +a: AbiWord +b: OpenOffice.org 3.2 Base +c: OpenOffice.org 3.2 Calc +d: OpenOffice.org 3.2 Draw +e: ePDFViewer - Lightweight PDF document viewer +f: GV +g: OpenOffice.org 3.2 Impress +h: Kontact +i: KAddressBook +j: KOrganizer - Calendar and Scheduling Program +k: KTimeTracker +l: KWord - Write text documents +m: Lokalize +n: Okular +o: OpenOffice.org 3.2 Math +p: OpenOffice.org 3.2 Printer Administration +q: OpenOffice.org 3.2 +r: OpenOffice.org 3.2 Writer +s: Orage - Desktop calendar +t: Xpdf - Views Adobe PDF (acrobat) files + +Settings +a: Assistive Technologies - Choose which accessibility features to enable when you log in +b: Preferred Applications +c: Monitors - Change resolution and position of monitors +d: Preferred Applications +e: Keyboard Indicator plugins - Enable/disable installed plugins +f: Privilege granting - Configure behavior of the privilege-granting tool +g: About Me - Set your personal information +h: Appearance - Customize the look of your desktop +i: Network Proxy - Set your network proxy preferences +j: Screensaver - Change screensaver properties +k: Mouse - Configure pointer device behavior and appearance +l: Volume Control - Change sound volume and sound events +m: Control Center +n: Multimedia Systems Selector - Configure defaults for GStreamer applications +o: Touchpad - Set your touchpad preferences +p: Menu Updating Tool +q: Change Password +r: Menu Editor +s: System Settings +t: Keyboard Shortcuts - Assign shortcut keys to commands +u: Keyboard - Edit keyboard settings and application shortcuts +v: Preferred Applications +w: Appearance - Customize the look of your desktop +x: Monitor Settings - Change screen resolution and configure external monitors +y: File Management - Change the behaviour and appearance of file manager windows +z: Pop-Up Notifications - Set your pop-up notification preferences +|: Opera Widget Manager +|: Qt Config - Configure Qt behavior, styles, fonts +|: Startup Applications - Choose what applications to start when you log in +|: File Manager +|: Windows - Set your window properties +|: Desktop - Set desktop background and menu and icon behaviour +|: Display - Configure screen settings and layout +|: Keyboard - Edit keyboard settings and application shortcuts +|: Mouse - Configure pointer device behavior and appearance +|: Session and Startup - Customize desktop startup and splash screen +|: Xfce 4 Settings Manager - Graphical Settings Manager for Xfce 4 +|: Appearance - Customize the look of your desktop +|: Window Manager - Configure window behavior and shortcuts +|: Window Manager Tweaks - Fine-tune window behaviour and effects +|: Workspaces - Set number and names of workspaces +|: Xfce 4 Calendar Settings - Settings for the Xfce 4 Calendar Application +|: Accessibility - Improve keyboard and mouse accessibility +|: Panel - Customize the panel settings +|: Settings Editor - Graphical settings editor for Xfconf +|: Xfce 4 Printing System Settings - Allow you to select the printing system backend that xfprint will use +|: Screensaver - Change screensaver properties + +System +a: Terminal +b: Bulk Rename - Rename Multiple Files +c: Open Folder with Thunar - Open the specified folders in Thunar +d: Thunar File Manager - Browse the filesystem with the file manager +e: Avahi Zeroconf Browser - Browse for Zeroconf services available on your network +f: CD/DVD Creator - Create CDs and DVDs +g: Manage Printing +h: System Monitor +i: GParted - Create, reorganize, and delete partitions +j: Dolphin +k: KDiskFree +l: Konqueror +m: Konqueror +n: Konqueror +o: Konqueror +p: KInfoCenter +q: File Manager - Super User Mode +r: Konsole +s: KRandRTray - A panel applet for resizing and reorientating X screens. +t: Krfb +u: Krusader - root-mode +v: System Monitor +w: KSystemLog +x: KUser +y: KWalletManager +z: KwikDisk +|: Task Manager - Manage running processes +|: File Browser - Browse the file system with the file manager +|: Disk Utility - Manage Drives and Media +|: UNetbootin - Tool for creating Live USB drives +|: Oracle VM VirtualBox +|: Xfe - A lightweight file manager for X Window +|: XNC - Graphical File manager, X Northern Captain + +Utility +a: Terminal +b: Bulk Rename - Rename Multiple Files +c: Open Folder with Thunar - Open the specified folders in Thunar +d: Thunar File Manager - Browse the filesystem with the file manager +e: dosbox Emulator - An emulator to run old DOS games +f: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password +g: About GNOME - Learn more about GNOME +h: Panel - Customize the panel settings +i: Theme Installer - Installs themes packages for various parts of the desktop +j: Image Viewer +k: Character Map - Insert special characters into documents +l: gVim - GTK2 enhanced vim text editor +m: Help - Get help with GNOME +n: Home +o: KCharSelect +p: KFloppy +q: KJots +r: Akonaditray +s: Ark +t: KDE Groupware Wizard +u: KAlarm +v: Kate +w: KCalc +x: KFileReplace +y: Find Files/Folders +z: KFontView +|: KGpg - A GnuPG frontend +|: Kleopatra +|: Kleopatra +|: Klipper +|: KMag +|: KMouseTool - Clicks the mouse for you, reducing the effects of RSI +|: KMouth +|: KNotes +|: KonsoleKalendar +|: Krusader +|: Snippets datafile editor +|: KTimer +|: KTimeTracker +|: KWrite +|: Okteta +|: SuperKaramba - An engine for cool desktop eyecandy. +|: Sweeper +|: LXTerminal - Use the command line +|: Mousepad - Simple text editor +|: File Browser - Browse the file system with the file manager +|: Computer - Browse all local and remote disks and folders accessible from this computer +|: Home Folder - Open your personal folder +|: Network - Browse bookmarked and local network locations +|: File Manager +|: Scilab - A scientific software package for numerical computations +|: About Xfce +|: Application Finder - Find and launch applications installed on your system +|: File Manager +|: Help - Get help with GNOME +|: Log Out +|: Run Program... +|: Terminal +|: Web Browser +|: Xfi - A simple image viewer for Xfe +|: Xfp - A simple package manager for Xfe +|: Xfce 4 Print Manager - Show the printer list and allow you to manage their jobs +|: Xfce 4 Print Dialog - Print a file and allow you to set up its layout +|: Xfv - A simple text viewer for Xfe +|: Xfw - A simple text editor for Xfe +|: XNC - Graphical File manager, X Northern Captain +|: Help - Get help with GNOME + +Terminalemulator +a: Terminal +b: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password +c: Konsole +d: LXTerminal - Use the command line + +Archlinux +a: AUR - Archlinux AUR +b: Bugs - Archlinux Bugtracker +c: Developers - Archlinux development team +d: Documentation - Archlinux Documentation +e: Donate - Archlinux Donations +f: Forum - Archlinux Forum +g: Homepage - Archlinux homepage +h: SVN - Archlinux SVN +i: Schwag - Archlinux goodie shopping +j: Wiki - Archlinux Wiki + +Screensaver +a: Abstractile - Generates mosaic patterns of interlocking tiles. Written by Steve Sundstrom; 2004. +b: Anemone - Wiggling tentacles. Written by Gabriel Finch; 2002. +c: Anemotaxis - Anemotaxis demonstrates a search algorithm designed for locating a source of odor in turbulent atmosphere. The searcher is able to sense the odor and determine local instantaneous wind direction. The goal is to find the source in the shortest mean time. http://en.wikipedia.org/wiki/Anemotaxis Written by Eugene Balkovsky; 2004. +d: AntInspect - Draws a trio of ants moving their spheres around a circle. Written by Blair Tennessy; 2004. +e: AntMaze - Draws a few views of a few ants walking around in a simple maze. Written by Blair Tennessy; 2005. +f: AntSpotlight - Draws an ant (with a headlight) who walks on top of an image of your desktop or other image. Written by Blair Tennessy; 2003. +g: Apollonian - Draws an Apollonian gasket: a fractal packing of circles with smaller circles, demonstrating Descartes's theorem. http://en.wikipedia.org/wiki/Apollonian_gasket http://en.wikipedia.org/wiki/Descartes%27_theorem Written by Allan R. Wilks and David Bagley; 2002. +h: Apple2 - Simulates an original Apple ][ Plus computer in all its 1979 glory. It also reproduces the appearance of display on a color television set of the period. In "Basic Programming Mode", a simulated user types in a BASIC program and runs it. In "Text Mode", it displays the output of a program, or the contents of a file or URL. In "Slideshow Mode", it chooses random images and displays them within the limitations of the Apple ][ display hardware. (Six available colors in hi-res mode!) On X11 systems, This program is also a fully-functional VT100 emulator. http://en.wikipedia.org/wiki/Apple_II_series Written by Trevor Blackwell; 2003. +i: Atlantis - A 3D animation of a number of sharks, dolphins, and whales. Written by Mark Kilgard; 1998. +j: Attraction - Uses a simple simple motion model to generate many different display modes. The control points attract each other up to a certain distance, and then begin to repel each other. The attraction/repulsion is proportional to the distance between any two particles, similar to the strong and weak nuclear forces. Written by Jamie Zawinski and John Pezaris; 1992. +k: Atunnel - Draws an animation of a textured tunnel in GL. Written by Eric Lassauge and Roman Podobedov; 2003. +l: Barcode - Draws a random sequence of colorful barcodes scrolling across your screen. CONSUME! The barcodes follow the UPC-A, UPC-E, EAN-8 or EAN-13 standards. http://en.wikipedia.org/wiki/Universal_Product_Code http://en.wikipedia.org/wiki/European_Article_Number Written by Dan Bornstein; 2003. +m: Blaster - Draws a simulation of flying space-combat robots (cleverly disguised as colored circles) doing battle in front of a moving star field. Written by Jonathan Lin; 1999. +n: BlinkBox - Shows a ball contained inside of a bounding box. Colored blocks blink in when the ball hits the sides. Written by Jeremy English; 2003. +o: BlitSpin - Repeatedly rotates a bitmap by 90 degrees by using logical operations: the bitmap is divided into quadrants, and the quadrants are shifted clockwise. Then the same thing is done again with progressively smaller quadrants, except that all sub-quadrants of a given size are rotated in parallel. As you watch it, the image appears to dissolve into static and then reconstitute itself, but rotated. Written by Jamie Zawinski; 1992. +p: BlockTube - Draws a swirling, falling tunnel of reflective slabs. They fade from hue to hue. Written by Lars R. Damerow; 2003. +q: Boing - This bouncing ball is a clone of the first graphics demo for the Amiga 1000, which was written by Dale Luck and RJ Mical during a break at the 1984 Consumer Electronics Show (or so the legend goes.) This looks like the original Amiga demo if you turn off "smoothing" and "lighting" and turn on "scanlines", and is somewhat more modern otherwise. http://en.wikipedia.org/wiki/Amiga#Boing_Ball Written by Jamie Zawinski; 2005. +r: Bouboule - This draws what looks like a spinning, deforming balloon with varying-sized spots painted on its invisible surface. Written by Jeremie Petit; 1997. +s: BouncingCow - A Cow. A Trampoline. Together, they fight crime. Written by Jamie Zawinski; 2003. +t: Boxed - Draws a box full of 3D bouncing balls that explode. Written by Sander van Grieken; 2002. +u: BoxFit - Packs the screen with growing squares or circles, colored according to a horizontal or vertical gradient, or according to the colors of the desktop or a loaded image file. The objects grow until they touch, then stop. When the screen is full, they shrink away and the process restarts. Written by Jamie Zawinski; 2005. +v: Braid - Draws random color-cycling inter-braided concentric circles. Written by John Neil; 1997. +w: BSOD - BSOD stands for "Blue Screen of Death". The finest in personal computer emulation, BSOD simulates popular screen savers from a number of less robust operating systems. Written by Jamie Zawinski; 1998. +x: Bubble3D - Draws a stream of rising, undulating 3D bubbles, rising toward the top of the screen, with transparency and specular reflections. Written by Richard Jones; 1998. +y: Bumps - A spotlight roams across an embossed version of your desktop or other picture. Written by Shane Smit; 1999. +z: Cage - This draws Escher's "Impossible Cage", a 3d analog of a moebius strip, and rotates it in three dimensions. http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo Vianna; 1998. +|: Carousel - Loads several random images, and displays them flying in a circular formation. The formation changes speed and direction randomly, and images periodically drop out to be replaced by new ones. Written by Jamie Zawinski; 2005. +|: CCurve - Generates self-similar linear fractals, including the classic "C Curve". http://en.wikipedia.org/wiki/Levy_C_curve Written by Rick Campbell; 1999. +|: Celtic - Repeatedly draws random Celtic cross-stitch patterns. http://en.wikipedia.org/wiki/Celtic_knot Written by Max Froumentin; 2005. +|: Circuit - Animates a number of 3D electronic components. Written by Ben Buxton; 2001. +|: CloudLife - Generates cloud-like formations based on a variant of Conway's Life. The difference is that cells have a maximum age, after which they count as 3 for populating the next generation. This makes long-lived formations explode instead of just sitting there. http://en.wikipedia.org/wiki/Conway%27s_Game_of_Life Written by Don Marti; 2003. +|: Compass - This draws a compass, with all elements spinning about randomly, for that "lost and nauseous" feeling. Written by Jamie Zawinski; 1999. +|: Coral - Simulates coral growth, albeit somewhat slowly. Written by Frederick Roeber; 1997. +|: Cosmos - Display a slideshow of pictures of the cosmos +|: Crackberg - Flies through height maps, optionally animating the creation and destruction of generated tiles; tiles `grow' into place. Written by Matus Telgarsky; 2005. +|: Crystal - Moving polygons, similar to a kaleidoscope. See also the "Kaleidescope" and "GLeidescope" screen savers. http://en.wikipedia.org/wiki/Kaleidoscope Written by Jouk Jansen; 1998. +|: Cube21 - Animates a Rubik-like puzzle known as Cube 21 or Square-1. The rotations are chosen randomly. See also the "Rubik", "RubikBlocks" and "GLSnake" screen savers. http://en.wikipedia.org/wiki/Square_One_%28puzzle%29 Written by Vasek Potocek; 2005. +|: Cubenetic - Draws a pulsating set of overlapping boxes with ever-chaning blobby patterns undulating across their surfaces. It's sort of a cubist Lavalite. Written by Jamie Zawinski; 2002. +|: CubeStorm - Draws a series of rotating 3D boxes that intersect each other and eventually fill space. Written by Jamie Zawinski; 2003. +|: CubicGrid - Draws the view of an observer located inside a rotating 3D lattice of colored points. Written by Vasek Potocek; 2007. +|: CWaves - This generates a languidly-scrolling vertical field of sinusoidal colors. Written by Jamie Zawinski; 2007. +|: Cynosure - Random dropshadowed rectangles pop onto the screen in lockstep. Written by Ozymandias G. Desiderata, Jamie Zawinski, and Stephen Linhart; 1998. +|: DangerBall - Draws a ball that periodically extrudes many random spikes. Ouch! Written by Jamie Zawinski; 2001. +|: DecayScreen - This takes an image and makes it melt. You've no doubt seen this effect before, but no screensaver would really be complete without it. It works best if there's something colorful visible. Warning, if the effect continues after the screen saver is off, seek medical attention. Written by David Wald, Vivek Khera, Jamie Zawinski, and Vince Levey; 1993. +|: Deco - Subdivides and colors rectangles randomly. It looks kind of like Brady-Bunch-era rec-room wall paneling. http://en.wikipedia.org/wiki/Piet_Mondrian#Paris_1919.E2.80.931938 Written by Jamie Zawinski and Michael Bayne; 1997. +|: Deluxe - Draws a pulsing sequence of transparent stars, circles, and lines. Written by Jamie Zawinski; 1999. +|: Demon - A cellular automaton that starts with a random field, and organizes it into stripes and spirals. http://en.wikipedia.org/wiki/Maxwell%27s_demon Written by David Bagley; 1999. +|: Discrete - More "discrete map" systems, including new variants of Hopalong and Julia, and a few others. See also the "Hopalong" and "Julia" screen savers. Written by Tim Auckland; 1998. +|: Distort - Grabs an image of the screen, and then lets a transparent lens wander around the screen, magnifying whatever is underneath. Written by Jonas Munsin; 1998. +|: Drift - Drifting recursive fractal cosmic flames. Written by Scott Draves; 1997. +|: Endgame - Black slips out of three mating nets, but the fourth one holds him tight! A brilliant composition! See also the "Queens" screen saver. http://en.wikipedia.org/wiki/Chess_endgame Written by Blair Tennessy; 2002. +|: Engine - Draws a simple model of an engine that floats around the screen. http://en.wikipedia.org/wiki/Internal_combustion_engine#Operation Written by Ben Buxton and Ed Beroset; 2001. +|: Epicycle - This draws the path traced out by a point on the edge of a circle. That circle rotates around a point on the rim of another circle, and so on, several times. These were the basis for the pre-heliocentric model of planetary motion. http://en.wikipedia.org/wiki/Deferent_and_epicycle Written by James Youngman; 1998. +|: Eruption - Exploding fireworks. See also the "Fireworkx", "XFlame" and "Pyro" screen savers. Written by W.P. van Paassen; 2003. +|: Euler2D - Simulates two dimensional incompressible inviscid fluid flow. http://en.wikipedia.org/wiki/Euler_equations_%28fluid_dynamics%29 http://en.wikipedia.org/wiki/Inviscid_flow Written by Stephen Montgomery-Smith; 2002. +|: Extrusion - Draws various rotating extruded shapes that twist around, lengthen, and turn inside out. Written by Linas Vepstas, David Konerding, and Jamie Zawinski; 1999. +|: FadePlot - Draws what looks like a waving ribbon following a sinusoidal path. Written by Bas van Gaalen and Charles Vidal; 1997. +|: Fiberlamp - Draws a groovy rotating fiber optic lamp. Written by Tim Auckland; 2005. +|: Fireworkx - Exploding fireworks. See also the "Eruption", "XFlame" and "Pyro" screen savers. Written by Rony B Chandran; 2004. +|: Flame - Iterative fractals. Written by Scott Draves; 1993. +|: FlipFlop - Draws a grid of 3D colored tiles that change positions with each other. Written by Kevin Ogden and Sergio Gutierrez; 2003. +|: FlipScreen3D - Grabs an image of the desktop, turns it into a GL texture map, and spins it around and deforms it in various ways. Written by Ben Buxton and Jamie Zawinski; 2001. +|: FlipText - Draws successive pages of text. The lines flip in and out in a soothing 3D pattern. Written by Jamie Zawinski; 2005. +|: Flow - Strange attractors formed of flows in a 3D differential equation phase space. Features the popular attractors described by Lorentz, Roessler, Birkhoff and Duffing, and can discover entirely new attractors by itself. http://en.wikipedia.org/wiki/Attractor#Strange_attractor Written by Tim Auckland; 1998. +|: FluidBalls - Models the physics of bouncing balls, or of particles in a gas or fluid, depending on the settings. If "Shake Box" is selected, then every now and then, the box will be rotated, changing which direction is down (in order to keep the settled balls in motion.) Written by Peter Birtles and Jamie Zawinski; 2002. +|: Flurry - This X11 port of the OSX screensaver of the same name draws a colourful star(fish)like flurry of particles. Original Mac version: http://homepage.mac.com/calumr Written by Calum Robinson and Tobias Sargeant; 2002. +|: FlyingToasters - A fleet of 3d space-age jet-powered flying toasters (and toast!) Inspired by the ancient Berkeley Systems After Dark flying toasters. http://en.wikipedia.org/wiki/After_Dark_%28software%29#Flying_Toasters Written by Jamie Zawinski and Devon Dossett; 2003. +|: FontGlide - Puts text on the screen using large characters that glide in from the edges, assemble, then disperse. Alternately, it can simply scroll whole sentences from right to left. Written by Jamie Zawinski; 2003. +|: Floating Feet - Bubbles the GNOME foot logo around the screen +|: FuzzyFlakes - Falling colored snowflake/flower shapes. http://en.wikipedia.org/wiki/Snowflake Written by Barry Dmytro; 2004. +|: Galaxy - This draws spinning galaxies, which then collide and scatter their stars to the, uh, four winds or something. Written by Uli Siegmund, Harald Backert, and Hubert Feyrer; 1997. +|: Gears - This draws sets of turning, interlocking gears, rotating in three dimensions. See also the "Pinion" and "MoebiusGears" screen savers. http://en.wikipedia.org/wiki/Involute_gear http://en.wikipedia.org/wiki/Epicyclic_gearing Written by Jamie Zawinski; 2007. +|: GFlux - Draws a rippling waves on a rotating wireframe grid. Written by Josiah Pease; 2000. +|: GLBlur - This draws a box and a few line segments, and generates a radial blur outward from it. This creates flowing field effects. This is done by rendering the scene into a small texture, then repeatedly rendering increasingly-enlarged and increasingly-transparent versions of that texture onto the frame buffer. As such, it's quite GPU-intensive: if you don't have a very good graphics card, it will hurt your machine bad. Written by Jamie Zawinski; 2002. +|: GLCells - Cells growing, dividing and dying on your screen. Written by Matthias Toussaint; 2007. +|: Gleidescope - A kaleidoscope that operates on your desktop image, or on image files loaded from disk. http://en.wikipedia.org/wiki/Kaleidoscope Written by Andrew Dean; 2003. +|: GLHanoi - Solves the Towers of Hanoi puzzle. Move N disks from one pole to another, one disk at a time, with no disk ever resting on a disk smaller than itself. http://en.wikipedia.org/wiki/Tower_of_Hanoi Written by Dave Atkinson; 2005. +|: GLKnots - Generates some twisting 3d knot patterns. Spins 'em around. http://en.wikipedia.org/wiki/Knot_theory Written by Jamie Zawinski; 2003. +|: GLMatrix - Draws 3D dropping characters similar to what is seen in the title sequence of "The Matrix". See also "xmatrix" for a 2D rendering of the similar effect that appeared on the computer monitors actually *in* the movie. Written by Jamie Zawinski; 2003. +|: GLPlanet - Draws a planet bouncing around in space. The built-in image is a map of the earth (extracted from `xearth'), but you can wrap any texture around the sphere, e.g., the planetary textures that come with `ssystem'. Written by David Konerding; 1998. +|: GLSchool - Uses Craig Reynolds' Boids algorithm to simulate a school of fish. http://en.wikipedia.org/wiki/Boids Written by David C. Lambert; 2006. +|: GLSlideshow - Loads a random sequence of images and smoothly scans and zooms around in each, fading from pan to pan. Written by Jamie Zawinski and Mike Oliphant; 2003. +|: GLSnake - Draws a simulation of the Rubik's Snake puzzle. See also the "Rubik" and "Cube21" screen savers. http://en.wikipedia.org/wiki/Rubik%27s_Snake Written by Jamie Wilkinson, Andrew Bennetts, and Peter Aylett; 2002. +|: GLText - Displays a few lines of text spinning around in a solid 3D font. The text can use strftime() escape codes to display the current date and time. Written by Jamie Zawinski; 2001. +|: Goop - This draws set of animating, transparent, amoeba-like blobs. The blobs change shape as they wander around the screen, and they are translucent, so you can see the lower blobs through the higher ones, and when one passes over another, their colors merge. I got the idea for this from a mouse pad I had once, which achieved the same kind of effect in real life by having several layers of plastic with colored oil between them. Written by Jamie Zawinski; 1997. +|: Grav - This draws a simple orbital simulation. With trails enabled, it looks kind of like a cloud-chamber photograph. Written by Greg Bowering; 1997. +|: Greynetic - Draws random colored, stippled and transparent rectangles. Written by Jamie Zawinski; 1992. +|: Halftone - Draws the gravity force in each point on the screen seen through a halftone dot pattern. The gravity force is calculated from a set of moving mass points. View it from a distance for best effect. http://en.wikipedia.org/wiki/Halftone Written by Peter Jaric; 2002. +|: Halo - Draws trippy psychedelic circular patterns that hurt to look at. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 1993. +|: Helix - Spirally string-art-ish patterns. Written by Jamie Zawinski; 1992. +|: Hopalong - This draws lacy fractal patterns based on iteration in the imaginary plane, from a 1986 Scientific American article. See also the "Discrete" screen saver. Written by Patrick Naughton; 1992. +|: Hypertorus - This shows a rotating Clifford Torus: a torus lying on the "surface" of a 4D hypersphere. Inspired by Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/N-sphere http://en.wikipedia.org/wiki/Clifford_torus http://en.wikipedia.org/wiki/Regular_polytope Written by Carsten Steger; 2003. +|: Hypnowheel - Draws a series of overlapping, translucent spiral patterns. The tightness of their spirals fluctuates in and out. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 2008. +|: IFS - This one draws spinning, colliding iterated-function-system images. Note that the "Detail" parameter is exponential. Number of points drawn is functions^detail. http://en.wikipedia.org/wiki/Iterated_function_system Written by Chris Le Sueur and Robby Griffin; 1997. +|: IMSMap - This generates random cloud-like patterns. The idea is to take four points on the edge of the image, and assign each a random "elevation". Then find the point between them, and give it a value which is the average of the other four, plus some small random offset. Coloration is done based on elevation. Written by Juergen Nickelsen and Jamie Zawinski; 1992. +|: Interaggregate - A surface is filled with a hundred medium to small sized circles. Each circle has a different size and direction, but moves at the same slow rate. Displays the instantaneous intersections of the circles as well as the aggregate intersections of the circles. Though actually it doesn't look like circles at all! Written by Casey Reas, William Ngan, Robert Hodgin, and Jamie Zawinski; 2004. +|: Interference - Color field based on computing decaying sinusoidal waves. Written by Hannu Mallat; 1998. +|: Intermomentary - A surface is filled with a hundred medium to small sized circles. Each circle has a different size and direction, but moves at the same slow rate. Displays the instantaneous intersections of the circles as well as the aggregate intersections of the circles. The circles begin with a radius of 1 pixel and slowly increase to some arbitrary size. Circles are drawn with small moving points along the perimeter. The intersections are rendered as glowing orbs. Glowing orbs are rendered only when a perimeter point moves past the intersection point. Written by Casey Reas, William Ngan, Robert Hodgin, and Jamie Zawinski; 2004. +|: JigglyPuff - This does bad things with quasi-spherical objects. You have a tetrahedron with tesselated faces. The vertices on these faces have forces on them: one proportional to the distance from the surface of a sphere; and one proportional to the distance from the neighbors. They also have inertia. The resulting effect can range from a shape that does nothing, to a frenetic polygon storm. Somewhere in between there it usually manifests as a blob that jiggles in a kind of disturbing manner. Written by Keith Macleod; 2003. +|: Jigsaw - This grabs a screen image, carves it up into a jigsaw puzzle, shuffles it, and then solves the puzzle. http://en.wikipedia.org/wiki/Jigsaw_puzzle http://en.wikipedia.org/wiki/Tessellation Written by Jamie Zawinski; 1997. +|: Juggler3D - Draws a 3D juggling stick-man. http://en.wikipedia.org/wiki/Siteswap Written by Tim Auckland and Jamie Zawinski; 2002. +|: Julia - Animates the Julia set (a close relative of the Mandelbrot set). The small moving dot indicates the control point from which the rest of the image was generated. See also the "Discrete" screen saver. http://en.wikipedia.org/wiki/Julia_set Written by Sean McCullough; 1997. +|: Kaleidescope - A simple kaleidoscope. See also "GLeidescope". http://en.wikipedia.org/wiki/Kaleidoscope Written by Ron Tapia; 1997. +|: Klein - This shows a 4D Klein bottle. You can walk on the Klein bottle or rotate it in 4D or walk on it while it rotates in 4D. Inspired by Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/Klein_bottle Written by Carsten Steger; 2008. +|: Kumppa - Spiraling, spinning, and very, very fast splashes of color rush toward the screen. Written by Teemu Suutari; 1998. +|: Lament - Animates a simulation of Lemarchand's Box, the Lament Configuration, repeatedly solving itself. Warning: occasionally opens doors. http://en.wikipedia.org/wiki/Lemarchand%27s_box Written by Jamie Zawinski; 1998. +|: Lavalite - Draws a 3D Simulation a Lava Lite(r). Odd-shaped blobs of a mysterious substance are heated, slowly rise to the top of the bottle, and then drop back down as they cool. This simulation requires a fairly fast machine (both CPU and 3D performance.) "LAVA LITE(r) and the configuration of the LAVA(r) brand motion lamp are registered trademarks of Haggerty Enterprises, Inc. The configuration of the globe and base of the motion lamp are registered trademarks of Haggerty Enterprises, Inc. in the U.S.A. and in other countries around the world." http://en.wikipedia.org/wiki/Lava_lamp http://en.wikipedia.org/wiki/Metaballs Written by Jamie Zawinski; 2002. +|: LCDscrub - This screen saver is not meant to look pretty, but rather, to repair burn-in on LCD monitors. Believe it or not, screen burn is not a thing of the past. It can happen to LCD screens pretty easily, even in this modern age. However, leaving the screen on and displaying high contrast images can often repair the damage. That's what this screen saver does. See also: http://docs.info.apple.com/article.html?artnum +|: Lockward - A translucent spinning, blinking thing. Sort of a cross between the wards in an old combination lock and those old backlit information displays that animated and changed color via polarized light. Written by Leo L. Schwab; 2007. +|: Loop - Generates loop-shaped colonies that spawn, age, and eventually die. http://en.wikipedia.org/wiki/Langton%27s_loops Written by David Bagley; 1999. +|: m6502 - This emulates a 6502 microprocessor. The family of 6502 chips were used throughout the 70's and 80's in machines such as the Atari 2600, Commodore PET, VIC20 and C64, Apple ][, and the NES. Some example programs are included, and it can also read in an assembly file as input. Original JavaScript Version by Stian Soreng: http://www.6502asm.com/. Ported to XScreenSaver by Jeremy English. Written by Stian Soreng and Jeremy English; 2007. +|: Maze - This generates random mazes (with three different maze-generation algorithms), and then solves them. Backtracking and look-ahead paths are displayed in different colors. http://en.wikipedia.org/wiki/Maze_generation_algorithm Written by Martin Weiss, Dave Lemke, Jim Randell, Jamie Zawinski, Johannes Keukelaar, and Zack Weinberg; 1985. +|: MemScroller - This draws a dump of its own process memory scrolling across the screen in three windows at three different rates. Written by Jamie Zawinski; 2004. +|: Menger - This draws the three-dimensional variant of the recursive Menger Gasket, a cube-based fractal object analagous to the Sierpinski Tetrahedron. http://en.wikipedia.org/wiki/Menger_sponge http://en.wikipedia.org/wiki/Sierpinski_carpet Written by Jamie Zawinski; 2001. +|: MetaBalls - Draws two dimensional metaballs: overlapping and merging balls with fuzzy edges. http://en.wikipedia.org/wiki/Metaballs Written by W.P. van Paassen; 2003. +|: MirrorBlob - Draws a wobbly blob that distorts the image behind it. Written by Jon Dowdall; 2003. +|: Moebius - This animates a 3D rendition M.C. Escher's "Moebius Strip II", an image of ants walking along the surface of a moebius strip. http://en.wikipedia.org/wiki/Moebius_strip http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo F. Vianna; 1997. +|: MoebiusGears - Draws a closed, interlinked chain of rotating gears. The layout of the gears follows the path of a moebius strip. See also the "Pinion" and "Gears" screen savers. http://en.wikipedia.org/wiki/Involute_gear http://en.wikipedia.org/wiki/Moebius_strip Written by Jamie Zawinski; 2007. +|: Moire - When the lines on the screen Make more lines in between, That's a moire'! http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski and Michael Bayne; 1997. +|: Moire2 - Generates fields of concentric circles or ovals, and combines the planes with various operations. The planes are moving independently of one another, causing the interference lines to spray. http://en.wikipedia.org/wiki/Moire_pattern Written by Jamie Zawinski; 1998. +|: Molecule - Draws several different representations of molecules. Some common molecules are built in, and it can also read PDB (Protein Data Bank) files as input. http://en.wikipedia.org/wiki/Protein_Data_Bank_%28file_format%29 Written by Jamie Zawinski; 2001. +|: Morph3D - Platonic solids that turn inside out and get spikey. http://en.wikipedia.org/wiki/Platonic_solid Written by Marcelo Vianna; 1997. +|: Mountain - Generates random 3D plots that look vaguely mountainous. Written by Pascal Pensa; 1997. +|: Munch - DATAI 2 ADDB 1,2 ROTC 2,-22 XOR 1,2 JRST .-4 As reported by HAKMEM (MIT AI Memo 239, 1972), Jackson Wright wrote the above PDP-1 code in 1962. That code still lives on here, some 46 years later. In "mismunch" mode, it displays a creatively broken misimplementation of the classic munching squares algorithm instead. http://en.wikipedia.org/wiki/HAKMEM http://en.wikipedia.org/wiki/Munching_square Written by Jackson Wright, Tim Showalter, Jamie Zawinski and Steven Hazel; 1997. +|: NerveRot - Draws different shapes composed of nervously vibrating squiggles, as if seen through a camera operated by a monkey on crack. Written by Dan Bornstein; 2000. +|: Noof - Draws some rotatey patterns, using OpenGL. Written by Bill Torzewski; 2004. +|: NoseGuy - A little man with a big nose wanders around your screen saying things. Written by Dan Heller and Jamie Zawinski; 1992. +|: Pacman - Simulates a game of Pac-Man on a randomly-created level. http://en.wikipedia.org/wiki/Pac-Man Written by Edwin de Jong; 2004. +|: Pedal - This is sort of a combination spirograph/string-art. It generates a large, complex polygon, and renders it by filling using an even/odd winding rule. Written by Dale Moore; 1995. +|: Penetrate - Simulates (something like) the classic arcade game Missile Command. http://en.wikipedia.org/wiki/Missile_Command Written by Adam Miller; 1999. +|: Penrose - Draws quasiperiodic tilings; think of the implications on modern formica technology. In April 1997, Sir Roger Penrose, a British math professor who has worked with Stephen Hawking on such topics as relativity, black holes, and whether time has a beginning, filed a copyright-infringement lawsuit against the Kimberly-Clark Corporation, which Penrose said copied a pattern he created (a pattern demonstrating that "a nonrepeating pattern could exist in nature") for its Kleenex quilted toilet paper. Penrose said he doesn't like litigation but, "When it comes to the population of Great Britain being invited by a multinational to wipe their bottoms on what appears to be the work of a Knight of the Realm, then a last stand must be taken." As reported by News of the Weird #491, 4-Jul-1997. http://en.wikipedia.org/wiki/Penrose_tiling Written by Timo Korvola; 1997. +|: Pictures folder - Display a slideshow from your Pictures folder +|: Petri - This simulates colonies of mold growing in a petri dish. Growing colored circles overlap and leave spiral interference in their wake. Written by Dan Bornstein; 1999. +|: Phosphor - Draws a simulation of an old terminal, with large pixels and long-sustain phosphor. On X11 systems, This program is also a fully-functional VT100 emulator! Written by Jamie Zawinski; 1999. +|: Photopile - Loads several random images, and displays them as if lying in a random pile. The pile is periodically reshuffled, with new images coming in and old ones being thrown out. Written by Jens Kilian; 2008. +|: Piecewise - This draws a bunch of moving circles which switch from visibility to invisibility at intersection points. Written by Geoffrey Irving; 2003. +|: Pinion - Draws an interconnected set of gears moving across the screen. See also the "Gears" and "MoebiusGears" screen savers. http://en.wikipedia.org/wiki/Involute_gear Written by Jamie Zawinski; 2004. +|: Pipes - A growing plumbing system, with bolts and valves. Written by Marcelo Vianna; 1997. +|: Polyhedra - Displays different 3D solids and some information about each. A new solid is chosen every few seconds. There are 75 uniform polyhedra, plus 5 infinite sets of prisms and antiprisms; including their duals brings the total to 160. http://en.wikipedia.org/wiki/Uniform_polyhedra Written by Dr. Zvi Har'El and Jamie Zawinski; 2004. +|: Polyominoes - Repeatedly attempts to completely fill a rectangle with irregularly-shaped puzzle pieces. http://en.wikipedia.org/wiki/Polyomino Written by Stephen Montgomery-Smith; 2002. +|: Polytopes - This shows one of the six regular 4D polytopes rotating in 4D. Inspired by H.S.M Coxeter's book "Regular Polytopes", 3rd Edition, Dover Publications, Inc., 1973, and Thomas Banchoff's book "Beyond the Third Dimension: Geometry, Computer Graphics, and Higher Dimensions", Scientific American Library, 1990. http://en.wikipedia.org/wiki/Hypercube http://en.wikipedia.org/wiki/Regular_polytope Written by Carsten Steger; 2003. +|: Pong - This simulates the 1971 Pong home video game, as well as various artifacts from displaying it on a color TV set. In clock mode, the score keeps track of the current time. http://en.wikipedia.org/wiki/Pong Written by Jeremy English and Trevor Blackwell; 2003. +|: PopSquares - This draws a pop-art-ish looking grid of pulsing colors. Written by Levi Burton; 2003. +|: Providence - "A pyramid unfinished. In the zenith an eye in a triangle, surrounded by a glory, proper." http://en.wikipedia.org/wiki/Eye_of_Providence Written by Blair Tennessy; 2004. +|: Pulsar - Draws some intersecting planes, making use of alpha blending, fog, textures, and mipmaps. Written by David Konerding; 1999. +|: Pyro - Exploding fireworks. See also the "Fireworkx", "Eruption", and "XFlame" screen savers. Written by Jamie Zawinski; 1992. +|: Qix - Bounces a series of line segments around the screen, and uses variations on this basic motion pattern to produce all sorts of different presentations: line segments, filled polygons, and overlapping translucent areas. http://en.wikipedia.org/wiki/Qix Written by Jamie Zawinski; 1992. +|: Queens - Solves the N-Queens problem (where N is between 5 and 10 queens). The problem is: how may one place N queens on an NxN chessboard such that no queen can attack a sister? See also the "Endgame" screen saver. http://en.wikipedia.org/wiki/Eight_queens_puzzle Written by Blair Tennessy; 2002. +|: RDbomb - Draws a grid of growing square-like shapes that, once they overtake each other, react in unpredictable ways. "RD" stands for reaction-diffusion. Written by Scott Draves; 1997. +|: Ripples - This draws rippling interference patterns like splashing water, overlayed on the desktop or an image. Written by Tom Hammersley; 1999. +|: Rocks - This draws an animation of flight through an asteroid field, with changes in rotation and direction. Written by Jamie Zawinski; 1992. +|: Rorschach - This generates random inkblot patterns via a reflected random walk. Any deep-seated neurotic tendencies which this program reveals are your own problem. http://en.wikipedia.org/wiki/Rorschach_inkblot_test http://en.wikipedia.org/wiki/Random_walk Written by Jamie Zawinski; 1992. +|: RotZoomer - Creates a collage of rotated and scaled portions of the screen. Written by Claudio Matsuoka; 2001. +|: Rubik - Draws a Rubik's Cube that rotates in three dimensions and repeatedly shuffles and solves itself. See also the "GLSnake" and "Cube21" screen savers. http://en.wikipedia.org/wiki/Rubik%27s_Cube Written by Marcelo Vianna; 1997. +|: RubikBlocks - Animates the Rubik's Mirror Blocks puzzle. See also the "Rubik", "Cube21", and "GLSnake" screen savers. http://en.wikipedia.org/wiki/Combination_puzzles#Irregular_Cuboids Written by Vasek Potocek; 2009. +|: SBalls - Draws an animation of textured balls spinning like crazy. Written by Eric Lassauge; 2002. +|: ShadeBobs - This draws smoothly-shaded oscillating oval patterns that look something like vapor trails or neon tubes. Written by Shane Smit; 1999. +|: Sierpinski - This draws the two-dimensional variant of the recursive Sierpinski triangle fractal. See also the "Sierpinski3D" screen saver. http://en.wikipedia.org/wiki/Sierpinski_triangle Written by Desmond Daignault; 1997. +|: Sierpinski3D - This draws the Sierpinski tetrahedron fractal, the three-dimensional variant of the recursive Sierpinski triangle. http://en.wikipedia.org/wiki/Sierpinski_triangle#Analogs_in_higher_dimension Written by Jamie Zawinski and Tim Robinson; 1999. +|: SkyTentacles - There is a tentacled abomination in the sky. From above you it devours. Written by Jamie Zawinski; 2008. +|: SlideScreen - This takes an image, divides it into a grid, and then randomly shuffles the squares around as if it was one of those "fifteen-puzzle" games where there is a grid of squares, one of which is missing. http://en.wikipedia.org/wiki/Fifteen_puzzle Written by Jamie Zawinski; 1994. +|: Slip - This throws some random bits on the screen, then sucks them through a jet engine and spews them out the other side. To avoid turning the image completely to mush, every now and then it will it interject some splashes of color into the scene, or go into a spin cycle, or stretch the image like taffy. Written by Scott Draves and Jamie Zawinski; 1997. +|: Sonar - This draws a sonar screen that pings (get it?) the hosts on your local network, and plots their distance (response time) from you. The three rings represent ping times of approximately 2.5, 70 and 2,000 milliseconds respectively. Alternately, it can run a simulation that doesn't involve hosts. (If pinging doesn't work, you may need to make the executable be setuid.) http://en.wikipedia.org/wiki/Ping#History Written by Jamie Zawinski and Stephen Martin; 1998. +|: SpeedMine - Simulates speeding down a rocky mineshaft, or a funky dancing worm. Written by Conrad Parker; 2001. +|: Spheremonics - These closed objects are commonly called spherical harmonics, although they are only remotely related to the mathematical definition found in the solution to certain wave functions, most notably the eigenfunctions of angular momentum operators. http://en.wikipedia.org/wiki/Spherical_harmonics#Visualization_of_the_spherical_harmonics Written by Paul Bourke and Jamie Zawinski; 2002. +|: Spotlight - Draws a spotlight scanning across a black screen, illuminating the underlying desktop (or a picture) when it passes. Written by Rick Schultz and Jamie Zawinski; 1999. +|: Sproingies - Slinky-like creatures walk down an infinite staircase and occasionally explode! http://en.wikipedia.org/wiki/Slinky http://en.wikipedia.org/wiki/Q%2Abert http://en.wikipedia.org/wiki/Marble_Madness Written by Ed Mackey; 1997. +|: Squiral - Draws a set of interacting, square-spiral-producing automata. The spirals grow outward until they hit something, then they go around it. Written by Jeff Epler; 1999. +|: Stairs - Escher's infinite staircase. http://en.wikipedia.org/wiki/Maurits_Cornelis_Escher Written by Marcelo Vianna; 1998. +|: Starfish - This generates a sequence of undulating, throbbing, star-like patterns which pulsate, rotate, and turn inside out. Another display mode uses these shapes to lay down a field of colors, which are then cycled. The motion is very organic. Written by Jamie Zawinski; 1997. +|: StarWars - Draws a stream of text slowly scrolling into the distance at an angle, over a star field, like at the beginning of the movie of the same name. http://en.wikipedia.org/wiki/Star_Wars_opening_crawl Written by Jamie Zawinski and Claudio Matauoka; 2001. +|: StonerView - Chains of colorful squares dance around each other in complex spiral patterns. Inspired by David Tristram's `electropaint' screen saver, originally written for SGI computers in the late 1980s or early 1990s. Written by Andrew Plotkin; 2001. +|: Strange - This draws iterations to strange attractors: it's a colorful, unpredictably-animating swarm of dots that swoops and twists around. http://en.wikipedia.org/wiki/Attractor#Strange_attractor Written by Massimino Pascal; 1997. +|: Substrate - Crystalline lines grow on a computational substrate. A simple perpendicular growth rule creates intricate city-like structures. Written by J. Tarbell and Mike Kershaw; 2004. +|: Superquadrics - Morphing 3D shapes. Written by Ed Mackey; 1987, 1997. +|: Surfaces - This draws a visualization of several interesting parametric surfaces. http://mathworld.wolfram.com/DinisSurface.html http://en.wikipedia.org/wiki/Enneper_surface http://mathworld.wolfram.com/EnnepersMinimalSurface.html http://mathworld.wolfram.com/KuenSurface.html http://en.wikipedia.org/wiki/Moebius_strip http://mathworld.wolfram.com/Seashell.html http://mathworld.wolfram.com/SwallowtailCatastrophe.html http://mathworld.wolfram.com/BohemianDome.html http://en.wikipedia.org/wiki/Whitney_umbrella http://mathworld.wolfram.com/PlueckersConoid.html http://mathworld.wolfram.com/HennebergsMinimalSurface.html http://mathworld.wolfram.com/CatalansSurface.html http://mathworld.wolfram.com/CorkscrewSurface.html Written by Andrey Mirtchovski and Carsten Steger; 2003. +|: Swirl - Flowing, swirly patterns. Written by M. Dobie and R. Taylor; 1997. +|: Tangram - Solves tangram puzzles. http://en.wikipedia.org/wiki/Tangram Written by Jeremy English; 2005. +|: Thornbird - Displays a view of the "Bird in a Thornbush" fractal. Written by Tim Auckland; 2002. +|: TimeTunnel - Draws an animation similar to the opening and closing effects on the Dr. Who TV show. Written by Sean P. Brennan; 2005. +|: TopBlock - Creates a 3D world with dropping blocks that build up and up. Written by rednuht; 2006. +|: Triangle - Generates random mountain ranges using iterative subdivision of triangles. Written by Tobias Gloth; 1997. +|: Truchet - This draws line- and arc-based truchet patterns that tile the screen. http://en.wikipedia.org/wiki/Tessellation Written by Adrian Likins; 1998. +|: Twang - Divides the screen into a grid, and plucks them. Written by Dan Bornstein; 2002. +|: Vermiculate - Draws squiggly worm-like paths. Written by Tyler Pierce; 2001. +|: VidWhacker - This is a shell script that grabs a frame of video from the system's video input, and then uses some PBM filters (chosen at random) to manipulate and recombine the video frame in various ways (edge detection, subtracting the image from a rotated version of itself, etc.) Then it displays that image for a few seconds, and does it again. This works really well if you just feed broadcast television into it. Written by Jamie Zawinski; 1998. +|: Voronoi - Draws a randomly-colored Voronoi tessellation, and periodically zooms in and adds new points. The existing points also wander around. There are a set of control points on the plane, each at the center of a colored cell. Every pixel within that cell is closer to that cell's control point than to any other control point. That is what determines the cell's shapes. http://en.wikipedia.org/wiki/Voronoi_diagram Written by Jamie Zawinski; 2007. +|: Wander - Draws a colorful random-walk, in various forms. http://en.wikipedia.org/wiki/Random_walk Written by Rick Campbell; 1999. +|: WebCollage - This makes collages out of random images pulled off of the World Wide Web. It finds these images by doing random web searches, and then extracting images from the returned pages. WARNING: THE INTERNET SOMETIMES CONTAINS PORNOGRAPHY. The Internet being what it is, absolutely anything might show up in the collage including -- quite possibly -- pornography, or even nudity. Please act accordingly. See also http://www.jwz.org/webcollage/ Written by Jamie Zawinski; 1999. +|: WhirlWindWarp - Floating stars are acted upon by a mixture of simple 2D forcefields. The strength of each forcefield changes continuously, and it is also switched on and off at random. Written by Paul 'Joey' Clark; 2001. +|: Wormhole - Flying through a colored wormhole in space. Written by Jon Rafkind; 2004. +|: XAnalogTV - XAnalogTV shows a detailed simulation of an old TV set showing various test patterns, with various picture artifacts like snow, bloom, distortion, ghosting, and hash noise. It also simulates the TV warming up. It will cycle through 12 channels, some with images you give it, and some with color bars or nothing but static. Written by Trevor Blackwell; 2003. +|: XFlame - Draws a simulation of pulsing fire. It can also take an arbitrary image and set it on fire too. Written by Carsten Haitzler and many others; 1999. +|: XJack - This behaves schizophrenically and makes a lot of typos. Written by Jamie Zawinski; 1997. +|: XLyap - This generates pretty fractal pictures via the Lyapunov exponent. http://en.wikipedia.org/wiki/Lyapunov_exponent Written by Ron Record; 1997. +|: XMatrix - Draws dropping characters similar to what is seen on the computer monitors in "The Matrix". See also "GLMatrix" for a 3D rendering of the similar effect that appeared in the movie's title sequence. Written by Jamie Zawinski; 1999. +|: XRaySwarm - Draws a few swarms of critters flying around the screen, with faded color trails behind them. Written by Chris Leger; 2000. +|: XSpirograph - Simulates that pen-in-nested-plastic-gears toy from your childhood. http://en.wikipedia.org/wiki/Spirograph Written by Rohit Singh; 2000. +|: Zoom - Zooms in on a part of the screen and then moves around. With the "Lenses" option, the result is like looking through many overlapping lenses rather than just a simple zoom. Written by James Macnicol; 2001. Child-Menu r: Rename the current child @@ -47,6 +709,7 @@ m: < Frame movement menu > f: < Frame focus policy menu > w: < Managed window type menu > +u: < Unmanaged window behaviour > s: < Frame miscallenous menu > x: Maximize/Unmaximize the current frame in its parent frame @@ -171,6 +834,11 @@ n: Manage only normal window type u: Do not manage any window type +Frame-Unmanaged-Window-Menu +s: Show unmanaged windows when frame is not selected +h: Hide unmanaged windows when frame is not selected +d: Set default behaviour to hide or not unmanaged windows when frame is not selected + Frame-Miscellaneous-Menu s: Show all frames info windows i: Hide all frames info windows @@ -231,10 +899,10 @@ a: < Frame colors group > b: < Miscellaneous group > c: < Query string group > -d: < Menu group > -e: < Identify key group > -f: < Main mode group > -g: < Info mode group > +d: < Identify key group > +e: < Main mode group > +f: < Info mode group > +g: < Menu group > h: < Corner group > i: < Hook group > j: < Placement group > @@ -244,22 +912,23 @@ Conf-Frame-Colors-Group a: Configure FRAME-FOREGROUND-ROOT -b: Configure FRAME-FOREGROUND-HIDDEN -c: Configure FRAME-FOREGROUND -d: Configure FRAME-BACKGROUND +b: Configure FRAME-FOREGROUND +c: Configure FRAME-BACKGROUND +d: Configure FRAME-FOREGROUND-HIDDEN Conf-Miscellaneous-Group -a: Configure CREATE-FRAME-ON-ROOT -b: Configure NEVER-MANAGED-WINDOW-LIST -c: Configure DEFAULT-FONT-STRING -d: Configure DEFAULT-MODIFIERS -e: Configure DEFAULT-FOCUS-POLICY -f: Configure DEFAULT-FRAME-DATA -g: Configure LOOP-TIMEOUT -h: Configure HAVE-TO-COMPRESS-NOTIFY -i: Configure DEFAULT-WINDOW-WIDTH -j: Configure DEFAULT-MANAGED-TYPE -k: Configure DEFAULT-WINDOW-HEIGHT +a: Configure NEVER-MANAGED-WINDOW-LIST +b: Configure CREATE-FRAME-ON-ROOT +c: Configure DEFAULT-FRAME-DATA +d: Configure DEFAULT-FONT-STRING +e: Configure HIDE-UNMANAGED-WINDOW +f: Configure DEFAULT-MODIFIERS +g: Configure DEFAULT-FOCUS-POLICY +h: Configure LOOP-TIMEOUT +i: Configure HAVE-TO-COMPRESS-NOTIFY +j: Configure DEFAULT-WINDOW-WIDTH +k: Configure DEFAULT-MANAGED-TYPE +l: Configure DEFAULT-WINDOW-HEIGHT Conf-Query-String-Group a: Configure QUERY-BACKGROUND @@ -267,12 +936,6 @@ c: Configure QUERY-FONT-STRING d: Configure QUERY-FOREGROUND -Conf-Menu-Group -a: Configure MENU-COLOR-SUBMENU -b: Configure MENU-COLOR-COMMENT -c: Configure MENU-COLOR-MENU-KEY -d: Configure MENU-COLOR-KEY - Conf-Identify-Key-Group a: Configure IDENTIFY-FOREGROUND b: Configure IDENTIFY-BORDER @@ -286,29 +949,35 @@ Conf-Info-Mode-Group a: Configure INFO-BACKGROUND -b: Configure INFO-FOREGROUND -c: Configure INFO-BORDER -d: Configure INFO-SELECTED-BACKGROUND -e: Configure INFO-FONT-STRING -f: Configure INFO-COLOR-UNDERLINE -g: Configure INFO-COLOR-FIRST -h: Configure INFO-LINE-CURSOR -i: Configure INFO-COLOR-TITLE -j: Configure INFO-CLICK-TO-SELECT +b: Configure INFO-COLOR-FIRST +c: Configure INFO-FOREGROUND +d: Configure INFO-BORDER +e: Configure INFO-SELECTED-BACKGROUND +f: Configure INFO-FONT-STRING +g: Configure INFO-COLOR-UNDERLINE +h: Configure INFO-COLOR-TITLE +i: Configure INFO-CLICK-TO-SELECT +j: Configure INFO-LINE-CURSOR k: Configure INFO-COLOR-SECOND +Conf-Menu-Group +a: Configure MENU-COLOR-SUBMENU +b: Configure MENU-COLOR-COMMENT +c: Configure MENU-COLOR-MENU-KEY +d: Configure MENU-COLOR-KEY +e: Configure XDG-SECTION-LIST + Conf-Corner-Group a: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON b: Configure CORNER-MAIN-MODE-LEFT-BUTTON -c: Configure VIRTUAL-KEYBOARD-KILL-CMD -d: Configure CLFSWM-TERMINAL-CMD -e: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON -f: Configure VIRTUAL-KEYBOARD-CMD -g: Configure CORNER-SECOND-MODE-LEFT-BUTTON -h: Configure CORNER-SIZE -i: Configure CORNER-MAIN-MODE-RIGHT-BUTTON -j: Configure CLFSWM-TERMINAL-NAME -k: Configure CORNER-SECOND-MODE-RIGHT-BUTTON +c: Configure CLFSWM-TERMINAL-CMD +d: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON +e: Configure VIRTUAL-KEYBOARD-CMD +f: Configure CORNER-SECOND-MODE-LEFT-BUTTON +g: Configure CORNER-SIZE +h: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +i: Configure CLFSWM-TERMINAL-NAME +j: Configure CORNER-SECOND-MODE-RIGHT-BUTTON Conf-Hook-Group a: Configure INIT-HOOK From pbrochard at common-lisp.net Sat Sep 11 21:48:31 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 17:48:31 -0400 Subject: [clfswm-cvs] r321 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 11 17:48:31 2010 New Revision: 321 Log: set-globally-hide-unmanaged-window, set-globally-show-unmanaged-window: New functions and menu entry. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp clfswm/src/menu-def.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 11 17:48:31 2010 @@ -3,6 +3,9 @@ * src/clfswm-util.lisp (set-hide-unmanaged-window) (set-show-unmanaged-window, set-default-hide-unmanaged-window): New functions and menu entry. + (set-globally-hide-unmanaged-window) + (set-globally-show-unmanaged-window): New functions and menu + entry. * src/clfswm-internal.lisp (hide-unmanager-window-p): New function. Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 11 17:48:31 2010 @@ -1366,4 +1366,12 @@ (setf (frame-data-slot *current-child* :unmanaged-window-action) nil) (leave-second-mode))) +(defun set-globally-hide-unmanaged-window () + "Hide unmanaged windows by default. This is overriden by functions above" + (setf *hide-unmanaged-window* t) + (leave-second-mode)) +(defun set-globally-show-unmanaged-window () + "Show unmanaged windows by default. This is overriden by functions above" + (setf *hide-unmanaged-window* nil) + (leave-second-mode)) Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Sat Sep 11 17:48:31 2010 @@ -159,6 +159,8 @@ (add-menu-key 'frame-unmanaged-window-menu "s" 'set-show-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "h" 'set-hide-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "d" 'set-default-hide-unmanaged-window) +(add-menu-key 'frame-unmanaged-window-menu "w" 'set-globally-show-unmanaged-window) +(add-menu-key 'frame-unmanaged-window-menu "i" 'set-globally-hide-unmanaged-window) (add-menu-key 'frame-miscellaneous-menu "s" 'show-all-frames-info) From pbrochard at common-lisp.net Sat Sep 11 21:49:59 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 17:49:59 -0400 Subject: [clfswm-cvs] r322 - clfswm/doc Message-ID: Author: pbrochard Date: Sat Sep 11 17:49:59 2010 New Revision: 322 Log: Documentation update Modified: clfswm/doc/menu.html clfswm/doc/menu.txt Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Sat Sep 11 17:49:59 2010 @@ -2449,6 +2449,12 @@

d: Set default behaviour to hide or not unmanaged windows when frame is not selected

+

+ w: Show unmanaged windows by default. This is overriden by functions above +

+

+ i: Hide unmanaged windows by default. This is overriden by functions above +


Frame-Miscellaneous-Menu @@ -2608,316 +2614,316 @@ Configuration-Menu

- a: < Frame colors group > + a: < Hook group >

- b: < Miscellaneous group > + b: < Main mode group >

- c: < Query string group > + c: < Frame colors group >

d: < Identify key group >

- e: < Main mode group > + e: < Second mode group >

- f: < Info mode group > + f: < Corner group >

- g: < Menu group > + g: < Query string group >

- h: < Corner group > + h: < Circulate mode group >

- i: < Hook group > + i: < Placement group >

- j: < Placement group > + j: < Miscellaneous group >

- k: < Circulate mode group > + k: < Info mode group >

- l: < Second mode group > + l: < Menu group >

F2: Save all configuration variables in clfswmrc


- Conf-Frame-Colors-Group + Conf-Hook-Group

- a: Configure FRAME-FOREGROUND-ROOT + a: Configure INIT-HOOK

- b: Configure FRAME-FOREGROUND + b: Configure DEFAULT-NW-HOOK

- c: Configure FRAME-BACKGROUND + c: Configure LOOP-HOOK

- d: Configure FRAME-FOREGROUND-HIDDEN + d: Configure BINDING-HOOK


- Conf-Miscellaneous-Group + Conf-Main-Mode-Group

- a: Configure NEVER-MANAGED-WINDOW-LIST + a: Configure COLOR-UNSELECTED

- b: Configure CREATE-FRAME-ON-ROOT -

-

- c: Configure DEFAULT-FRAME-DATA + b: Configure COLOR-SELECTED

- d: Configure DEFAULT-FONT-STRING + c: Configure COLOR-MAYBE-SELECTED

+
+

+ Conf-Frame-Colors-Group +

- e: Configure HIDE-UNMANAGED-WINDOW + a: Configure FRAME-FOREGROUND-ROOT

- f: Configure DEFAULT-MODIFIERS + b: Configure FRAME-FOREGROUND

- g: Configure DEFAULT-FOCUS-POLICY + c: Configure FRAME-FOREGROUND-HIDDEN

- h: Configure LOOP-TIMEOUT + d: Configure FRAME-BACKGROUND

+
+

+ Conf-Identify-Key-Group +

- i: Configure HAVE-TO-COMPRESS-NOTIFY + a: Configure IDENTIFY-FOREGROUND

- j: Configure DEFAULT-WINDOW-WIDTH + b: Configure IDENTIFY-FONT-STRING

- k: Configure DEFAULT-MANAGED-TYPE + c: Configure IDENTIFY-BORDER

- l: Configure DEFAULT-WINDOW-HEIGHT + d: Configure IDENTIFY-BACKGROUND


- Conf-Query-String-Group + Conf-Second-Mode-Group

- a: Configure QUERY-BACKGROUND + a: Configure SM-BACKGROUND-COLOR

- b: Configure QUERY-BORDER + b: Configure SM-HEIGHT

- c: Configure QUERY-FONT-STRING + c: Configure SM-WIDTH

- d: Configure QUERY-FOREGROUND + d: Configure SM-FOREGROUND-COLOR +

+

+ e: Configure SM-BORDER-COLOR +

+

+ f: Configure SM-FONT-STRING


- Conf-Identify-Key-Group + Conf-Corner-Group

- a: Configure IDENTIFY-FOREGROUND + a: Configure CORNER-MAIN-MODE-LEFT-BUTTON

- b: Configure IDENTIFY-BORDER + b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON

- c: Configure IDENTIFY-BACKGROUND + c: Configure CORNER-SECOND-MODE-LEFT-BUTTON

- d: Configure IDENTIFY-FONT-STRING + d: Configure CORNER-SECOND-MODE-RIGHT-BUTTON

-
-

- Conf-Main-Mode-Group -

- a: Configure COLOR-MAYBE-SELECTED + e: Configure CORNER-SIZE

- b: Configure COLOR-SELECTED + f: Configure CLFSWM-TERMINAL-CMD +

+

+ g: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +

+

+ h: Configure VIRTUAL-KEYBOARD-CMD +

+

+ i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON

- c: Configure COLOR-UNSELECTED + j: Configure CLFSWM-TERMINAL-NAME


- Conf-Info-Mode-Group + Conf-Query-String-Group

- a: Configure INFO-BACKGROUND + a: Configure QUERY-FONT-STRING

- b: Configure INFO-COLOR-FIRST + b: Configure QUERY-BACKGROUND

- c: Configure INFO-FOREGROUND + c: Configure QUERY-BORDER

- d: Configure INFO-BORDER + d: Configure QUERY-FOREGROUND

+
+

+ Conf-Circulate-Mode-Group +

- e: Configure INFO-SELECTED-BACKGROUND + a: Configure CIRCULATE-WIDTH

- f: Configure INFO-FONT-STRING + b: Configure CIRCULATE-TEXT-LIMITE

- g: Configure INFO-COLOR-UNDERLINE + c: Configure CIRCULATE-BORDER

- h: Configure INFO-COLOR-TITLE + d: Configure CIRCULATE-HEIGHT

- i: Configure INFO-CLICK-TO-SELECT + e: Configure CIRCULATE-FONT-STRING

- j: Configure INFO-LINE-CURSOR + f: Configure CIRCULATE-BACKGROUND

- k: Configure INFO-COLOR-SECOND + g: Configure CIRCULATE-FOREGROUND


- Conf-Menu-Group + Conf-Placement-Group

- a: Configure MENU-COLOR-SUBMENU + a: Configure CIRCULATE-MODE-PLACEMENT

- b: Configure MENU-COLOR-COMMENT + b: Configure QUERY-MODE-PLACEMENT

- c: Configure MENU-COLOR-MENU-KEY + c: Configure BANISH-POINTER-PLACEMENT

- d: Configure MENU-COLOR-KEY + d: Configure INFO-MODE-PLACEMENT

- e: Configure XDG-SECTION-LIST + e: Configure SECOND-MODE-PLACEMENT


- Conf-Corner-Group + Conf-Miscellaneous-Group

- a: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON + a: Configure HAVE-TO-COMPRESS-NOTIFY

- b: Configure CORNER-MAIN-MODE-LEFT-BUTTON + b: Configure HIDE-UNMANAGED-WINDOW

- c: Configure CLFSWM-TERMINAL-CMD + c: Configure DEFAULT-WINDOW-WIDTH

- d: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON + d: Configure CREATE-FRAME-ON-ROOT

- e: Configure VIRTUAL-KEYBOARD-CMD + e: Configure DEFAULT-FRAME-DATA

- f: Configure CORNER-SECOND-MODE-LEFT-BUTTON + f: Configure DEFAULT-MODIFIERS

- g: Configure CORNER-SIZE + g: Configure NEVER-MANAGED-WINDOW-LIST

- h: Configure CORNER-MAIN-MODE-RIGHT-BUTTON + h: Configure DEFAULT-MANAGED-TYPE

- i: Configure CLFSWM-TERMINAL-NAME + i: Configure DEFAULT-WINDOW-HEIGHT

- j: Configure CORNER-SECOND-MODE-RIGHT-BUTTON + j: Configure DEFAULT-FONT-STRING

-
-

- Conf-Hook-Group -

- a: Configure INIT-HOOK -

-

- b: Configure LOOP-HOOK + k: Configure DEFAULT-FOCUS-POLICY

- c: Configure BINDING-HOOK -

-

- d: Configure DEFAULT-NW-HOOK + l: Configure LOOP-TIMEOUT


- Conf-Placement-Group + Conf-Info-Mode-Group

- a: Configure BANISH-POINTER-PLACEMENT + a: Configure INFO-FOREGROUND

- b: Configure SECOND-MODE-PLACEMENT + b: Configure INFO-COLOR-UNDERLINE

- c: Configure QUERY-MODE-PLACEMENT + c: Configure INFO-SELECTED-BACKGROUND

- d: Configure INFO-MODE-PLACEMENT + d: Configure INFO-LINE-CURSOR

- e: Configure CIRCULATE-MODE-PLACEMENT -

-
-

- Conf-Circulate-Mode-Group -

-

- a: Configure CIRCULATE-WIDTH + e: Configure INFO-CLICK-TO-SELECT

- b: Configure CIRCULATE-HEIGHT + f: Configure INFO-BACKGROUND

- c: Configure CIRCULATE-FONT-STRING + g: Configure INFO-COLOR-FIRST

- d: Configure CIRCULATE-FOREGROUND + h: Configure INFO-BORDER

- e: Configure CIRCULATE-TEXT-LIMITE + i: Configure INFO-FONT-STRING

- f: Configure CIRCULATE-BACKGROUND + j: Configure INFO-COLOR-TITLE

- g: Configure CIRCULATE-BORDER + k: Configure INFO-COLOR-SECOND


- Conf-Second-Mode-Group + Conf-Menu-Group

- a: Configure SM-FONT-STRING + a: Configure MENU-COLOR-COMMENT

- b: Configure SM-BACKGROUND-COLOR + b: Configure MENU-COLOR-KEY

- c: Configure SM-FOREGROUND-COLOR + c: Configure XDG-SECTION-LIST

- d: Configure SM-HEIGHT -

-

- e: Configure SM-BORDER-COLOR + d: Configure MENU-COLOR-MENU-KEY

- f: Configure SM-WIDTH + e: Configure MENU-COLOR-SUBMENU


Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Sat Sep 11 17:49:59 2010 @@ -838,6 +838,8 @@ s: Show unmanaged windows when frame is not selected h: Hide unmanaged windows when frame is not selected d: Set default behaviour to hide or not unmanaged windows when frame is not selected +w: Show unmanaged windows by default. This is overriden by functions above +i: Hide unmanaged windows by default. This is overriden by functions above Frame-Miscellaneous-Menu s: Show all frames info windows @@ -896,118 +898,118 @@ p: Prompt for an other window manager Configuration-Menu -a: < Frame colors group > -b: < Miscellaneous group > -c: < Query string group > +a: < Hook group > +b: < Main mode group > +c: < Frame colors group > d: < Identify key group > -e: < Main mode group > -f: < Info mode group > -g: < Menu group > -h: < Corner group > -i: < Hook group > -j: < Placement group > -k: < Circulate mode group > -l: < Second mode group > +e: < Second mode group > +f: < Corner group > +g: < Query string group > +h: < Circulate mode group > +i: < Placement group > +j: < Miscellaneous group > +k: < Info mode group > +l: < Menu group > F2: Save all configuration variables in clfswmrc +Conf-Hook-Group +a: Configure INIT-HOOK +b: Configure DEFAULT-NW-HOOK +c: Configure LOOP-HOOK +d: Configure BINDING-HOOK + +Conf-Main-Mode-Group +a: Configure COLOR-UNSELECTED +b: Configure COLOR-SELECTED +c: Configure COLOR-MAYBE-SELECTED + Conf-Frame-Colors-Group a: Configure FRAME-FOREGROUND-ROOT b: Configure FRAME-FOREGROUND -c: Configure FRAME-BACKGROUND -d: Configure FRAME-FOREGROUND-HIDDEN - -Conf-Miscellaneous-Group -a: Configure NEVER-MANAGED-WINDOW-LIST -b: Configure CREATE-FRAME-ON-ROOT -c: Configure DEFAULT-FRAME-DATA -d: Configure DEFAULT-FONT-STRING -e: Configure HIDE-UNMANAGED-WINDOW -f: Configure DEFAULT-MODIFIERS -g: Configure DEFAULT-FOCUS-POLICY -h: Configure LOOP-TIMEOUT -i: Configure HAVE-TO-COMPRESS-NOTIFY -j: Configure DEFAULT-WINDOW-WIDTH -k: Configure DEFAULT-MANAGED-TYPE -l: Configure DEFAULT-WINDOW-HEIGHT - -Conf-Query-String-Group -a: Configure QUERY-BACKGROUND -b: Configure QUERY-BORDER -c: Configure QUERY-FONT-STRING -d: Configure QUERY-FOREGROUND +c: Configure FRAME-FOREGROUND-HIDDEN +d: Configure FRAME-BACKGROUND Conf-Identify-Key-Group a: Configure IDENTIFY-FOREGROUND -b: Configure IDENTIFY-BORDER -c: Configure IDENTIFY-BACKGROUND -d: Configure IDENTIFY-FONT-STRING - -Conf-Main-Mode-Group -a: Configure COLOR-MAYBE-SELECTED -b: Configure COLOR-SELECTED -c: Configure COLOR-UNSELECTED +b: Configure IDENTIFY-FONT-STRING +c: Configure IDENTIFY-BORDER +d: Configure IDENTIFY-BACKGROUND -Conf-Info-Mode-Group -a: Configure INFO-BACKGROUND -b: Configure INFO-COLOR-FIRST -c: Configure INFO-FOREGROUND -d: Configure INFO-BORDER -e: Configure INFO-SELECTED-BACKGROUND -f: Configure INFO-FONT-STRING -g: Configure INFO-COLOR-UNDERLINE -h: Configure INFO-COLOR-TITLE -i: Configure INFO-CLICK-TO-SELECT -j: Configure INFO-LINE-CURSOR -k: Configure INFO-COLOR-SECOND - -Conf-Menu-Group -a: Configure MENU-COLOR-SUBMENU -b: Configure MENU-COLOR-COMMENT -c: Configure MENU-COLOR-MENU-KEY -d: Configure MENU-COLOR-KEY -e: Configure XDG-SECTION-LIST +Conf-Second-Mode-Group +a: Configure SM-BACKGROUND-COLOR +b: Configure SM-HEIGHT +c: Configure SM-WIDTH +d: Configure SM-FOREGROUND-COLOR +e: Configure SM-BORDER-COLOR +f: Configure SM-FONT-STRING Conf-Corner-Group -a: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON -b: Configure CORNER-MAIN-MODE-LEFT-BUTTON -c: Configure CLFSWM-TERMINAL-CMD -d: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON -e: Configure VIRTUAL-KEYBOARD-CMD -f: Configure CORNER-SECOND-MODE-LEFT-BUTTON -g: Configure CORNER-SIZE -h: Configure CORNER-MAIN-MODE-RIGHT-BUTTON -i: Configure CLFSWM-TERMINAL-NAME -j: Configure CORNER-SECOND-MODE-RIGHT-BUTTON +a: Configure CORNER-MAIN-MODE-LEFT-BUTTON +b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON +c: Configure CORNER-SECOND-MODE-LEFT-BUTTON +d: Configure CORNER-SECOND-MODE-RIGHT-BUTTON +e: Configure CORNER-SIZE +f: Configure CLFSWM-TERMINAL-CMD +g: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +h: Configure VIRTUAL-KEYBOARD-CMD +i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON +j: Configure CLFSWM-TERMINAL-NAME -Conf-Hook-Group -a: Configure INIT-HOOK -b: Configure LOOP-HOOK -c: Configure BINDING-HOOK -d: Configure DEFAULT-NW-HOOK - -Conf-Placement-Group -a: Configure BANISH-POINTER-PLACEMENT -b: Configure SECOND-MODE-PLACEMENT -c: Configure QUERY-MODE-PLACEMENT -d: Configure INFO-MODE-PLACEMENT -e: Configure CIRCULATE-MODE-PLACEMENT +Conf-Query-String-Group +a: Configure QUERY-FONT-STRING +b: Configure QUERY-BACKGROUND +c: Configure QUERY-BORDER +d: Configure QUERY-FOREGROUND Conf-Circulate-Mode-Group a: Configure CIRCULATE-WIDTH -b: Configure CIRCULATE-HEIGHT -c: Configure CIRCULATE-FONT-STRING -d: Configure CIRCULATE-FOREGROUND -e: Configure CIRCULATE-TEXT-LIMITE +b: Configure CIRCULATE-TEXT-LIMITE +c: Configure CIRCULATE-BORDER +d: Configure CIRCULATE-HEIGHT +e: Configure CIRCULATE-FONT-STRING f: Configure CIRCULATE-BACKGROUND -g: Configure CIRCULATE-BORDER +g: Configure CIRCULATE-FOREGROUND -Conf-Second-Mode-Group -a: Configure SM-FONT-STRING -b: Configure SM-BACKGROUND-COLOR -c: Configure SM-FOREGROUND-COLOR -d: Configure SM-HEIGHT -e: Configure SM-BORDER-COLOR -f: Configure SM-WIDTH +Conf-Placement-Group +a: Configure CIRCULATE-MODE-PLACEMENT +b: Configure QUERY-MODE-PLACEMENT +c: Configure BANISH-POINTER-PLACEMENT +d: Configure INFO-MODE-PLACEMENT +e: Configure SECOND-MODE-PLACEMENT + +Conf-Miscellaneous-Group +a: Configure HAVE-TO-COMPRESS-NOTIFY +b: Configure HIDE-UNMANAGED-WINDOW +c: Configure DEFAULT-WINDOW-WIDTH +d: Configure CREATE-FRAME-ON-ROOT +e: Configure DEFAULT-FRAME-DATA +f: Configure DEFAULT-MODIFIERS +g: Configure NEVER-MANAGED-WINDOW-LIST +h: Configure DEFAULT-MANAGED-TYPE +i: Configure DEFAULT-WINDOW-HEIGHT +j: Configure DEFAULT-FONT-STRING +k: Configure DEFAULT-FOCUS-POLICY +l: Configure LOOP-TIMEOUT + +Conf-Info-Mode-Group +a: Configure INFO-FOREGROUND +b: Configure INFO-COLOR-UNDERLINE +c: Configure INFO-SELECTED-BACKGROUND +d: Configure INFO-LINE-CURSOR +e: Configure INFO-CLICK-TO-SELECT +f: Configure INFO-BACKGROUND +g: Configure INFO-COLOR-FIRST +h: Configure INFO-BORDER +i: Configure INFO-FONT-STRING +j: Configure INFO-COLOR-TITLE +k: Configure INFO-COLOR-SECOND + +Conf-Menu-Group +a: Configure MENU-COLOR-COMMENT +b: Configure MENU-COLOR-KEY +c: Configure XDG-SECTION-LIST +d: Configure MENU-COLOR-MENU-KEY +e: Configure MENU-COLOR-SUBMENU Clfswm-Menu r: Reset clfswm From pbrochard at common-lisp.net Sat Sep 11 21:51:50 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 11 Sep 2010 17:51:50 -0400 Subject: [clfswm-cvs] r323 - clfswm Message-ID: Author: pbrochard Date: Sat Sep 11 17:51:49 2010 New Revision: 323 Log: TODO update Modified: clfswm/TODO Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Sep 11 17:51:49 2010 @@ -7,8 +7,7 @@ =============== Should handle these soon. -- Add a data slot to tell if a frame must hide or not its floating windows when its not selected. - +Nothing here yet :) MAYBE ===== From pbrochard at common-lisp.net Sun Sep 12 21:15:31 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 12 Sep 2010 17:15:31 -0400 Subject: [clfswm-cvs] r324 - in clfswm: . contrib src Message-ID: Author: pbrochard Date: Sun Sep 12 17:15:31 2010 New Revision: 324 Log: contrib/clfswm: Add support to cmucl, ccl and ecl. Modified: clfswm/ChangeLog clfswm/contrib/clfswm clfswm/src/bindings-second-mode.lisp clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Sep 12 17:15:31 2010 @@ -1,3 +1,7 @@ +2010-09-12 Philippe Brochard + + * contrib/clfswm: Add support to cmucl, ccl and ecl. + 2010-09-11 Philippe Brochard * src/clfswm-util.lisp (set-hide-unmanaged-window) Modified: clfswm/contrib/clfswm ============================================================================== --- clfswm/contrib/clfswm (original) +++ clfswm/contrib/clfswm Sun Sep 12 17:15:31 2010 @@ -31,6 +31,15 @@ # delete the image and restart your X session. # -------------------------------------------------------------------------- + +no_start=no +lisp=clisp +lisp_opt='' +dump_path="$XDG_CACHE_HOME/clfswm/" +asdf_path="$(pwd)/contrib" +clfswm_asd_path="$(pwd)" + + usage() { echo "$0 [options] @@ -38,8 +47,9 @@ n,no-start don't start CLFSWM after image dump f,force force image dump rebuild same as -f,--force -l,with-lisp= use as the common lisp implementation -d,dump-path= path to the dump directory +l,with-lisp use as the common lisp implementation [$lisp] +o,lisp-opt use as lisp option +d,dump-path path to the dump directory [\$XDG_CACHE_HOME=$XDG_CACHE_HOME] with-clfswm path to clfswm.asd file with-asdf path to the asdf.lisp file" @@ -53,21 +63,46 @@ build_clisp () { - clisp -m 8MB -E ISO-8859-1 -q -K full -i $asdf_path/asdf.lisp -x "(asdf:oos 'asdf:load-op :clfswm)\ - (EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION 'clfswm:main :EXECUTABLE t :norc t)" + clisp $lisp_opt -m 8MB -E ISO-8859-1 -q -i $asdf_path/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") + (asdf:oos 'asdf:load-op :clfswm) \ + (EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION (lambda () (clfswm:main) (quit)) :EXECUTABLE t :norc t)" } build_sbcl() { - sbcl --disable-debugger --eval "(mapc 'require '(asdf clfswm))" \ + sbcl $lisp_opt --disable-debugger --eval "(require :asdf)" \ + --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ + --eval "(require :clfswm)" \ --eval "(save-lisp-and-die \"$dump_image\" :toplevel 'clfswm:main)" } -no_start=no -lisp=clisp -dump_path=$HOME/var/cache -asdf_path=$HOME/usr/src/SVNed/clfswm -clfswm_asd_path=$HOME/usr/share/common-lisp/systems +build_cmucl() +{ + cmucl $lisp_opt -eval "(load \"$asdf_path/asdf.lisp\")" \ + -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ + -eval "(require :clx)" \ + -eval "(asdf:oos 'asdf:load-op :clfswm)" \ + -eval "(save-lisp \"$dump_image\" :init-function (lambda () (clfswm:main) (quit)))" +} + +build_ccl() +{ + ccl $lisp_opt --eval "(require :asdf)" \ + --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ + --eval "(asdf:oos 'asdf:load-op :clfswm)" \ + --eval "(save-application \"$dump_image\" :toplevel-function (lambda () (clfswm:main) (quit)))" +} + +build_ecl() +{ + ecl $lisp_opt -eval "(require :asdf)" \ + -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ + -eval "(asdf:make-build :clfswm :type :program :monolithic t :move-here \".\" :prologue-code '(progn (require :asdf) (require :clx)))" \ + -eval "(ext:quit 0)" + mv ./clfswm-mono $dump_image + echo $dump_image +} + while test $# != 0 do @@ -90,10 +125,13 @@ case "$1" in '') usage;; - clisp|sbcl) + clisp|sbcl|cmucl|ccl|ecl) lisp="$1" ;; esac ;; + -o|--lisp-opt) + shift + lisp_opt="$1" ;; --) shift break ;; @@ -121,15 +159,24 @@ test -e $clfswm_asd_path/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path" test -e $asdf_path/asdf.lisp || die "can't find asdf.lisp in $asdf_path" + mkdir -p "$dump_path" + mkdir -p "$dump_path/contrib" eval build_$lisp + rm -rf "$dump_path/contrib" + cp -R "$clfswm_asd_path/contrib/" "$dump_path/" + rm -rf $(find "$dump_path/" -name "*svn") fi # Run the resulting image if test no = "$no_start" then + cd $dump_path case $lisp in clisp ) $dump_image ;; sbcl ) exec sbcl --core "$dump_image" ;; + cmucl ) exec cmucl -core "$dump_image" ;; + ccl ) exec ccl -I "$dump_image" ;; + ecl ) $dump_image -eval "(progn (clfswm:main) (ext:quit 0))" ;; *) echo "..." ;; esac else Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Sun Sep 12 17:15:31 2010 @@ -129,8 +129,8 @@ (define-second-key ("v" :control :shift) 'paste-selection-no-clear) (define-second-key ("Delete" :control) 'remove-current-child) (define-second-key ("Delete") 'delete-current-child) - (define-shell (#\c) b-start-xterm "start an xterm" "exec xterm") - (define-shell (#\e) b-start-emacs "start emacs" "exec emacs") + (define-shell (#\c) b-start-xterm "start an xterm" "cd $HOME && exec xterm") + (define-shell (#\e) b-start-emacs "start emacs" "cd $HOME && exec emacs") (define-shell (#\e :control) b-start-emacsremote "start an emacs for another user" "exec xterm -e emacsremote") Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Sep 12 17:15:31 2010 @@ -355,7 +355,7 @@ (multiple-value-bind (program return) (query-string "Run:") (when (and (equal return :return) program (not (equal program ""))) - (setf *second-mode-program* program) + (setf *second-mode-program* (concatenate 'string "cd $HOME && " program)) (leave-second-mode)))) From pbrochard at common-lisp.net Thu Sep 16 13:15:05 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 16 Sep 2010 09:15:05 -0400 Subject: [clfswm-cvs] r325 - in clfswm: . contrib Message-ID: Author: pbrochard Date: Thu Sep 16 09:15:04 2010 New Revision: 325 Log: contrib/clfswm: Move clfswm sources to if there is no write permission on . So anybody can start clfswm even if there is no write permission on the source directory. Modified: clfswm/ChangeLog clfswm/TODO clfswm/contrib/clfswm Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Sep 16 09:15:04 2010 @@ -1,3 +1,9 @@ +2010-09-16 Philippe Brochard + + * contrib/clfswm: Move clfswm sources to $tmp_dir if there is no + write permission on $clfswm_asd_path. So anybody can start clfswm + even if there is no write permission on the source directory. + 2010-09-12 Philippe Brochard * contrib/clfswm: Add support to cmucl, ccl and ecl. Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Thu Sep 16 09:15:04 2010 @@ -9,6 +9,12 @@ Nothing here yet :) +- contrib/clfswm: Test if source directory is writable to compile clfswm. +if not copy clfswm source in $XDG_CACHE_HOME/clfswm/sources and set +$clfswm_asd_path to it then compile from here. + +- configure: copy contrib/clfswm in . and set default values in it. + MAYBE ===== Modified: clfswm/contrib/clfswm ============================================================================== --- clfswm/contrib/clfswm (original) +++ clfswm/contrib/clfswm Thu Sep 16 09:15:04 2010 @@ -39,6 +39,8 @@ asdf_path="$(pwd)/contrib" clfswm_asd_path="$(pwd)" +tmp_dir=/tmp + usage() { @@ -48,10 +50,10 @@ f,force force image dump rebuild same as -f,--force l,with-lisp use as the common lisp implementation [$lisp] -o,lisp-opt use as lisp option +o,lisp-opt use as lisp option [$lisp_opt] d,dump-path path to the dump directory [\$XDG_CACHE_HOME=$XDG_CACHE_HOME] -with-clfswm path to clfswm.asd file -with-asdf path to the asdf.lisp file" +with-clfswm path to clfswm.asd file [$clfswm_asd_path] +with-asdf path to the asdf.lisp file [$asdf_path]" exit 0 } @@ -159,12 +161,24 @@ test -e $clfswm_asd_path/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path" test -e $asdf_path/asdf.lisp || die "can't find asdf.lisp in $asdf_path" + # Move clfswm sources to $tmp_dir if there is no write permission on $clfswm_asd_path + if test ! -w $clfswm_asd_path ; then + rm -rf $tmp_dir/clfswm-tmp + mkdir $tmp_dir/clfswm-tmp + cp -R $clfswm_asd_path/* $tmp_dir/clfswm-tmp + clfswm_asd_path=$tmp_dir/clfswm-tmp + asdf_path=$tmp_dir/clfswm-tmp/contrib + echo "* Note: No write access in sources, copying in $clfswm_asd_path" + fi + mkdir -p "$dump_path" mkdir -p "$dump_path/contrib" eval build_$lisp rm -rf "$dump_path/contrib" cp -R "$clfswm_asd_path/contrib/" "$dump_path/" rm -rf $(find "$dump_path/" -name "*svn") + + rm -rf $tmp_dir/clfswm-tmp fi # Run the resulting image @@ -182,3 +196,4 @@ else echo "As requested, we have just dumped the image." fi + From pbrochard at common-lisp.net Fri Sep 24 21:47:28 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 24 Sep 2010 17:47:28 -0400 Subject: [clfswm-cvs] r326 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Sep 24 17:47:27 2010 New Revision: 326 Log: src/clfswm-util.lisp (speed-mouse-reset, speed-mouse-left, speed-mouse-right, speed-mouse-up, speed-mouse-down, speed-mouse-undo, speed-mouse-first-history): New functions to quickly move the mouse. Implemented for the second mode. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/bindings-second-mode.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/clfswm-util.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Fri Sep 24 17:47:27 2010 @@ -1,3 +1,10 @@ +2010-09-24 Philippe Brochard + + * src/clfswm-util.lisp (speed-mouse-reset, speed-mouse-left) + (speed-mouse-right, speed-mouse-up, speed-mouse-down) + (speed-mouse-undo, speed-mouse-first-history): New functions to + quickly move the mouse. Implemented for the second mode. + 2010-09-16 Philippe Brochard * contrib/clfswm: Move clfswm sources to $tmp_dir if there is no Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Fri Sep 24 17:47:27 2010 @@ -7,12 +7,6 @@ =============== Should handle these soon. -Nothing here yet :) - -- contrib/clfswm: Test if source directory is writable to compile clfswm. -if not copy clfswm source in $XDG_CACHE_HOME/clfswm/sources and set -$clfswm_asd_path to it then compile from here. - - configure: copy contrib/clfswm in . and set default values in it. MAYBE Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Fri Sep 24 17:47:27 2010 @@ -104,6 +104,15 @@ (define-second-key ("Left" :mod-1) 'select-previous-brother) (define-second-key ("Down" :mod-1) 'select-previous-level) (define-second-key ("Up" :mod-1) 'select-next-level) + + (define-second-key ("Right") 'speed-mouse-right) + (define-second-key ("Left") 'speed-mouse-left) + (define-second-key ("Down") 'speed-mouse-down) + (define-second-key ("Up") 'speed-mouse-up) + (define-second-key ("Left" :control) 'speed-mouse-undo) + (define-second-key ("Up" :control) 'speed-mouse-first-history) + (define-second-key ("Down" :control) 'speed-mouse-reset) + (define-second-key ("Tab" :mod-1) 'select-next-child) (define-second-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-second-key (#\Tab :shift) 'switch-to-last-child) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Fri Sep 24 17:47:27 2010 @@ -119,7 +119,8 @@ (no-focus) (ungrab-main-keys) (xgrab-keyboard *root*) - (xgrab-pointer *root* 66 67)) + (xgrab-pointer *root* 66 67) + (speed-mouse-reset)) ;; PHIL here (defun sm-loop-function () (raise-window *sm-window*)) @@ -150,7 +151,7 @@ (defun leave-second-mode () "Leave second mode" (cond (*in-second-mode* - (banish-pointer) + ;; (banish-pointer) ;; PHIL here (setf *in-second-mode* nil) (throw 'exit-second-loop nil)) (t (setf *in-second-mode* nil) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Fri Sep 24 17:47:27 2010 @@ -1375,3 +1375,60 @@ "Show unmanaged windows by default. This is overriden by functions above" (setf *hide-unmanaged-window* nil) (leave-second-mode)) + + +;;; Speed mouse movement +;;(let (minx miny maxx maxy history lx ly) +;; (labels ((middle (x1 x2) +;; (round (/ (+ x1 x2) 2))) +;; (reset-if-moved (x y) +;; (when (or (/= x (or lx x)) (/= y (or ly y))) +;; (speed-mouse-reset))) +;; (add-in-history (x y) +;; (push (list x y) history))) + (defun speed-mouse-reset () + (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil)) + (defun speed-mouse-left () + (with-x-pointer + (reset-if-moved x y) + (setf maxx x) + (add-in-history x y) + (setf lx (middle (or minx 0) maxx)) + (xlib:warp-pointer *root* lx y))) + (defun speed-mouse-right () + (with-x-pointer + (reset-if-moved x y) + (setf minx x) + (add-in-history x y) + (setf lx (middle minx (or maxx 1280))) + (xlib:warp-pointer *root* lx y))) + (defun speed-mouse-up () + (with-x-pointer + (reset-if-moved x y) + (setf maxy y) + (add-in-history x y) + (setf ly (middle (or miny 0) maxy)) + (xlib:warp-pointer *root* x ly))) + (defun speed-mouse-down () + (with-x-pointer + (reset-if-moved x y) + (setf miny y) + (add-in-history x y) + (setf ly (middle miny (or maxy 800))) + (xlib:warp-pointer *root* x ly))) + (defun speed-mouse-undo () + (when history + (let ((h (pop history))) + (when h + (destructuring-bind (bx by) h + (setf lx bx ly by + minx nil maxx nil + miny nil maxy nil) + (xlib:warp-pointer *root* lx ly)))))) + (defun speed-mouse-first-history () + (when history + (let ((h (first (last history)))) + (when h + (setf lx (first h) + ly (second h)) + (xlib:warp-pointer *root* lx ly))))))) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Fri Sep 24 17:47:27 2010 @@ -74,7 +74,11 @@ - +(defmacro with-x-pointer (&body body) + "Bind (x y) to mouse pointer positions" + `(multiple-value-bind (x y) + (xlib:query-pointer *root*) + , at body)) From pbrochard at common-lisp.net Fri Sep 24 21:56:27 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 24 Sep 2010 17:56:27 -0400 Subject: [clfswm-cvs] r327 - clfswm/src Message-ID: Author: pbrochard Date: Fri Sep 24 17:56:27 2010 New Revision: 327 Log: src/clfswm-util.lisp (speed-mouse-reset, speed-mouse-left, speed-mouse-right, speed-mouse-up, speed-mouse-down, speed-mouse-undo, speed-mouse-first-history): New functions to quickly move the mouse. Implemented for the second mode. Modified: clfswm/src/clfswm-util.lisp Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Fri Sep 24 17:56:27 2010 @@ -1378,14 +1378,14 @@ ;;; Speed mouse movement -;;(let (minx miny maxx maxy history lx ly) -;; (labels ((middle (x1 x2) -;; (round (/ (+ x1 x2) 2))) -;; (reset-if-moved (x y) -;; (when (or (/= x (or lx x)) (/= y (or ly y))) -;; (speed-mouse-reset))) -;; (add-in-history (x y) -;; (push (list x y) history))) +(let (minx miny maxx maxy history lx ly) + (labels ((middle (x1 x2) + (round (/ (+ x1 x2) 2))) + (reset-if-moved (x y) + (when (or (/= x (or lx x)) (/= y (or ly y))) + (speed-mouse-reset))) + (add-in-history (x y) + (push (list x y) history))) (defun speed-mouse-reset () (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil)) (defun speed-mouse-left () From pbrochard at common-lisp.net Sat Sep 25 12:18:55 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 25 Sep 2010 08:18:55 -0400 Subject: [clfswm-cvs] r328 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 25 08:18:55 2010 New Revision: 328 Log: src/clfswm-util.lisp (speed-mouse-right, speed-mouse-down): Use screen size instead of hardcoded test coordinates. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 25 08:18:55 2010 @@ -1,3 +1,8 @@ +2010-09-25 Philippe Brochard + + * src/clfswm-util.lisp (speed-mouse-right, speed-mouse-down): Use + screen size instead of hardcoded test coordinates. + 2010-09-24 Philippe Brochard * src/clfswm-util.lisp (speed-mouse-reset, speed-mouse-left) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 25 08:18:55 2010 @@ -1400,7 +1400,7 @@ (reset-if-moved x y) (setf minx x) (add-in-history x y) - (setf lx (middle minx (or maxx 1280))) + (setf lx (middle minx (or maxx (xlib:screen-width *screen*)))) (xlib:warp-pointer *root* lx y))) (defun speed-mouse-up () (with-x-pointer @@ -1414,7 +1414,7 @@ (reset-if-moved x y) (setf miny y) (add-in-history x y) - (setf ly (middle miny (or maxy 800))) + (setf ly (middle miny (or maxy (xlib:screen-height *screen*)))) (xlib:warp-pointer *root* x ly))) (defun speed-mouse-undo () (when history From pbrochard at common-lisp.net Sat Sep 25 13:07:04 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 25 Sep 2010 09:07:04 -0400 Subject: [clfswm-cvs] r329 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 25 09:07:04 2010 New Revision: 329 Log: src/clfswm-expose-mode.lisp: Move and rename present*-windows in a separate clfswm-expose-mode.lisp file. Added: clfswm/src/clfswm-expose-mode.lisp Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-corner.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-util.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 25 09:07:04 2010 @@ -1,5 +1,8 @@ 2010-09-25 Philippe Brochard + * src/clfswm-expose-mode.lisp: Move and rename present*-windows in + a separate clfswm-expose-mode.lisp file. + * src/clfswm-util.lisp (speed-mouse-right, speed-mouse-down): Use screen size instead of hardcoded test coordinates. Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sat Sep 25 09:07:04 2010 @@ -46,8 +46,10 @@ (:file "clfswm-second-mode" :depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode" "clfswm-placement")) + (:file "clfswm-expose-mode" + :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools")) (:file "clfswm-corner" - :depends-on ("package" "config" "clfswm-internal")) + :depends-on ("package" "config" "clfswm-internal" "clfswm-expose-mode" "xlib-util")) (:file "clfswm-info" :depends-on ("package" "version" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal" "clfswm-autodoc" "clfswm-corner" Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Sat Sep 25 09:07:04 2010 @@ -147,7 +147,9 @@ (define-second-key ("F10" :mod-1) 'fast-layout-switch) (define-second-key ("F10" :shift) 'show-all-frames-info-key) (define-second-key ("F10" :shift :mod-1) 'show-all-frames-info) - (define-second-key ("F10" :control) 'toggle-show-root-frame) + (define-second-key ("F10" :shift :control) 'toggle-show-root-frame) + (define-second-key ("F10") 'expose-windows) + (define-second-key ("F10" :control) 'expose-all-windows) ;; Bind or jump functions (define-second-key ("1" :mod-1) 'bind-or-jump 1) (define-second-key ("2" :mod-1) 'bind-or-jump 2) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sat Sep 25 09:07:04 2010 @@ -61,7 +61,9 @@ (define-main-key ("F10" :mod-1) 'fast-layout-switch) (define-main-key ("F10" :shift) 'show-all-frames-info-key) (define-main-key ("F10" :shift :mod-1) 'show-all-frames-info) - (define-main-key ("F10" :control) 'toggle-show-root-frame) + (define-main-key ("F10" :shift :control) 'toggle-show-root-frame) + (define-main-key ("F10") 'expose-windows) + (define-main-key ("F10" :control) 'expose-all-windows) (define-main-key (#\b :mod-1) 'banish-pointer) ;; Escape (define-main-key ("Escape" :control) 'ask-close/kill-current-window) Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Sat Sep 25 09:07:04 2010 @@ -73,44 +73,6 @@ ;;;***************************************;;; ;;; CONFIG - Corner actions definitions: ;;; ;;;***************************************;;; - -(defmacro present-windows-generic ((first-restore-frame) &body body) - `(progn - (with-all-frames (,first-restore-frame frame) - (setf (frame-data-slot frame :old-layout) (frame-layout frame) - (frame-layout frame) #'tile-space-layout)) - (show-all-children *current-root*) - (wait-no-key-or-button-press) - (wait-a-key-or-button-press ) - (wait-no-key-or-button-press) - (multiple-value-bind (x y) (xlib:query-pointer *root*) - (let* ((child (find-child-under-mouse x y)) - (parent (find-parent-frame child *root-frame*))) - (when (and child parent) - , at body - (focus-all-children child parent)))) - (with-all-frames (,first-restore-frame frame) - (setf (frame-layout frame) (frame-data-slot frame :old-layout) - (frame-data-slot frame :old-layout) nil)) - (show-all-children *current-root*))) - -(defun present-windows () - "Present all windows in the current frame (An expose like)" - (stop-button-event) - (present-windows-generic (*current-root*)) - t) - -(defun present-all-windows () - "Present all windows in all frames (An expose like)" - (stop-button-event) - (switch-to-root-frame :show-later t) - (present-windows-generic (*root-frame*) - (hide-all-children *root-frame*) - (setf *current-root* parent)) - t) - - - (defun find-window-in-query-tree (target-win) (dolist (win (xlib:query-tree *root*)) (when (child-equal-p win target-win) Added: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- (empty file) +++ clfswm/src/clfswm-expose-mode.lisp Sat Sep 25 09:07:04 2010 @@ -0,0 +1,60 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: Expose functions - An expose like. +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2010 Philippe Brochard +;;; +;;; 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; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; 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. +;;; +;;; -------------------------------------------------------------------------- + +(in-package :clfswm) + +(defun expose-windows-generic (first-restore-frame func) + (with-all-frames (first-restore-frame frame) + (setf (frame-data-slot frame :old-layout) (frame-layout frame) + (frame-layout frame) #'tile-space-layout)) + (show-all-children *current-root*) + (wait-no-key-or-button-press) + (wait-a-key-or-button-press ) + (wait-no-key-or-button-press) + (multiple-value-bind (x y) (xlib:query-pointer *root*) + (let* ((child (find-child-under-mouse x y)) + (parent (find-parent-frame child *root-frame*))) + (when (and child parent) + (pfuncall func parent) + (focus-all-children child parent)))) + (with-all-frames (first-restore-frame frame) + (setf (frame-layout frame) (frame-data-slot frame :old-layout) + (frame-data-slot frame :old-layout) nil)) + (show-all-children *current-root*) + t) + +(defun expose-windows () + "Present all windows in the current frame (An expose like)" + (stop-button-event) + (expose-windows-generic *current-root* nil)) + +(defun expose-all-windows () + "Present all windows in all frames (An expose like)" + (stop-button-event) + (switch-to-root-frame :show-later t) + (expose-windows-generic *root-frame* + (lambda (parent) + (hide-all-children *root-frame*) + (setf *current-root* parent)))) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Sat Sep 25 09:07:04 2010 @@ -65,7 +65,8 @@ (define-init-hash-table-key *circulate-keys* "Circulate mode keys") (define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys") - +(define-init-hash-table-key *expose-keys* "Expose windows mode keys") +(define-init-hash-table-key *expose-mouse* "Mouse buttons actions in expose windows mode") (defun unalias-modifiers (list) (dolist (mod *modifier-alias*) @@ -122,9 +123,12 @@ (define-define-key "circulate" *circulate-keys*) (define-define-key "circulate-release" *circulate-keys-release*) +(define-define-key "expose" *expose-keys*) + (define-define-mouse "main-mouse" *main-mouse*) (define-define-mouse "second-mouse" *second-mouse*) (define-define-mouse "info-mouse" *info-mouse*) +(define-define-mouse "expose" *expose-mouse*) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 25 09:07:04 2010 @@ -1377,7 +1377,7 @@ (leave-second-mode)) -;;; Speed mouse movement +;;; Speed mouse movement. (let (minx miny maxx maxy history lx ly) (labels ((middle (x1 x2) (round (/ (+ x1 x2) 2))) Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sat Sep 25 09:07:04 2010 @@ -161,6 +161,8 @@ (defparameter *query-keys* nil) (defparameter *circulate-keys* nil) (defparameter *circulate-keys-release* nil) +(defparameter *expose-keys* nil) +(defparameter *expose-mouse* nil) (defparameter *other-window-manager* nil) From pbrochard at common-lisp.net Sat Sep 25 19:40:58 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 25 Sep 2010 15:40:58 -0400 Subject: [clfswm-cvs] r330 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 25 15:40:58 2010 New Revision: 330 Log: src/xlib-util.lisp (with-handle-event-symbol): Use a filled list with handle-event-fun symbols instead of inspecting clfswm internals symbols on each mode change. Modified: clfswm/ChangeLog clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-expose-mode.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 25 15:40:58 2010 @@ -1,5 +1,9 @@ 2010-09-25 Philippe Brochard + * src/xlib-util.lisp (with-handle-event-symbol): Use a filled list + with handle-event-fun symbols instead of inspecting clfswm + internals symbols on each mode change. + * src/clfswm-expose-mode.lisp: Move and rename present*-windows in a separate clfswm-expose-mode.lisp file. Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Sat Sep 25 15:40:58 2010 @@ -148,8 +148,8 @@ (define-second-key ("F10" :shift) 'show-all-frames-info-key) (define-second-key ("F10" :shift :mod-1) 'show-all-frames-info) (define-second-key ("F10" :shift :control) 'toggle-show-root-frame) - (define-second-key ("F10") 'expose-windows) - (define-second-key ("F10" :control) 'expose-all-windows) + (define-second-key ("F10") 'expose-windows-mode) + (define-second-key ("F10" :control) 'expose-all-windows-mode) ;; Bind or jump functions (define-second-key ("1" :mod-1) 'bind-or-jump 1) (define-second-key ("2" :mod-1) 'bind-or-jump 2) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sat Sep 25 15:40:58 2010 @@ -62,8 +62,8 @@ (define-main-key ("F10" :shift) 'show-all-frames-info-key) (define-main-key ("F10" :shift :mod-1) 'show-all-frames-info) (define-main-key ("F10" :shift :control) 'toggle-show-root-frame) - (define-main-key ("F10") 'expose-windows) - (define-main-key ("F10" :control) 'expose-all-windows) + (define-main-key ("F10") 'expose-windows-mode) + (define-main-key ("F10" :control) 'expose-all-windows-mode) (define-main-key (#\b :mod-1) 'banish-pointer) ;; Escape (define-main-key ("Escape" :control) 'ask-close/kill-current-window) Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Sat Sep 25 15:40:58 2010 @@ -45,12 +45,12 @@ (show-all-children *current-root*) t) -(defun expose-windows () +(defun expose-windows-mode () "Present all windows in the current frame (An expose like)" (stop-button-event) (expose-windows-generic *current-root* nil)) -(defun expose-all-windows () +(defun expose-all-windows-mode () "Present all windows in all frames (An expose like)" (stop-button-event) (switch-to-root-frame :show-later t) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Sep 25 15:40:58 2010 @@ -169,6 +169,7 @@ (defun init-display () + (fill-handle-event-fun-symbols) (assoc-keyword-handle-event 'main-mode) (setf *screen* (first (xlib:display-roots *display*)) *root* (xlib:screen-root *screen*) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Sep 25 15:40:58 2010 @@ -101,11 +101,19 @@ (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword) (subseq name (length "handle-event-fun-") (1- pos-mod)))))))) +(defparameter *handle-event-fun-symbols* nil) + +(defun fill-handle-event-fun-symbols () + (with-all-internal-symbols (symbol :clfswm) + (let ((pos (symbol-search "handle-event-fun-" symbol))) + (when (and pos (zerop pos)) + (pushnew symbol *handle-event-fun-symbols*))))) + (defmacro with-handle-event-symbol ((mode) &body body) "Bind symbol to all handle event functions available in mode" `(let ((pattern (format nil "handle-event-fun-~A" ,mode))) - (with-all-internal-symbols (symbol :clfswm) + (dolist (symbol *handle-event-fun-symbols*) (let ((pos (symbol-search pattern symbol))) (when (and pos (zerop pos)) , at body))))) From pbrochard at common-lisp.net Sat Sep 25 19:48:33 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 25 Sep 2010 15:48:33 -0400 Subject: [clfswm-cvs] r331 - clfswm/src Message-ID: Author: pbrochard Date: Sat Sep 25 15:48:33 2010 New Revision: 331 Log: Update corners from present-windows to expose-windows-mode Modified: clfswm/src/config.lisp Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sat Sep 25 15:48:33 2010 @@ -77,7 +77,7 @@ (defparameter *corner-main-mode-left-button* '((:top-left open-menu) (:top-right present-virtual-keyboard) - (:bottom-right present-windows) + (:bottom-right expose-windows-mode) (:bottom-left nil)) "Config(Corner group): Actions on corners in the main mode with the left mouse button") @@ -91,14 +91,14 @@ (defparameter *corner-main-mode-right-button* '((:top-left present-clfswm-terminal) (:top-right ask-close/kill-current-window) - (:bottom-right present-all-windows) + (:bottom-right expose-all-windows-mode) (:bottom-left nil)) "Config(Corner group): Actions on corners in the main mode with the right mouse button") (defparameter *corner-second-mode-left-button* '((:top-left nil) (:top-right nil) - (:bottom-right present-windows) + (:bottom-right expose-windows-mode) (:bottom-left nil)) "Config(Corner group): Actions on corners in the second mode with the left mouse button") @@ -112,7 +112,7 @@ (defparameter *corner-second-mode-right-button* '((:top-left nil) (:top-right nil) - (:bottom-right present-all-windows) + (:bottom-right expose-all-windows-mode) (:bottom-left nil)) "Config(Corner group): Actions on corners in the second mode with the right mouse button") From pbrochard at common-lisp.net Sat Sep 25 21:39:26 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 25 Sep 2010 17:39:26 -0400 Subject: [clfswm-cvs] r332 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Sep 25 17:39:26 2010 New Revision: 332 Log: src/clfswm-expose-mode.lisp (expose-windows-mode, expose-all-windows-mode): Use a generic mode. src/clfswm-internal.lisp (child-position): New function. Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/clfswm-expose-mode.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-util.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Sep 25 17:39:26 2010 @@ -1,5 +1,12 @@ 2010-09-25 Philippe Brochard + * src/clfswm-layout.lisp (*-layout): Use child-position. + + * src/clfswm-internal.lisp (child-position): New function. + + * src/clfswm-expose-mode.lisp (expose-windows-mode) + (expose-all-windows-mode): Use a generic mode. + * src/xlib-util.lisp (with-handle-event-symbol): Use a filled list with handle-event-fun symbols instead of inspecting clfswm internals symbols on each mode change. Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sat Sep 25 17:39:26 2010 @@ -47,7 +47,7 @@ :depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode" "clfswm-placement")) (:file "clfswm-expose-mode" - :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools")) + :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools" "clfswm-keys")) (:file "clfswm-corner" :depends-on ("package" "config" "clfswm-internal" "clfswm-expose-mode" "xlib-util")) (:file "clfswm-info" Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Sat Sep 25 17:39:26 2010 @@ -25,26 +25,94 @@ (in-package :clfswm) -(defun expose-windows-generic (first-restore-frame func) +(defun leave-expose-mode () + "Leave the expose mode" + (throw 'exit-expose-loop nil)) + +(defun valid-expose-mode () + "Valid the expose mode" + (throw 'exit-expose-loop t)) + +(defun mouse-leave-expose-mode (window root-x root-y) + "Leave the expose mode" + (declare (ignore window root-x root-y)) + (throw 'exit-expose-loop nil)) + +(defun mouse-valid-expose-mode (window root-x root-y) + "Valid the expose mode" + (declare (ignore window root-x root-y)) + (throw 'exit-expose-loop t)) + + +(define-handler expose-mode :key-press (code state) + (funcall-key-from-code *expose-keys* code state)) + +(define-handler expose-mode :button-press (code state window root-x root-y) + (funcall-button-from-code *expose-mouse* code state window root-x root-y *fun-press*)) + + + +(add-hook *binding-hook* 'set-default-expose-keys) + +(defun set-default-expose-keys () + (define-expose-key ("Escape") 'leave-expose-mode) + (define-expose-key ("g" :control) 'leave-expose-mode) + (define-expose-key ("Escape" :alt) 'leave-expose-mode) + (define-expose-key ("g" :control :alt) 'leave-expose-mode) + (define-expose-key ("Return") 'valid-expose-mode) + (define-expose-key ("space") 'valid-expose-mode) + (define-expose-key ("Tab") 'valid-expose-mode) + (define-expose-key ("Right") 'speed-mouse-right) + (define-expose-key ("Left") 'speed-mouse-left) + (define-expose-key ("Down") 'speed-mouse-down) + (define-expose-key ("Up") 'speed-mouse-up) + (define-expose-key ("Left" :control) 'speed-mouse-undo) + (define-expose-key ("Up" :control) 'speed-mouse-first-history) + (define-expose-key ("Down" :control) 'speed-mouse-reset) + (define-expose-mouse (1) 'mouse-valid-expose-mode) + (define-expose-mouse (2) 'mouse-leave-expose-mode) + (define-expose-mouse (3) 'mouse-leave-expose-mode)) + + + + +(defun expose-windows-generic (first-restore-frame body) + (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2)) + (truncate (/ (xlib:screen-height *screen*) 2))) (with-all-frames (first-restore-frame frame) (setf (frame-data-slot frame :old-layout) (frame-layout frame) (frame-layout frame) #'tile-space-layout)) (show-all-children *current-root*) - (wait-no-key-or-button-press) - (wait-a-key-or-button-press ) - (wait-no-key-or-button-press) - (multiple-value-bind (x y) (xlib:query-pointer *root*) - (let* ((child (find-child-under-mouse x y)) - (parent (find-parent-frame child *root-frame*))) - (when (and child parent) - (pfuncall func parent) - (focus-all-children child parent)))) - (with-all-frames (first-restore-frame frame) - (setf (frame-layout frame) (frame-data-slot frame :old-layout) - (frame-data-slot frame :old-layout) nil)) - (show-all-children *current-root*) + (dbg 'ici) + (let ((grab-keyboard-p (xgrab-keyboard-p)) + (grab-pointer-p (xgrab-pointer-p))) + (xgrab-pointer *root* 92 93) + (unless grab-keyboard-p + (ungrab-main-keys) + (xgrab-keyboard *root*)) + (dbg 'ici-2) + (when (generic-mode 'expose-mode 'exit-expose-loop + :original-mode '(main-mode)) + (dbg 'ici-3) + (multiple-value-bind (x y) (xlib:query-pointer *root*) + (let* ((child (find-child-under-mouse x y)) + (parent (find-parent-frame child *root-frame*))) + (when (and child parent) + (pfuncall body parent) + (focus-all-children child parent))))) + (with-all-frames (first-restore-frame frame) + (setf (frame-layout frame) (frame-data-slot frame :old-layout) + (frame-data-slot frame :old-layout) nil)) + (show-all-children *current-root*) + (unless grab-keyboard-p + (xungrab-keyboard) + (grab-main-keys)) + (if grab-pointer-p + (xgrab-pointer *root* 66 67) + (xungrab-pointer))) t) + (defun expose-windows-mode () "Present all windows in the current frame (An expose like)" (stop-button-event) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Sep 25 17:39:26 2010 @@ -102,7 +102,7 @@ nil) -(declaim (inline child-member child-remove)) +(declaim (inline child-member child-remove child-position)) (defun child-member (child list) (member child list :test #'child-equal-p)) @@ -110,6 +110,8 @@ (defun child-remove (child list) (remove child list :test #'child-equal-p)) +(defun child-position (child list) + (position child list :test #'child-equal-p)) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Sat Sep 25 17:39:26 2010 @@ -128,7 +128,7 @@ (define-define-mouse "main-mouse" *main-mouse*) (define-define-mouse "second-mouse" *second-mouse*) (define-define-mouse "info-mouse" *info-mouse*) -(define-define-mouse "expose" *expose-mouse*) +(define-define-mouse "expose-mouse" *expose-mouse*) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Sat Sep 25 17:39:26 2010 @@ -208,7 +208,7 @@ (defmethod tile-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (length managed-children)) (n (ceiling (sqrt len))) (dx (/ (frame-rw parent) n)) @@ -231,7 +231,7 @@ (defmethod tile-horizontal-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (length managed-children)) (n (ceiling (sqrt len))) (dx (/ (frame-rw parent) (ceiling (/ len n)))) @@ -254,7 +254,7 @@ (defmethod one-column-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (length managed-children)) (dy (/ (frame-rh parent) len))) (values (round (+ (frame-rx parent) 1)) @@ -274,7 +274,7 @@ (defmethod one-line-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (length managed-children)) (dx (/ (frame-rw parent) len))) (values (round (+ (frame-rx parent) (* pos dx) 1)) @@ -296,13 +296,14 @@ "Tile Space: tile child in its frame leaving spaces between them" (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (length managed-children)) (n (ceiling (sqrt len))) (dx (/ rw n)) (dy (/ rh (ceiling (/ len n)))) (size (or (frame-data-slot parent :tile-space-size) 0.1))) (when (> size 0.5) (setf size 0.45)) + (dbg pos len n dx dy size) ;; PHIL here (values (round (+ rx (truncate (* (mod pos n) dx)) (* dx size) 1)) (round (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size) 1)) (round (- dx (* dx size 2) 2)) @@ -332,7 +333,7 @@ "Tile Left: main child on left and others on right" (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8))) @@ -361,7 +362,7 @@ "Tile Right: main child on right and others on left" (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8))) @@ -393,7 +394,7 @@ "Tile Top: main child on top and others on bottom" (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dx (/ rw len)) (size (or (frame-data-slot parent :tile-size) 0.8))) @@ -423,7 +424,7 @@ "Tile Bottom: main child on bottom and others on top" (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dx (/ rw len)) (size (or (frame-data-slot parent :tile-size) 0.8))) @@ -469,7 +470,7 @@ "Tile Left Space: main child on left and others on right. Leave some space on the left." (with-slots (rx ry rw rh) parent (let* ((managed-children (get-managed-child parent)) - (pos (position child managed-children)) + (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8)) @@ -517,7 +518,7 @@ (no-layout child parent) (if (child-member child main-windows) (let* ((dy (/ rh len)) - (pos (position child main-windows))) + (pos (child-position child main-windows))) (values (1+ (round (+ rx (* rw (- 1 size))))) (1+ (round (+ ry (* dy pos)))) (- (round (* rw size)) 2) @@ -545,7 +546,7 @@ (no-layout child parent) (if (child-member child main-windows) (let* ((dy (/ rh len)) - (pos (position child main-windows))) + (pos (child-position child main-windows))) (values (1+ rx) (1+ (round (+ ry (* dy pos)))) (- (round (* rw size)) 2) @@ -572,7 +573,7 @@ (no-layout child parent) (if (child-member child main-windows) (let* ((dx (/ rw len)) - (pos (position child main-windows))) + (pos (child-position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) (1+ ry) (- (round dx) 2) @@ -599,7 +600,7 @@ (no-layout child parent) (if (child-member child main-windows) (let* ((dx (/ rw len)) - (pos (position child main-windows))) + (pos (child-position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) (1+ (round (+ ry (* rh (- 1 size))))) (- (round dx) 2) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Sep 25 17:39:26 2010 @@ -1387,8 +1387,10 @@ (add-in-history (x y) (push (list x y) history))) (defun speed-mouse-reset () + "Reset speed mouse coordinates" (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil)) (defun speed-mouse-left () + "Speed move mouse to left" (with-x-pointer (reset-if-moved x y) (setf maxx x) @@ -1396,6 +1398,7 @@ (setf lx (middle (or minx 0) maxx)) (xlib:warp-pointer *root* lx y))) (defun speed-mouse-right () + "Speed move mouse to right" (with-x-pointer (reset-if-moved x y) (setf minx x) @@ -1403,6 +1406,7 @@ (setf lx (middle minx (or maxx (xlib:screen-width *screen*)))) (xlib:warp-pointer *root* lx y))) (defun speed-mouse-up () + "Speed move mouse to up" (with-x-pointer (reset-if-moved x y) (setf maxy y) @@ -1410,6 +1414,7 @@ (setf ly (middle (or miny 0) maxy)) (xlib:warp-pointer *root* x ly))) (defun speed-mouse-down () + "Speed move mouse to down" (with-x-pointer (reset-if-moved x y) (setf miny y) @@ -1417,6 +1422,7 @@ (setf ly (middle miny (or maxy (xlib:screen-height *screen*)))) (xlib:warp-pointer *root* x ly))) (defun speed-mouse-undo () + "Undo last speed mouse move" (when history (let ((h (pop history))) (when h @@ -1426,6 +1432,7 @@ miny nil maxy nil) (xlib:warp-pointer *root* lx ly)))))) (defun speed-mouse-first-history () + "Revert to the first speed move mouse" (when history (let ((h (first (last history)))) (when h Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sat Sep 25 17:39:26 2010 @@ -120,8 +120,9 @@ (funcall function))) (defun pfuncall (function &rest args) - (when (or (functionp function) - (and (symbolp function) (fboundp function))) + (when (and function + (or (functionp function) + (and (symbolp function) (fboundp function)))) (apply function args))) From pbrochard at common-lisp.net Sun Sep 26 19:22:31 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 26 Sep 2010 15:22:31 -0400 Subject: [clfswm-cvs] r333 - in clfswm: . doc src Message-ID: Author: pbrochard Date: Sun Sep 26 15:22:30 2010 New Revision: 333 Log: src/clfswm-expose-mode.lisp (expose-mode-display-accel-windows): New functions. Add a window on each child in the expose mode to quickly select them. Modified: clfswm/ChangeLog clfswm/doc/corner.html clfswm/doc/corner.txt clfswm/doc/keys.html clfswm/doc/keys.txt clfswm/doc/menu.html clfswm/doc/menu.txt clfswm/src/clfswm-autodoc.lisp clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-expose-mode.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-layout.lisp clfswm/src/config.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Sep 26 15:22:30 2010 @@ -1,3 +1,12 @@ +2010-09-26 Philippe Brochard + + * src/clfswm-expose-mode.lisp (expose-mode-display-accel-windows): + New functions. Add a window on each child in the expose mode to + quickly select them. + + * src/clfswm-internal.lisp (child-x, child-y, child-width) + (child-height): New methods to get real child coordinates. + 2010-09-25 Philippe Brochard * src/clfswm-layout.lisp (*-layout): Use child-position. Modified: clfswm/doc/corner.html ============================================================================== --- clfswm/doc/corner.html (original) +++ clfswm/doc/corner.html Sun Sep 26 15:22:30 2010 @@ -120,7 +120,7 @@ Bottom-Left: - --- + Start the file manager Modified: clfswm/doc/corner.txt ============================================================================== --- clfswm/doc/corner.txt (original) +++ clfswm/doc/corner.txt Sun Sep 26 15:22:30 2010 @@ -16,7 +16,7 @@ Top-Left: Hide/Unhide a terminal Top-Right: Close or kill the current window (ask before doing anything) Bottom-Right: Present all windows in all frames (An expose like) - Bottom-Left: --- + Bottom-Left: Start the file manager *Corner-Second-Mode-Left-Button*: Top-Left: --- Modified: clfswm/doc/keys.html ============================================================================== --- clfswm/doc/keys.html (original) +++ clfswm/doc/keys.html Sun Sep 26 15:22:30 2010 @@ -241,7 +241,7 @@ - Control + Control Shift F10 @@ -252,6 +252,28 @@ + + + + F10 + + + Present all windows in the current frame (An expose like) + + + + + Control + + + F10 + + + Present all windows in all frames (An expose like) + + + + Mod-1 @@ -299,7 +321,7 @@ Mod-1 - 1 + Ccedilla Bind or jump to a slot (a frame or a window) @@ -310,7 +332,7 @@ Mod-1 - 2 + Underscore Bind or jump to a slot (a frame or a window) @@ -321,7 +343,7 @@ Mod-1 - 3 + Egrave Bind or jump to a slot (a frame or a window) @@ -332,7 +354,7 @@ Mod-1 - 4 + Minus Bind or jump to a slot (a frame or a window) @@ -343,7 +365,7 @@ Mod-1 - 5 + Parenleft Bind or jump to a slot (a frame or a window) @@ -354,7 +376,7 @@ Mod-1 - 6 + Quoteright Bind or jump to a slot (a frame or a window) @@ -365,7 +387,7 @@ Mod-1 - 7 + Quotedbl Bind or jump to a slot (a frame or a window) @@ -376,7 +398,7 @@ Mod-1 - 8 + Eacute Bind or jump to a slot (a frame or a window) @@ -387,7 +409,7 @@ Mod-1 - 9 + Ampersand Bind or jump to a slot (a frame or a window) @@ -395,15 +417,103 @@ + + + + Twosuperior + + + Move the pointer to the lower right corner of the screen + + + + + Mod-1 + + + F2 + + + Open the Music Player Daemon (MPD) menu + + + + Mod-1 - 0 + Agrave Bind or jump to a slot (a frame or a window) + + + + + + Pause + + + Open the Reboot/Halt menu + + + + + + + + Control_r + + + Move the pointer to the lower right corner of the screen + + + + + + + + 176 + + + Raise the volume + + + + + + + + 174 + + + Lower the volume + + + + + Control + + + 66 + + + Present all windows in the current frame (An expose like) + + + + + Control Shift + + + 66 + + + Present all windows in all frames (An expose like) + +

@@ -807,6 +917,83 @@ + + + + Right + + + Speed move mouse to right + + + + + + + + Left + + + Speed move mouse to left + + + + + + + + Down + + + Speed move mouse to down + + + + + + + + Up + + + Speed move mouse to up + + + + + Control + + + Left + + + Undo last speed mouse move + + + + + Control + + + Up + + + Revert to the first speed move mouse + + + + + Control + + + Down + + + Reset speed mouse coordinates + + + + Mod-1 @@ -1137,7 +1324,7 @@ - Control + Control Shift F10 @@ -1148,10 +1335,32 @@ + + + + F10 + + + Present all windows in the current frame (An expose like) + + + + + Control + + + F10 + + + Present all windows in all frames (An expose like) + + + + Mod-1 - 1 + Ccedilla Bind or jump to a slot (a frame or a window) @@ -1162,7 +1371,7 @@ Mod-1 - 2 + Underscore Bind or jump to a slot (a frame or a window) @@ -1173,7 +1382,7 @@ Mod-1 - 3 + Egrave Bind or jump to a slot (a frame or a window) @@ -1184,7 +1393,7 @@ Mod-1 - 4 + Minus Bind or jump to a slot (a frame or a window) @@ -1195,7 +1404,7 @@ Mod-1 - 5 + Parenleft Bind or jump to a slot (a frame or a window) @@ -1206,7 +1415,7 @@ Mod-1 - 6 + Quoteright Bind or jump to a slot (a frame or a window) @@ -1217,7 +1426,7 @@ Mod-1 - 7 + Quotedbl Bind or jump to a slot (a frame or a window) @@ -1228,7 +1437,7 @@ Mod-1 - 8 + Eacute Bind or jump to a slot (a frame or a window) @@ -1239,7 +1448,7 @@ Mod-1 - 9 + Ampersand Bind or jump to a slot (a frame or a window) @@ -1247,15 +1456,48 @@ + + + + Twosuperior + + + Move the pointer to the lower right corner of the screen + + + + Mod-1 - 0 + Agrave Bind or jump to a slot (a frame or a window) + + + + + + Space + + + start the file manager + + + + + + + + Z + + + start the web browser + +

@@ -1645,6 +1887,357 @@ +

+ + Circulate mode keys + +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ Modifiers + + Key/Button + + Function +
+ + + Escape + + Leave the circulate mode +
+ Control + + G + + Leave the circulate mode +
+ Mod-1 + + Escape + + Leave the circulate mode +
+ Mod-1 Control + + G + + Leave the circulate mode +
+ Mod-1 + + Tab + + Select the next child +
+ Mod-1 Shift + + Tab + + Select the previous child +
+ Mod-1 Shift + + Iso_left_tab + + Select the previous child +
+ Mod-1 + + Right + + Select the next brother +
+ Mod-1 + + Left + + Select the previous borther +
+

+ + Expose windows mode keys + +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ Modifiers + + Key/Button + + Function +
+ + + Escape + + Leave the expose mode +
+ Control + + G + + Leave the expose mode +
+ Mod-1 + + Escape + + Leave the expose mode +
+ Mod-1 Control + + G + + Leave the expose mode +
+ + + Return + + Valid the expose mode +
+ + + Space + + Valid the expose mode +
+ + + Tab + + Valid the expose mode +
+ + + Right + + Speed move mouse to right +
+ + + Left + + Speed move mouse to left +
+ + + Down + + Speed move mouse to down +
+ + + Up + + Speed move mouse to up +
+ Control + + Left + + Undo last speed mouse move +
+ Control + + Up + + Revert to the first speed move mouse +
+ Control + + Down + + Reset speed mouse coordinates +
+ + + A + + Leave the expose mode +
+

+ + Mouse buttons actions in expose windows mode + +

+ + + + + + + + + + + + + + + + + + + + + +
+ Modifiers + + Key/Button + + Function +
+ + + 1 + + Valid the expose mode +
+ + + 2 + + Leave the expose mode +
+ + + 3 + + Leave the expose mode +

This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-html-in-file or Modified: clfswm/doc/keys.txt ============================================================================== --- clfswm/doc/keys.txt (original) +++ clfswm/doc/keys.txt Sun Sep 26 15:22:30 2010 @@ -25,21 +25,31 @@ Mod-1 F10 Switch between two layouts Shift F10 Show all frames info windows until a key is release Mod-1 Shift F10 Show all frames info windows - Control F10 Show/Hide the root frame + Control Shift F10 Show/Hide the root frame + F10 Present all windows in the current frame (An expose like) + Control F10 Present all windows in all frames (An expose like) Mod-1 B Move the pointer to the lower right corner of the screen Control Escape Close or kill the current window (ask before doing anything) Mod-1 T Switch to editing mode Control Less Switch to editing mode - Mod-1 1 Bind or jump to a slot (a frame or a window) - Mod-1 2 Bind or jump to a slot (a frame or a window) - Mod-1 3 Bind or jump to a slot (a frame or a window) - Mod-1 4 Bind or jump to a slot (a frame or a window) - Mod-1 5 Bind or jump to a slot (a frame or a window) - Mod-1 6 Bind or jump to a slot (a frame or a window) - Mod-1 7 Bind or jump to a slot (a frame or a window) - Mod-1 8 Bind or jump to a slot (a frame or a window) - Mod-1 9 Bind or jump to a slot (a frame or a window) - Mod-1 0 Bind or jump to a slot (a frame or a window) + Mod-1 Ccedilla Bind or jump to a slot (a frame or a window) + Mod-1 Underscore Bind or jump to a slot (a frame or a window) + Mod-1 Egrave Bind or jump to a slot (a frame or a window) + Mod-1 Minus Bind or jump to a slot (a frame or a window) + Mod-1 Parenleft Bind or jump to a slot (a frame or a window) + Mod-1 Quoteright Bind or jump to a slot (a frame or a window) + Mod-1 Quotedbl Bind or jump to a slot (a frame or a window) + Mod-1 Eacute Bind or jump to a slot (a frame or a window) + Mod-1 Ampersand Bind or jump to a slot (a frame or a window) + Twosuperior Move the pointer to the lower right corner of the screen + Mod-1 F2 Open the Music Player Daemon (MPD) menu + Mod-1 Agrave Bind or jump to a slot (a frame or a window) + Pause Open the Reboot/Halt menu + Control_r Move the pointer to the lower right corner of the screen + 176 Raise the volume + 174 Lower the volume + Control 66 Present all windows in the current frame (An expose like) + Control Shift 66 Present all windows in all frames (An expose like) Mouse buttons actions in main mode: @@ -85,6 +95,13 @@ Mod-1 Left Select the previous brother Mod-1 Down Select the previous level in frame Mod-1 Up Select the next level in frame + Right Speed move mouse to right + Left Speed move mouse to left + Down Speed move mouse to down + Up Speed move mouse to up + Control Left Undo last speed mouse move + Control Up Revert to the first speed move mouse + Control Down Reset speed mouse coordinates Mod-1 Tab Select the next child Mod-1 Shift Tab Select the previouschild Shift Tab Store the current child and switch to the previous one @@ -115,17 +132,22 @@ Mod-1 F10 Switch between two layouts Shift F10 Show all frames info windows until a key is release Mod-1 Shift F10 Show all frames info windows - Control F10 Show/Hide the root frame - Mod-1 1 Bind or jump to a slot (a frame or a window) - Mod-1 2 Bind or jump to a slot (a frame or a window) - Mod-1 3 Bind or jump to a slot (a frame or a window) - Mod-1 4 Bind or jump to a slot (a frame or a window) - Mod-1 5 Bind or jump to a slot (a frame or a window) - Mod-1 6 Bind or jump to a slot (a frame or a window) - Mod-1 7 Bind or jump to a slot (a frame or a window) - Mod-1 8 Bind or jump to a slot (a frame or a window) - Mod-1 9 Bind or jump to a slot (a frame or a window) - Mod-1 0 Bind or jump to a slot (a frame or a window) + Control Shift F10 Show/Hide the root frame + F10 Present all windows in the current frame (An expose like) + Control F10 Present all windows in all frames (An expose like) + Mod-1 Ccedilla Bind or jump to a slot (a frame or a window) + Mod-1 Underscore Bind or jump to a slot (a frame or a window) + Mod-1 Egrave Bind or jump to a slot (a frame or a window) + Mod-1 Minus Bind or jump to a slot (a frame or a window) + Mod-1 Parenleft Bind or jump to a slot (a frame or a window) + Mod-1 Quoteright Bind or jump to a slot (a frame or a window) + Mod-1 Quotedbl Bind or jump to a slot (a frame or a window) + Mod-1 Eacute Bind or jump to a slot (a frame or a window) + Mod-1 Ampersand Bind or jump to a slot (a frame or a window) + Twosuperior Move the pointer to the lower right corner of the screen + Mod-1 Agrave Bind or jump to a slot (a frame or a window) + Space start the file manager + Z start the web browser Mouse buttons actions in second mode: @@ -175,6 +197,48 @@ Motion NIL +Circulate mode keys: +------------------- + + Escape Leave the circulate mode + Control G Leave the circulate mode + Mod-1 Escape Leave the circulate mode + Mod-1 Control G Leave the circulate mode + Mod-1 Tab Select the next child + Mod-1 Shift Tab Select the previous child + Mod-1 Shift Iso_left_tab Select the previous child + Mod-1 Right Select the next brother + Mod-1 Left Select the previous borther + + +Expose windows mode keys: +------------------------ + + Escape Leave the expose mode + Control G Leave the expose mode + Mod-1 Escape Leave the expose mode + Mod-1 Control G Leave the expose mode + Return Valid the expose mode + Space Valid the expose mode + Tab Valid the expose mode + Right Speed move mouse to right + Left Speed move mouse to left + Down Speed move mouse to down + Up Speed move mouse to up + Control Left Undo last speed mouse move + Control Up Revert to the first speed move mouse + Control Down Reset speed mouse coordinates + A Leave the expose mode + + +Mouse buttons actions in expose windows mode: +-------------------------------------------- + + 1 Valid the expose mode + 2 Leave the expose mode + 3 Leave the expose mode + + This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-in-file or the produce-all-docs Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Sun Sep 26 15:22:30 2010 @@ -81,6 +81,105 @@

v: Show the current CLFSWM version

+

+ F2: < Music Player Daemon (MPD) menu > +

+

+ x: < XMMS menu > +

+

+ i: < CDPLAYER menu > +

+
+

+ Mpd-Menu +

+

+ i: Show MPD informations +

+

+ p: Play the previous song in the current playlist +

+

+ n: Play the next song in the current playlist +

+

+ t: Toggles Play/Pause, plays if stopped +

+

+ y: Start playing +

+

+ k: Stop the currently playing playlists +

+

+ x: Seeks to +5% +

+

+ w: Seeks to -5% +

+

+ l: Show the current MPD playlist +

+

+ s: Start sonata +

+

+ g: Start gmpc +

+
+

+ Xmms-Menu +

+

+ r: Lanch XMMS +

+

+ s: Show the current xmms status +

+

+ l: Show the current xmms playlist +

+

+ n: Play the next XMMS track +

+

+ p: Play the previous XMMS track +

+

+ e: open xmms "Load file(s)" dialog window. +

+
+

+ Cdplayer-Menu +

+

+ y: Start playing CD +

+

+ k: Stop playing CD +

+

+ t: Toggle pause +

+

+ s: Show the current CD status +

+

+ l: Show the current CD playlist +

+

+ n: Play the next CD track +

+

+ p: Play the previous CD track +

+

+ e: Eject CD +

+

+ c: Close CD +


Standard-Menu @@ -650,6 +749,9 @@ |: SolarWolf

+ |: Spring - An open source RTS with similar gameplay to TA +

+

|: SuperTux 2 - Play a classic 2D platform game

@@ -1168,6 +1270,9 @@ |: Disk Utility - Manage Drives and Media

+ |: rxvt-unicode - An Unicode capable rxvt clone +

+

|: UNetbootin - Tool for creating Live USB drives

@@ -1337,6 +1442,9 @@ |: Scilab - A scientific software package for numerical computations

+ |: Tilda +

+

|: About Xfce

@@ -1400,6 +1508,12 @@

d: LXTerminal - Use the command line

+

+ e: rxvt-unicode - An Unicode capable rxvt clone +

+

+ f: Tilda +


Archlinux @@ -2626,16 +2740,16 @@ d: < Identify key group >

- e: < Second mode group > + e: < Corner group >

- f: < Corner group > + f: < Query string group >

- g: < Query string group > + g: < Circulate mode group >

- h: < Circulate mode group > + h: < Second mode group >

i: < Placement group > @@ -2715,28 +2829,6 @@


- Conf-Second-Mode-Group -

-

- a: Configure SM-BACKGROUND-COLOR -

-

- b: Configure SM-HEIGHT -

-

- c: Configure SM-WIDTH -

-

- d: Configure SM-FOREGROUND-COLOR -

-

- e: Configure SM-BORDER-COLOR -

-

- f: Configure SM-FONT-STRING -

-
-

Conf-Corner-Group

@@ -2774,10 +2866,10 @@ Conf-Query-String-Group

- a: Configure QUERY-FONT-STRING + a: Configure QUERY-BACKGROUND

- b: Configure QUERY-BACKGROUND + b: Configure QUERY-FONT-STRING

c: Configure QUERY-BORDER @@ -2790,16 +2882,16 @@ Conf-Circulate-Mode-Group

- a: Configure CIRCULATE-WIDTH + a: Configure CIRCULATE-BORDER

- b: Configure CIRCULATE-TEXT-LIMITE + b: Configure CIRCULATE-WIDTH

- c: Configure CIRCULATE-BORDER + c: Configure CIRCULATE-HEIGHT

- d: Configure CIRCULATE-HEIGHT + d: Configure CIRCULATE-TEXT-LIMITE

e: Configure CIRCULATE-FONT-STRING @@ -2812,6 +2904,28 @@


+ Conf-Second-Mode-Group +

+

+ a: Configure SM-FOREGROUND-COLOR +

+

+ b: Configure SM-BACKGROUND-COLOR +

+

+ c: Configure SM-HEIGHT +

+

+ d: Configure SM-WIDTH +

+

+ e: Configure SM-BORDER-COLOR +

+

+ f: Configure SM-FONT-STRING +

+
+

Conf-Placement-Group

@@ -2938,6 +3052,28 @@

x: Exit clfswm

+

+ Pause: < Suspend/Reboot/Halt menu > +

+
+

+ Reboot-Halt-Menu +

+

+ -: Do nothing +

+

+ s: Suspend the computer to RAM +

+

+ d: Suspend the computer to DISK +

+

+ r: Reboot the computer +

+

+ h: Halt the computer +


Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Sun Sep 26 15:22:30 2010 @@ -24,6 +24,41 @@ p: Show current processes sorted by CPU usage m: Show current processes sorted by memory usage v: Show the current CLFSWM version +F2: < Music Player Daemon (MPD) menu > +x: < XMMS menu > +i: < CDPLAYER menu > + +Mpd-Menu +i: Show MPD informations +p: Play the previous song in the current playlist +n: Play the next song in the current playlist +t: Toggles Play/Pause, plays if stopped +y: Start playing +k: Stop the currently playing playlists +x: Seeks to +5% +w: Seeks to -5% +l: Show the current MPD playlist +s: Start sonata +g: Start gmpc + +Xmms-Menu +r: Lanch XMMS +s: Show the current xmms status +l: Show the current xmms playlist +n: Play the next XMMS track +p: Play the previous XMMS track +e: open xmms "Load file(s)" dialog window. + +Cdplayer-Menu +y: Start playing CD +k: Stop playing CD +t: Toggle pause +s: Show the current CD status +l: Show the current CD playlist +n: Play the next CD track +p: Play the previous CD track +e: Eject CD +c: Close CD Standard-Menu a: < TEXTEDITOR > @@ -220,6 +255,7 @@ |: Neverputt - A 3D mini golf game |: OpenArena - A Quake3-based FPS Game |: SolarWolf +|: Spring - An open source RTS with similar gameplay to TA |: SuperTux 2 - Play a classic 2D platform game |: Trackballs - Simple game similar to the classical game Marble Madness |: Battle for Wesnoth - A fantasy turn-based strategy game @@ -396,6 +432,7 @@ |: Task Manager - Manage running processes |: File Browser - Browse the file system with the file manager |: Disk Utility - Manage Drives and Media +|: rxvt-unicode - An Unicode capable rxvt clone |: UNetbootin - Tool for creating Live USB drives |: Oracle VM VirtualBox |: Xfe - A lightweight file manager for X Window @@ -453,6 +490,7 @@ |: Network - Browse bookmarked and local network locations |: File Manager |: Scilab - A scientific software package for numerical computations +|: Tilda |: About Xfce |: Application Finder - Find and launch applications installed on your system |: File Manager @@ -475,6 +513,8 @@ b: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password c: Konsole d: LXTerminal - Use the command line +e: rxvt-unicode - An Unicode capable rxvt clone +f: Tilda Archlinux a: AUR - Archlinux AUR @@ -902,10 +942,10 @@ b: < Main mode group > c: < Frame colors group > d: < Identify key group > -e: < Second mode group > -f: < Corner group > -g: < Query string group > -h: < Circulate mode group > +e: < Corner group > +f: < Query string group > +g: < Circulate mode group > +h: < Second mode group > i: < Placement group > j: < Miscellaneous group > k: < Info mode group > @@ -935,14 +975,6 @@ c: Configure IDENTIFY-BORDER d: Configure IDENTIFY-BACKGROUND -Conf-Second-Mode-Group -a: Configure SM-BACKGROUND-COLOR -b: Configure SM-HEIGHT -c: Configure SM-WIDTH -d: Configure SM-FOREGROUND-COLOR -e: Configure SM-BORDER-COLOR -f: Configure SM-FONT-STRING - Conf-Corner-Group a: Configure CORNER-MAIN-MODE-LEFT-BUTTON b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON @@ -956,20 +988,28 @@ j: Configure CLFSWM-TERMINAL-NAME Conf-Query-String-Group -a: Configure QUERY-FONT-STRING -b: Configure QUERY-BACKGROUND +a: Configure QUERY-BACKGROUND +b: Configure QUERY-FONT-STRING c: Configure QUERY-BORDER d: Configure QUERY-FOREGROUND Conf-Circulate-Mode-Group -a: Configure CIRCULATE-WIDTH -b: Configure CIRCULATE-TEXT-LIMITE -c: Configure CIRCULATE-BORDER -d: Configure CIRCULATE-HEIGHT +a: Configure CIRCULATE-BORDER +b: Configure CIRCULATE-WIDTH +c: Configure CIRCULATE-HEIGHT +d: Configure CIRCULATE-TEXT-LIMITE e: Configure CIRCULATE-FONT-STRING f: Configure CIRCULATE-BACKGROUND g: Configure CIRCULATE-FOREGROUND +Conf-Second-Mode-Group +a: Configure SM-FOREGROUND-COLOR +b: Configure SM-BACKGROUND-COLOR +c: Configure SM-HEIGHT +d: Configure SM-WIDTH +e: Configure SM-BORDER-COLOR +f: Configure SM-FONT-STRING + Conf-Placement-Group a: Configure CIRCULATE-MODE-PLACEMENT b: Configure QUERY-MODE-PLACEMENT @@ -1015,6 +1055,14 @@ r: Reset clfswm l: Reload clfswm x: Exit clfswm +Pause: < Suspend/Reboot/Halt menu > + +Reboot-Halt-Menu +-: Do nothing +s: Suspend the computer to RAM +d: Suspend the computer to DISK +r: Reboot the computer +h: Halt the computer This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-in-file or Modified: clfswm/src/clfswm-autodoc.lisp ============================================================================== --- clfswm/src/clfswm-autodoc.lisp (original) +++ clfswm/src/clfswm-autodoc.lisp Sun Sep 26 15:22:30 2010 @@ -85,7 +85,7 @@ (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-doc-html (list *main-keys* *main-mouse* *second-keys* *second-mouse* - *info-keys* *info-mouse*) + *info-keys* *info-mouse* *circulate-keys* *expose-keys* *expose-mouse*) stream)) (format t " done~%")) @@ -126,7 +126,7 @@ (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-doc (list *main-keys* *main-mouse* *second-keys* *second-mouse* - *info-keys* *info-mouse*) + *info-keys* *info-mouse* *circulate-keys* *expose-keys* *expose-mouse*) stream)) (format t " done~%")) Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Sun Sep 26 15:22:30 2010 @@ -152,6 +152,8 @@ (defun circulate-leave-function () + (when *circulate-gc* + (xlib:free-gcontext *circulate-gc*)) (when *circulate-window* (xlib:destroy-window *circulate-window*)) (when *circulate-font* Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Sun Sep 26 15:22:30 2010 @@ -25,6 +25,9 @@ (in-package :clfswm) +(defparameter *expose-font* nil) +(defparameter *expose-windows-list* nil) + (defun leave-expose-mode () "Leave the expose mode" (throw 'exit-expose-loop nil)) @@ -50,6 +53,8 @@ (define-handler expose-mode :button-press (code state window root-x root-y) (funcall-button-from-code *expose-mouse* code state window root-x root-y *fun-press*)) +(define-handler expose-mode :exposure () + (expose-draw-letter)) (add-hook *binding-hook* 'set-default-expose-keys) @@ -73,33 +78,95 @@ (define-expose-mouse (2) 'mouse-leave-expose-mode) (define-expose-mouse (3) 'mouse-leave-expose-mode)) +(defmacro define-expose-letter-keys () + (labels ((produce-name (n) + (symb "%" "expose-fun-key-" n "%"))) + `(progn + ,@(loop for n from 0 to 25 + collect `(progn + (defun ,(produce-name n) () + ,(format nil "Select child '~A' (~A)" (number->char n) n) + (let ((child (nth ,n *expose-windows-list*))) + (when child + (xlib:warp-pointer *root* (xlib:drawable-x (first child)) (xlib:drawable-y (first child))) + (when *expose-valid-on-key* + (valid-expose-mode))))) + (define-expose-key (,(number->char n)) ',(produce-name n))))))) + +(define-expose-letter-keys) + + +(defun expose-draw-letter () + (loop for lwin in *expose-windows-list* + for n from 0 do + (xlib:draw-glyphs (first lwin) (second lwin) + (xlib:max-char-width *expose-font*) + (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*)) + (format nil "~A" (number->char n))))) + +(defun expose-create-window (child n) + (declare (ignore n)) + (with-placement (*expose-mode-placement* x y (child-width child) (child-height child)) + (let* ((window (xlib:create-window :parent *root* + :x (+ (child-x child) x) + :y (+ (child-y child) y) + :width (* (xlib:max-char-width *expose-font*) 3) + :height (* (xlib:font-ascent *expose-font*) 2) + :background (get-color *expose-background*) + :border-width 1 + :border (get-color *expose-border*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press))) + (gc (xlib:create-gcontext :drawable window + :foreground (get-color *expose-foreground*) + :background (get-color *expose-background*) + :font *expose-font* + :line-style :solid))) + (map-window window) + (push (list window gc) *expose-windows-list*)))) + + +(defun expose-mode-display-accel-windows () + (let ((n -1)) + (with-all-children-reversed (*current-root* child) + (when (< n 25) + (expose-create-window child (incf n))))) + (setf *expose-windows-list* (nreverse *expose-windows-list*)) + (expose-draw-letter)) (defun expose-windows-generic (first-restore-frame body) + (setf *expose-font* (xlib:open-font *display* *expose-font-string*) + *expose-windows-list* nil) (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2)) (truncate (/ (xlib:screen-height *screen*) 2))) (with-all-frames (first-restore-frame frame) (setf (frame-data-slot frame :old-layout) (frame-layout frame) (frame-layout frame) #'tile-space-layout)) (show-all-children *current-root*) - (dbg 'ici) + (expose-mode-display-accel-windows) (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) - (dbg 'ici-2) (when (generic-mode 'expose-mode 'exit-expose-loop :original-mode '(main-mode)) - (dbg 'ici-3) (multiple-value-bind (x y) (xlib:query-pointer *root*) (let* ((child (find-child-under-mouse x y)) (parent (find-parent-frame child *root-frame*))) (when (and child parent) (pfuncall body parent) (focus-all-children child parent))))) + (when *expose-font* + (xlib:close-font *expose-font*)) + (dolist (lwin *expose-windows-list*) + (awhen (first lwin) + (xlib:destroy-window it)) + (awhen (second lwin) + (xlib:free-gcontext it))) (with-all-frames (first-restore-frame frame) (setf (frame-layout frame) (frame-data-slot frame :old-layout) (frame-data-slot frame :old-layout) nil)) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sun Sep 26 15:22:30 2010 @@ -197,6 +197,32 @@ "???") +(defgeneric child-x (child)) +(defmethod child-x ((child xlib:window)) + (xlib:drawable-x child)) +(defmethod child-x ((child frame)) + (frame-rx child)) + +(defgeneric child-y (child)) +(defmethod child-y ((child xlib:window)) + (xlib:drawable-y child)) +(defmethod child-y ((child frame)) + (frame-ry child)) + +(defgeneric child-width (child)) +(defmethod child-width ((child xlib:window)) + (xlib:drawable-width child)) +(defmethod child-width ((child frame)) + (frame-rw child)) + +(defgeneric child-height (child)) +(defmethod child-height ((child xlib:window)) + (xlib:drawable-height child)) +(defmethod child-height ((child frame)) + (frame-rh child)) + + + (defgeneric rename-child (child name)) @@ -230,6 +256,18 @@ (,rec ,root)))) +;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child))))) +(defmacro with-all-children-reversed ((root child) &body body) + (let ((rec (gensym)) + (sub-child (gensym))) + `(labels ((,rec (,child) + , at body + (when (frame-p ,child) + (dolist (,sub-child (frame-child ,child)) + (,rec ,sub-child))))) + (,rec ,root)))) + + ;; (with-all-frames (*root-frame* frame) (print (frame-number frame))) (defmacro with-all-frames ((root frame) &body body) (let ((rec (gensym)) @@ -450,22 +488,23 @@ (let ((pos dy)) (when (child-equal-p frame *current-root*) (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) - (format nil "~A hidden windows" (length (get-hidden-windows)))) + (format nil " ~A hidden windows" (length (get-hidden-windows)))) (when *child-selection* (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (with-output-to-string (str) - (format str "Selection: ") + (format str " Selection: ") (dolist (child *child-selection*) (typecase child - (xlib:window (format str "~A " (xlib:wm-name child))) - (frame (format str "frame:~A[~A] " (frame-number child) + (xlib:window (format str " ~A " (xlib:wm-name child))) + (frame (format str " frame:~A[~A] " (frame-number child) (aif (frame-name child) it ""))))))))) (dolist (ch child) - (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (ensure-printable (child-fullname ch)))) + (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) + (format nil " ~A" (ensure-printable (child-fullname ch))))) (setf (xlib:gcontext-foreground gc) (get-color *frame-foreground-hidden*)) (dolist (ch hidden-children) (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) - (format nil "~A - hidden" (ensure-printable (child-fullname ch)))))) + (format nil " ~A - hidden" (ensure-printable (child-fullname ch)))))) (copy-pixmap-buffer window gc)))) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Sun Sep 26 15:22:30 2010 @@ -303,7 +303,6 @@ (dy (/ rh (ceiling (/ len n)))) (size (or (frame-data-slot parent :tile-space-size) 0.1))) (when (> size 0.5) (setf size 0.45)) - (dbg pos len n dx dy size) ;; PHIL here (values (round (+ rx (truncate (* (mod pos n) dx)) (* dx size) 1)) (round (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size) 1)) (round (- dx (* dx size 2) 2)) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Sep 26 15:22:30 2010 @@ -263,6 +263,19 @@ "Config(Circulate mode group): Maximum text limite in the circulate window") +;;; CONFIG - Expose string colors +(defparameter *expose-font-string* *default-font-string* + "Config(Expose mode group): Expose string window font string") +(defparameter *expose-background* "black" + "Config(Expose mode group): Expose string window background color") +(defparameter *expose-foreground* "green" + "Config(Expose mode group): Expose string window foreground color") +(defparameter *expose-border* "red" + "Config(Expose mode group): Expose string window border color") +(defparameter *expose-valid-on-key* t + "Config(Expose mode group): Valid expose mode when an accel key is pressed") + + ;;; CONFIG - Show key binding colors (defparameter *info-color-title* "Magenta" Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sun Sep 26 15:22:30 2010 @@ -206,6 +206,8 @@ "Config(Placement group): Query mode window placement") (defparameter *circulate-mode-placement* 'bottom-middle-placement "Config(Placement group): Circulate mode window placement") +(defparameter *expose-mode-placement* 'top-left-placement + "Config(Placement group): Expose mode window placement (Selection keys position)") From pbrochard at common-lisp.net Sun Sep 26 19:40:30 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 26 Sep 2010 15:40:30 -0400 Subject: [clfswm-cvs] r334 - clfswm/src Message-ID: Author: pbrochard Date: Sun Sep 26 15:40:30 2010 New Revision: 334 Log: Fixe a double gcontext free Modified: clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-expose-mode.lisp Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Sun Sep 26 15:40:30 2010 @@ -160,6 +160,7 @@ (xlib:close-font *circulate-font*)) (xlib:display-finish-output *display*) (setf *circulate-window* nil + *circulate-gc* nil *circulate-font* nil)) (defun circulate-loop-function () Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Sun Sep 26 15:40:30 2010 @@ -160,13 +160,14 @@ (when (and child parent) (pfuncall body parent) (focus-all-children child parent))))) - (when *expose-font* - (xlib:close-font *expose-font*)) (dolist (lwin *expose-windows-list*) (awhen (first lwin) (xlib:destroy-window it)) (awhen (second lwin) - (xlib:free-gcontext it))) + (xlib:free-gcontext it))) + (when *expose-font* + (xlib:close-font *expose-font*)) + (setf *expose-windows-list* nil) (with-all-frames (first-restore-frame frame) (setf (frame-layout frame) (frame-data-slot frame :old-layout) (frame-data-slot frame :old-layout) nil)) From pbrochard at common-lisp.net Wed Sep 29 21:18:20 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 29 Sep 2010 17:18:20 -0400 Subject: [clfswm-cvs] r335 - in clfswm: . contrib Message-ID: Author: pbrochard Date: Wed Sep 29 17:18:19 2010 New Revision: 335 Log: configure: Use the Xavier Maillard clfswm script in contrib to build an executable in the standard way. Modified: clfswm/ChangeLog clfswm/Makefile.template clfswm/configure clfswm/contrib/clfswm Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Sep 29 17:18:19 2010 @@ -1,3 +1,8 @@ +2010-09-29 Philippe Brochard + + * configure: Use the Xavier Maillard clfswm script in contrib to + build an executable in the standard way. + 2010-09-26 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-mode-display-accel-windows): Modified: clfswm/Makefile.template ============================================================================== --- clfswm/Makefile.template (original) +++ clfswm/Makefile.template Wed Sep 29 17:18:19 2010 @@ -1,50 +1,45 @@ # -*- makefile -*- -PROJECT_NAME=+PROJECT_NAME+ DESTDIR=+DESTDIR+ - -LISP=+LISP+ -EVAL_OPT=+EVAL_OPT+ -LOAD_OPT=+LOAD_OPT+ -EXT=+EXT+ -CORE=+CORE+ - -all: build - @echo "ALL" +BUILD_PATH=+BUILD_PATH+ build: @echo "Building" - $(LISP) $(CORE) $(EVAL_OPT) '(progn (pushnew :BUILD *features*) (load "load.lisp") (quit))' + chmod a+x $(BUILD_PATH)/clfswm @echo "" - @echo "Type 'make install' to install $(PROJECT_NAME) in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "Type 'make install' to install clfswm in '$(DESTDIR)/bin/clfswm'" @echo "" install: - @echo "1) Installing: Creating directories" - mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/src - mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/contrib mkdir -p $(DESTDIR)/bin - @echo "2) Installing: Copying files" - cp -R `pwd`/load.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ - cp -R `pwd`/clfswm.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ - cp -R `pwd`/src/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/src - cp -R `pwd`/contrib/* $(DESTDIR)/lib/$(PROJECT_NAME)/contrib - @sleep 1 - cp -R `pwd`/src/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/src - @echo "3) Installing: Creating starter script" - echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) - echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp" >> $(DESTDIR)/bin/$(PROJECT_NAME) - chmod a+x $(DESTDIR)/bin/$(PROJECT_NAME) + rm -rf $(DESTDIR)/lib/clfswm/ + mkdir -p $(DESTDIR)/lib/clfswm/src + mkdir -p $(DESTDIR)/share/doc/clfswm + cp $(BUILD_PATH)/clfswm $(DESTDIR)/bin + cp $(BUILD_PATH)/clfswm.asd $(DESTDIR)/lib/clfswm/ + cp -R $(BUILD_PATH)/src/*.lisp $(DESTDIR)/lib/clfswm/src + cp -R $(BUILD_PATH)/contrib $(DESTDIR)/lib/clfswm/ + cp -R $(BUILD_PATH)/doc/* $(DESTDIR)/share/doc/clfswm/ + cp -R $(BUILD_PATH)/AUTHORS $(DESTDIR)/share/doc/clfswm/ + cp -R $(BUILD_PATH)/COPYING $(DESTDIR)/share/doc/clfswm/ + cp -R $(BUILD_PATH)/README $(DESTDIR)/share/doc/clfswm/ + cp -R $(BUILD_PATH)/TODO $(DESTDIR)/share/doc/clfswm/ + cp -R $(BUILD_PATH)/ChangeLog $(DESTDIR)/share/doc/clfswm/ @echo "" - @echo "$(PROJECT_NAME) has been installed in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "clfswm has been installed in '$(DESTDIR)/bin/clfswm'" @echo "" uninstall: - rm -rf $(DESTDIR)/bin/$(PROJECT_NAME) - rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ + rm -rf $(DESTDIR)/bin/clfswm + rm -rf $(DESTDIR)/lib/clfswm + rm -rf $(DESTDIR)/share/doc/clfswm clean: find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f dist: clean - cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) + cd .. && tar czvf clfswm-`date +%y%m%d`.tar.gz clfswm + + +distclean: clean + rm -f clfswm Makefile Modified: clfswm/configure ============================================================================== --- clfswm/configure (original) +++ clfswm/configure Wed Sep 29 17:18:19 2010 @@ -1,11 +1,16 @@ #! /bin/sh -PROJECT_NAME=clfswm -CONFIGURE_VERSION=0.1 +CONFIGURE_VERSION=0.2 +PREFIX="/usr/local" +lisp=clisp +lisp_opt='' +dump_path="\$XDG_CACHE_HOME/clfswm/" +clfswm_asd_path="$PREFIX/lib/clfswm" +asdf_path="$PREFIX/lib/clfswm/contrib" usage () { - echo "'configure' configures $PROJECT_NAME to adapt to many kinds of systems. + echo "'configure' configures clfswm to adapt to many kinds of systems. Usage: ./configure [OPTION]... [VAR=VALUE]... @@ -14,18 +19,17 @@ Configuration: -h, --help display this help and exit -V, --version display version information and exit - --with-lisp=LISP use a particular Lisp implementation [ask] - --with-lisp-eval-opt=OPT use a particular Lisp eval command line option - --with-lisp-load-opt=OPT use a particular Lisp load command line option - --with-lisp-ext=OPT use a particular Lisp extension filename - --with-lisp-core=CORE use a particular Lisp core (initial memory image) - --prefix=PREFIX install architecture-independent files in PREFIX - [/usr/local] + --prefix=PREFIX install architecture-independent files in PREFIX [/usr/local] + -l, --with-lisp use as the common lisp implementation [$lisp] + -o, --lisp-opt use as lisp option [$lisp_opt] + -d, --dump-path path to the dump directory [$dump_path] + --with-clfswm path to clfswm.asd file [$clfswm_asd_path] + --with-asdf path to the asdf.lisp file [$asdf_path] By default, 'make install' will install all the files in '/usr/local/bin', '/usr/local/lib' etc. You can specify an installation prefix other than '/usr/local' using '--prefix', -for instance '--prefix=$HOME'." +for instance '--prefix=\$HOME/clfswm'." exit 0 } @@ -35,88 +39,80 @@ exit 0 } +reset_clfswm_asd_path=true +reset_asdf_path=true - -TEMP=`getopt -o hV: --long help,version,srcdir:,with-lisp:,with-lisp-eval-opt:,with-lisp-load-opt:,with-lisp-ext:,with-lisp-core:,prefix: -- "$@"` -PREFIX=/usr/local - -if [ $? != 0 ] ; then echo "Terminating..." >&2 ; exit 1 ; fi - -eval set -- "$TEMP" - -while true ; do +while test $# != 0 +do case "$1" in - -h|--help) usage ; shift ;; - -V|--version) version ; shift ;; - --srcdir) SRCDIR=$2 ; shift 2 ;; - --with-lisp) LISP=$2 ; shift 2 ;; - --with-lisp-eval-opt) EVAL_OPT=$2 ; shift 2 ;; - --with-lisp-load-opt) LOAD_OPT=$2 ; shift 2 ;; - --with-lisp-ext) EXT=$2 ; shift 2 ;; - --with-lisp-core) CORE=$2 ; shift 2 ;; - --prefix) PREFIX=$2 ; shift 2 ;; - --) shift ; break ;; - *) echo "Internal error!" ; exit 1 ;; + --prefix) + shift + PREFIX="$1" ;; + -d|--dump-path) + shift + dump_path="$1" ;; + --with-clfswm) + shift + clfswm_asd_path="$1" + reset_clfswm_asd_path=false ;; + --with-asdf) + shift + asdf_path="$1" + reset_asdf_path=false ;; + -l|--with-lisp) + shift + case "$1" in + '') + usage;; + clisp|sbcl|cmucl|ccl|ecl) + lisp="$1" ;; + esac + ;; + -o|--lisp-opt) + shift + lisp_opt="$1" ;; + --) + shift + break ;; + *) + usage ;; esac + shift done + DESTDIR=$PREFIX +if [ "$reset_clfswm_asd_path" = "true" ]; then + clfswm_asd_path="$PREFIX/lib/clfswm" +fi -if [ "x$LISP" = "x" ]; then - echo "Please, choose a Lisp implementation in: -1) SBCL 2) CMUCL 3) CLISP 4) ECL 5) CCL 6) Other" - read REP_LISP - case $REP_LISP in - 1) LISP=sbcl ;; - 2) LISP=cmucl ;; - 3) LISP=clisp ;; - 4) LISP=ecl ;; - 5) LISP=ccl ;; - 6) echo -n "Please, enter your Lisp implementation: " - read LISP ;; - *) echo "Error"; exit -1 ;; - esac +if [ "$reset_asdf_path" = "true" ]; then + asdf_path="$PREFIX/lib/clfswm/contrib" fi -case $LISP in - clisp) LISP=$(which clisp) - EVAL_OPT="-x -q" - LOAD_OPT="" - EXT=fas ;; - sbcl) LISP=$(which sbcl) - EVAL_OPT="--eval" - LOAD_OPT="--load" - EXT=fasl ;; - cmucl) LISP=$(which cmucl) - EVAL_OPT="-eval" - LOAD_OPT="-load" - EXT=x86f ;; - ecl) LISP=$(which ecl) - EVAL_OPT="-eval" - LOAD_OPT="-load" - EXT=fas ;; - ccl) LISP=$(which ccl) - EVAL_OPT="-e" - LOAD_OPT="-l" - EXT=lx32fsl ;; -esac - -echo "Configuration:" -echo SRCDIR = $SRCDIR -echo PREFIX = $PREFIX -echo "LISP=$LISP EVAL_OPT=$EVAL_OPT LOAD_OPT=$LOAD_OPT EXT=$EXT CORE=$CORE" - -sed -e "s#+PROJECT_NAME+#$PROJECT_NAME#g" \ - -e "s#+DESTDIR+#$DESTDIR#g" \ - -e "s#+LISP+#$LISP#g" \ - -e "s#+EVAL_OPT+#$EVAL_OPT#g" \ - -e "s#+LOAD_OPT+#$LOAD_OPT#g" \ - -e "s#+EXT+#$EXT#g" \ - -e "s#+CORE+#$CORE#g" \ +echo " prefix=$PREFIX + with-lisp=$lisp + lisp-opt=$lisp_opt + dump-path=$dump_path + with-clfswm=$clfswm_asd_path + with-asdf=$asdf_path" + + + +sed -e "s?^lisp=.*# +config+?lisp=\"$lisp\" # +config+?g" \ + -e "s?^lisp_opt=.*# +config+?lisp_opt=\"$lisp_opt\" # +config+?g" \ + -e "s?^dump_path=.*# +config+?dump_path=\"$dump_path\" # +config+?g" \ + -e "s?^clfswm_asd_path=.*# +config+?clfswm_asd_path=\"$clfswm_asd_path\" # +config+?g" \ + -e "s?^asdf_path=.*# +config+?asdf_path=\"$asdf_path\" # +config+?g" \ + $(pwd)/contrib/clfswm > $(pwd)/clfswm + +sed -e "s#+DESTDIR+#$DESTDIR#g" \ + -e "s#+BUILD_PATH+#$(pwd)/#g" \ Makefile.template > Makefile + echo "" -echo "Type 'make' to build $PROJECT_NAME" +echo "Type 'make' to build clfswm" echo "" Modified: clfswm/contrib/clfswm ============================================================================== --- clfswm/contrib/clfswm (original) +++ clfswm/contrib/clfswm Wed Sep 29 17:18:19 2010 @@ -33,11 +33,12 @@ no_start=no -lisp=clisp -lisp_opt='' -dump_path="$XDG_CACHE_HOME/clfswm/" -asdf_path="$(pwd)/contrib" -clfswm_asd_path="$(pwd)" + +lisp=clisp # +config+ +lisp_opt='' # +config+ +dump_path="$XDG_CACHE_HOME/clfswm/" # +config+ +clfswm_asd_path="$(pwd)" # +config+ +asdf_path="$(pwd)/contrib" # +config+ tmp_dir=/tmp @@ -45,15 +46,14 @@ usage() { echo "$0 [options] --- -n,no-start don't start CLFSWM after image dump -f,force force image dump -rebuild same as -f,--force -l,with-lisp use as the common lisp implementation [$lisp] -o,lisp-opt use as lisp option [$lisp_opt] -d,dump-path path to the dump directory [\$XDG_CACHE_HOME=$XDG_CACHE_HOME] -with-clfswm path to clfswm.asd file [$clfswm_asd_path] -with-asdf path to the asdf.lisp file [$asdf_path]" + -n, --no-start don't start CLFSWM after image dump + -f, --force force image dump + --rebuild same as -f, --force + -l, --with-lisp use as the common lisp implementation [$lisp] + -o, --lisp-opt use as lisp option [$lisp_opt] + -d, --dump-path path to the dump directory [$dump_path] + --with-clfswm path to clfswm.asd file [$clfswm_asd_path] + --with-asdf path to the asdf.lisp file [$asdf_path]" exit 0 } @@ -65,7 +65,7 @@ build_clisp () { - clisp $lisp_opt -m 8MB -E ISO-8859-1 -q -i $asdf_path/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") + clisp $lisp_opt -m 8MB -E ISO-8859-1 -q -i "$asdf_path"/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") (asdf:oos 'asdf:load-op :clfswm) \ (EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION (lambda () (clfswm:main) (quit)) :EXECUTABLE t :norc t)" } @@ -101,8 +101,8 @@ -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ -eval "(asdf:make-build :clfswm :type :program :monolithic t :move-here \".\" :prologue-code '(progn (require :asdf) (require :clx)))" \ -eval "(ext:quit 0)" - mv ./clfswm-mono $dump_image - echo $dump_image + mv ./clfswm-mono "$dump_image" + echo "$dump_image" } @@ -152,45 +152,54 @@ rm -f "$dump_image" fi -if test ! -e "$dump_image" || - ( for i in "$(dirname $(readlink $clfswm_asd_path/clfswm.asd))"/*.lisp - do test "$dump_image" -ot "$i" && exit 1 - done ) +clfswm_asd="$clfswm_asd_path"/clfswm.asd +if test -L "$clfswm_asd_path"; then + clfswm_asd=$(readlink "$clfswm_asd") +fi + +older_image=0 +for i in "$(dirname $clfswm_asd)"/src/*.lisp; do + test "$dump_image" -ot "$i" && older_image=1 +done + +if test ! -e "$dump_image" || test $older_image -eq 1 then - test -x $(type -p $lisp) || die "$lisp can't be found." - test -e $clfswm_asd_path/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path" - test -e $asdf_path/asdf.lisp || die "can't find asdf.lisp in $asdf_path" + echo "Image is nonexistent or older than sources. Rebuilding clfswm." + test -x $(type -p "$lisp") || die "$lisp can't be found." + test -e "$clfswm_asd_path"/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path" + test -e "$asdf_path"/asdf.lisp || die "can't find asdf.lisp in $asdf_path" # Move clfswm sources to $tmp_dir if there is no write permission on $clfswm_asd_path - if test ! -w $clfswm_asd_path ; then - rm -rf $tmp_dir/clfswm-tmp - mkdir $tmp_dir/clfswm-tmp - cp -R $clfswm_asd_path/* $tmp_dir/clfswm-tmp - clfswm_asd_path=$tmp_dir/clfswm-tmp - asdf_path=$tmp_dir/clfswm-tmp/contrib - echo "* Note: No write access in sources, copying in $clfswm_asd_path" + if test ! -w "$clfswm_asd_path" ; then + echo "* Note: No write access in sources ($clfswm_asd_path), + -> copying in a writable directory ($tmp_dir/clfswm-tmp)" + rm -rf "$tmp_dir"/clfswm-tmp + mkdir "$tmp_dir"/clfswm-tmp + cp -R "$clfswm_asd_path"/* "$tmp_dir"/clfswm-tmp + clfswm_asd_path="$tmp_dir"/clfswm-tmp + asdf_path="$tmp_dir"/clfswm-tmp/contrib fi mkdir -p "$dump_path" mkdir -p "$dump_path/contrib" - eval build_$lisp + eval build_"$lisp" rm -rf "$dump_path/contrib" cp -R "$clfswm_asd_path/contrib/" "$dump_path/" rm -rf $(find "$dump_path/" -name "*svn") - rm -rf $tmp_dir/clfswm-tmp + rm -rf "$tmp_dir"/clfswm-tmp fi # Run the resulting image if test no = "$no_start" then - cd $dump_path + cd "$dump_path" case $lisp in - clisp ) $dump_image ;; + clisp ) "$dump_image" ;; sbcl ) exec sbcl --core "$dump_image" ;; cmucl ) exec cmucl -core "$dump_image" ;; ccl ) exec ccl -I "$dump_image" ;; - ecl ) $dump_image -eval "(progn (clfswm:main) (ext:quit 0))" ;; + ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" ;; *) echo "..." ;; esac else From pbrochard at common-lisp.net Wed Sep 29 21:46:57 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 29 Sep 2010 17:46:57 -0400 Subject: [clfswm-cvs] r336 - clfswm/contrib Message-ID: Author: pbrochard Date: Wed Sep 29 17:46:57 2010 New Revision: 336 Log: Upgrade to asdf 2.0 Modified: clfswm/contrib/asdf.lisp Modified: clfswm/contrib/asdf.lisp ============================================================================== --- clfswm/contrib/asdf.lisp (original) +++ clfswm/contrib/asdf.lisp Wed Sep 29 17:46:57 2010 @@ -1,19 +1,25 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; -*- mode: common-lisp; package: asdf; -*- +;;; This is ASDF: Another System Definition Facility. ;;; -;;; Feedback, bug reports, and patches are all welcome: please mail to -;;; . But note first that the canonical -;;; source for asdf is presently the cCLan CVS repository at -;;; +;;; Feedback, bug reports, and patches are all welcome: +;;; please mail to . +;;; Note first that the canonical source for ASDF is presently +;;; . ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; bugs. There are usually two "supported" revisions - the git HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; +;;; Copyright (c) 2001-2010 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -33,111 +39,808 @@ ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END -;;; the problem with writing a defsystem replacement is bootstrapping: -;;; we can't use defsystem to compile it. Hence, all in one file +;;; The problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file. -(defpackage #:asdf - (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:hyperdocumentation #:hyperdoc - - #:compile-op #:load-op #:load-source-op #:test-system-version - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - - #:operation-on-warnings - #:operation-on-failure - - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*asdf-revision* - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-dependency - #:circular-dependency ; errors - - #:retry - #:accept ; restarts - - ) - (:use :cl)) - -#+nil -(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") - - -(in-package #:asdf) - -(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") - (colon (or (position #\: v) -1)) - (dot (position #\. v))) - (and v colon dot - (list (parse-integer v :start (1+ colon) - :junk-allowed t) - (parse-integer v :start (1+ dot) - :junk-allowed t))))) +#+xcvb (module ()) -(defvar *compile-file-warnings-behaviour* :warn) -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +(cl:in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:cl))) + ;;; Implementation-dependent tweaks + ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) + #+ecl (require :cmp)) + +(in-package :asdf) + +;;;; Create packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See more at the end of the file. + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:2.131" (1+ (length "VERSION")))) + (existing-asdf (fboundp 'find-system)) + (existing-version *asdf-version*) + (already-there (equal asdf-version existing-version))) + (unless (and existing-asdf already-there) + (when existing-asdf + (format *trace-output* + "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" + existing-version asdf-version)) + (labels + ((unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-unintern u + (loop :for s :being :each :present-symbol :in u :collect s)) + (loop :for p :in (package-used-by-list u) :do + (unuse-package u p)) + (delete-package u)))) + (ensure-exists (name nicknames use) + (let ((previous + (remove-duplicates + (mapcar #'find-package (cons name nicknames)) + :from-end t))) + ;; do away with packages with conflicting (nick)names + (map () #'unlink-package (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (cond + (p + (rename-package p name nicknames) + (ensure-use p use) + p) + (t + (make-package name :nicknames nicknames :use use)))))) + (find-sym (symbol package) + (find-symbol (string symbol) package)) + (intern* (symbol package) + (intern (string symbol) package)) + (remove-symbol (symbol package) + (let ((sym (find-sym symbol package))) + (when sym + (unexport sym package) + (unintern sym package) + sym))) + (ensure-unintern (package symbols) + (loop :with packages = (list-all-packages) + :for sym :in symbols + :for removed = (remove-symbol sym package) + :when removed :do + (loop :for p :in packages :do + (when (eq removed (find-sym sym p)) + (unintern removed p))))) + (ensure-shadow (package symbols) + (shadow symbols package)) + (ensure-use (package use) + (dolist (used (reverse use)) + (do-external-symbols (sym used) + (unless (eq sym (find-sym sym package)) + (remove-symbol sym package))) + (use-package used package))) + (ensure-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-sym name package) + :when sym :do (fmakunbound sym))) + (ensure-export (package export) + (let ((formerly-exported-symbols nil) + (bothly-exported-symbols nil) + (newly-exported-symbols nil)) + (loop :for sym :being :each :external-symbol :in package :do + (if (member sym export :test 'string-equal) + (push sym bothly-exported-symbols) + (push sym formerly-exported-symbols))) + (loop :for sym :in export :do + (unless (member sym bothly-exported-symbols :test 'string-equal) + (push sym newly-exported-symbols))) + (loop :for user :in (package-used-by-list package) + :for shadowing = (package-shadowing-symbols user) :do + (loop :for new :in newly-exported-symbols + :for old = (find-sym new user) + :when (and old (not (member old shadowing))) + :do (unintern old user))) + (loop :for x :in newly-exported-symbols :do + (export (intern* x package))))) + (ensure-package (name &key nicknames use unintern fmakunbound shadow export) + (let* ((p (ensure-exists name nicknames use))) + (ensure-unintern p unintern) + (ensure-shadow p shadow) + (ensure-export p export) + (ensure-fmakunbound p fmakunbound) + p))) + (macrolet + ((pkgdcl (name &key nicknames use export + redefined-functions unintern fmakunbound shadow) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions unintern) + :fmakunbound ',(append fmakunbound)))) + (unlink-package :asdf-utilities) + (pkgdcl + :asdf + :use (:common-lisp) + :redefined-functions + (#:perform #:explain #:output-files #:operation-done-p + #:perform-with-restarts #:component-relative-pathname + #:system-source-file #:operate #:find-component #:find-system + #:apply-output-translations #:translate-pathname*) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector) + :fmakunbound + (#:system-source-file + #:component-relative-pathname #:system-relative-pathname + #:process-source-registry + #:inherit-source-registry #:process-source-registry-directive) + :export + (#:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:compile-system #:load-system #:test-system #:clear-system + #:compile-op #:load-op #:load-source-op + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + #:version-satisfies + + #:input-files #:output-files #:output-file #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:module-components-by-name ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-on-warnings + #:operation-on-failure + #:component-visited-p + ;;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*asdf-verbose* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:clear-configuration + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file* + #:compile-file-pathname* + #:enable-asdf-binary-locations-compatibility + #:*default-source-registries* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry + #:system-registered-p + #:asdf-message + + ;; Utilities + #:absolute-pathname-p + ;; #:aif #:it + ;; #:appendf + #:coerce-name + #:directory-pathname-p + ;; #:ends-with + #:ensure-directory-pathname + #:getenv + ;; #:get-uid + ;; #:length=n-p + #:merge-pathnames* + #:pathname-directory-pathname + #:read-file-forms + ;; #:remove-keys + ;; #:remove-keyword + #:resolve-symlinks + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:truenamize + #:while-collecting))) + (setf *asdf-version* asdf-version + *upgraded-p* (if existing-version + (cons existing-version *upgraded-p*) + *upgraded-p*)))))) + +;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +(when *upgraded-p* + #+ecl + (when (find-class 'compile-op nil) + (defmethod update-instance-for-redefined-class :after + ((c compile-op) added deleted plist &key) + (declare (ignore added deleted)) + (let ((system-p (getf plist 'system-p))) + (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) + (when (member 'components-by-name added) + (compute-module-components-by-name m)))))) + +;;;; ------------------------------------------------------------------------- +;;;; User-visible parameters +;;;; +(defun asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." + *asdf-version*) + +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + +(defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* + (or #+sbcl :error #+clisp :ignore :warn) + "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) +when compiling a file? Valid values are :error, :warn, and :ignore. +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") (defvar *verbose-out* nil) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; utility stuff +(defvar *asdf-verbose* t) + +(defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + +#+allegro +(eval-when (:compile-toplevel :execute) + (defparameter *acl-warn-save* + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + excl:*warn-on-nested-reader-conditionals*)) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* nil))) + +;;;; ------------------------------------------------------------------------- +;;;; ASDF Interface, in terms of generic functions. +(macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + `(progn + #+(or ecl gcl) (fmakunbound ',name) + ,(when (and #+ecl (symbolp name)) + `(declaim (notinline ,name))) ; fails for setf functions on ecl + (,',def ,name ,formals , at rest))))) + (defdef defgeneric* defgeneric) + (defdef defun* defun)) + +(defgeneric* find-system (system &optional error-p)) +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) +(defgeneric* component-operation-time (operation component)) +(defgeneric* operation-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + +(defgeneric* system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defgeneric* component-relative-pathname (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) + +(defgeneric* component-property (component property)) + +(defgeneric* (setf component-property) (new-value component property)) + +(defgeneric* version-satisfies (component version)) + +(defgeneric* find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) + +(defgeneric* source-file-type (component system)) + +(defgeneric* operation-ancestor (operation) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) + +(defgeneric* component-visited-p (operation component) + (:documentation "Returns the value stored by a call to +VISIT-COMPONENT, if that has been called, otherwise NIL. +This value stored will be a cons cell, the first element +of which is a computed key, so not interesting. The +CDR wil be the DATA value stored by VISIT-COMPONENT; recover +it as (cdr (component-visited-p op c)). + In the current form of ASDF, the DATA value retrieved is +effectively a boolean, indicating whether some operations are +to be performed in order to do OPERATION X COMPONENT. If the +data value is NIL, the combination had been explored, but no +operations needed to be performed.")) + +(defgeneric* visit-component (operation component data) + (:documentation "Record DATA as being associated with OPERATION +and COMPONENT. This is a side-effecting function: the association +will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the +OPERATION\). + No evidence that DATA is ever interesting, beyond just being +non-NIL. Using the data field is probably very risky; if there is +already a record for OPERATION X COMPONENT, DATA will be quietly +discarded instead of recorded. + Starting with 2.006, TRAVERSE will store an integer in data, +so that nodes can be sorted in decreasing order of traversal.")) + + +(defgeneric* (setf visiting-component) (new-value operation component)) + +(defgeneric* component-visiting-p (operation component)) + +(defgeneric* component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on 's presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defgeneric* component-self-dependencies (operation component)) + +(defgeneric* traverse (operation component) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + + +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities + +(defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + , at body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) -(defun pathname-sans-name+type (pathname) +(defun* pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, -and NIL NAME and TYPE components" - (make-pathname :name nil :type nil :defaults pathname)) +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) + +(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname +does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. +Also, if either argument is NIL, then the other argument is returned unmodified." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (pathname-directory specified)) + #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) + (name (or (pathname-name specified) (pathname-name defaults))) + (type (or (pathname-type specified) (pathname-type defaults))) + (version (or (pathname-version specified) (pathname-version defaults)))) + (labels ((ununspecific (x) + (if (eq x :unspecific) nil x)) + (unspecific-handler (p) + (if (typep p 'logical-pathname) #'ununspecific #'identity))) + (multiple-value-bind (host device directory unspecific-handler) + (#-gcl ecase #+gcl case (first directory) + ((nil) + (values (pathname-host defaults) + (pathname-device defaults) + (pathname-directory defaults) + (unspecific-handler defaults))) + ((:absolute) + (values (pathname-host specified) + (pathname-device specified) + directory + (unspecific-handler specified))) + ((:relative) + (values (pathname-host defaults) + (pathname-device defaults) + (if (pathname-directory defaults) + (append (pathname-directory defaults) (cdr directory)) + directory) + (unspecific-handler defaults))) + #+gcl + (t + (assert (stringp (first directory))) + (values (pathname-host defaults) + (pathname-device defaults) + (append (pathname-directory defaults) directory) + (unspecific-handler defaults)))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + +(define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + +(define-modify-macro orf (&rest args) + or "or a flag") + +(defun* first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun* last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + +(defun* asdf-message (format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply #'format *verbose-out* format-string format-args)) + +(defun* split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (block nil + (let ((list nil) (words 0) (end (length string))) + (flet ((separatorp (char) (find char separator)) + (done () (return (cons (subseq string 0 end) list)))) + (loop + :for start = (if (and max (>= words (1- max))) + (done) + (position-if #'separatorp string :end end :from-end t)) :do + (when (null start) + (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) + +(defun* split-name-type (filename) + (let ((unspecific + ;; Giving :unspecific as argument to make-pathname is not portable. + ;; See CLHS make-pathname and 19.2.2.2.3. + ;; We only use it on implementations that support it. + (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) + (destructuring-bind (name &optional (type unspecific)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename unspecific) + (values name type))))) + +(defun* component-name-to-pathname-components (s &optional force-directory) + "Splits the path string S, returning three values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings, suitable for + use with MAKE-PATHNAME when prepended with the flag + value. +A filename with type extension, possibly NIL in the + case of a directory pathname. +FORCE-DIRECTORY forces S to be interpreted as a directory +pathname \(third return value will be NIL, final component +of S will be treated as part of the directory path. + +The intention of this function is to support structured component names, +e.g., \(:file \"foo/bar\"\), which will be unpacked to relative +pathnames." + (check-type s string) + (let* ((components (split-string s :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char s) #\/) + (values :absolute (cdr components)) + (values :relative nil)) + (values :relative components)) + (setf components (remove "" components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil)) ; "" already removed + (force-directory + (values relative components nil)) + (t + (values relative (butlast components) last-comp)))))) + +(defun* remove-keys (key-names args) + (loop :for (name val) :on args :by #'cddr + :unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + :append (list name val))) + +(defun* remove-keyword (key args) + (loop :for (k v) :on args :by #'cddr + :unless (eq k key) + :append (list k v))) + +(defun* getenv (x) + (#+abcl ext:getenv + #+allegro sys:getenv + #+clisp ext:getenv + #+clozure ccl:getenv + #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) + #+ecl si:getenv + #+gcl system:getenv + #+lispworks lispworks:environment-variable + #+sbcl sb-ext:posix-getenv + x)) + +(defun* directory-pathname-p (pathname) + "Does PATHNAME represent a directory? + +A directory-pathname is a pathname _without_ a filename. The three +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing directory." + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))) + +(defun* ensure-directory-pathname (pathspec) + "Converts the non-wild pathname designator PATHSPEC to directory form." + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (error "Invalid pathname designator ~S" pathspec)) + ((wild-pathname-p pathspec) + (error "Can't reliably convert wild pathnames.")) + ((directory-pathname-p pathspec) + pathspec) + (t + (make-pathname :directory (append (or (pathname-directory pathspec) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil + :defaults pathspec)))) + +(defun* absolute-pathname-p (pathspec) + (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec)))))) + +(defun* length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + +(defun* ends-with (s suffix) + (check-type s string) + (check-type suffix string) + (let ((start (- (length s) (length suffix)))) + (and (<= 0 start) + (string-equal s suffix :start1 start)))) + +(defun* read-file-forms (file) + (with-open-file (in file) + (loop :with eof = (list nil) + :for form = (read in nil eof) + :until (eq form eof) + :collect form))) -(define-modify-macro appendf (&rest args) - append "Append onto list") +#-(and (or win32 windows mswindows mingw32) (not cygwin)) +(progn + #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) + '(ffi:clines "#include " "#include ")) + (defun* get-uid () + #+allegro (excl.osi:getuid) + #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") + :for f = (ignore-errors (read-from-string s)) + :when f :return (funcall f)) + #+(or cmu scl) (unix:unix-getuid) + #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) + '(ffi:c-inline () () :int "getuid()" :one-liner t) + '(ext::getuid)) + #+sbcl (sb-unix:unix-getuid) + #-(or allegro clisp cmu ecl sbcl scl) + (let ((uid-string + (with-output-to-string (*verbose-out*) + (run-shell-command "id -ur")))) + (with-input-from-string (stream uid-string) + (read-line stream) + (handler-case (parse-integer (read-line stream)) + (error () (error "Unable to find out user ID"))))))) + +(defun* pathname-root (pathname) + (make-pathname :host (pathname-host pathname) + :device (pathname-device pathname) + :directory '(:absolute) + :name nil :type nil :version nil)) + +(defun* probe-file* (p) + "when given a pathname P, probes the filesystem for a file or directory +with given pathname and if it exists return its truename." + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) + '(ignore-errors (truename p))))))) + +(defun* truenamize (p) + "Resolve as much of a pathname as possible" + (block nil + (when (typep p 'logical-pathname) (return p)) + (let* ((p (merge-pathnames* p)) + (directory (pathname-directory p))) + (when (typep p 'logical-pathname) (return p)) + (let ((found (probe-file* p))) + (when found (return found))) + #-(or sbcl cmu) (when (stringp directory) (return p)) + (when (not (eq :absolute (car directory))) (return p)) + (let ((sofar (probe-file* (pathname-root p)))) + (unless sofar (return p)) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname :host nil :device nil + :directory `(:relative , at directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :for component :in (cdr directory) + :for rest :on (cdr directory) + :for more = (probe-file* + (merge-pathnames* + (make-pathname :directory `(:relative ,component)) + sofar)) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) + +(defun* resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro (excl:pathname-resolve-symbolic-links path)) + +(defun* default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + +(defun* lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) + +(defparameter *wild-path* + (make-pathname :directory '(:relative :wild-inferiors) + :name :wild :type :wild :version :wild)) + +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) + +(defun* directorize-pathname-host-device (pathname) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) + (separator (last-char (namestring foo))) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + (lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components root-string t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname :defaults root + :directory `(:absolute , at path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; classes, condiitons +;;;; ------------------------------------------------------------------------- +;;;; Classes, Conditions (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. @@ -148,40 +851,78 @@ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name + circular-dependency-components) + (ftype (function (t t) t) (setf module-components-by-name))) + + (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply #'format s (format-control c) (format-arguments c))))) + +(define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s "~@" + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) - ((components :initarg :components :reader circular-dependency-components))) + ((components :initarg :components :reader circular-dependency-components)) + (:report (lambda (c s) + (format s "~@" (circular-dependency-components c))))) + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s "~@" + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) +(define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation - "Component name: designator for a string composed of portable pathname characters") + "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - (in-order-to :initform nil :initarg :in-order-to) - ;;; XXX crap name - (do-first :initform nil :initarg :do-first) + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? + ;; POIU is a parallel (multi-process build) extension of ASDF. See + ;; http://www.cliki.net/poiu + (load-dependencies :accessor component-load-dependencies :initform nil) + ;; XXX crap name, but it's an official API name! + (do-first :initform nil :initarg :do-first + :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated @@ -190,90 +931,118 @@ ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) - (operation-times :initform (make-hash-table ) - :accessor component-operation-times) + (absolute-pathname) + (operation-times :initform (make-hash-table) + :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties - :initform nil))) + :initform nil))) + +(defun* component-find-path (component) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) + ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" - (call-next-method c nil) (missing-required-by c))) + (call-next-method c nil) (missing-required-by c))) -(defun sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) +(defun* sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@" - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (component-name (missing-parent c))))) + (format s "~@" + (missing-requires c) + (when (missing-parent c) + (component-name (missing-parent c))))) + +(defmethod print-object ((c missing-component-of-version) s) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) -(defgeneric component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) - (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity t) - (ignore-errors - (prin1 (component-name c) stream)))) - -(defclass module (component) - ((components :initform nil :accessor module-components :initarg :components) - ;; what to do if we can't satisfy a dependency of one of this module's - ;; components. This allows a limited form of conditional processing - (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) - (default-component-class :accessor module-default-component-class - :initform 'cl-source-file :initarg :default-component-class))) - -(defgeneric component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) +(defvar *default-component-class* 'cl-source-file) -(defun component-parent-pathname (component) - (aif (component-parent component) - (component-pathname it) - *default-pathname-defaults*)) +(defun* compute-module-components-by-name (module) + (let ((hash (make-hash-table :test 'equal))) + (setf (module-components-by-name module) hash) + (loop :for c :in (module-components module) + :for name = (component-name c) + :for previous = (gethash name (module-components-by-name module)) + :do + (when previous + (error 'duplicate-names :name name)) + :do (setf (gethash name (module-components-by-name module)) c)) + hash)) -(defgeneric component-relative-pathname (component) - (:documentation "Extracts the relative pathname applicable for a particular component.")) - -(defmethod component-relative-pathname ((component module)) - (or (slot-value component 'relative-pathname) - (make-pathname - :directory `(:relative ,(component-name component)) - :host (pathname-host (component-parent-pathname component))))) +(defclass module (component) + ((components + :initform nil + :initarg :components + :accessor module-components) + (components-by-name + :accessor module-components-by-name) + ;; What to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing. + (if-component-dep-fails + :initform :fail + :initarg :if-component-dep-fails + :accessor module-if-component-dep-fails) + (default-component-class + :initform *default-component-class* + :initarg :default-component-class + :accessor module-default-component-class))) + +(defun* component-parent-pathname (component) + ;; No default anymore (in particular, no *default-pathname-defaults*). + ;; If you force component to have a NULL pathname, you better arrange + ;; for any of its children to explicitly provide a proper absolute pathname + ;; wherever a pathname is actually wanted. + (let ((parent (component-parent component))) + (when parent + (component-pathname parent)))) (defmethod component-pathname ((component component)) - (let ((*default-pathname-defaults* (component-parent-pathname component))) - (merge-pathnames (component-relative-pathname component)))) - -(defgeneric component-property (component property)) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error "Invalid relative pathname ~S for component ~S" + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) -(defgeneric (setf component-property) (new-value component property)) - (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties)))))) + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value) (defclass system (module) ((description :accessor system-description :initarg :description) @@ -281,173 +1050,362 @@ :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) - -;;; version-satisfies + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license) + (source-file :reader system-source-file :initarg :source-file + :writer %set-system-source-file))) -;;; with apologies to christophe rhodes ... -(defun split (string &optional max (ws '(#\Space #\Tab))) - (flet ((is-ws (char) (find char ws))) - (nreverse - (let ((list nil) (start 0) (words 0) end) - (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) - -(defgeneric version-satisfies (component version)) +;;;; ------------------------------------------------------------------------- +;;;; version-satisfies (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) + (version-satisfies (component-version c) version)) + +(defmethod version-satisfies ((cver string) version) (let ((x (mapcar #'parse-integer - (split (component-version c) nil '(#\.)))) - (y (mapcar #'parse-integer - (split version nil '(#\.))))) + (split-string cver :separator "."))) + (y (mapcar #'parse-integer + (split-string version :separator ".")))) (labels ((bigger (x y) - (cond ((not y) t) - ((not x) nil) - ((> (car x) (car y)) t) - ((= (car x) (car y)) - (bigger (cdr x) (cdr y)))))) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding systems +;;;; ------------------------------------------------------------------------- +;;;; Finding systems -(defvar *defined-systems* (make-hash-table :test 'equal)) -(defun coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error "~@" name)))) +(defun* make-defined-systems-table () + (make-hash-table :test 'equal)) + +(defvar *defined-systems* (make-defined-systems-table) + "This is a hash table whose keys are strings, being the +names of the systems, and whose values are pairs, the first +element of which is a universal-time indicating when the +system definition was last updated, and the second element +of which is a system object.") + +(defun* coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) + +(defun* system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +(defun* clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and a general such operation + ;; cannot be portably written, considering how much CL relies on side-effects + ;; of global data structures. + ;; Note that this does a setf gethash instead of a remhash + ;; this way there remains a hint in the *defined-systems* table + ;; that the system was loaded at some point. + (setf (gethash (coerce-name name) *defined-systems*) nil)) + +(defun* map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (maphash (lambda (_ datum) + (declare (ignore _)) + (destructuring-bind (_ . def) datum + (declare (ignore _)) + (funcall fn def))) + *defined-systems*)) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defvar *system-definition-search-functions* - '(sysdef-central-registry-search)) +(defparameter *system-definition-search-functions* + '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) -(defun system-definition-pathname (system) - (some (lambda (x) (funcall x system)) - *system-definition-search-functions*)) - -(defvar *central-registry* - '(*default-pathname-defaults* - #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" - #+nil "telent:asdf;systems;")) - -(defun sysdef-central-registry-search (system) - (let ((name (coerce-name system))) +(defun* system-definition-pathname (system) + (let ((system-name (coerce-name system))) + (or + (some (lambda (x) (funcall x system-name)) + *system-definition-search-functions*) + (let ((system-pair (system-registered-p system-name))) + (and system-pair + (system-source-file (cdr system-pair))))))) + +(defvar *central-registry* nil +"A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This is for backward compatibilily. +Going forward, we recommend new users should be using the source-registry. +") + +(defun* probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let ((file + (make-pathname + :defaults defaults :version :newest :case :local + :name name + :type "asd"))) + (when (probe-file file) + (return file))) + #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target))))))))) + +(defun* sysdef-central-registry-search (system) + (let ((name (coerce-name system)) + (to-remove nil) + (to-replace nil)) (block nil - (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file))))))) - - -(defun find-system (name &optional (error-p t)) - (let* ((name (coerce-name name)) - (in-memory (gethash name *defined-systems*)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (file-write-date on-disk)))) - (let ((*package* (make-package (gensym #.(package-name *package*)) - :use '(:cl :asdf)))) - (format *verbose-out* - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) - (load on-disk))) - (let ((in-memory (gethash name *defined-systems*))) - (if in-memory - (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) - (cdr in-memory)) - (if error-p (error 'missing-component :requires name)))))) - -(defun register-system (name system) - (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) - -(defun system-registered-p (name) - (gethash (coerce-name name) *defined-systems*)) + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir))) + (when defaults + (cond ((directory-pathname-p defaults) + (let ((file (probe-asd name defaults))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + "~@" + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :report (lambda (s) + (format s "Coerce entry to ~a, replace ~a and continue." + (ensure-directory-pathname defaults) dir)) + (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position)))))))))) + +(defun* make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "~A~D" :asdf counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defun* safe-file-write-date (pathname) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls operation-done-p which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (or (and pathname (probe-file pathname) (file-write-date pathname)) + (progn + (when (and pathname *asdf-verbose*) + (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." + pathname)) + 0))) + +(defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + +(defmethod find-system ((name string) &optional (error-p t)) + (catch 'find-system + (let* ((in-memory (system-registered-p name)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (safe-file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname on-disk + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + on-disk *package*) + (load on-disk))) + (delete-package package)))) + (let ((in-memory (system-registered-p name))) + (cond + (in-memory + (when on-disk + (setf (car in-memory) (safe-file-write-date on-disk))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name))))))) + +(defun* register-system (name system) + (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun* find-system-fallback (requested fallback &optional source-file) + (setf fallback (coerce-name fallback) + source-file (or source-file *compile-file-truename* *load-truename*) + requested (coerce-name requested)) + (when (equal requested fallback) + (let* ((registered (cdr (gethash fallback *defined-systems*))) + (system (or registered + (make-instance + 'system :name fallback + :source-file source-file)))) + (unless registered + (register-system fallback system)) + (throw 'find-system system)))) + +(defun* sysdef-find-asdf (name) + (find-system-fallback name "asdf")) + + +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) + +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((module module) (name string)) + (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! + (compute-module-components-by-name module)) + (values (gethash name (module-components-by-name module)))) + +(defmethod find-component ((component component) (name symbol)) + (if name + (find-component component (coerce-name name)) + component)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding components +(defmethod find-component ((module module) (name cons)) + (find-component (find-component module (car name)) (cdr name))) -(defgeneric find-component (module name &optional version) - (:documentation "Finds the component with name NAME present in the -MODULE module; if MODULE is nil, then the component is assumed to be a -system.")) - -(defmethod find-component ((module module) name &optional version) - (if (slot-boundp module 'components) - (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) - - -;;; a component with no parent is a system -(defmethod find-component ((module (eql nil)) name &optional version) - (let ((m (find-system name nil))) - (if (and m (version-satisfies m version)) m))) ;;; component subclasses -(defclass source-file (component) ()) +(defclass source-file (component) + ((type :accessor source-file-explicit-type :initarg :type :initform nil))) -(defclass cl-source-file (source-file) ()) -(defclass c-source-file (source-file) ()) -(defclass java-source-file (source-file) ()) +(defclass cl-source-file (source-file) + ((type :initform "lisp"))) +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) (defclass static-file (source-file) ()) (defclass doc-file (static-file) ()) -(defclass html-file (doc-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) -(defgeneric source-file-type (component system)) -(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") -(defmethod source-file-type ((c c-source-file) (s module)) "c") -(defmethod source-file-type ((c java-source-file) (s module)) "java") -(defmethod source-file-type ((c html-file) (s module)) "html") -(defmethod source-file-type ((c static-file) (s module)) nil) - -(defmethod component-relative-pathname ((component source-file)) - (let* ((*default-pathname-defaults* (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) - (if (slot-value component 'relative-pathname) - (merge-pathnames - (slot-value component 'relative-pathname) - name-type) - name-type))) +(defmethod source-file-type ((component module) (s module)) + (declare (ignorable component s)) + :directory) +(defmethod source-file-type ((component source-file) (s module)) + (declare (ignorable s)) + (source-file-explicit-type component)) + +(defun* merge-component-name-type (name &key type defaults) + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you either (a) use absolute pathnames, or + ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of + ;; ASDF:MERGE-PATHNAMES* + (etypecase name + (pathname + name) + (symbol + (merge-component-name-type (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components name (eq type :directory)) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) + (host (pathname-host defaults)) + (device (pathname-device defaults))) + (make-pathname :directory `(,relative , at path) + :name name :type type + :host host :device device))))))) + +(defmethod component-relative-pathname ((component component)) + (merge-component-name-type + (or (slot-value component 'relative-pathname) + (component-name component)) + :type (source-file-type component (component-system component)) + :defaults (component-parent-pathname component))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; operations +;;;; ------------------------------------------------------------------------- +;;;; Operations -;;; one of these is instantiated whenever (operate ) is called +;;; one of these is instantiated whenever #'operate is called (defclass operation () - ((forced :initform nil :initarg :force :accessor operation-forced) + ( + ;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of existing system, + ;; but not recurse to other systems we depend on. + ;; :ALL (or any other atom) to force all systems + ;; including other systems we depend on. + ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) + ;; to force systems named in a given list + ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. + (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs - :accessor operation-original-initargs) - (visited-nodes :initform nil :accessor operation-visited-nodes) - (visiting-nodes :initform nil :accessor operation-visiting-nodes) + :accessor operation-original-initargs) + (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) @@ -456,326 +1414,580 @@ (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force - &allow-other-keys) - (declare (ignore slot-names force)) + &key force + &allow-other-keys) + (declare (ignorable operation slot-names force)) ;; empty method to disable initarg validity checking - ) - -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) + (values)) -(defun node-for (o c) +(defun* node-for (o c) (cons (class-name (class-of o)) c)) -(defgeneric operation-ancestor (operation) - (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) - (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) (operation-ancestor it) operation)) -(defun make-sub-operation (c o dep-c dep-o) +(defun* make-sub-operation (c o dep-c dep-o) + "C is a component, O is an operation, DEP-C is another +component, and DEP-O, confusingly enough, is an operation +class specifier, not an operation." (let* ((args (copy-list (operation-original-initargs o))) - (force-p (getf args :force))) + (force-p (getf args :force))) ;; note explicit comparison with T: any other non-NIL force value ;; (e.g. :recursive) will pass through (cond ((and (null (component-parent c)) - (null (component-parent dep-c)) - (not (eql c dep-c))) - (when (eql force-p t) - (setf (getf args :force) nil)) - (apply #'make-instance dep-o - :parent o - :original-initargs args args)) - ((subtypep (type-of o) dep-o) - o) - (t - (apply #'make-instance dep-o - :parent o :original-initargs args args))))) - + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) -(defgeneric visit-component (operation component data)) (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) - (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) - -(defgeneric component-visited-p (operation component)) + (setf (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o))) + (cons t data)))) (defmethod component-visited-p ((o operation) (c component)) - (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) - -(defgeneric (setf visiting-component) (new-value operation component)) + (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o)))) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables - (declare (ignorable new-value operation component))) + (declare (ignorable operation component)) + new-value) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) - (a (operation-ancestor o))) + (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal))))) - -(defgeneric component-visiting-p (operation component)) + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) (defmethod component-visiting-p ((o operation) (c component)) - (let ((node (cons o c))) - (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + (let ((node (node-for o c))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) -(defgeneric component-depends-on (operation component)) +(defmethod component-depends-on ((op-spec symbol) (c component)) + (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) - (slot-value c 'in-order-to)))) - -(defgeneric component-self-dependencies (operation component)) + (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) - + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) - (self-deps (component-self-dependencies operation c))) + (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) - self-deps) - ;; no previous operations needed? I guess we work with the - ;; original source file, then - (list (component-pathname c))))) + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) -(defmethod input-files ((operation operation) (c module)) nil) +(defmethod component-operation-time (o c) + (gethash (type-of o) (component-operation-times c))) (defmethod operation-done-p ((o operation) (c component)) (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) - -;;; So you look at this code and think "why isn't it a bunch of -;;; methods". And the answer is, because standard method combination -;;; runs :before methods most->least-specific, which is back to front -;;; for our purposes. And CLISP doesn't have non-standard method -;;; combinations, so let's keep it simple and aspire to portability - -(defgeneric traverse (operation component)) -(defmethod traverse ((operation operation) (c component)) - (let ((forced nil)) - (labels ((do-one-dep (required-op required-c required-v) - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-dep (op dep) - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) - (t - (dolist (d dep) - (cond ((consp d) - (assert (string-equal - (symbol-name (first d)) - "VERSION")) - (appendf forced - (do-one-dep op (second d) (third d)))) - (t - (appendf forced (do-one-dep op d nil))))))))) + (in-files (input-files o c)) + (op-time (component-operation-time o c))) + (flet ((earliest-out () + (reduce #'min (mapcar #'safe-file-write-date out-files))) + (latest-in () + (reduce #'max (mapcar #'safe-file-write-date in-files)))) + (cond + ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much. + ;; e.g. operations on systems, modules that have no immediate action, + ;; but are only meaningful through traversed dependencies + t) + ((not out-files) + ;; an operation without output-files is probably meant + ;; for its side-effects in the current image, + ;; assumed to be idem-potent, + ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. + (and op-time (>= op-time (latest-in)))) + ((not in-files) + ;; an operation without output-files and no input-files + ;; is probably meant for its side-effects on the file-system, + ;; assumed to have to be done everytime. + ;; (I don't think there is any such case in ASDF unless extended) + nil) + (t + ;; an operation with both input and output files is assumed + ;; as computing the latter from the former, + ;; assumed to have been done if the latter are all older + ;; than the former. + ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. + ;; We use >= instead of > to play nice with generated files. + ;; This opens a race condition if an input file is changed + ;; after the output is created but within the same second + ;; of filesystem time; but the same race condition exists + ;; whenever the computation from input to output takes more + ;; than one second of filesystem time (or just crosses the + ;; second). So that's cool. + (and + (every #'probe-file in-files) + (every #'probe-file out-files) + (>= (earliest-out) (latest-in)))))))) + + + +;;; For 1.700 I've done my best to refactor TRAVERSE +;;; by splitting it up in a bunch of functions, +;;; so as to improve the collection and use-detection algorithm. --fare +;;; The protocol is as follows: we pass around operation, dependency, +;;; bunch of other stuff, and a force argument. Return a force flag. +;;; The returned flag is T if anything has changed that requires a rebuild. +;;; The force argument is a list of components that will require a rebuild +;;; if the flag is T, at which point whoever returns the flag has to +;;; mark them all as forced, and whoever recurses again can use a NIL list +;;; as a further argument. + +(defvar *forcing* nil + "This dynamically-bound variable is used to force operations in +recursive calls to traverse.") + +(defgeneric* do-traverse (operation component collect)) + +(defun* %do-one-dep (operation c collect required-op required-c required-v) + ;; collects a partial plan that results from performing required-op + ;; on required-c, possibly with a required-vERSION + (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) + (and d (version-satisfies d required-v) d)) + (if required-v + (error 'missing-dependency-of-version + :required-by c + :version required-v + :requires required-c) + (error 'missing-dependency + :required-by c + :requires required-c)))) + (op (make-sub-operation c operation dep-c required-op))) + (do-traverse op dep-c collect))) + +(defun* do-one-dep (operation c collect required-op required-c required-v) + ;; this function is a thin, error-handling wrapper around + ;; %do-one-dep. Returns a partial plan per that function. + (loop + (restart-case + (return (%do-one-dep operation c collect + required-op required-c required-v)) + (retry () + :report (lambda (s) + (format s "~@" + (component-find-path required-c))) + :test + (lambda (c) + #| + (print (list :c1 c (typep c 'missing-dependency))) + (when (typep c 'missing-dependency) + (print (list :c2 (missing-requires c) required-c + (equalp (missing-requires c) + required-c)))) + |# + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) + +(defun* do-dep (operation c collect op dep) + ;; type of arguments uncertain: + ;; op seems to at least potentially be a symbol, rather than an operation + ;; dep is a list of component names + (cond ((eq op 'feature) + (if (member (car dep) *features*) + nil + (error 'missing-dependency + :required-by c + :requires (car dep)))) + (t + (let ((flag nil)) + (flet ((dep (op comp ver) + (when (do-one-dep operation c collect + op comp ver) + (setf flag t)))) + (dolist (d dep) + (if (atom d) + (dep op d nil) + ;; structured dependencies --- this parses keywords + ;; the keywords could be broken out and cleanly (extensibly) + ;; processed by EQL methods + (cond ((eq :version (first d)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (dep op (second d) (third d))) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + ((eq :feature (first d)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second d) *features* :test 'string-equal) + (dep op (third d) nil))) + (t + (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) + flag)))) + +(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes + +(defun* do-collect (collect x) + (funcall collect x)) + +(defmethod do-traverse ((operation operation) (c component) collect) + (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (labels + ((update-flag (x) + (when x + (setf flag t))) + (dep (op comp) + (update-flag (do-dep operation c collect op comp)))) + ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (progn + (update-flag (cdr it)) + (return-from do-traverse flag))) ;; dependencies - (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (when (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) - (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) - (setf (visiting-component operation c) nil) - (visit-component operation c (and forced t)) - forced))) - + (unwind-protect + (progn + ;; first we check and do all the dependencies for the module. + ;; Operations planned in this loop will show up + ;; in the results, and are consumed below. + (let ((*forcing* nil)) + ;; upstream dependencies are never forced to happen just because + ;; the things that depend on them are.... + (loop + :for (required-op . deps) :in (component-depends-on operation c) + :do (dep required-op deps))) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag + (or + *forcing* + (not (operation-done-p operation c)) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=))))))) + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) + +(defun* flatten-tree (l) + ;; You collected things into a list. + ;; Most elements are just things to collect again. + ;; A (simple-vector 1) indicate that you should recurse into its contents. + ;; This way, in two passes (rather than N being the depth of the tree), + ;; you can collect things with marginally constant-time append, + ;; achieving linear time collection instead of quadratic time. + (while-collecting (c) + (labels ((r (x) + (if (typep x '(simple-vector 1)) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) + +(defmethod traverse ((operation operation) (c component)) + ;; cerror'ing a feature that seems to have NEVER EVER worked + ;; ever since danb created it in his 2003-03-16 commit e0d02781. + ;; It was both fixed and disabled in the 1.700 rewrite. + (when (consp (operation-forced operation)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") + (setf (operation-forced operation) + (mapcar #'coerce-name (operation-forced operation)))) + (flatten-tree + (while-collecting (collect) + (let ((*visit-count* 0)) + (do-traverse operation c #'collect))))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@" + "~@" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) + (declare (ignorable operation c)) nil) (defmethod explain ((operation operation) (component component)) - (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + (asdf-message "~&;;; ~A~%" (operation-description operation component))) + +(defmethod operation-description (operation component) + (format nil "~A on component ~S" (class-of operation) (component-find-path component))) -;;; compile-op +;;;; ------------------------------------------------------------------------- +;;;; compile-op (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (on-warnings :initarg :on-warnings :accessor operation-on-warnings - :initform *compile-file-warnings-behaviour*) + :initform *compile-file-warnings-behaviour*) (on-failure :initarg :on-failure :accessor operation-on-failure - :initform *compile-file-failure-behaviour*))) + :initform *compile-file-failure-behaviour*) + (flags :initarg :flags :accessor compile-op-flags + :initform #-ecl nil #+ecl '(:system-p t)))) + +(defun output-file (operation component) + "The unique output file of performing OPERATION on COMPONENT" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) (defmethod perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) +#+ecl +(defmethod perform :after ((o compile-op) (c cl-source-file)) + ;; Note how we use OUTPUT-FILES to find the binary locations + ;; This allows the user to override the names. + (let* ((files (output-files o c)) + (object (first files)) + (fasl (second files))) + (c:build-fasl fasl :lisp-files (list object)))) + (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (get-universal-time))) + +(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) + (values t t t)) + compile-file*)) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (output-file (first (output-files operation c))) + (*compile-file-warnings-behaviour* (operation-on-warnings operation)) + (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) - ;(declare (ignore output)) + (apply #'compile-file* source-file :output-file output-file + (compile-op-flags operation)) (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - "~@" - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (case (operation-on-warnings operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) (when failure-p - (case (operation-on-failure operation) - (:warn (warn - "~@" - operation c)) - (:error (error 'compile-failed :component c :operation operation)) - (:ignore nil))) + (case (operation-on-failure operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) (unless output - (error 'compile-error :component c :operation operation))))) + (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) - #+:broken-fasl-loader (list (component-pathname c))) + (declare (ignorable operation)) + (let ((p (lispize-pathname (component-pathname c)))) + #-:broken-fasl-loader + (list (compile-file-pathname p #+ecl :type #+ecl :object) + #+ecl (compile-file-pathname p :type :fasl)) + #+:broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod input-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) -;;; load-op +(defmethod operation-description ((operation compile-op) component) + (declare (ignorable operation)) + (format nil "compiling component ~S" (component-find-path component))) -(defclass load-op (operation) ()) +;;;; ------------------------------------------------------------------------- +;;;; load-op + +(defclass basic-load-op (operation) ()) + +(defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) - (mapcar #'load (input-files o c))) + #-ecl (mapcar #'load (input-files o c)) + #+ecl (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (let ((output (compile-file-pathname (lispize-pathname i)))) + (load output)))) + +(defmethod perform-with-restarts (operation component) + (perform operation component)) + +(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (declare (ignorable o)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-load + (setf state :recompiled) + (perform (make-instance 'compile-op) c)) + (t + (with-simple-restart + (try-recompiling "Recompile ~a and try loading it again" + (component-name c)) + (setf state :failed-load) + (call-next-method) + (setf state :success)))))) + +(defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-compile + (setf state :recompiled) + (perform-with-restarts o c)) + (t + (with-simple-restart + (try-recompiling "Try recompiling ~a" + (component-name c)) + (setf state :failed-compile) + (call-next-method) + (setf state :success)))))) (defmethod perform ((operation load-op) (c static-file)) + (declare (ignorable operation c)) nil) + (defmethod operation-done-p ((operation load-op) (c static-file)) + (declare (ignorable operation c)) t) -(defmethod output-files ((o operation) (c component)) +(defmethod output-files ((operation operation) (c component)) + (declare (ignorable operation c)) nil) (defmethod component-depends-on ((operation load-op) (c component)) + (declare (ignorable operation)) (cons (list 'compile-op (component-name c)) (call-next-method))) -;;; load-source-op +(defmethod operation-description ((operation load-op) component) + (declare (ignorable operation)) + (format nil "loading component ~S" (component-find-path component))) + + +;;;; ------------------------------------------------------------------------- +;;;; load-source-op -(defclass load-source-op (operation) ()) +(defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) + (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) (and (load source) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation load-source-op) (c component)) + (declare (ignorable operation c)) nil) ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op - (slot-value c 'in-order-to))))) + (component-in-order-to c))))) (mapcar (lambda (dep) (if (eq (car dep) 'load-op) (cons 'load-source-op (cdr dep)) @@ -783,320 +1995,1522 @@ what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) + (declare (ignorable o)) (if (or (not (component-property c 'last-loaded-as-source)) - (> (file-write-date (component-pathname c)) - (component-property c 'last-loaded-as-source))) + (> (safe-file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) nil t)) +(defmethod operation-description ((operation load-source-op) component) + (declare (ignorable operation)) + (format nil "loading component ~S" (component-find-path component))) + + +;;;; ------------------------------------------------------------------------- +;;;; test-op + (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) + (declare (ignorable operation c)) nil) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; invoking operations +(defmethod operation-done-p ((operation test-op) (c system)) + "Testing a system is _never_ done." + (declare (ignorable operation c)) + nil) -(defun operate (operation-class system &rest args) - (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) - (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) - -(defun oos (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; syntax - -(defun remove-keyword (key arglist) - (labels ((aux (key arglist) - (cond ((null arglist) nil) - ((eq key (car arglist)) (cddr arglist)) - (t (cons (car arglist) (cons (cadr arglist) - (remove-keyword - key (cddr arglist)))))))) - (aux key arglist))) +(defmethod component-depends-on :around ((o test-op) (c system)) + (declare (ignorable o)) + (cons `(load-op ,(component-name c)) (call-next-method))) + + +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(defgeneric* operate (operation-class system &key &allow-other-keys)) + +(defmethod operate (operation-class system &rest args + &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force + &allow-other-keys) + (declare (ignore force)) + (let* ((*package* *package*) + (*readtable* *readtable*) + (op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (loop + (restart-case + (progn + (perform-with-restarts op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" (operation-description op component)))) + (accept () + :report + (lambda (s) + (format s "~@" + (operation-description op component))) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))) + (values op steps)))) + +(defun* oos (operation-class system &rest args &key force verbose version + &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(let ((operate-docstring + "Operate does three things: + +1. It creates an instance of OPERATION-CLASS using any keyword parameters +as initargs. +2. It finds the asdf-system specified by SYSTEM (possibly loading +it from disk). +3. It then calls TRAVERSE with the operation and system as arguments + +The traverse operation is wrapped in WITH-COMPILATION-UNIT and error +handling code. If a VERSION argument is supplied, then operate also +ensures that the system found satisfies it using the VERSION-SATISFIES +method. + +Note that dependencies may cause the operation to invoke other +operations on the system or its components: the new operations will be +created with the same initargs as the original one. +")) + (setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + operate-docstring)) + (setf (documentation 'operate 'function) + operate-docstring)) + +(defun* load-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for +details." + (declare (ignore force verbose version)) + (apply #'operate 'load-op system args)) + +(defun* compile-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE +for details." + (declare (ignore force verbose version)) + (apply #'operate 'compile-op system args)) + +(defun* test-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for +details." + (declare (ignore force verbose version)) + (apply #'operate 'test-op system args)) + +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(defun* load-pathname () + (let ((pn (or *load-pathname* *compile-file-pathname*))) + (if *resolve-symlinks* + (and pn (resolve-symlinks pn)) + pn))) + +(defun* determine-system-pathname (pathname pathname-supplied-p) + ;; The defsystem macro calls us to determine + ;; the pathname of a system as follows: + ;; 1. the one supplied, + ;; 2. derived from *load-pathname* via load-pathname + ;; 3. taken from the *default-pathname-defaults* via default-directory + (let* ((file-pathname (load-pathname)) + (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) + (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) + directory-pathname + (default-directory)))) (defmacro defsystem (name &body options) - (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options - (let ((component-options (remove-keyword :class options))) + (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) + defsystem-depends-on &allow-other-keys) + options + (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) - *default-pathname-defaults*) - ',component-options)))))) - - -(defun class-for-type (parent type) - (let ((class - (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.(package-name *package*))) - nil))) - (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class 'cl-source-file))) - (sysdef-error "~@" type)))) + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + ,@(loop :for system :in defsystem-depends-on + :collect `(load-system ,system)) + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name)))) + (%set-system-source-file (load-pathname) + (cdr (system-registered-p ',name)))) + (parse-component-form + nil (list* + :module (coerce-name ',name) + :pathname + ,(determine-system-pathname pathname pathname-arg-p) + ',component-options)))))) + +(defun* class-for-type (parent type) + (or (loop :for symbol :in (list + (unless (keywordp type) type) + (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class (subtypep class 'component)) + :return class) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class *default-component-class*))) + (sysdef-error "~@" type))) -(defun maybe-add-tree (tree op1 op2 c) +(defun* maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. Returns the new tree (which probably shares structure with the old one)" (let ((first-op-tree (assoc op1 tree))) (if first-op-tree - (progn - (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) - nil - (setf (cdr it) (cons c (cdr it)))) - (setf (cdr first-op-tree) - (acons op2 (list c) (cdr first-op-tree)))) - tree) - (acons op1 (list (list op2 c)) tree)))) - -(defun union-of-dependencies (&rest deps) + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun* union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) - (dolist (op (cdr op-tree)) - (dolist (c (cdr op)) - (setf new-tree - (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) new-tree)) -(defun remove-keys (key-names args) - (loop for ( name val ) on args by #'cddr - unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - append (list name val))) - -(defvar *serial-depends-on*) +(defvar *serial-depends-on* nil) -(defun parse-component-form (parent options) - (destructuring-bind - (type name &rest rest &key - ;; the following list of keywords is reproduced below in the - ;; remove-keys form. important to keep them in sync - components pathname default-component-class - perform explain output-files operation-done-p - depends-on serial in-order-to - ;; list ends - &allow-other-keys) options - (check-component-input type name depends-on components in-order-to) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - depends-on serial in-order-to) - rest)) - (ret - (or (find-component parent name) - (make-instance (class-for-type parent type))))) - (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) - (apply #'reinitialize-instance - ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) - (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) - (let ((*serial-depends-on* nil)) - (setf (module-components ret) - (loop for c-form in components - for c = (parse-component-form ret c-form) - collect c - if serial - do (push (component-name c) *serial-depends-on*))))) - - (setf (slot-value ret 'in-order-to) - (union-of-dependencies - in-order-to - `((compile-op (compile-op , at depends-on)) - (load-op (load-op , at depends-on)))) - (slot-value ret 'do-first) `((compile-op (load-op , at depends-on)))) - - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - , at body)) - (component-inline-methods ret)))) - ret))) +(defun* sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~S") + type name value)) -(defun check-component-input (type name depends-on components in-order-to) +(defun* check-component-input (type name weakly-depends-on + depends-on components in-order-to) "A partial test of the values of a component." (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." - type name depends-on)) + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." - type name components)) + type name components)) (unless (and (listp in-order-to) (listp (car in-order-to))) (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) + type name in-order-to))) -(defun sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") - type name value)) +(defun* %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + (lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + ;; clear methods, then add the new ones + (setf (component-inline-methods component) nil)) + +(defun* %define-component-inline-methods (ret rest) + (dolist (name +asdf-methods+) + (let ((keyword (intern (symbol-name name) :keyword))) + (loop :for data = rest :then (cddr data) + :for key = (first data) + :for value = (second data) + :while data + :when (eq key keyword) :do + (destructuring-bind (op qual (o c) &body body) value + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + , at body)) + (component-inline-methods ret))))))) + +(defun* %refresh-component-inline-methods (component rest) + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest)) -(defun resolve-symlinks (path) - #-allegro (truename path) - #+allegro (excl:pathname-resolve-symbolic-links path) - ) +(defun* parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (when *serial-depends-on* + (push *serial-depends-on* depends-on)) + (apply #'reinitialize-instance ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) + (component-pathname ret) ; eagerly compute the absolute pathname + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop + :for c-form :in components + :for c = (parse-component-form ret c-form) + :for name = (component-name c) + :collect c + :when serial :do (setf *serial-depends-on* name)))) + (compute-module-components-by-name ret)) + + (setf (component-load-dependencies ret) depends-on) ;; Used by POIU + + (setf (component-in-order-to ret) + (union-of-dependencies + in-order-to + `((compile-op (compile-op , at depends-on)) + (load-op (load-op , at depends-on))))) + (setf (component-do-first ret) `((compile-op (load-op , at depends-on)))) -;;; optional extras + (%refresh-component-inline-methods ret rest) + ret))) -;;; run-shell-command functions for other lisp implementations will be -;;; gratefully accepted, if they do the same thing. If the docstring -;;; is ambiguous, send a bug report +;;;; --------------------------------------------------------------------------- +;;;; run-shell-command +;;;; +;;;; run-shell-command functions for other lisp implementations will be +;;;; gratefully accepted, if they do the same thing. +;;;; If the docstring is ambiguous, send a bug report. +;;;; +;;;; We probably should move this functionality to its own system and deprecate +;;;; use of it from the asdf package. However, this would break unspecified +;;;; existing software, so until a clear alternative exists, we can't deprecate +;;;; it, and even after it's been deprecated, we will support it for a few +;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 -(defun run-shell-command (control-string &rest args) +(defun* run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with -output to *verbose-out*. Returns the shell's exit code." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) - (format *verbose-out* "; $ ~A~%" command) - #+sbcl - (sb-impl::process-exit-code - (sb-ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) - - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) + (asdf-message "; $ ~A~%" command) + + #+abcl + (ext:run-shell-command command :output *verbose-out*) #+allegro - (excl:run-shell-command command :input nil :output *verbose-out*) - + ;; will this fail if command has embedded quotes - it seems to work + (multiple-value-bind (stdout stderr exit-code) + (excl.osi:command-output + (format nil "~a -c \"~a\"" + #+mswindows "sh" #-mswindows "/bin/sh" command) + :input nil :whole nil + #+mswindows :show-window #+mswindows :hide) + (format *verbose-out* "~{~&; ~a~%~}~%" stderr) + (format *verbose-out* "~{~&; ~a~%~}~%" stdout) + exit-code) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+clozure + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) + + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + + #+gcl + (lisp:system command) + #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" + :show-cmd nil + :prefix "" :output-stream *verbose-out*) - - #+clisp ;XXX not exactly *verbose-out*, I know - (ext:run-shell-command command :output :terminal :wait t) - #+openmcl - (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output *verbose-out* - :wait t))) - #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (si:system command) - #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) - (error "RUN-SHELL-PROGRAM not implemented for this Lisp") - )) + #+sbcl + (sb-ext:process-exit-code + (apply #'sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out* + #+win32 '(:search t) #-win32 nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) -(defgeneric hyperdocumentation (package name doc-type)) -(defmethod hyperdocumentation ((package symbol) name doc-type) - (hyperdocumentation (find-package package) name doc-type)) +;;;; --------------------------------------------------------------------------- +;;;; system-relative-pathname -(defun hyperdoc (name doc-type) - (hyperdocumentation (symbol-package name) name doc-type)) +(defmethod system-source-file ((system-name string)) + (system-source-file (find-system system-name))) +(defmethod system-source-file ((system-name symbol)) + (system-source-file (find-system system-name))) + +(defun* system-source-directory (system-designator) + "Return a pathname object corresponding to the +directory in which the system specification (.asd file) is +located." + (make-pathname :name nil + :type nil + :defaults (system-source-file system-designator))) + +(defun* relativize-directory (directory) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory))) + +(defun* relativize-pathname-directory (pathspec) + (let ((p (pathname pathspec))) + (make-pathname + :directory (relativize-directory (pathname-directory p)) + :defaults p))) + +(defun* system-relative-pathname (system name &key type) + (merge-pathnames* + (merge-component-name-type name :type type) + (system-source-directory system))) -(pushnew :asdf *features*) +;;; --------------------------------------------------------------------------- +;;; implementation-identifier +;;; +;;; produce a string to identify current implementation. +;;; Initially stolen from SLIME's SWANK, hacked since. -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") - (pushnew :sbcl-hooks-require *features*))) +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp + :corman :cormanlisp :armedbear :gcl :ecl :scl)) + +(defparameter *os-features* + '((:windows :mswindows :win32 :mingw32) + (:solaris :sunos) + :linux ;; for GCL at least, must appear before :bsd. + :macosx :darwin :apple + :freebsd :netbsd :openbsd :bsd + :unix)) + +(defparameter *architecture-features* + '((:x86-64 :amd64 :x86_64 :x8664-target) + (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) + :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + + +(defun* lisp-version-string () + (let ((s (lisp-implementation-version))) + (declare (ignorable s)) + #+allegro (format nil + "~A~A~A~A" + excl::*common-lisp-version-number* + ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox + (if (eq excl:*current-case-mode* + :case-sensitive-lower) "M" "A") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case + (:-ics "8") + (:+ics "")) + (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp (subseq s 0 (position #\space s)) + #+clozure (format nil "~d.~d-fasl~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #\- #\/ s) + #+digitool (subseq s 8) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+lispworks (format nil "~A~@[~A~]" s + (when (member :lispworks-64bit *features*) "-64bit")) + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version + #+(or cormanlisp mcl sbcl scl) s + #-(or allegro armedbear clisp clozure cmu cormanlisp digitool + ecl gcl lispworks mcl sbcl scl) s)) + +(defun* first-feature (features) + (labels + ((fp (thing) + (etypecase thing + (symbol + (let ((feature (find thing *features*))) + (when feature (return-from fp feature)))) + ;; allows features to be lists of which the first + ;; member is the "main name", the rest being aliases + (cons + (dolist (subf thing) + (when (find subf *features*) (return-from fp (first thing)))))) + nil)) + (loop :for f :in features + :when (fp f) :return :it))) + +(defun* implementation-type () + (first-feature *implementation-features*)) + +(defun* implementation-identifier () + (labels + ((maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (implementation-type) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-feature *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-feature *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp implementation version."))) + (substitute-if + #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) + (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) + + + +;;; --------------------------------------------------------------------------- +;;; Generic support for configuration files + +(defparameter *inter-directory-separator* + #+(or unix cygwin) #\: + #-(or unix cygwin) #\;) + +(defun* user-homedir () + (truename (user-homedir-pathname))) + +(defun* try-directory-subpath (x sub &key type) + (let* ((p (and x (ensure-directory-pathname x))) + (tp (and p (probe-file* p))) + (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) + (ts (and sp (probe-file* sp)))) + (and ts (values sp ts)))) +(defun* user-configuration-directories () + (remove-if + #'null + (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") + ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (try dir "common-lisp/")) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") + ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try (getenv "APPDATA") "common-lisp/config/")) + ,(try (user-homedir) ".config/common-lisp/"))))) +(defun* system-configuration-directories () + (remove-if + #'null + (append + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") + ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) + (list #p"/etc/common-lisp/")))) +(defun* in-first-directory (dirs x) + (loop :for dir :in dirs + :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) +(defun* in-user-configuration-directory (x) + (in-first-directory (user-configuration-directories) x)) +(defun* in-system-configuration-directory (x) + (in-first-directory (system-configuration-directories) x)) + +(defun* configuration-inheritance-directive-p (x) + (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) + (or (member x kw) + (and (length=n-p x 1) (member (car x) kw))))) + +(defun* validate-configuration-form (form tag directive-validator + &optional (description tag)) + (unless (and (consp form) (eq (car form) tag)) + (error "Error: Form doesn't specify ~A ~S~%" description form)) + (loop :with inherit = 0 + :for directive :in (cdr form) :do + (if (configuration-inheritance-directive-p directive) + (incf inherit) + (funcall directive-validator directive)) + :finally + (unless (= inherit 1) + (error "One and only one of ~S or ~S is required" + :inherit-configuration :ignore-inherited-configuration))) + form) + +(defun* validate-configuration-file (file validator description) + (let ((forms (read-file-forms file))) + (unless (length=n-p forms 1) + (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) + (funcall validator (car forms)))) + +(defun* hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + +(defun* validate-configuration-directory (directory tag validator) + (let ((files (sort (ignore-errors + (remove-if + 'hidden-file-p + (directory (make-pathname :name :wild :type "conf" :defaults directory) + #+sbcl :resolve-symlinks #+sbcl nil))) + #'string< :key #'namestring))) + `(,tag + ,@(loop :for file :in files :append + (mapcar validator (read-file-forms file))) + :inherit-configuration))) + + +;;; --------------------------------------------------------------------------- +;;; asdf-output-translations +;;; +;;; this code is heavily inspired from +;;; asdf-binary-translations, common-lisp-controller and cl-launch. +;;; --------------------------------------------------------------------------- + +(defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") + +(defvar *user-cache* + (flet ((try (x &rest sub) (and x `(,x , at sub)))) + (or + (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + '(:home ".cache" "common-lisp" :implementation)))) +(defvar *system-cache* + ;; No good default, plus there's a security problem + ;; with other users messing with such directories. + *user-cache*) + +(defun* output-translations () + (car *output-translations*)) + +(defun* (setf output-translations) (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key (lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (length (pathname-directory (car x))))))))) + new-value) + +(defun* output-translations-initialized-p () + (and *output-translations* t)) + +(defun* clear-output-translations () + "Undoes any initialization of the output translations. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *output-translations* '()) + (values)) + +(defparameter *wild-asd* + (make-pathname :directory '(:relative :wild-inferiors) + :name :wild :type "asd" :version :newest)) + +(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) + resolve-location)) + +(defun* resolve-relative-location-component (super x &optional wildenp) + (let* ((r (etypecase x + (pathname x) + (string x) + (cons + (let ((car (resolve-relative-location-component super (car x) nil))) + (if (null (cdr x)) + car + (let ((cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) wildenp))) + (merge-pathnames* cdr car))))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :implementation) (implementation-identifier)) + ((eql :implementation-type) (string-downcase (implementation-type))) + #-(and (or win32 windows mswindows mingw32) (not cygwin)) + ((eql :uid) (princ-to-string (get-uid))))) + (d (if (pathnamep x) r (ensure-directory-pathname r))) + (s (if (and wildenp (not (pathnamep x))) + (wilden d) + d))) + (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) + (error "pathname ~S is not relative to ~S" s super)) + (merge-pathnames* s super))) + +(defun* resolve-absolute-location-component (x wildenp) + (let* ((r + (etypecase x + (pathname x) + (string (ensure-directory-pathname x)) + (cons + (let ((car (resolve-absolute-location-component (car x) nil))) + (if (null (cdr x)) + car + (let ((cdr (resolve-relative-location-component + car (cdr x) wildenp))) + (merge-pathnames* cdr car))))) + ((eql :root) + ;; special magic! we encode such paths as relative pathnames, + ;; but it means "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location-component + (make-pathname :directory '(:relative)))) + ((eql :home) (user-homedir)) + ((eql :user-cache) (resolve-location *user-cache* nil)) + ((eql :system-cache) (resolve-location *system-cache* nil)) + ((eql :default-directory) (default-directory)))) + (s (if (and wildenp (not (pathnamep x))) + (wilden r) + r))) + (unless (absolute-pathname-p s) + (error "Not an absolute pathname ~S" s)) + s)) + +(defun* resolve-location (x &optional wildenp) + (if (atom x) + (resolve-absolute-location-component x wildenp) + (loop :with path = (resolve-absolute-location-component (car x) nil) + :for (component . morep) :on (cdr x) + :do (setf path (resolve-relative-location-component + path component (and wildenp (not morep)))) + :finally (return path)))) + +(defun* location-designator-p (x) + (flet ((componentp (c) (typep c '(or string pathname keyword)))) + (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) + +(defun* location-function-p (x) + (and + (consp x) + (length=n-p x 2) + (or (and (equal (first x) :function) + (typep (second x) 'symbol)) + (and (equal (first x) 'lambda) + (cddr x) + (length=n-p (second x) 2))))) + +(defun* validate-output-translations-directive (directive) + (unless + (or (member directive '(:inherit-configuration + :ignore-inherited-configuration + :enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive)))))) + (error "Invalid directive ~S~%" directive)) + directive) + +(defun* validate-output-translations-form (form) + (validate-configuration-form + form + :output-translations + 'validate-output-translations-directive + "output translations")) + +(defun* validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form "output translations")) + +(defun* validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive)) + +(defun* parse-output-translations-string (string) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error "environment string isn't: ~S" string)) + ((eql (char string 0) #\") + (parse-output-translations-string (read-from-string string))) + ((eql (char string 0) #\() + (validate-output-translations-form (read-from-string string))) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with source = nil + :for i = (or (position *inter-directory-separator* string :start start) end) :do + (let ((s (subseq string start i))) + (cond + (source + (push (list source (if (equal "" s) nil s)) directives) + (setf source nil)) + ((equal "" s) + (when inherit + (error "only one inherited configuration allowed: ~S" string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error "Uneven number of components in source to destination mapping ~S" string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) + +(defparameter *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) + +(defun* wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) + #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system + #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; If we want to enable the user cache by default, here would be the place: + :enable-user-cache)) + +(defparameter *output-translations-file* #p"asdf-output-translations.conf") +(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") + +(defun* user-output-translations-pathname () + (in-user-configuration-directory *output-translations-file* )) +(defun* system-output-translations-pathname () + (in-system-configuration-directory *output-translations-file*)) +(defun* user-output-translations-directory-pathname () + (in-user-configuration-directory *output-translations-directory*)) +(defun* system-output-translations-directory-pathname () + (in-system-configuration-directory *output-translations-directory*)) +(defun* environment-output-translations () + (getenv "ASDF_OUTPUT_TRANSLATIONS")) + +(defgeneric* process-output-translations (spec &key inherit collect)) +(declaim (ftype (function (t &key (:collect (or symbol function))) t) + inherit-output-translations)) +(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) + process-output-translations-directive)) + +(defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) +(defmethod process-output-translations ((pathname pathname) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file pathname) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) +(defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) +(defmethod process-output-translations ((x null) &key inherit collect) + (declare (ignorable x)) + (inherit-output-translations inherit :collect collect)) +(defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) + +(defun* inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) + +(defun* process-output-translations-directive (directive &key inherit collect) + (if (atom directive) + (ecase directive + ((:enable-user-cache) + (process-output-translations-directive '(t :user-cache) :collect collect)) + ((:disable-cache) + (process-output-translations-directive '(t t) :collect collect)) + ((:inherit-configuration) + (inherit-output-translations inherit :collect collect)) + ((:ignore-inherited-configuration nil) + nil)) + (let ((src (first directive)) + (dst (second directive))) + (if (eq src :include) + (when dst + (process-output-translations (pathname dst) :inherit nil :collect collect)) + (when src + (let ((trusrc (or (eql src t) + (let ((loc (resolve-location src t))) + (if (absolute-pathname-p loc) (truenamize loc) loc))))) + (cond + ((location-function-p dst) + (funcall collect + (list trusrc + (if (symbolp (second dst)) + (fdefinition (second dst)) + (eval (second dst)))))) + ((eq dst t) + (funcall collect (list trusrc t))) + (t + (let* ((trudst (make-pathname + :defaults (if dst (resolve-location dst t) trusrc))) + (wilddst (make-pathname + :name :wild :type :wild :version :wild + :defaults trudst))) + (funcall collect (list wilddst t)) + (funcall collect (list trusrc trudst))))))))))) + +(defun* compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) + +(defun* initialize-output-translations (&optional parameter) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf (output-translations) (compute-output-translations parameter))) + +(defun* disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) + +;; checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system). +(defun* ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) + +(defun* translate-pathname* (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) + +(defun* apply-output-translations (path) + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop :with p = (truenamize path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) + +(defmethod output-files :around (operation component) + "Translate output files, unless asked not to" + (declare (ignorable operation component)) + (values + (multiple-value-bind (files fixedp) (call-next-method) + (if fixedp + files + (mapcar #'apply-output-translations files))) + t)) + +(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (or output-file + (apply-output-translations + (apply 'compile-file-pathname + (truenamize (lispize-pathname input-file)) + keys)))) + +(defun* tmpize-pathname (x) + (make-pathname + :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :defaults x)) + +(defun* delete-file-if-exists (x) + (when (and x (probe-file x)) + (delete-file x))) + +(defun* compile-file* (input-file &rest keys &key &allow-other-keys) + (let* ((output-file (apply 'compile-file-pathname* input-file keys)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keys) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (ecase status + ((:success :warn :ignore) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (:error + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) + +#+abcl +(defun* translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (let* ((p (pathname (first (pathname-device source)))) + (root (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device p))))) + (apply-output-translations + (merge-pathnames* + (relativize-pathname-directory source) + (merge-pathnames* + (relativize-pathname-directory (ensure-directory-pathname p)) + root))))) + +;;;; ----------------------------------------------------------------- +;;;; Compatibility mode for ASDF-Binary-Locations + +(defun* enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + ;; Use ".cache/common-lisp" instead ??? + (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) + (user-homedir))) + (include-per-user-information nil) + (map-all-source-files nil) + (source-to-target-mappings nil)) + (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) + (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) + (mapped-files (make-pathname + :name :wild :version :wild + :type (if map-all-source-files :wild fasl-type))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir)))) + :implementation ,wild-inferiors) + `(:root ,wild-inferiors :implementation)))) + (initialize-output-translations + `(:output-translations + , at source-to-target-mappings + ((:root ,wild-inferiors ,mapped-files) + (, at destination-directory ,mapped-files)) + (t t) + :ignore-inherited-configuration)))) + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 -#+(and sbcl sbcl-hooks-require) +#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) (progn - (defun module-provide-asdf (name) - (handler-bind ((style-warning #'muffle-warning)) - (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) - (when system - (asdf:operate 'asdf:load-op name) - t)))) - - (pushnew - '(merge-pathnames "systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) - - (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) - - (pushnew - '(merge-pathnames ".sbcl/systems/" - (user-homedir-pathname)) - *central-registry*) - - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) +(defparameter *link-initial-dword* 76) +(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + +(defun* read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + +(defun* read-little-endian (s &optional (bytes 4)) + (loop + :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + +(defun* parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (concatenate 'string + (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + +(defun* parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file () + nil))))) + +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 + +;; Using ack 1.2 exclusions +(defvar *default-source-registry-exclusions* + '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often build stuff under the debian directory... BAD. + +(defvar *source-registry-exclusions* *default-source-registry-exclusions*) + +(defvar *source-registry* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a list of directory pathnames where to look for .asd files") + +(defun* source-registry () + (car *source-registry*)) + +(defun* (setf source-registry) (new-value) + (setf *source-registry* (list new-value)) + new-value) + +(defun* source-registry-initialized-p () + (and *source-registry* t)) + +(defun* clear-source-registry () + "Undoes any initialization of the source registry. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *source-registry* '()) + (values)) + +(defun* validate-source-registry-directive (directive) + (unless + (or (member directive '(:default-registry (:default-registry)) :test 'equal) + (destructuring-bind (kw &rest rest) directive + (case kw + ((:include :directory :tree) + (and (length=n-p rest 1) + (typep (car rest) '(or pathname string null)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + (null rest)))) + (error "Invalid directive ~S~%" directive)) + directive) + +(defun* validate-source-registry-form (form) + (validate-configuration-form + form :source-registry 'validate-source-registry-directive "a source registry")) + +(defun* validate-source-registry-file (file) + (validate-configuration-file + file 'validate-source-registry-form "a source registry")) + +(defun* validate-source-registry-directory (directory) + (validate-configuration-directory + directory :source-registry 'validate-source-registry-directive)) + +(defun* parse-source-registry-string (string) + (cond + ((or (null string) (equal string "")) + '(:source-registry :inherit-configuration)) + ((not (stringp string)) + (error "environment string isn't: ~S" string)) + ((find (char string 0) "\"(") + (validate-source-registry-form (read-from-string string))) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :for pos = (position *inter-directory-separator* string :start start) :do + (let ((s (subseq string start (or pos end)))) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error "only one inherited configuration allowed: ~S" string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((ends-with s "//") + (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) + (t + (push `(:directory ,s) directives))) + (cond + (pos + (setf start (1+ pos))) + (t + (unless inherit + (push '(:ignore-inherited-configuration) directives)) + (return `(:source-registry ,@(nreverse directives)))))))))) + +(defun* register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (funcall collect directory) + (let* ((files + (handler-case + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+clisp #+clisp :circle t) + (error (c) + (warn "Error while scanning system definitions under directory ~S:~%~A" + directory c) + nil))) + (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) + :test #'equal :from-end t))) + (loop + :for dir :in dirs + :unless (loop :for x :in exclude + :thereis (find x (pathname-directory dir) :test #'equal)) + :do (funcall collect dir))))) + +(defparameter *default-source-registries* + '(environment-source-registry + user-source-registry + user-source-registry-directory + system-source-registry + system-source-registry-directory + default-source-registry)) + +(defparameter *source-registry-file* #p"source-registry.conf") +(defparameter *source-registry-directory* #p"source-registry.conf.d/") + +(defun* wrapping-source-registry () + `(:source-registry + #+sbcl (:tree ,(getenv "SBCL_HOME")) + :inherit-configuration + #+cmu (:tree #p"modules:"))) +(defun* default-source-registry () + (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + `(:source-registry + #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) + (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) + ,@(let* + #+(or unix cygwin) + ((datahome + (or (getenv "XDG_DATA_HOME") + (try (user-homedir) ".local/share/"))) + (datadirs + (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) + (dirs (cons datahome (split-string datadirs :separator ":")))) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + ((datahome (getenv "APPDATA")) + (datadir + #+lispworks (sys:get-folder-path :local-appdata) + #-lispworks (try (getenv "ALLUSERSPROFILE") + "Application Data")) + (dirs (list datahome datadir))) + #-(or unix win32 windows mswindows mingw32 cygwin) + ((dirs ())) + (loop :for dir :in dirs + :collect `(:directory ,(try dir "common-lisp/systems/")) + :collect `(:tree ,(try dir "common-lisp/source/")))) + :inherit-configuration))) +(defun* user-source-registry () + (in-user-configuration-directory *source-registry-file*)) +(defun* system-source-registry () + (in-system-configuration-directory *source-registry-file*)) +(defun* user-source-registry-directory () + (in-user-configuration-directory *source-registry-directory*)) +(defun* system-source-registry-directory () + (in-system-configuration-directory *source-registry-directory*)) +(defun* environment-source-registry () + (getenv "CL_SOURCE_REGISTRY")) + +(defgeneric* process-source-registry (spec &key inherit register)) +(declaim (ftype (function (t &key (:register (or symbol function))) t) + inherit-source-registry)) +(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) + process-source-registry-directive)) + +(defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) +(defmethod process-source-registry ((pathname pathname) &key inherit register) + (cond + ((directory-pathname-p pathname) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register)) + ((probe-file pathname) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register)) + (t + (inherit-source-registry inherit :register register)))) +(defmethod process-source-registry ((string string) &key inherit register) + (process-source-registry (parse-source-registry-string string) + :inherit inherit :register register)) +(defmethod process-source-registry ((x null) &key inherit register) + (declare (ignorable x)) + (inherit-source-registry inherit :register register)) +(defmethod process-source-registry ((form cons) &key inherit register) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) + (dolist (directive (cdr (validate-source-registry-form form))) + (process-source-registry-directive directive :inherit inherit :register register)))) + +(defun* inherit-source-registry (inherit &key register) + (when inherit + (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + +(defun* process-source-registry-directive (directive &key inherit register) + (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) + (ecase kw + ((:include) + (destructuring-bind (pathname) rest + (process-source-registry (pathname pathname) :inherit nil :register register))) + ((:directory) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (ensure-directory-pathname pathname))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) + ((:exclude) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) + ((:default-registry) + (inherit-source-registry '(default-source-registry) :register register)) + ((:inherit-configuration) + (inherit-source-registry inherit :register register)) + ((:ignore-inherited-configuration) + nil))) + nil) + +(defun* flatten-source-registry (&optional parameter) + (remove-duplicates + (while-collecting (collect) + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register (lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude))))) + :test 'equal :from-end t)) + +;; Will read the configuration and initialize all internal variables, +;; and return the new configuration. +(defun* compute-source-registry (&optional parameter) + (while-collecting (collect) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (register-asd-directory + directory + :recurse recurse :exclude exclude :collect #'collect))))) + +(defun* initialize-source-registry (&optional parameter) + (setf (source-registry) (compute-source-registry parameter))) + +;; Checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system) to make sure the source registry is initialized. +;; However, it will do so *without* a parameter, at which point it +;; will be too late to provide a parameter to this function, though +;; you may override the configuration explicitly by calling +;; initialize-source-registry directly with your parameter. +(defun* ensure-source-registry (&optional parameter) + (if (source-registry-initialized-p) + (source-registry) + (initialize-source-registry parameter))) + +(defun* sysdef-source-registry-search (system) + (ensure-source-registry) + (loop :with name = (coerce-name system) + :for defaults :in (source-registry) + :for file = (probe-asd name defaults) + :when file :return file)) + +(defun* clear-configuration () + (clear-source-registry) + (clear-output-translations)) + +;;;; ----------------------------------------------------------------- +;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL +;;;; +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error (lambda (e) + (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" + name e)))) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (load-system system) + t)))) + +#+(or abcl clisp clozure cmu ecl sbcl) +(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom)))) + (when x + (eval `(pushnew 'module-provide-asdf + #+abcl sys::*module-provider-functions* + #+clisp ,x + #+clozure ccl:*module-provider-functions* + #+cmu ext:*module-provider-functions* + #+ecl si:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Cleanups after hot-upgrade. +;;;; Things to do in case we're upgrading from a previous version of ASDF. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; +;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 +(eval-when (:compile-toplevel :load-toplevel :execute) + #+ecl ;; Support upgrade from before ECL went to 1.369 + (when (fboundp 'compile-op-system-p) + (defmethod compile-op-system-p ((op compile-op)) + (getf :system-p (compile-op-flags op))) + (defmethod initialize-instance :after ((op compile-op) + &rest initargs + &key system-p &allow-other-keys) + (declare (ignorable initargs)) + (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) + +;;;; ----------------------------------------------------------------- +;;;; Done! +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + +#+allegro +(eval-when (:compile-toplevel :execute) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) + +(pushnew :asdf *features*) +(pushnew :asdf2 *features*) + +(provide :asdf) -(provide 'asdf) +;;; Local Variables: +;;; mode: lisp +;;; End: From pbrochard at common-lisp.net Wed Sep 29 22:08:19 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 29 Sep 2010 18:08:19 -0400 Subject: [clfswm-cvs] r337 - in clfswm: . doc src Message-ID: Author: pbrochard Date: Wed Sep 29 18:08:19 2010 New Revision: 337 Log: TODO update. Documentation update. Modified: clfswm/TODO clfswm/doc/corner.html clfswm/doc/corner.txt clfswm/doc/keys.html clfswm/doc/keys.txt clfswm/doc/menu.html clfswm/doc/menu.txt clfswm/load.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-util.lisp clfswm/src/menu-def.lisp Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Wed Sep 29 18:08:19 2010 @@ -7,7 +7,7 @@ =============== Should handle these soon. -- configure: copy contrib/clfswm in . and set default values in it. +- Add a binding/functions to circulate over children of the current child. MAYBE ===== @@ -28,6 +28,10 @@ * up * down +Maybe this can be done with a compositing system on Lisp with clx that support xrender. + http://en.wikipedia.org/wiki/Compositing_window_manager + http://ktown.kde.org/~fredrik/composite_howto.html + - Undo/redo Modified: clfswm/doc/corner.html ============================================================================== --- clfswm/doc/corner.html (original) +++ clfswm/doc/corner.html Wed Sep 29 18:08:19 2010 @@ -120,7 +120,7 @@ Bottom-Left: - Start the file manager + --- Modified: clfswm/doc/corner.txt ============================================================================== --- clfswm/doc/corner.txt (original) +++ clfswm/doc/corner.txt Wed Sep 29 18:08:19 2010 @@ -16,7 +16,7 @@ Top-Left: Hide/Unhide a terminal Top-Right: Close or kill the current window (ask before doing anything) Bottom-Right: Present all windows in all frames (An expose like) - Bottom-Left: Start the file manager + Bottom-Left: --- *Corner-Second-Mode-Left-Button*: Top-Left: --- Modified: clfswm/doc/keys.html ============================================================================== --- clfswm/doc/keys.html (original) +++ clfswm/doc/keys.html Wed Sep 29 18:08:19 2010 @@ -321,7 +321,7 @@ Mod-1 - Ccedilla + 1 Bind or jump to a slot (a frame or a window) @@ -332,7 +332,7 @@ Mod-1 - Underscore + 2 Bind or jump to a slot (a frame or a window) @@ -343,7 +343,7 @@ Mod-1 - Egrave + 3 Bind or jump to a slot (a frame or a window) @@ -354,7 +354,7 @@ Mod-1 - Minus + 4 Bind or jump to a slot (a frame or a window) @@ -365,7 +365,7 @@ Mod-1 - Parenleft + 5 Bind or jump to a slot (a frame or a window) @@ -376,7 +376,7 @@ Mod-1 - Quoteright + 6 Bind or jump to a slot (a frame or a window) @@ -387,7 +387,7 @@ Mod-1 - Quotedbl + 7 Bind or jump to a slot (a frame or a window) @@ -398,7 +398,7 @@ Mod-1 - Eacute + 8 Bind or jump to a slot (a frame or a window) @@ -409,7 +409,7 @@ Mod-1 - Ampersand + 9 Bind or jump to a slot (a frame or a window) @@ -417,103 +417,15 @@ - - - - Twosuperior - - - Move the pointer to the lower right corner of the screen - - - - Mod-1 - F2 - - - Open the Music Player Daemon (MPD) menu - - - - - Mod-1 - - - Agrave + 0 Bind or jump to a slot (a frame or a window) - - - - - - Pause - - - Open the Reboot/Halt menu - - - - - - - - Control_r - - - Move the pointer to the lower right corner of the screen - - - - - - - - 176 - - - Raise the volume - - - - - - - - 174 - - - Lower the volume - - - - - Control - - - 66 - - - Present all windows in the current frame (An expose like) - - - - - Control Shift - - - 66 - - - Present all windows in all frames (An expose like) - -

@@ -1360,7 +1272,7 @@ Mod-1 - Ccedilla + 1 Bind or jump to a slot (a frame or a window) @@ -1371,7 +1283,7 @@ Mod-1 - Underscore + 2 Bind or jump to a slot (a frame or a window) @@ -1382,7 +1294,7 @@ Mod-1 - Egrave + 3 Bind or jump to a slot (a frame or a window) @@ -1393,7 +1305,7 @@ Mod-1 - Minus + 4 Bind or jump to a slot (a frame or a window) @@ -1404,7 +1316,7 @@ Mod-1 - Parenleft + 5 Bind or jump to a slot (a frame or a window) @@ -1415,7 +1327,7 @@ Mod-1 - Quoteright + 6 Bind or jump to a slot (a frame or a window) @@ -1426,7 +1338,7 @@ Mod-1 - Quotedbl + 7 Bind or jump to a slot (a frame or a window) @@ -1437,7 +1349,7 @@ Mod-1 - Eacute + 8 Bind or jump to a slot (a frame or a window) @@ -1448,7 +1360,7 @@ Mod-1 - Ampersand + 9 Bind or jump to a slot (a frame or a window) @@ -1456,48 +1368,15 @@ - - - - Twosuperior - - - Move the pointer to the lower right corner of the screen - - - - Mod-1 - Agrave + 0 Bind or jump to a slot (a frame or a window) - - - - - - Space - - - start the file manager - - - - - - - - Z - - - start the web browser - -

@@ -2026,6 +1905,292 @@ + A + + + Select child 'a' (0) + + + + + + + + B + + + Select child 'b' (1) + + + + + + + + C + + + Select child 'c' (2) + + + + + + + + D + + + Select child 'd' (3) + + + + + + + + E + + + Select child 'e' (4) + + + + + + + + F + + + Select child 'f' (5) + + + + + + + + G + + + Select child 'g' (6) + + + + + + + + H + + + Select child 'h' (7) + + + + + + + + I + + + Select child 'i' (8) + + + + + + + + J + + + Select child 'j' (9) + + + + + + + + K + + + Select child 'k' (10) + + + + + + + + L + + + Select child 'l' (11) + + + + + + + + M + + + Select child 'm' (12) + + + + + + + + N + + + Select child 'n' (13) + + + + + + + + O + + + Select child 'o' (14) + + + + + + + + P + + + Select child 'p' (15) + + + + + + + + Q + + + Select child 'q' (16) + + + + + + + + R + + + Select child 'r' (17) + + + + + + + + S + + + Select child 's' (18) + + + + + + + + T + + + Select child 't' (19) + + + + + + + + U + + + Select child 'u' (20) + + + + + + + + V + + + Select child 'v' (21) + + + + + + + + W + + + Select child 'w' (22) + + + + + + + + X + + + Select child 'x' (23) + + + + + + + + Y + + + Select child 'y' (24) + + + + + + + + Z + + + Select child 'z' (25) + + + + + + + Escape @@ -2175,17 +2340,6 @@ Reset speed mouse coordinates - - - - - - A - - - Leave the expose mode - -

Modified: clfswm/doc/keys.txt ============================================================================== --- clfswm/doc/keys.txt (original) +++ clfswm/doc/keys.txt Wed Sep 29 18:08:19 2010 @@ -32,24 +32,16 @@ Control Escape Close or kill the current window (ask before doing anything) Mod-1 T Switch to editing mode Control Less Switch to editing mode - Mod-1 Ccedilla Bind or jump to a slot (a frame or a window) - Mod-1 Underscore Bind or jump to a slot (a frame or a window) - Mod-1 Egrave Bind or jump to a slot (a frame or a window) - Mod-1 Minus Bind or jump to a slot (a frame or a window) - Mod-1 Parenleft Bind or jump to a slot (a frame or a window) - Mod-1 Quoteright Bind or jump to a slot (a frame or a window) - Mod-1 Quotedbl Bind or jump to a slot (a frame or a window) - Mod-1 Eacute Bind or jump to a slot (a frame or a window) - Mod-1 Ampersand Bind or jump to a slot (a frame or a window) - Twosuperior Move the pointer to the lower right corner of the screen - Mod-1 F2 Open the Music Player Daemon (MPD) menu - Mod-1 Agrave Bind or jump to a slot (a frame or a window) - Pause Open the Reboot/Halt menu - Control_r Move the pointer to the lower right corner of the screen - 176 Raise the volume - 174 Lower the volume - Control 66 Present all windows in the current frame (An expose like) - Control Shift 66 Present all windows in all frames (An expose like) + Mod-1 1 Bind or jump to a slot (a frame or a window) + Mod-1 2 Bind or jump to a slot (a frame or a window) + Mod-1 3 Bind or jump to a slot (a frame or a window) + Mod-1 4 Bind or jump to a slot (a frame or a window) + Mod-1 5 Bind or jump to a slot (a frame or a window) + Mod-1 6 Bind or jump to a slot (a frame or a window) + Mod-1 7 Bind or jump to a slot (a frame or a window) + Mod-1 8 Bind or jump to a slot (a frame or a window) + Mod-1 9 Bind or jump to a slot (a frame or a window) + Mod-1 0 Bind or jump to a slot (a frame or a window) Mouse buttons actions in main mode: @@ -135,19 +127,16 @@ Control Shift F10 Show/Hide the root frame F10 Present all windows in the current frame (An expose like) Control F10 Present all windows in all frames (An expose like) - Mod-1 Ccedilla Bind or jump to a slot (a frame or a window) - Mod-1 Underscore Bind or jump to a slot (a frame or a window) - Mod-1 Egrave Bind or jump to a slot (a frame or a window) - Mod-1 Minus Bind or jump to a slot (a frame or a window) - Mod-1 Parenleft Bind or jump to a slot (a frame or a window) - Mod-1 Quoteright Bind or jump to a slot (a frame or a window) - Mod-1 Quotedbl Bind or jump to a slot (a frame or a window) - Mod-1 Eacute Bind or jump to a slot (a frame or a window) - Mod-1 Ampersand Bind or jump to a slot (a frame or a window) - Twosuperior Move the pointer to the lower right corner of the screen - Mod-1 Agrave Bind or jump to a slot (a frame or a window) - Space start the file manager - Z start the web browser + Mod-1 1 Bind or jump to a slot (a frame or a window) + Mod-1 2 Bind or jump to a slot (a frame or a window) + Mod-1 3 Bind or jump to a slot (a frame or a window) + Mod-1 4 Bind or jump to a slot (a frame or a window) + Mod-1 5 Bind or jump to a slot (a frame or a window) + Mod-1 6 Bind or jump to a slot (a frame or a window) + Mod-1 7 Bind or jump to a slot (a frame or a window) + Mod-1 8 Bind or jump to a slot (a frame or a window) + Mod-1 9 Bind or jump to a slot (a frame or a window) + Mod-1 0 Bind or jump to a slot (a frame or a window) Mouse buttons actions in second mode: @@ -214,6 +203,32 @@ Expose windows mode keys: ------------------------ + A Select child 'a' (0) + B Select child 'b' (1) + C Select child 'c' (2) + D Select child 'd' (3) + E Select child 'e' (4) + F Select child 'f' (5) + G Select child 'g' (6) + H Select child 'h' (7) + I Select child 'i' (8) + J Select child 'j' (9) + K Select child 'k' (10) + L Select child 'l' (11) + M Select child 'm' (12) + N Select child 'n' (13) + O Select child 'o' (14) + P Select child 'p' (15) + Q Select child 'q' (16) + R Select child 'r' (17) + S Select child 's' (18) + T Select child 't' (19) + U Select child 'u' (20) + V Select child 'v' (21) + W Select child 'w' (22) + X Select child 'x' (23) + Y Select child 'y' (24) + Z Select child 'z' (25) Escape Leave the expose mode Control G Leave the expose mode Mod-1 Escape Leave the expose mode @@ -228,7 +243,6 @@ Control Left Undo last speed mouse move Control Up Revert to the first speed move mouse Control Down Reset speed mouse coordinates - A Leave the expose mode Mouse buttons actions in expose windows mode: Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Wed Sep 29 18:08:19 2010 @@ -81,105 +81,6 @@

v: Show the current CLFSWM version

-

- F2: < Music Player Daemon (MPD) menu > -

-

- x: < XMMS menu > -

-

- i: < CDPLAYER menu > -

-
-

- Mpd-Menu -

-

- i: Show MPD informations -

-

- p: Play the previous song in the current playlist -

-

- n: Play the next song in the current playlist -

-

- t: Toggles Play/Pause, plays if stopped -

-

- y: Start playing -

-

- k: Stop the currently playing playlists -

-

- x: Seeks to +5% -

-

- w: Seeks to -5% -

-

- l: Show the current MPD playlist -

-

- s: Start sonata -

-

- g: Start gmpc -

-
-

- Xmms-Menu -

-

- r: Lanch XMMS -

-

- s: Show the current xmms status -

-

- l: Show the current xmms playlist -

-

- n: Play the next XMMS track -

-

- p: Play the previous XMMS track -

-

- e: open xmms "Load file(s)" dialog window. -

-
-

- Cdplayer-Menu -

-

- y: Start playing CD -

-

- k: Stop playing CD -

-

- t: Toggle pause -

-

- s: Show the current CD status -

-

- l: Show the current CD playlist -

-

- n: Play the next CD track -

-

- p: Play the previous CD track -

-

- e: Eject CD -

-

- c: Close CD -


Standard-Menu @@ -2728,46 +2629,68 @@ Configuration-Menu

- a: < Hook group > + a: < Expose mode group >

- b: < Main mode group > + b: < Hook group >

- c: < Frame colors group > + c: < Main mode group >

- d: < Identify key group > + d: < Frame colors group >

- e: < Corner group > + e: < Identify key group >

- f: < Query string group > + f: < Second mode group >

- g: < Circulate mode group > + g: < Corner group >

- h: < Second mode group > + h: < Query string group >

- i: < Placement group > + i: < Circulate mode group >

- j: < Miscellaneous group > + j: < Placement group >

- k: < Info mode group > + k: < Miscellaneous group >

- l: < Menu group > + l: < Info mode group > +

+

+ m: < Menu group >

F2: Save all configuration variables in clfswmrc


+ Conf-Expose-Mode-Group +

+

+ a: Configure EXPOSE-FOREGROUND +

+

+ b: Configure EXPOSE-VALID-ON-KEY +

+

+ c: Configure EXPOSE-BORDER +

+

+ d: Configure EXPOSE-FONT-STRING +

+

+ e: Configure EXPOSE-BACKGROUND +

+
+

Conf-Hook-Group

@@ -2829,6 +2752,28 @@


+ Conf-Second-Mode-Group +

+

+ a: Configure SM-FOREGROUND-COLOR +

+

+ b: Configure SM-BACKGROUND-COLOR +

+

+ c: Configure SM-HEIGHT +

+

+ d: Configure SM-WIDTH +

+

+ e: Configure SM-BORDER-COLOR +

+

+ f: Configure SM-FONT-STRING +

+
+

Conf-Corner-Group

@@ -2841,16 +2786,16 @@ c: Configure CORNER-SECOND-MODE-LEFT-BUTTON

- d: Configure CORNER-SECOND-MODE-RIGHT-BUTTON + d: Configure CORNER-MAIN-MODE-RIGHT-BUTTON

- e: Configure CORNER-SIZE + e: Configure CORNER-SECOND-MODE-RIGHT-BUTTON

- f: Configure CLFSWM-TERMINAL-CMD + f: Configure CORNER-SIZE

- g: Configure CORNER-MAIN-MODE-RIGHT-BUTTON + g: Configure CLFSWM-TERMINAL-CMD

h: Configure VIRTUAL-KEYBOARD-CMD @@ -2882,10 +2827,10 @@ Conf-Circulate-Mode-Group

- a: Configure CIRCULATE-BORDER + a: Configure CIRCULATE-WIDTH

- b: Configure CIRCULATE-WIDTH + b: Configure CIRCULATE-BORDER

c: Configure CIRCULATE-HEIGHT @@ -2904,28 +2849,6 @@


- Conf-Second-Mode-Group -

-

- a: Configure SM-FOREGROUND-COLOR -

-

- b: Configure SM-BACKGROUND-COLOR -

-

- c: Configure SM-HEIGHT -

-

- d: Configure SM-WIDTH -

-

- e: Configure SM-BORDER-COLOR -

-

- f: Configure SM-FONT-STRING -

-
-

Conf-Placement-Group

@@ -2938,10 +2861,13 @@ c: Configure BANISH-POINTER-PLACEMENT

- d: Configure INFO-MODE-PLACEMENT + d: Configure EXPOSE-MODE-PLACEMENT

- e: Configure SECOND-MODE-PLACEMENT + e: Configure INFO-MODE-PLACEMENT +

+

+ f: Configure SECOND-MODE-PLACEMENT


@@ -3052,28 +2978,6 @@

x: Exit clfswm

-

- Pause: < Suspend/Reboot/Halt menu > -

-
-

- Reboot-Halt-Menu -

-

- -: Do nothing -

-

- s: Suspend the computer to RAM -

-

- d: Suspend the computer to DISK -

-

- r: Reboot the computer -

-

- h: Halt the computer -


Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Wed Sep 29 18:08:19 2010 @@ -24,41 +24,6 @@ p: Show current processes sorted by CPU usage m: Show current processes sorted by memory usage v: Show the current CLFSWM version -F2: < Music Player Daemon (MPD) menu > -x: < XMMS menu > -i: < CDPLAYER menu > - -Mpd-Menu -i: Show MPD informations -p: Play the previous song in the current playlist -n: Play the next song in the current playlist -t: Toggles Play/Pause, plays if stopped -y: Start playing -k: Stop the currently playing playlists -x: Seeks to +5% -w: Seeks to -5% -l: Show the current MPD playlist -s: Start sonata -g: Start gmpc - -Xmms-Menu -r: Lanch XMMS -s: Show the current xmms status -l: Show the current xmms playlist -n: Play the next XMMS track -p: Play the previous XMMS track -e: open xmms "Load file(s)" dialog window. - -Cdplayer-Menu -y: Start playing CD -k: Stop playing CD -t: Toggle pause -s: Show the current CD status -l: Show the current CD playlist -n: Play the next CD track -p: Play the previous CD track -e: Eject CD -c: Close CD Standard-Menu a: < TEXTEDITOR > @@ -938,20 +903,28 @@ p: Prompt for an other window manager Configuration-Menu -a: < Hook group > -b: < Main mode group > -c: < Frame colors group > -d: < Identify key group > -e: < Corner group > -f: < Query string group > -g: < Circulate mode group > -h: < Second mode group > -i: < Placement group > -j: < Miscellaneous group > -k: < Info mode group > -l: < Menu group > +a: < Expose mode group > +b: < Hook group > +c: < Main mode group > +d: < Frame colors group > +e: < Identify key group > +f: < Second mode group > +g: < Corner group > +h: < Query string group > +i: < Circulate mode group > +j: < Placement group > +k: < Miscellaneous group > +l: < Info mode group > +m: < Menu group > F2: Save all configuration variables in clfswmrc +Conf-Expose-Mode-Group +a: Configure EXPOSE-FOREGROUND +b: Configure EXPOSE-VALID-ON-KEY +c: Configure EXPOSE-BORDER +d: Configure EXPOSE-FONT-STRING +e: Configure EXPOSE-BACKGROUND + Conf-Hook-Group a: Configure INIT-HOOK b: Configure DEFAULT-NW-HOOK @@ -975,14 +948,22 @@ c: Configure IDENTIFY-BORDER d: Configure IDENTIFY-BACKGROUND +Conf-Second-Mode-Group +a: Configure SM-FOREGROUND-COLOR +b: Configure SM-BACKGROUND-COLOR +c: Configure SM-HEIGHT +d: Configure SM-WIDTH +e: Configure SM-BORDER-COLOR +f: Configure SM-FONT-STRING + Conf-Corner-Group a: Configure CORNER-MAIN-MODE-LEFT-BUTTON b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON c: Configure CORNER-SECOND-MODE-LEFT-BUTTON -d: Configure CORNER-SECOND-MODE-RIGHT-BUTTON -e: Configure CORNER-SIZE -f: Configure CLFSWM-TERMINAL-CMD -g: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +d: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +e: Configure CORNER-SECOND-MODE-RIGHT-BUTTON +f: Configure CORNER-SIZE +g: Configure CLFSWM-TERMINAL-CMD h: Configure VIRTUAL-KEYBOARD-CMD i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON j: Configure CLFSWM-TERMINAL-NAME @@ -994,28 +975,21 @@ d: Configure QUERY-FOREGROUND Conf-Circulate-Mode-Group -a: Configure CIRCULATE-BORDER -b: Configure CIRCULATE-WIDTH +a: Configure CIRCULATE-WIDTH +b: Configure CIRCULATE-BORDER c: Configure CIRCULATE-HEIGHT d: Configure CIRCULATE-TEXT-LIMITE e: Configure CIRCULATE-FONT-STRING f: Configure CIRCULATE-BACKGROUND g: Configure CIRCULATE-FOREGROUND -Conf-Second-Mode-Group -a: Configure SM-FOREGROUND-COLOR -b: Configure SM-BACKGROUND-COLOR -c: Configure SM-HEIGHT -d: Configure SM-WIDTH -e: Configure SM-BORDER-COLOR -f: Configure SM-FONT-STRING - Conf-Placement-Group a: Configure CIRCULATE-MODE-PLACEMENT b: Configure QUERY-MODE-PLACEMENT c: Configure BANISH-POINTER-PLACEMENT -d: Configure INFO-MODE-PLACEMENT -e: Configure SECOND-MODE-PLACEMENT +d: Configure EXPOSE-MODE-PLACEMENT +e: Configure INFO-MODE-PLACEMENT +f: Configure SECOND-MODE-PLACEMENT Conf-Miscellaneous-Group a: Configure HAVE-TO-COMPRESS-NOTIFY @@ -1055,14 +1029,6 @@ r: Reset clfswm l: Reload clfswm x: Exit clfswm -Pause: < Suspend/Reboot/Halt menu > - -Reboot-Halt-Menu --: Do nothing -s: Suspend the computer to RAM -d: Suspend the computer to DISK -r: Reboot the computer -h: Halt the computer This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-in-file or Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Wed Sep 29 18:08:19 2010 @@ -61,6 +61,11 @@ (ignore-errors (main :read-conf-file-p t)) + +;;;; Uncomment lines above to save the default documentation. +;;#-BUILD +;;(ignore-errors +;; (main :read-conf-file-p nil)) ;;(produce-all-docs) Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Sep 29 18:08:19 2010 @@ -458,6 +458,14 @@ "Show the second mode key binding" (show-key-binding *second-keys* *second-mouse*)) +(defun show-circulate-mode-key-binding () + "Show the circulate mode key binding" + (show-key-binding *circulate-keys*)) + +(defun show-expose-window-mode-key-binding () + "Show the expose window mode key binding" + (show-key-binding *expose-keys* *expose-mouse*)) + (defun corner-help-colorize-line (list) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Wed Sep 29 18:08:19 2010 @@ -1210,9 +1210,9 @@ ;;; Standard menu functions - Based on the XDG specifications -(defparameter *xdg-section-list* (nconc '(TextEditor FileManager WebBrowser) - '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility) - '(TerminalEmulator Archlinux Screensaver)) +(defparameter *xdg-section-list* (append '(TextEditor FileManager WebBrowser) + '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility) + '(TerminalEmulator Archlinux Screensaver)) "Config(Menu group): Standard menu sections") Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Wed Sep 29 18:08:19 2010 @@ -67,6 +67,8 @@ (add-menu-key 'help-menu "h" 'show-global-key-binding) (add-menu-key 'help-menu "b" 'show-main-mode-key-binding) (add-menu-key 'help-menu "s" 'show-second-mode-key-binding) +(add-menu-key 'help-menu "r" 'show-circulate-mode-key-binding) +(add-menu-key 'help-menu "e" 'show-expose-window-mode-key-binding) (add-menu-key 'help-menu "c" 'show-corner-help) (add-menu-key 'help-menu "g" 'show-config-variable) (add-menu-key 'help-menu "d" 'show-date) From pbrochard at common-lisp.net Thu Sep 30 07:15:00 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 30 Sep 2010 03:15:00 -0400 Subject: [clfswm-cvs] r338 - clfswm Message-ID: Author: pbrochard Date: Thu Sep 30 03:14:59 2010 New Revision: 338 Log: TODO update Modified: clfswm/TODO Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Thu Sep 30 03:14:59 2010 @@ -7,6 +7,8 @@ =============== Should handle these soon. +- Add a expose-(all-)windows menu. + - Add a binding/functions to circulate over children of the current child. MAYBE From pbrochard at common-lisp.net Thu Sep 30 12:23:19 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 30 Sep 2010 08:23:19 -0400 Subject: [clfswm-cvs] r339 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Sep 30 08:23:19 2010 New Revision: 339 Log: src/clfswm-expose-mode.lisp (expose-create-window): Show window title in accel window. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-expose-mode.lisp clfswm/src/config.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Sep 30 08:23:19 2010 @@ -1,3 +1,8 @@ +2010-09-30 Philippe Brochard + + * src/clfswm-expose-mode.lisp (expose-create-window): Show window + title in accel window. + 2010-09-29 Philippe Brochard * configure: Use the Xavier Maillard clfswm script in contrib to Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Thu Sep 30 08:23:19 2010 @@ -7,8 +7,6 @@ =============== Should handle these soon. -- Add a expose-(all-)windows menu. - - Add a binding/functions to circulate over children of the current child. MAYBE Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Thu Sep 30 08:23:19 2010 @@ -97,33 +97,39 @@ (defun expose-draw-letter () - (loop for lwin in *expose-windows-list* - for n from 0 do + (loop for lwin in *expose-windows-list* do (xlib:draw-glyphs (first lwin) (second lwin) (xlib:max-char-width *expose-font*) (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*)) - (format nil "~A" (number->char n))))) + (third lwin)))) (defun expose-create-window (child n) - (declare (ignore n)) - (with-placement (*expose-mode-placement* x y (child-width child) (child-height child)) - (let* ((window (xlib:create-window :parent *root* - :x (+ (child-x child) x) - :y (+ (child-y child) y) - :width (* (xlib:max-char-width *expose-font*) 3) - :height (* (xlib:font-ascent *expose-font*) 2) + (let* ((*current-child* child) + (string (format nil "~A~A" (number->char n) + (if *expose-show-window-title* + (format nil " - ~A" (child-fullname child)) + ""))) + (width (if *expose-show-window-title* + (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2)) + (- (child-width child) 4)) + (* (xlib:max-char-width *expose-font*) 3))) + (height (* (xlib:font-ascent *expose-font*) 2))) + (with-placement (*expose-mode-placement* x y width height) + (let* ((window (xlib:create-window :parent *root* + :x x :y y + :width width :height height + :background (get-color *expose-background*) + :border-width 1 + :border (get-color *expose-border*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press))) + (gc (xlib:create-gcontext :drawable window + :foreground (get-color *expose-foreground*) :background (get-color *expose-background*) - :border-width 1 - :border (get-color *expose-border*) - :colormap (xlib:screen-default-colormap *screen*) - :event-mask '(:exposure :key-press))) - (gc (xlib:create-gcontext :drawable window - :foreground (get-color *expose-foreground*) - :background (get-color *expose-background*) - :font *expose-font* - :line-style :solid))) - (map-window window) - (push (list window gc) *expose-windows-list*)))) + :font *expose-font* + :line-style :solid))) + (map-window window) + (push (list window gc string) *expose-windows-list*))))) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Thu Sep 30 08:23:19 2010 @@ -274,6 +274,8 @@ "Config(Expose mode group): Expose string window border color") (defparameter *expose-valid-on-key* t "Config(Expose mode group): Valid expose mode when an accel key is pressed") +(defparameter *expose-show-window-title* t + "Config(Expose mode group): Show the window title on accel window") Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Thu Sep 30 08:23:19 2010 @@ -206,7 +206,7 @@ "Config(Placement group): Query mode window placement") (defparameter *circulate-mode-placement* 'bottom-middle-placement "Config(Placement group): Circulate mode window placement") -(defparameter *expose-mode-placement* 'top-left-placement +(defparameter *expose-mode-placement* 'top-left-child-placement "Config(Placement group): Expose mode window placement (Selection keys position)")