Add stumpwm-scm
This commit is contained in:
parent
39f13f3216
commit
27cb0dd97e
5 changed files with 266 additions and 0 deletions
|
@ -2,3 +2,4 @@ app-security
|
|||
dev-lang
|
||||
dev-python
|
||||
media-sound
|
||||
x11-wm
|
||||
|
|
1
packages/x11-wm/stumpwm/files/stumpwm-exherbo.el.in
Normal file
1
packages/x11-wm/stumpwm/files/stumpwm-exherbo.el.in
Normal file
|
@ -0,0 +1 @@
|
|||
(autoload 'stumpwm-mode "stumpwm-mode" nil t)
|
132
packages/x11-wm/stumpwm/files/stumpwm-hex-colours.patch
Normal file
132
packages/x11-wm/stumpwm/files/stumpwm-hex-colours.patch
Normal file
|
@ -0,0 +1,132 @@
|
|||
diff --git a/color.lisp b/color.lisp
|
||||
index 2085fbc..5ada58a 100644
|
||||
--- a/color.lisp
|
||||
+++ b/color.lisp
|
||||
@@ -66,31 +66,38 @@ then call (update-color-map).")
|
||||
(xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color))
|
||||
|
||||
(defun lookup-color (screen color)
|
||||
- (cond
|
||||
- ((typep color 'xlib:color) color)
|
||||
- (t (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color))))
|
||||
+ (flet ((hex ()
|
||||
+ (apply #'xlib:make-color
|
||||
+ (loop for (x y) in '((:red 16) (:green 8) (:blue 0))
|
||||
+ nconcing (list x (/ (ldb (byte 8 y) color)
|
||||
+ 256))))))
|
||||
+ (cond ((integerp color) (hex))
|
||||
+ ((typep color 'xlib:color) color)
|
||||
+ (t (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)))))
|
||||
|
||||
;; Normal colors are dimmed and bright colors are intensified in order
|
||||
;; to more closely resemble the VGA pallet.
|
||||
(defun update-color-map (screen)
|
||||
"Read *colors* and cache their pixel colors for use when rendering colored text."
|
||||
- (let ((scm (xlib:screen-default-colormap (screen-number screen))))
|
||||
- (labels ((map-colors (amt)
|
||||
- (loop for c in *colors*
|
||||
- as color = (lookup-color screen c)
|
||||
- do (adjust-color color amt)
|
||||
- collect (xlib:alloc-color scm color))))
|
||||
- (setf (screen-color-map-normal screen) (apply #'vector (map-colors -0.25))
|
||||
- (screen-color-map-bright screen) (apply #'vector (map-colors 0.25))))))
|
||||
+ (labels ((map-colors (amt)
|
||||
+ (loop for c in *colors*
|
||||
+ as color = (lookup-color screen c)
|
||||
+ do (adjust-color color amt)
|
||||
+ collect (alloc-color screen color))))
|
||||
+ (let ((amt (if *bright-colors*
|
||||
+ '(-0.25 . 0.25)
|
||||
+ '(0.0 . 0.0))))
|
||||
+ (setf (screen-color-map-normal screen) (apply #'vector (map-colors (car amt)))
|
||||
+ (screen-color-map-bright screen) (apply #'vector (map-colors (cdr amt)))))))
|
||||
|
||||
(defun update-screen-color-context (screen)
|
||||
- (let* ((cc (screen-message-cc screen))
|
||||
- (bright (lookup-color screen *text-color*)))
|
||||
- (setf
|
||||
- (ccontext-default-fg cc) (screen-fg-color screen)
|
||||
- (ccontext-default-bg cc) (screen-bg-color screen))
|
||||
- (adjust-color bright 0.25)
|
||||
- (setf (ccontext-default-bright cc) (alloc-color screen bright))))
|
||||
+ (let ((cc (screen-message-cc screen))
|
||||
+ (bright (lookup-color screen *text-color*)))
|
||||
+ (when *bright-colors*
|
||||
+ (adjust-color bright 0.25))
|
||||
+ (setf (ccontext-default-fg cc) (screen-fg-color screen)
|
||||
+ (ccontext-default-bg cc) (screen-bg-color screen)
|
||||
+ (ccontext-default-bright cc) (alloc-color screen bright))))
|
||||
|
||||
(defun get-bg-color (screen cc color)
|
||||
(setf *background* color)
|
||||
diff --git a/mode-line.lisp b/mode-line.lisp
|
||||
index d30dfb9..42c3bc2 100644
|
||||
--- a/mode-line.lisp
|
||||
+++ b/mode-line.lisp
|
||||
@@ -282,8 +282,8 @@ critical."
|
||||
(xlib:create-window
|
||||
:parent parent
|
||||
:x 0 :y 0 :width 1 :height 1
|
||||
- :background (alloc-color screen *mode-line-background-color*)
|
||||
- :border (alloc-color screen *mode-line-border-color*)
|
||||
+ :background (alloc-color screen (lookup-color screen *mode-line-background-color*))
|
||||
+ :border (alloc-color screen (lookup-color screen *mode-line-border-color*))
|
||||
:border-width *mode-line-border-width*
|
||||
;; You can click the modeline
|
||||
:event-mask (xlib:make-event-mask :button-press :exposure)
|
||||
@@ -350,15 +350,16 @@ critical."
|
||||
(defun make-mode-line-gc (window screen)
|
||||
(xlib:create-gcontext :drawable window
|
||||
:font (screen-font screen)
|
||||
- :foreground (alloc-color screen *mode-line-foreground-color*)
|
||||
- :background (alloc-color screen *mode-line-background-color*)))
|
||||
+ :foreground (alloc-color screen (lookup-color screen *mode-line-foreground-color*))
|
||||
+ :background (alloc-color screen (lookup-color screen *mode-line-background-color*))))
|
||||
|
||||
|
||||
(defun update-mode-line-color-context (ml)
|
||||
(let* ((cc (mode-line-cc ml))
|
||||
(screen (mode-line-screen ml))
|
||||
(bright (lookup-color screen *mode-line-foreground-color*)))
|
||||
- (adjust-color bright 0.25)
|
||||
+ (when *bright-colors*
|
||||
+ (adjust-color bright 0.25))
|
||||
(setf (ccontext-default-bright cc) (alloc-color screen bright))))
|
||||
|
||||
(defun make-head-mode-line (screen head format)
|
||||
diff --git a/primitives.lisp b/primitives.lisp
|
||||
index 50d062e..c37a028 100644
|
||||
--- a/primitives.lisp
|
||||
+++ b/primitives.lisp
|
||||
@@ -109,6 +109,7 @@
|
||||
*default-group-name*
|
||||
*window-border-style*
|
||||
*data-dir*
|
||||
+ *bright-colors*
|
||||
add-hook
|
||||
clear-window-placement-rules
|
||||
concat
|
||||
@@ -153,6 +154,9 @@ be an integer.")
|
||||
(defvar *grab-pointer-count* 0
|
||||
"The number of times the pointer has been grabbed")
|
||||
|
||||
+(defvar *bright-colors* t
|
||||
+ "Make colors brighter. This is the default.")
|
||||
+
|
||||
;;; Hooks
|
||||
|
||||
(defvar *command-mode-start-hook* '(command-mode-start-message)
|
||||
diff --git a/screen.lisp b/screen.lisp
|
||||
index ab708c3..562dbf4 100644
|
||||
--- a/screen.lisp
|
||||
+++ b/screen.lisp
|
||||
@@ -249,7 +249,7 @@ identity with a range check."
|
||||
|
||||
(defmacro set-any-color (val color)
|
||||
`(progn (dolist (s *screen-list*)
|
||||
- (setf (,val s) (alloc-color s ,color)))
|
||||
+ (setf (,val s) (alloc-color s (lookup-color s ,color))))
|
||||
(update-colors-all-screens)))
|
||||
|
||||
;; FIXME: I don't like any of this. Isn't there a way to define
|
||||
|
77
packages/x11-wm/stumpwm/files/stumpwm-printing.patch
Normal file
77
packages/x11-wm/stumpwm/files/stumpwm-printing.patch
Normal file
|
@ -0,0 +1,77 @@
|
|||
Source: Elias Pipping <pipping@exherbo.org>
|
||||
Upstream: no (pasted on irc)
|
||||
Reason: A window whose title contains the string ^\ cannot have it printed
|
||||
|
||||
From 56b478ae447ca8bf4b0d6d80e10fe00fb1c8d95b Mon Sep 17 00:00:00 2001
|
||||
From: Elias Pipping <pipping@exherbo.org>
|
||||
Date: Sat, 5 Jan 2013 22:03:53 +0100
|
||||
Subject: [PATCH 1/2] Typo
|
||||
|
||||
---
|
||||
primitives.lisp | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/primitives.lisp b/primitives.lisp
|
||||
index 50d062e..3d42012 100644
|
||||
--- a/primitives.lisp
|
||||
+++ b/primitives.lisp
|
||||
@@ -753,7 +753,7 @@ do:
|
||||
(format t "%~a~@[~a~]" len from-left-p)
|
||||
(let* ((fmt (cadr (assoc (car cur) fmt-alist :test 'char=)))
|
||||
(str (cond (fmt
|
||||
- ;; it can return any type, not jut as string.
|
||||
+ ;; it can return any type, not just a string.
|
||||
(format nil "~a" (apply fmt args)))
|
||||
((char= (car cur) #\%)
|
||||
(string #\%))
|
||||
--
|
||||
1.8.0.3
|
||||
|
||||
From db588e4393567b3016c2be57511d35d3c01e4e46 Mon Sep 17 00:00:00 2001
|
||||
From: Elias Pipping <pipping@exherbo.org>
|
||||
Date: Sat, 5 Jan 2013 22:08:11 +0100
|
||||
Subject: [PATCH 2/2] Escape window information before printing
|
||||
|
||||
Otherwise, a window with a title like ^\ will wreak havoc when
|
||||
echo-string-list fails to parse it.
|
||||
---
|
||||
primitives.lisp | 16 ++++++++++++++--
|
||||
1 file changed, 14 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/primitives.lisp b/primitives.lisp
|
||||
index 3d42012..88b45d4 100644
|
||||
--- a/primitives.lisp
|
||||
+++ b/primitives.lisp
|
||||
@@ -732,6 +732,15 @@ do:
|
||||
;;;
|
||||
;;; formatting routines
|
||||
|
||||
+(defun escape-string (str)
|
||||
+ (let (buf)
|
||||
+ (map nil #'(lambda (ch)
|
||||
+ (push ch buf)
|
||||
+ (when (char= ch #\^)
|
||||
+ (push ch buf)))
|
||||
+ str)
|
||||
+ (coerce (reverse buf) 'string)))
|
||||
+
|
||||
(defun format-expand (fmt-alist fmt &rest args)
|
||||
(let* ((chars (coerce fmt 'list))
|
||||
(output "")
|
||||
@@ -753,8 +762,11 @@ do:
|
||||
(format t "%~a~@[~a~]" len from-left-p)
|
||||
(let* ((fmt (cadr (assoc (car cur) fmt-alist :test 'char=)))
|
||||
(str (cond (fmt
|
||||
- ;; it can return any type, not just a string.
|
||||
- (format nil "~a" (apply fmt args)))
|
||||
+ ;; Any sequence that could be interpreted as
|
||||
+ ;; a colorisation directive is escaped here
|
||||
+ (escape-string
|
||||
+ ;; it can return any type, not just a string.
|
||||
+ (format nil "~a" (apply fmt args))))
|
||||
((char= (car cur) #\%)
|
||||
(string #\%))
|
||||
(t
|
||||
--
|
||||
1.8.0.3
|
||||
|
55
packages/x11-wm/stumpwm/stumpwm-scm.exheres-0
Normal file
55
packages/x11-wm/stumpwm/stumpwm-scm.exheres-0
Normal file
|
@ -0,0 +1,55 @@
|
|||
# Copyright 2011 Elias Pipping <pipping@exherbo.org>
|
||||
# Distributed under the terms of the GNU General Public License v2
|
||||
|
||||
require github [ user=sabetts ] autotools [ supported_autoconf=[ 2.5 ] supported_automake=[ none ] ]
|
||||
require elisp-optional [ source_directory=contrib ]
|
||||
|
||||
SUMMARY="A tiling, keyboard driven X11 Window Manager written entirely in Common Lisp"
|
||||
HOMEPAGE="http://www.nongnu.org/stumpwm/"
|
||||
|
||||
LICENCES="GPL-2"
|
||||
SLOT="0"
|
||||
PLATFORMS="~amd64"
|
||||
MYOPTIONS="emacs"
|
||||
|
||||
DEPENDENCIES="
|
||||
build:
|
||||
dev-lisp/cl-ppcre
|
||||
dev-lisp/clx[~scm]
|
||||
build+run:
|
||||
dev-lang/sbcl [[ note = [ contains asdf ] ]]
|
||||
suggestion:
|
||||
(
|
||||
app-misc/rlwrap
|
||||
x11-apps/xprop
|
||||
) [[ *description = [ For stumpish ] ]]
|
||||
"
|
||||
|
||||
RESTRICT="strip"
|
||||
|
||||
DEFAULT_SRC_PREPARE_PATCHES=( "${FILES}"/stumpwm-printing.patch
|
||||
"${FILES}"/stumpwm-hex-colours.patch )
|
||||
DEFAULT_SRC_CONFIGURE_PARAMS=( --with-lisp=sbcl )
|
||||
DEFAULT_SRC_COMPILE_PARAMS=( -j1 LISP='/usr/bin/sbcl --disable-debugger' )
|
||||
|
||||
src_prepare() {
|
||||
default
|
||||
eautoconf
|
||||
}
|
||||
|
||||
src_compile() {
|
||||
default
|
||||
elisp-optional_src_compile
|
||||
}
|
||||
|
||||
src_install() {
|
||||
emake install destdir="${IMAGE}"
|
||||
|
||||
insinto /usr/share/${PN}/contrib
|
||||
doins contrib/*.lisp
|
||||
|
||||
dobin contrib/stumpish
|
||||
|
||||
elisp-optional_src_install
|
||||
}
|
||||
|
Loading…
Reference in a new issue