├── .gitignore
├── .gitmodules
├── AUTHORS
├── COPYING
├── ChangeLog
├── FONTS
├── Makefile
├── README
├── TODO
├── clfswm-session.desktop
├── clfswm.1
├── clfswm.asd
├── clfswm.desktop
├── contrib
    ├── README
    ├── amixer.lisp
    ├── blank-window-mode.lisp
    ├── cd-player.lisp
    ├── clfswm
    ├── contrib-example.lisp
    ├── fcitx.lisp
    ├── keyb_fr.lisp
    ├── moc.lisp
    ├── mpd.lisp
    ├── osd.lisp
    ├── reboot-halt.lisp
    ├── server
    │   ├── clfswm-client.asd
    │   ├── clfswm-client.lisp
    │   ├── crypt.lisp
    │   ├── key.lisp
    │   ├── load.lisp
    │   ├── md5.lisp
    │   ├── net.lisp
    │   ├── server.lisp
    │   └── test.lisp
    ├── toolbar.lisp
    ├── volume-mode.lisp
    ├── wallpaper.lisp
    └── xmms.lisp
├── doc
    ├── README
    ├── clfswm.1.txt
    ├── corner.html
    ├── corner.txt
    ├── dot-clfswmrc
    ├── keys.html
    ├── keys.txt
    ├── menu.html
    ├── menu.txt
    ├── variables.html
    └── variables.txt
├── load.lisp
└── src
    ├── bindings-second-mode.lisp
    ├── bindings.lisp
    ├── clfswm-autodoc.lisp
    ├── clfswm-circulate-mode.lisp
    ├── clfswm-configuration.lisp
    ├── clfswm-corner.lisp
    ├── clfswm-expose-mode.lisp
    ├── clfswm-fastswitch-mode.lisp
    ├── clfswm-generic-mode.lisp
    ├── clfswm-info.lisp
    ├── clfswm-internal.lisp
    ├── clfswm-keys.lisp
    ├── clfswm-layout.lisp
    ├── clfswm-menu.lisp
    ├── clfswm-nw-hooks.lisp
    ├── clfswm-pack.lisp
    ├── clfswm-placement.lisp
    ├── clfswm-query.lisp
    ├── clfswm-second-mode.lisp
    ├── clfswm-util.lisp
    ├── clfswm.lisp
    ├── config.lisp
    ├── keysyms.lisp
    ├── menu-def.lisp
    ├── my-html.lisp
    ├── netwm-util.lisp
    ├── package.lisp
    ├── tools.lisp
    ├── version.lisp
    └── xlib-util.lisp


/.gitignore:
--------------------------------------------------------------------------------
 1 | # git-ls-files --others --exclude-from=.git/info/exclude
 2 | # Lines that start with '#' are comments.
 3 | # For a project mostly in C, the following would be a good set of
 4 | # exclude patterns (uncomment them if you want to use them):
 5 | *.fas
 6 | *.fasl
 7 | *.lx64fsl
 8 | *.lib
 9 | *.orig
10 | *.patch
11 | *.diff
12 | *~
13 | 
14 | # Ignore CLX
15 | clx/
16 | 
17 | asdf.lisp
18 | clfswm
19 | 
20 | # Personal scripts:
21 | 1disp-load.lisp
22 | git-commit.sh
23 | 


--------------------------------------------------------------------------------
/.gitmodules:
--------------------------------------------------------------------------------
1 | [submodule "genera-fonts"]
2 | 	path = genera-fonts
3 | 	url = https://github.com/jethrovt/genera-fonts.git
4 | 


--------------------------------------------------------------------------------
/AUTHORS:
--------------------------------------------------------------------------------
 1 | CLFSWM -  A(nother) Common Lisp FullScreen Window Manager
 2 | ---------------------------------------------------------
 3 | 
 4 | Philippe Brochard   pbrochard at common-lisp dot net
 5 | 
 6 | 
 7 | Contributors
 8 | ------------
 9 | 
10 | Xavier Maillard     xma at gnu dot org
11 | Cyrille THOUVENIN
12 | Desmond O. Chang <dochang at gmail dot com>
13 | Sylvain HENRY <hsyl20 at gmail dot com>
14 | Ales Guzik <ales dot guzik at gmail dot com>
15 | Philipp Kroos <philipp dot kroos at t-online dot de>
16 | Jair Wang <andpuke at foxmail dot com>
17 | 
18 | -----------------------------------
19 | 
20 | Some of the CLFSWM code is based on
21 | 
22 | tinywm: http://incise.org/index.cgi/TinyWM
23 | 
24 | And on the excellent Shawn Betts (sabetts at vcn bc ca)
25 | Stumpwm: http://www.nongnu.org/stumpwm/
26 | 


--------------------------------------------------------------------------------
/ChangeLog:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/LdBeth/CLFSWM/4e936552d1388718d2947a5f6ca3eada19643e75/ChangeLog


--------------------------------------------------------------------------------
/FONTS:
--------------------------------------------------------------------------------
 1 | ====================
 2 |     Genera Fonts
 3 | ====================
 4 | CLFSWM uses `bfd` format Symbolics Genera fonts in the git submodule
 5 | `genera-fonts`. The default font is `genera-cptfontc`.
 6 | 
 7 | Installation
 8 | ============
 9 | To install fonts, first create a directory `/usr/share/fonts/genera`,
10 | and copying all files under `genera-fonts/bfd` to it, then make
11 | X Window recognize these fonts by adding these two lines to `.xintrc`.
12 | 
13 |     xset fp+ ~/x11/fonts/genera/
14 |     xset fp rehash
15 | 
16 | 
17 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | DESTDIR=/usr/local/
 2 | 
 3 | LOAD=load.lisp
 4 | 
 5 | all: clfswm
 6 | 
 7 | clfswm:
 8 | 	@echo "Please, tweak the file load.lisp to fit your needs."
 9 | 	@clisp -E iso-8859-1 $(LOAD) || \
10 | 	sbcl --load $(LOAD) || \
11 | 	cmucl -load $(LOAD) || lisp -load $(LOAD) || \
12 | 	ccl --load $(LOAD) || \
13 | 	ecl -load $(LOAD) || \
14 | 	echo "No Lisp found. Please, install one of CLISP, SBCL, CMUCL, CCL or ECL"
15 | 
16 | 
17 | install: clfswm
18 | 	@echo "Installing CLFSWM in $(DESTDIR)"
19 | 	mkdir -p $(DESTDIR)
20 | 	mkdir -p $(DESTDIR)/bin
21 | 	mkdir -p $(DESTDIR)/lib/clfswm
22 | 	mkdir -p $(DESTDIR)/share/doc/clfswm
23 | 	mkdir -p $(DESTDIR)/man/man.1
24 | 	mkdir -p $(DESTDIR)/share/applications
25 | 	mkdir -p $(DESTDIR)/share/xsessions
26 | 	cp clfswm $(DESTDIR)/bin/
27 | 	cp -R contrib/* $(DESTDIR)/lib/clfswm/
28 | 	cp doc/* $(DESTDIR)/share/doc/clfswm/
29 | 	cp README COPYING AUTHORS $(DESTDIR)/share/doc/clfswm/
30 | 	cp clfswm.1 $(DESTDIR)/man/man.1/
31 | 	cp clfswm.desktop $(DESTDIR)/share/applications/
32 | 	cp clfswm-session.desktop $(DESTDIR)/share/xsessions/
33 | 
34 | 
35 | uninstall:
36 | 	@echo "Uninstalling CLFSWM from $(DESTDIR)"
37 | 	rm -f $(DESTDIR)/bin/clfswm
38 | 	rm -rf $(DESTDIR)/lib/clfswm/*
39 | 	rm -f $(DESTDIR)/share/doc/clfswm/*
40 | 	rm -f $(DESTDIR)/man/man.1/clfswm.1
41 | 	rm -f $(DESTDIR)/share/applications/clfswm.desktop
42 | 	rm -f $(DESTDIR)/share/xsessions/clfswm-session.desktop
43 | 	rmdir $(DESTDIR)/lib/clfswm
44 | 	rmdir $(DESTDIR)/share/doc/clfswm
45 | 
46 | 
47 | clean:
48 | 	rm -f clfswm
49 | 
50 | 


--------------------------------------------------------------------------------
/README:
--------------------------------------------------------------------------------
  1 |         CLFSWM[0] - A(nother) Common Lisp FullScreen Window Manager
  2 | 
  3 |  CLFSWM is a 100% Common Lisp X11 window manager (based on [1]Tinywm
  4 |  and [2]Stumpwm. Many thanks to them).
  5 |  It can be driven only with the keyboard or with the mouse.
  6 | 
  7 |  A display contains a root frame and its children. A child can be a
  8 |  window or another frame. The root frame or its children can be the
  9 |  current root. The current root is fullscreen maximized (no
 10 |  decorations, no buttons, no menus: nothing, just the application
 11 |  fullscreen!).
 12 | 
 13 |  CLFSWM is highly dynamic. By default there is only one frame. Other
 14 |  frames are created/deleted on the fly. A window can be in more than
 15 |  one frame, so it can have multiple views of the same windows.
 16 | 
 17 |  Using CLFSWM is like walking through a tree of frames and windows.
 18 |  Enter in a child to make it the current root and make it fullscreen
 19 |  maximized. Leave it to make its parent the current root.
 20 | 
 21 |  Here is the default key binding to navigate through this tree:
 22 | 
 23 |   * Alt-Tab: circulate through children of the current child.
 24 |   * Alt-Left/Right: circulate through brother children (ie: this is like
 25 |       workspaces for a more conventional window manager)
 26 |   * Alt-Up: select the first child of the current frame.
 27 |   * Alt-Down: select the parent of the current child.
 28 |   * Alt-Enter: Make the current selected child the current root (ie
 29 |       maximize it)
 30 |   * Alt+Shift-Enter: Make the parent of the current root the current
 31 |       root (ie unmaximize the current root).
 32 | 
 33 |  There is no more need for a pager: you are in the pager!
 34 | 
 35 |  For its binding, CLFSWM has two modes:
 36 |  A main mode with minimal keys and mouse grabbing to avoid conflicts
 37 |  with others applications.
 38 |  And a second mode with more keys and mouse actions.
 39 |  For details of its usage, have a look at the files doc/keys.txt or
 40 |  doc/keys.html
 41 |  A lot of functions to manage CLFSWM can be found in the second mode
 42 |  menu. See the file menu-def.lisp for an overview.
 43 | 
 44 |  A frame can be placed anywhere in its parent frame. And can have
 45 |  different layouts to automatically manage its children (tile, tile
 46 |  to left, to bottom, no layout...).
 47 | 
 48 | 
 49 | * Installation
 50 | 
 51 | Boot up a common lisp implementation. I develop it with sbcl, I test
 52 | it with cmucl regularly and I use it with clisp (you need the clx/xlib
 53 | package).
 54 | 
 55 | To use CLFSWM, load the load.lisp file. It loads the ASDF package,
 56 | build the system and start the main loop. Then it dumps an executable
 57 | image. it may also install files for you in a standard directory
 58 | (/usr/local for example).
 59 | 
 60 | Have a look at load.lisp for more details. You can also make a copy and
 61 | tweak it.
 62 | 
 63 | Another way is to do something like this:
 64 | $ cd /in/the/directory/of/clfswm/
 65 | $ clisp/cmucl/sbcl/...                  # start a lisp
 66 |   > (load "asdf.lisp")                  ; asdf for clisp or cmucl
 67 | or> (require :asdf)                     ; asdf for sbcl
 68 |   > (require :clx)                      ; clx for cmucl
 69 |   > (asdf:oos 'asdf:load-op :clfswm)    ; compile and load the system
 70 |   > (in-package :clfswm)                ; go in the clfswm package
 71 |   > (clfswm:main)                       ; start the main loop
 72 | 
 73 | 
 74 | * Fonts
 75 | 
 76 | CLFSWM by default uses fonts in genera-fonts/, guides on how to
 77 | install these fonts for X Window are described in FONTS.
 78 | 
 79 | If you are having problem installing fonts, feel free to contact
 80 | the maintainer.
 81 | 
 82 | To override the default font, add following line to your config:
 83 | (setf *default-font-string* "fixed")
 84 | 
 85 | A list of valid values for font strings can be get by running:
 86 | $ xlsfonts
 87 | 
 88 | * Tweaking
 89 | 
 90 | To change the default keybinding, have a look at the bindings*.lisp
 91 | files and at the config.lisp file for global variables.
 92 | 
 93 | All variables can be overwritten in a user configuration file:
 94 | $XDG_CONFIG_HOME/clfswm/clfswmrc or $HOME/.clfswmrc or /etc/clfswmrc.
 95 | It's a standard lisp file loaded at start up. There is an example in
 96 | the clfswm source (see dot-clfswmrc).
 97 | 
 98 | There is a lot of hooks in CLFSWM to tweak its behaviour. For example,
 99 | if you want to add some frames at start up you can write your own
100 | init-hook (see dot-clfswmrc).
101 | 
102 | 
103 | * Lisp implementation note
104 | 
105 | If you are using clisp/new-clx, be sure to use the last version (at
106 | least 2.43). Older versions are a little bit bogus.
107 | If you are using clisp/mit-clx or an other clx than clisp/new-clx, you
108 | may find a speed up with the compress notify event. See the variable
109 | *have-to-compress-notify* in the configuration file.
110 | 
111 | 
112 | 
113 | * License
114 | 
115 |  CLFSWM is under the GNU General Public License - GPL license.
116 |  You can find more information in the files COPYING. or on the
117 |  [3]Free Software Foundation site.
118 | 
119 | 
120 | Philippe Brochard <pbrochard [at] common-lisp [dot] net>.
121 | 
122 | Références
123 | 
124 |       http://common-lisp.net/project/clfswm/
125 |       http://trac.common-lisp.net/clfswm/
126 |    1. http://incise.org/index.cgi/TinyWM
127 |    2. http://www.nongnu.org/stumpwm/
128 |    3. http://www.gnu.org/
129 | 


--------------------------------------------------------------------------------
/TODO:
--------------------------------------------------------------------------------
 1 | This file contains suggestions for further work.
 2 | Feel free to edit the wiki at http://trac.common-lisp.net/clfswm/wiki
 3 | if you want something in clfswm.
 4 | 
 5 | 
 6 | URGENT PROBLEMS
 7 | ===============
 8 | Should handle these soon.
 9 | 
10 | - Make CLFSWM running with ECL
11 | 
12 | - Implement a save/restore root-frame system. And use it on error reset or for undo/redo.
13 | 
14 | - Undo/redo
15 | 
16 | - Dump frame -> tree saved in register / save/restore (frame-tree-register n)
17 | 
18 | - Save/restore frame-tree-register to file (~/.clfswmrc)
19 | 
20 | 
21 | FOR THE NEXT RELEASE
22 | ====================
23 | 
24 | - Add toolbar modules in contrib/toolbar.lisp. Any help or request on adding the modules
25 |   you want in your toolbar is very welcome.
26 | 
27 | 
28 | MAYBE
29 | =====
30 | 
31 | - Add a tabbar layout : save some space on top/left... of the frame and display clickable
32 |     children name.
33 | 
34 | - cd/pwd/find a la shell to navigate through frames.
35 | 
36 | - Zoom:
37 |     Concept:
38 |       * zoom out: Behave as if the application window is bigger for the application but
39 |         completely drawn in a small amount of space (miniature). The zoom factor is inferior to 100%
40 |       * zoom in: Behave as a magnifying glass. The zoom factor is superior to 100%.
41 |         The part of the application window shown (viewport) can be moved.
42 | 
43 |     Operation:
44 |       * set-zoom-factor (frame, factor)
45 |       * move-viewport (frame &optional (increment 1))
46 |         * left
47 |         * right
48 |         * up
49 |         * down
50 | 
51 |     Note: This is done by some applications like the surf web browser from suckless:
52 |       http://surf.suckless.org/
53 | 
54 |     Maybe this can be done with a compositing system:
55 |       http://en.wikipedia.org/wiki/Compositing_window_manager
56 |       http://ktown.kde.org/~fredrik/composite_howto.html
57 | 
58 | - A screen lock with the ability to display custom texts and images.
59 | 
60 | - A dmenu like auto-completion menu for query window.
61 | 
62 | 
63 | 


--------------------------------------------------------------------------------
/clfswm-session.desktop:
--------------------------------------------------------------------------------
 1 | [Desktop Entry]
 2 | Version=1212
 3 | Encoding=UTF-8
 4 | Name=clfswm
 5 | Name[en_US]=clfswm
 6 | Comment=A(nother) Common Lisp FullScreen Window Manager
 7 | Terminal=false
 8 | Exec=clfswm
 9 | TryExec=clfswm
10 | 
11 | [Window Manager]
12 | SessionManaged=true
13 | 


--------------------------------------------------------------------------------
/clfswm.1:
--------------------------------------------------------------------------------
  1 | '\" t
  2 | .\"     Title: clfswm
  3 | .\"    Author: [see the "AUTHOR" section]
  4 | .\" Generator: DocBook XSL Stylesheets v1.76.1 <http://docbook.sf.net/>
  5 | .\"      Date: 10/12/2012
  6 | .\"    Manual: \ \&
  7 | .\"    Source: \ \&
  8 | .\"  Language: English
  9 | .\"
 10 | .TH "CLFSWM" "1" "10/12/2012" "\ \&" "\ \&"
 11 | .\" -----------------------------------------------------------------
 12 | .\" * Define some portability stuff
 13 | .\" -----------------------------------------------------------------
 14 | .\" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 15 | .\" http://bugs.debian.org/507673
 16 | .\" http://lists.gnu.org/archive/html/groff/2009-02/msg00013.html
 17 | .\" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 18 | .ie \n(.g .ds Aq \(aq
 19 | .el       .ds Aq '
 20 | .\" -----------------------------------------------------------------
 21 | .\" * set default formatting
 22 | .\" -----------------------------------------------------------------
 23 | .\" disable hyphenation
 24 | .nh
 25 | .\" disable justification (adjust text to left margin only)
 26 | .ad l
 27 | .\" -----------------------------------------------------------------
 28 | .\" * MAIN CONTENT STARTS HERE *
 29 | .\" -----------------------------------------------------------------
 30 | .SH "NAME"
 31 | clfswm \- A(nother) Common Lisp Full Screen Window Manager
 32 | .SH "SYNOPSIS"
 33 | .sp
 34 | \fBclfswm\fR [\fIimplementation\fR]
 35 | .SH "DESCRIPTION"
 36 | .sp
 37 | CLFSWM is a 100% Common Lisp X11 window manager (based on Tinywm and Stumpwm\&. Many thanks to them)\&. It can be driven only with the keyboard or with the mouse\&.
 38 | .sp
 39 | CLFSWM uses the following rules to determine which implementation should be used:
 40 | .sp
 41 | .RS 4
 42 | .ie n \{\
 43 | \h'-04' 1.\h'+01'\c
 44 | .\}
 45 | .el \{\
 46 | .sp -1
 47 | .IP "  1." 4.2
 48 | .\}
 49 | the first command line argument\&.
 50 | .RE
 51 | .sp
 52 | .RS 4
 53 | .ie n \{\
 54 | \h'-04' 2.\h'+01'\c
 55 | .\}
 56 | .el \{\
 57 | .sp -1
 58 | .IP "  2." 4.2
 59 | .\}
 60 | environment variable $LISP
 61 | .RE
 62 | .sp
 63 | .RS 4
 64 | .ie n \{\
 65 | \h'-04' 3.\h'+01'\c
 66 | .\}
 67 | .el \{\
 68 | .sp -1
 69 | .IP "  3." 4.2
 70 | .\}
 71 | the first line like "debian=<impl>" in its configuration file\&.
 72 | .RE
 73 | .sp
 74 | .RS 4
 75 | .ie n \{\
 76 | \h'-04' 4.\h'+01'\c
 77 | .\}
 78 | .el \{\
 79 | .sp -1
 80 | .IP "  4." 4.2
 81 | .\}
 82 | clisp
 83 | .RE
 84 | .sp
 85 | CLFSWM handles clisp, sbcl and cmucl internally\&. If you specify a different implementation, CLFSWM will try to execute the command clfswm\-<implementation>\&. See /usr/share/doc/clfswm/README\&.Debian for details\&.
 86 | .SH "OPTIONS"
 87 | .PP
 88 | \fIimplementation\fR
 89 | .RS 4
 90 | Indicates which implementation should be used\&.
 91 | .RE
 92 | .SH "ENVIRONMENT"
 93 | .PP
 94 | \fILISP\fR
 95 | .RS 4
 96 | Indicates which implementation should be used\&.
 97 | .RE
 98 | .SH "FILES"
 99 | .PP
100 | \fI$XDG_CONFIG_HOME/clfswm/clfswmrc\fR
101 | .RS 4
102 | User configuration file\&. If XDG_CONFIG_HOME is undefined,
103 | \fI$HOME/\&.config/clfswm/clfswmrc\fR
104 | will be used\&.
105 | .RE
106 | .PP
107 | \fI$HOME/\&.clfswmrc\fR
108 | .RS 4
109 | Deprecated\&. This file will be used only if the previous file does not exist\&.
110 | .RE
111 | .PP
112 | \fI/etc/clfswmrc\fR
113 | .RS 4
114 | System\-wide configuration file\&.
115 | .RE
116 | .SH "SEE ALSO"
117 | .sp
118 | clisp(1), sbcl(1), cmucl(1)\&.
119 | .SH "AUTHOR"
120 | .sp
121 | CLFSWM was written by Philippe Brochard <pbrochard@common\-lisp\&.net>\&.
122 | .sp
123 | This manual page was written by Desmond O\&. Chang <dochang@gmail\&.com>, for the Debian project (and may be used by others)\&.
124 | 


--------------------------------------------------------------------------------
/clfswm.asd:
--------------------------------------------------------------------------------
 1 |  ;;;; -*- Mode: Lisp -*-
 2 | ;;;; Author: Philippe Brochard <hocwp@free.fr>
 3 | ;;;; ASDF System Definition
 4 | ;;;
 5 | 
 6 | (in-package #:asdf)
 7 | 
 8 | (defsystem clfswm
 9 |   :description "CLFSWM: Fullscreen Window Manager"
10 |   :version "1209.2"
11 |   :author "Philippe Brochard  <hocwp@free.fr>"
12 |   :licence "GNU Public License (GPL)"
13 |   :components ((:module src
14 | 			:components
15 | 			((:file "tools")
16 |                          (:file "version"
17 | 				:depends-on ("tools"))
18 | 			 (:file "my-html"
19 | 				:depends-on ("tools"))
20 | 			 (:file "package"
21 | 				:depends-on ("my-html" "tools" "version"))
22 | 			 (:file "keysyms"
23 | 				:depends-on ("package"))
24 | 			 (:file "xlib-util"
25 | 				:depends-on ("package" "keysyms" "tools"))
26 | 			 (:file "config"
27 | 				:depends-on ("package" "xlib-util"))
28 | 			 (:file "netwm-util"
29 | 				:depends-on ("package" "xlib-util"))
30 | 			 (:file "clfswm-keys"
31 | 				:depends-on ("package" "config" "xlib-util" "keysyms"))
32 | 			 (:file "clfswm-autodoc"
33 | 				:depends-on ("package" "clfswm-keys" "my-html" "tools" "config"))
34 | 			 (:file "clfswm-internal"
35 | 				:depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config"))
36 |                          (:file "clfswm-placement"
37 | 				:depends-on ("package" "clfswm-internal"))
38 | 			 (:file "clfswm-generic-mode"
39 | 				:depends-on ("package" "tools" "xlib-util" "clfswm-internal"))
40 |                          (:file "clfswm-query"
41 | 				:depends-on ("package" "config" "xlib-util" "clfswm-keys"
42 | 						       "clfswm-generic-mode" "clfswm-placement"))
43 | 			 (:file "clfswm-circulate-mode"
44 | 				:depends-on ("xlib-util" "clfswm-keys" "clfswm-generic-mode"
45 | 							 "clfswm-internal" "netwm-util" "tools" "config"
46 |                                                          "clfswm-placement"))
47 | 			 (:file "clfswm"
48 | 				:depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config"
49 | 							 "clfswm-internal" "clfswm-circulate-mode" "tools"))
50 | 			 (:file "clfswm-second-mode"
51 | 				:depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode"
52 | 						       "clfswm-placement"))
53 | 			 (:file "clfswm-expose-mode"
54 | 				:depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools"
55 |                                                        "clfswm-keys" "clfswm-generic-mode" "clfswm-placement"
56 |                                                        "clfswm-query"))
57 |                          (:file "clfswm-fastswitch-mode"
58 |                                 :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools"
59 |                                                        "clfswm-keys" "clfswm-generic-mode" "clfswm-placement"
60 |                                                        "clfswm-expose-mode"))
61 | 			 (:file "clfswm-corner"
62 | 				:depends-on ("package" "config" "clfswm-internal" "clfswm-expose-mode" "xlib-util"))
63 | 			 (:file "clfswm-info"
64 | 				:depends-on ("package" "version" "xlib-util" "config" "clfswm-keys" "clfswm"
65 |                                                        "clfswm-internal"
66 | 						       "clfswm-autodoc" "clfswm-corner"
67 | 						       "clfswm-generic-mode" "clfswm-placement"))
68 | 			 (:file "clfswm-menu"
69 | 				:depends-on ("package" "clfswm-info"))
70 | 			 (:file "clfswm-util"
71 | 				:depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query"
72 |                                                       "clfswm-menu" "clfswm-autodoc" "clfswm-corner"
73 |                                                       "clfswm-placement" "tools"))
74 |                          (:file "clfswm-configuration"
75 | 				:depends-on ("package" "config" "clfswm-internal" "clfswm-util" "clfswm-query"
76 | 						       "clfswm-menu"))
77 |                          (:file "menu-def"
78 | 				:depends-on ("clfswm-menu" "clfswm-configuration" "clfswm" "clfswm-util" "clfswm-info"))
79 | 			 (:file "clfswm-layout"
80 | 				:depends-on ("package" "clfswm-internal" "clfswm-util" "clfswm-info" "menu-def"))
81 | 			 (:file "clfswm-pack"
82 | 				:depends-on ("clfswm" "xlib-util" "clfswm-util" "clfswm-second-mode" "clfswm-layout"))
83 | 			 (:file "clfswm-nw-hooks"
84 | 				:depends-on ("package" "clfswm-util" "clfswm-info" "clfswm-layout" "menu-def"))
85 | 			 (:file "bindings"
86 | 				:depends-on ("clfswm" "clfswm-internal" "clfswm-util" "clfswm-menu"))
87 | 			 (:file "bindings-second-mode"
88 | 				:depends-on ("clfswm" "clfswm-util" "clfswm-query" "bindings" "clfswm-pack"
89 |                                                       "clfswm-menu" "menu-def" "clfswm-layout")))))
90 |   :depends-on ( #-:CLX :clx #+:sbcl :sb-posix #+:ccl :asdf))
91 | 
92 | 
93 | 
94 | 
95 | 
96 | 


--------------------------------------------------------------------------------
/clfswm.desktop:
--------------------------------------------------------------------------------
1 | [Desktop Entry]
2 | Version=1212
3 | Encoding=UTF-8
4 | Type=Application
5 | Name=clfswm
6 | Comment=A(nother) Common Lisp FullScreen Window Manager
7 | Exec=clfswm
8 | 


--------------------------------------------------------------------------------
/contrib/README:
--------------------------------------------------------------------------------
 1 | The contrib directory is here if you want to contribute to CLFSWM and
 2 | if your code is not merged in the clfswm core.
 3 | 
 4 | To contribute, place your files in the contrib directory.
 5 | You can have your own repository and tell me if you want to merge it
 6 | in the clfswm svn/git.
 7 | 
 8 | To use a contributed code add a line like this in your configuration
 9 | file:
10 | 
11 | (load-contrib "contrib-example.lisp")
12 | 
13 | Have fun,
14 | 
15 | Philippe
16 | 


--------------------------------------------------------------------------------
/contrib/amixer.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Volume mode
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2015 Desmond O. Chang <dochang@gmail.com>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; Documentation: A volume mode.
 25 | ;;;   If you want to use this file, just add this line in
 26 | ;;; your configuration file:
 27 | ;;;
 28 | ;;;   (load-contrib "volume-mode.lisp")
 29 | ;;; And with the alsa mixer:
 30 | ;;;   (load-contrib "amixer.lisp")
 31 | ;;;
 32 | ;;;  This mode is inspired by the emms volume package.  When you change the
 33 | ;;;  volume in main mode or second mode, clfswm will enter volume mode and
 34 | ;;;  set a timer to leave this mode.  Changing volume in volume mode will
 35 | ;;;  reset the timer.  You can also leave volume mode manually by return,
 36 | ;;;  escape or control-g.
 37 | ;;;
 38 | ;;;  Special variable *VOLUME-MODE-TIMEOUT* controls the timeout in
 39 | ;;;  seconds.  If it's positive, volume mode will exit when timeout occurs;
 40 | ;;;  if it's 0, volume mode will exit right now; if it's negative, volume
 41 | ;;;  will not exit even if timeout occurs.  Default timeout is 3 seconds.
 42 | ;;;
 43 | ;;;  Volume mode uses three special variables to control the mixer:
 44 | ;;;  *VOLUME-MUTE-FUNCTION*, *VOLUME-LOWER-FUNCTION* and
 45 | ;;;  *VOLUME-RAISE-FUNCTION*.  Their values are functions which must accept
 46 | ;;;  no arguments and return two values indicating the mixer state.  The
 47 | ;;;  first value is the volume ratio whose type must be (real 0 1).  If the
 48 | ;;;  mixer is mute, the second value should be true, otherwise it should be
 49 | ;;;  false.  If volume controller cannot get the mixer state, it must
 50 | ;;;  return NIL.
 51 | ;;;
 52 | ;;;  Volume mode shows a mute sign, a percentage and a ratio bar on the
 53 | ;;;  screen.  A plus sign '+' means it's unmute and a minus sign '-' means
 54 | ;;;  it's mute now.  If volume mode doesn't know the mixer state, a message
 55 | ;;;  "unknown" will be shown.
 56 | ;;;
 57 | ;;;  contrib/amixer.lisp shows how to use volume mode with alsa.
 58 | ;;;
 59 | ;;; --------------------------------------------------------------------------
 60 | 
 61 | (in-package :clfswm)
 62 | 
 63 | (format t "Loading amixer code... ")
 64 | 
 65 | (defvar *amixer-scontrol* "Master"
 66 |   "Default control for amixer commands.")
 67 | 
 68 | (defun amixer-cmd (cmd scontrol &rest parameters)
 69 |   (let* ((sed "sed 's/^.*\\[\\([[:digit:]]\\+\\)%\\].*\\[\\(on\\|off\\)\\].*$/\\1%\\2/'")
 70 |          (fmt "amixer ~A ~A~{ ~A~} 2>/dev/null | tail -1 | ~A")
 71 |          (shell (format nil fmt cmd scontrol parameters sed))
 72 |          (line (read-line (do-shell shell) nil t)))
 73 |     (when (stringp line)
 74 |       (let* ((ratio (parse-integer line :junk-allowed t))
 75 |              (%-pos (position #\% line)))
 76 |         (values (and ratio (/ ratio 100))
 77 |                 (equal "off" (and %-pos (subseq line (1+ %-pos)))))))))
 78 | 
 79 | (defun amixer-sset (&rest parameters)
 80 |   (apply 'amixer-cmd "sset" *amixer-scontrol* parameters))
 81 | 
 82 | (defparameter *volume-mute-function*
 83 |   (lambda () (amixer-sset "toggle")))
 84 | 
 85 | (defparameter *volume-lower-function*
 86 |   (lambda () (amixer-sset "5%-")))
 87 | 
 88 | (defparameter *volume-raise-function*
 89 |   (lambda () (amixer-sset "5%+")))
 90 | 
 91 | (defun amixer-lower-1% ()
 92 |   "Lower 1% volume."
 93 |   (volume-set (lambda () (amixer-sset "1%-"))))
 94 | 
 95 | (defun amixer-raise-1% ()
 96 |   "Raise 1% volume."
 97 |   (volume-set (lambda () (amixer-sset "1%+"))))
 98 | 
 99 | (defun amixer-volume-bind ()
100 |   (define-volume-key ("less") 'amixer-lower-1%)
101 |   (define-volume-key ("greater") 'amixer-raise-1%)
102 |   (define-second-key ("less") 'amixer-lower-1%)
103 |   (define-second-key ("greater") 'amixer-raise-1%))
104 | 
105 | (add-hook *binding-hook* 'amixer-volume-bind)
106 | 
107 | (format t "done~%")
108 | 


--------------------------------------------------------------------------------
/contrib/blank-window-mode.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Blank window mode to place blank window on screen and manage
  6 | ;;;  them with the keyboard or the mouse.
  7 | ;;;  This is useful when you want to hide some part of the screen (for example
  8 | ;;;  in school class for interactive presentation).
  9 | ;;; --------------------------------------------------------------------------
 10 | ;;;
 11 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 12 | ;;;
 13 | ;;; This program is free software; you can redistribute it and/or modify
 14 | ;;; it under the terms of the GNU General Public License as published by
 15 | ;;; the Free Software Foundation; either version 3 of the License, or
 16 | ;;; (at your option) any later version.
 17 | ;;;
 18 | ;;; This program is distributed in the hope that it will be useful,
 19 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 20 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 21 | ;;; GNU General Public License for more details.
 22 | ;;;
 23 | ;;; You should have received a copy of the GNU General Public License
 24 | ;;; along with this program; if not, write to the Free Software
 25 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 26 | ;;;
 27 | ;;; Documentation: Blank window mode to place blank window on screen.
 28 | ;;;   If you want to use this file, just add this line in your configuration
 29 | ;;;   file:
 30 | ;;;
 31 | ;;;   (load-contrib "blank-window-mode.lisp")
 32 | ;;;
 33 | ;;; --------------------------------------------------------------------------
 34 | 
 35 | (in-package :clfswm)
 36 | 
 37 | (format t "Loading Blank Window Mode code... ")
 38 | 
 39 | (defconfig *blank-window-width* 50 'blank-window "Blank window width")
 40 | (defconfig *blank-window-height* 20 'blank-window "Blank window height")
 41 | (defconfig *blank-window-color* "white" 'blank-window "Blank window color")
 42 | (defconfig *blank-window-border* "magenta" 'blank-window "Blank window border color")
 43 | 
 44 | 
 45 | (defparameter *blank-window-list* nil)
 46 | (defparameter *in-blank-window-mode* nil)
 47 | (defparameter *blank-window-show-current* nil)
 48 | 
 49 | (defparameter *blank-window-keys* nil)
 50 | (defparameter *blank-window-mouse* nil)
 51 | 
 52 | 
 53 | (define-init-hash-table-key *blank-window-keys* "Blank-Window mode keys")
 54 | (define-init-hash-table-key *blank-window-mouse* "Blank-Window mode mouse button")
 55 | 
 56 | (define-define-key "blank-window" *blank-window-keys*)
 57 | (define-define-mouse "blank-window-mouse" *blank-window-mouse*)
 58 | 
 59 | (add-hook *binding-hook* 'init-*blank-window-keys*)
 60 | 
 61 | 
 62 | (defun leave-blank-window-mode (&optional window root-x root-y)
 63 |   "Leave the blank-window mode"
 64 |   (declare (ignore window root-x root-y))
 65 |   (when *in-blank-window-mode*
 66 |     (throw 'exit-blank-window-loop nil)))
 67 | 
 68 | 
 69 | 
 70 | (defun bwm-enter-function ()
 71 |   (setf *in-blank-window-mode* t)
 72 |   (ungrab-main-keys)
 73 |   (xgrab-keyboard *root*)
 74 |   (xgrab-pointer *root* 66 67)
 75 |   (dolist (window *blank-window-list*)
 76 |     (raise-window window)))
 77 | 
 78 | 
 79 | (defun bwm-leave-function ()
 80 |   (setf *in-blank-window-mode* nil)
 81 |   (xungrab-keyboard)
 82 |   (xungrab-pointer)
 83 |   (grab-main-keys)
 84 |   (wait-no-key-or-button-press))
 85 | 
 86 | 
 87 | 
 88 | (define-handler blank-window-mode :key-press (code state)
 89 |   (funcall-key-from-code *blank-window-keys* code state))
 90 | 
 91 | (define-handler blank-window-mode :button-press (code state window root-x root-y)
 92 |   (funcall-button-from-code *blank-window-mouse* code state window root-x root-y *fun-press*))
 93 | 
 94 | 
 95 | 
 96 | (defun blank-window-mode ()
 97 |   "Blank window mode"
 98 |   (generic-mode 'blank-window-mode
 99 | 		'exit-blank-window-loop
100 | 		:enter-function #'bwm-enter-function
101 | 		;;:loop-function #'bwm-loop-function
102 | 		:leave-function #'bwm-leave-function
103 |                 :original-mode 'main-mode))
104 | 
105 | 
106 | 
107 | 
108 | (defun create-new-blank-window (&rest args)
109 |   "Create a new blank window"
110 |   (declare (ignore args))
111 |   (with-x-pointer
112 |     (push (xlib:create-window :parent *root*
113 |                               :x (- x 50) :y y
114 |                               :width *blank-window-width* :height *blank-window-height*
115 |                               :background (get-color *blank-window-color*)
116 |                               :border-width 0
117 |                               :border (get-color *blank-window-border*)
118 |                               :colormap (xlib:screen-default-colormap *screen*)
119 |                               :event-mask '(:exposure))
120 |           *blank-window-list*))
121 |   (map-window (first *blank-window-list*)))
122 | 
123 | (defun clear-all-blank-window ()
124 |   "Clear all blank window"
125 |   (dolist (window *blank-window-list*)
126 |     (hide-window window)
127 |     (xlib:destroy-window window))
128 |   (setf *blank-window-list* nil))
129 | 
130 | (defmacro with-current-blank-window ((window) &body body)
131 |   `(let ((,window (first *blank-window-list*)))
132 |      (when ,window
133 |        ,@body)))
134 | 
135 | (defun blank-window-fill-width ()
136 |   "Current blank window fill all width screen"
137 |   (with-current-blank-window (window)
138 |     (setf (xlib:drawable-x window) 0
139 |           (xlib:drawable-width window) (xlib:drawable-width *root*))))
140 | 
141 | (defun blank-window-fill-height ()
142 |   "Current blank window fill all height screen"
143 |   (with-current-blank-window (window)
144 |     (setf (xlib:drawable-y window) 0
145 |           (xlib:drawable-height window) (xlib:drawable-height *root*))))
146 | 
147 | (defun blank-window-down (dy)
148 |   "Move current blank window down"
149 |   (with-current-blank-window (window)
150 |     (incf (xlib:drawable-y window) dy)))
151 | 
152 | (defun blank-window-right (dx)
153 |   "Move current blank window right"
154 |   (with-current-blank-window (window)
155 |     (incf (xlib:drawable-x window) dx)))
156 | 
157 | (defun blank-window-inc-width (dw)
158 |   "Change current blank window width"
159 |   (with-current-blank-window (window)
160 |     (decf (xlib:drawable-x window) dw)
161 |     (incf (xlib:drawable-width window) (* dw 2))))
162 | 
163 | (defun blank-window-inc-height (dh)
164 |   "Change current blank window height"
165 |   (with-current-blank-window (window)
166 |     (decf (xlib:drawable-y window) dh)
167 |     (incf (xlib:drawable-height window) (* dh 2))))
168 | 
169 | 
170 | (defun select-next-blank-window ()
171 |   "Select next blank window"
172 |   (with-current-blank-window (window)
173 |     (setf (xlib:drawable-border-width window) 0))
174 |   (setf *blank-window-list* (rotate-list *blank-window-list*))
175 |   (when *blank-window-show-current*
176 |     (with-current-blank-window (window)
177 |       (setf (xlib:drawable-border-width window) 1))))
178 | 
179 | (defun toggle-show-current-blank-window ()
180 |   (setf *blank-window-show-current* (not *blank-window-show-current*))
181 |   (with-current-blank-window (window)
182 |     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
183 | 
184 | (defun remove-current-blank-window ()
185 |   (let ((window (pop *blank-window-list*)))
186 |     (when window
187 |       (hide-window window)
188 |       (xlib:destroy-window window)))
189 |   (with-current-blank-window (window)
190 |     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
191 | 
192 | (defun find-blank-window-under-mouse ()
193 |   "Return the blank window under the mouse pointer if any"
194 |   (with-x-pointer
195 |     (dolist (win *blank-window-list*)
196 |       (when (in-window win x y)
197 |         (with-current-blank-window (window)
198 |           (setf (xlib:drawable-border-width window) 0))
199 |         (setf *blank-window-list* (remove win *blank-window-list* :test #'xlib:window-equal))
200 |         (push win *blank-window-list*)
201 |         (when *blank-window-show-current*
202 |           (with-current-blank-window (window)
203 |             (setf (xlib:drawable-border-width window) 1)))
204 |         (return-from find-blank-window-under-mouse win)))))
205 | 
206 | (defun move-blank-window (window root-x root-y)
207 |   "Move blank window with the mouse"
208 |   (declare (ignore window))
209 |   (let ((window (find-blank-window-under-mouse)))
210 |     (when window
211 |       (move-window window root-x root-y))))
212 | 
213 | (defun resize-blank-window (window root-x root-y)
214 |   "Resize blank window with the mouse"
215 |   (declare (ignore window))
216 |   (let ((window (find-blank-window-under-mouse)))
217 |     (when window
218 |       (resize-window window root-x root-y))))
219 | 
220 | (defun hide-unhide-current-blank-window ()
221 |   "Hide or unhide the current blank window"
222 |   (with-current-blank-window (window)
223 |     (if (window-hidden-p window)
224 |         (unhide-window window)
225 |         (hide-window window))))
226 | 
227 | 
228 | (defun blank-black-window ()
229 |   "Open a black window. ie light of the screen"
230 |   (let ((black-win (xlib:create-window :parent *root*
231 |                                        :x 0 :y 0
232 |                                        :width (xlib:drawable-width *root*)
233 |                                        :height (xlib:drawable-height *root*)
234 |                                        :background (get-color "black")
235 |                                        :border-width 0
236 |                                        :border (get-color "black")
237 |                                        :colormap (xlib:screen-default-colormap *screen*)
238 |                                        :event-mask '(:exposure))))
239 |     (map-window black-win)
240 |     (wait-no-key-or-button-press)
241 |     (wait-a-key-or-button-press)
242 |     (xlib:destroy-window black-win)
243 |     (wait-no-key-or-button-press)))
244 | 
245 | 
246 | 
247 | (defun set-default-blank-window-keys ()
248 |   ;;(define-blank-window-key ("Return") 'leave-blank-window-mode)
249 |   (define-blank-window-key ("Escape") 'leave-blank-window-mode)
250 |   (define-blank-window-key ("twosuperior") 'leave-blank-window-mode)
251 |   (define-blank-window-key ("Return") 'create-new-blank-window)
252 |   (define-blank-window-key ("BackSpace" :control) 'clear-all-blank-window)
253 |   (define-blank-window-key ("Tab") 'select-next-blank-window)
254 |   (define-blank-window-key ("w") 'blank-window-fill-width)
255 |   (define-blank-window-key ("h") 'blank-window-fill-height)
256 |   (define-blank-window-key ("Down") 'blank-window-down 5)
257 |   (define-blank-window-key ("Down" :shift) 'blank-window-down 1)
258 |   (define-blank-window-key ("Down" :control) 'blank-window-down 20)
259 |   (define-blank-window-key ("Up") 'blank-window-down -5)
260 |   (define-blank-window-key ("Up" :shift) 'blank-window-down -1)
261 |   (define-blank-window-key ("Up" :control) 'blank-window-down -20)
262 |   (define-blank-window-key ("Right") 'blank-window-right 5)
263 |   (define-blank-window-key ("Right" :shift) 'blank-window-right 1)
264 |   (define-blank-window-key ("Right" :control) 'blank-window-right 20)
265 |   (define-blank-window-key ("Left") 'blank-window-right -5)
266 |   (define-blank-window-key ("Left" :shift) 'blank-window-right -1)
267 |   (define-blank-window-key ("Left" :control) 'blank-window-right -20)
268 |   (define-blank-window-key ("c") 'toggle-show-current-blank-window)
269 |   (define-blank-window-key ("p") 'blank-window-inc-width 1)
270 |   (define-blank-window-key ("o") 'blank-window-inc-height 1)
271 |   (define-blank-window-key ("m") 'blank-window-inc-width -1)
272 |   (define-blank-window-key ("l") 'blank-window-inc-height -1)
273 |   (define-blank-window-key ("Delete") 'remove-current-blank-window)
274 |   (define-blank-window-key ("t") 'hide-unhide-current-blank-window)
275 |   (define-blank-window-key ("Control_R") 'banish-pointer)
276 |   (define-blank-window-key ("b") 'banish-pointer)
277 |   (define-blank-window-key ("x") 'blank-black-window)
278 | 
279 |   (define-blank-window-mouse (1) 'move-blank-window)
280 |   (define-blank-window-mouse (2) 'create-new-blank-window)
281 |   (define-blank-window-mouse (3) 'resize-blank-window))
282 | 
283 | 
284 | 
285 | (add-hook *binding-hook* 'set-default-blank-window-keys)
286 | 
287 | 
288 | 
289 | (format t "done~%")
290 | 


--------------------------------------------------------------------------------
/contrib/cd-player.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: Music Player Daemon (MPD) interface
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; Documentation: Handle the CD player
25 | ;;;   This code needs pcd (http://hocwp.free.fr/pcd.html).
26 | ;;    If you want to use this file, just add this line in
27 | ;;;   your configuration file:
28 | ;;;
29 | ;;;     (load-contrib "cd-player.lisp")
30 | ;;;
31 | ;;; --------------------------------------------------------------------------
32 | 
33 | (in-package :clfswm)
34 | 
35 | (format t "Loading CDPLAYER code... ")
36 | 
37 | (defun cdplayer-menu ()
38 |   "Open the CDPLAYER menu"
39 |   (open-menu (find-menu 'cdplayer-menu)))
40 | 
41 | (defun cdplayer-play ()
42 |   "Start playing CD"
43 |   (do-shell "pcd play"))
44 | 
45 | (defun cdplayer-stop ()
46 |   "Stop playing CD"
47 |   (do-shell "pcd stop"))
48 | 
49 | (defun cdplayer-pause ()
50 |   "Toggle pause"
51 |   (do-shell "pcd toggle"))
52 | 
53 | (defun show-cdplayer-status ()
54 |   "Show the current CD status"
55 |   (info-on-shell "CDPLAYER status:" "pcd info")
56 |   (cdplayer-menu))
57 | 
58 | (defun show-cdplayer-playlist ()
59 |   "Show the current CD playlist"
60 |   (info-on-shell "CDPLAYER:" "pcd more_info")
61 |   (cdplayer-menu))
62 | 
63 | (defun cdplayer-next-track ()
64 |   "Play the next CD track"
65 |   (do-shell "pcd next")
66 |   (cdplayer-menu))
67 | 
68 | (defun cdplayer-previous-track ()
69 |   "Play the previous CD track"
70 |   (do-shell "pcd previous")
71 |   (cdplayer-menu))
72 | 
73 | (defun cdplayer-eject ()
74 |   "Eject CD"
75 |   (do-shell "pcd eject"))
76 | 
77 | (defun cdplayer-close ()
78 |   "Close CD"
79 |   (do-shell "pcd close"))
80 | 
81 | (unless (find-menu 'cdplayer-menu)
82 |   (add-sub-menu 'help-menu "i" 'cdplayer-menu "CDPLAYER menu")
83 | 
84 |   (add-menu-key 'cdplayer-menu "y" 'cdplayer-play)
85 |   (add-menu-key 'cdplayer-menu "k" 'cdplayer-stop)
86 |   (add-menu-key 'cdplayer-menu "t" 'cdplayer-pause)
87 |   (add-menu-key 'cdplayer-menu "s" 'show-cdplayer-status)
88 |   (add-menu-key 'cdplayer-menu "l" 'show-cdplayer-playlist)
89 |   (add-menu-key 'cdplayer-menu "n" 'cdplayer-next-track)
90 |   (add-menu-key 'cdplayer-menu "p" 'cdplayer-previous-track)
91 |   (add-menu-key 'cdplayer-menu "e" 'cdplayer-eject)
92 |   (add-menu-key 'cdplayer-menu "c" 'cdplayer-close))
93 | 
94 | (format t "done~%")
95 | 


--------------------------------------------------------------------------------
/contrib/clfswm:
--------------------------------------------------------------------------------
  1 | #!/bin/bash -e
  2 | #
  3 | # (C) 2015 Xavier Maillard <xma@gnu.org>
  4 | #
  5 | # This program is free software; you can redistribute it and/or modify
  6 | # it under the terms of the GNU General Public License as published by
  7 | # the Free Software Foundation; either version 3 of the License, or
  8 | # (at your option) any later version.
  9 | #
 10 | # This program is distributed in the hope that it will be useful,
 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | # GNU General Public License for more details.
 14 | #
 15 | # You should have received a copy of the GNU General Public License
 16 | # along with this program; if not, write to the Free Software
 17 | # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 18 | #
 19 | #
 20 | # --------------------------------------------------------------------------
 21 | # Documentation:
 22 | #
 23 | # Original code and idea: http://stumpwm.antidesktop.net/cgi-bin/wiki/SetUp
 24 | #
 25 | # Installation:
 26 | # Put this script wherever you want and just call it from your .xinitrc file
 27 | #
 28 | # The first time you will launch it, it will build the final
 29 | # executable and then call it. To force a rebuild of your executable
 30 | # (say you have updated something in the CLFSWM source tree), just
 31 | # delete the image and restart your X session.
 32 | # --------------------------------------------------------------------------
 33 | 
 34 | 
 35 | no_start=no
 36 | 
 37 | lisp=clisp   # +config+
 38 | lisp_bin=''   # +config+
 39 | lisp_opt=''   # +config+
 40 | dump_path="$XDG_CACHE_HOME/clfswm/"   # +config+
 41 | clfswm_asd_path="$(pwd)"   # +config+
 42 | asdf_path="$(pwd)/contrib"   # +config+
 43 | 
 44 | tmp_dir=/tmp
 45 | 
 46 | 
 47 | usage() {
 48 | 
 49 |     echo "$0 [options]
 50 |   -n, --no-start           don't start CLFSWM after image dump
 51 |   -f, --force              force image dump
 52 |   --rebuild                same as -f, --force
 53 |   -l, --with-lisp          use <lisp> as the common lisp implementation [$lisp]
 54 |   -b, --lisp-bin            use <bin> as the common lisp program [$lisp_bin] (default: same as with-lisp type)
 55 |   -o, --lisp-opt           use <opt> as lisp option [$lisp_opt]
 56 |   -d, --dump-path          path to the dump directory [$dump_path]
 57 |   --with-clfswm            path to clfswm.asd file [$clfswm_asd_path]
 58 |   --with-asdf              path to the asdf.lisp file [$asdf_path]"
 59 | 
 60 |     exit 0
 61 | }
 62 | 
 63 | die() {
 64 | 	echo >&2 "$@"
 65 | 	exit 1
 66 | }
 67 | 
 68 | build_clisp ()
 69 | {
 70 |     $lisp_bin $lisp_opt -m 8MB -E ISO-8859-1 -q -i "$asdf_path"/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\")
 71 |                 (asdf:oos 'asdf:load-op :clfswm) \
 72 |        		(EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION (lambda () (clfswm:main) (quit)) :EXECUTABLE t :norc t)"
 73 | }
 74 | 
 75 | build_sbcl()
 76 | {
 77 |    $lisp_bin $lisp_opt --disable-debugger --eval "(require :asdf)" \
 78 |        --eval "(require :sb-posix)" \
 79 |        --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \
 80 |        --eval "(require :clfswm)" \
 81 |        --eval "(save-lisp-and-die \"$dump_image\" :toplevel 'clfswm:main)"
 82 | }
 83 | 
 84 | build_cmucl()
 85 | {
 86 |    $lisp_bin $lisp_opt -eval "(require :clx)" \
 87 |        -eval "(load \"$asdf_path/asdf.lisp\")" \
 88 |        -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \
 89 |        -eval "(asdf:oos 'asdf:load-op :clfswm)" \
 90 |        -eval "(save-lisp \"$dump_image\" :init-function (lambda () (clfswm:main) (quit)))"
 91 | }
 92 | 
 93 | build_ccl()
 94 | {
 95 |     $lisp_bin $lisp_opt --eval "(require :asdf)" \
 96 | 	--eval "(load \"$clfswm_asd_path/clfswm.asd\")" \
 97 | 	--eval "(asdf:oos 'asdf:load-op :clfswm)" \
 98 | 	--eval "(save-application \"$dump_image\" :toplevel-function (lambda () (clfswm:main) (quit)))"
 99 | }
100 | 
101 | build_ecl()
102 | {
103 |     $lisp_bin $lisp_opt -eval "(require :asdf)" \
104 | 	-eval "(load \"$clfswm_asd_path/clfswm.asd\")" \
105 | 	-eval "(asdf:make-build :clfswm :type :program :monolithic t :move-here \".\" :prologue-code '(progn (require :asdf) (require :clx)))" \
106 | 	-eval "(ext:quit 0)"
107 |     mv ./clfswm-mono "$dump_image"
108 |     echo "$dump_image"
109 | }
110 | 
111 | 
112 | while test $# != 0
113 | do
114 |     case "$1" in
115 | 	-n|--no-start)
116 | 	    no_start=yes ;;
117 | 	-f|--force|--rebuild)
118 | 	    force=yes ;;
119 | 	-d|--dump-path)
120 | 	    shift
121 | 	    dump_path="$1" ;;
122 | 	--with-clfswm)
123 | 	    shift
124 | 	    clfswm_asd_path="$1" ;;
125 | 	--with-asdf)
126 | 	    shift
127 | 	    asdf_path="$1" ;;
128 | 	-l|--with-lisp)
129 | 	    shift
130 | 	    case "$1" in
131 | 		'')
132 | 		    usage;;
133 | 		clisp|sbcl|cmucl|ccl|ecl)
134 | 		    lisp="$1" ;;
135 | 	    esac
136 | 	    ;;
137 |         -b|--lisp-bin)
138 |             shift
139 |             lisp_bin="$1" ;;
140 | 	-o|--lisp-opt)
141 | 	    shift
142 | 	    lisp_opt="$1" ;;
143 | 	--)
144 | 	    shift
145 | 	    break ;;
146 | 	-h|--help)
147 | 	    usage ;;
148 | 	*)
149 | 	    ARGS="$ARGS $1" ;;
150 |     esac
151 |     shift
152 | done
153 | 
154 | if [ "x$lisp_bin" == "x" ]; then
155 |     lisp_bin=$lisp
156 | fi
157 | 
158 | #dump_image="$dump_path/clfswm-$(cksum $(type -p $lisp) | cut -d ' ' -f 1)-$(echo "$clfswm_asd_path"|md5sum|cut -d ' ' -f 1).core"
159 | dump_image="$dump_path/clfswm-$(echo $(cksum $(type -p $lisp)) "$clfswm_asd_path" | md5sum |cut -d ' ' -f 1).core"
160 | 
161 | if test yes = "$force" && test -e "$dump_image"
162 | then
163 |     echo "Removing old image."
164 |     rm -f "$dump_image"
165 | fi
166 | 
167 | clfswm_asd="$clfswm_asd_path"/clfswm.asd
168 | if test -L "$clfswm_asd_path"; then
169 |     clfswm_asd=$(readlink "$clfswm_asd")
170 | fi
171 | 
172 | older_image=0
173 | for i in "$(dirname $clfswm_asd)"/src/*.lisp; do
174 |     test "$dump_image" -ot "$i" && older_image=1
175 | done
176 | 
177 | if test ! -e "$dump_image" || test $older_image -eq 1
178 | then
179 |     echo "Image is nonexistent or older than sources. Rebuilding clfswm."
180 |     echo "This may take some times."
181 |     echo "  lisp=$lisp"
182 |     echo "  lisp_bin=$lisp_bin"
183 |     echo "  lisp_opt=$lisp_opt"
184 |     echo "  dump_path=$dump_path"
185 |     echo "  clfswm_asd_path=$clfswm_asd_path"
186 |     echo "  asdf_path=$asdf_path"
187 |     echo "  dump_image=$dump_image"
188 | 
189 |     PID=""
190 |     if test -x "$(which zenity)" ; then
191 |         zenity --info --text " Rebuilding CLFSWM:\n\n      Image is nonexistent or older than sources.\n\nPlease wait, the next CLFSWM boot will be faster." &
192 |         PID=$!
193 |     fi
194 | 
195 |     test -x $(type -p "$lisp") || die "$lisp can't be found."
196 |     test -e "$clfswm_asd_path"/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path"
197 |     test -e "$asdf_path"/asdf.lisp || die "can't find asdf.lisp in $asdf_path"
198 | 
199 |     # Move clfswm sources to $tmp_dir if there is no write permission on $clfswm_asd_path
200 |     if test ! -w "$clfswm_asd_path" ; then
201 | 	echo "* Note: No write access in sources ($clfswm_asd_path),
202 |  -> copying in a writable directory ($tmp_dir/clfswm-tmp)"
203 | 	rm -rf "$tmp_dir"/clfswm-tmp
204 | 	mkdir "$tmp_dir"/clfswm-tmp
205 | 	cp -R "$clfswm_asd_path"/* "$tmp_dir"/clfswm-tmp
206 | 	clfswm_asd_path="$tmp_dir"/clfswm-tmp
207 | 	asdf_path="$tmp_dir"/clfswm-tmp/contrib
208 |     fi
209 | 
210 |     mkdir -p "$dump_path"
211 |     mkdir -p "$dump_path/contrib"
212 |     eval build_"$lisp"
213 |     rm -rf "$dump_path/contrib"
214 |     cp -R "$clfswm_asd_path/contrib/" "$dump_path/"
215 |     rm -rf $(find "$dump_path/" -name "*svn")
216 | 
217 |     rm -rf "$tmp_dir"/clfswm-tmp
218 | 
219 |     if test "$PID" != "" ; then
220 |         kill $PID
221 |     fi
222 | 
223 |     echo "CLFSWM image is: $dump_image"
224 | fi
225 | 
226 | # Run the resulting image
227 | if test no = "$no_start"
228 | then
229 |     cd "$dump_path"
230 |     echo "Arguments: $* and $ARGS"
231 |     case $lisp in
232 | 	clisp ) "$dump_image" -- $ARGS ;;
233 | 	sbcl ) exec $lisp_bin --core "$dump_image" $ARGS ;;
234 | 	cmucl ) exec $lisp_bin -core "$dump_image" $ARGS ;;
235 | 	ccl ) exec $lisp_bin -I "$dump_image" -- $ARGS ;;
236 | 	ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" $ARGS ;;
237 | 	*) echo "..." ;;
238 |     esac
239 | else
240 |     echo "As requested, we have just dumped the image."
241 | fi
242 | 


--------------------------------------------------------------------------------
/contrib/contrib-example.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: A contrib example.
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; Documentation: A contrib example.
25 | ;;;   If you want to use this file, just add this line in
26 | ;;; your configuration file:
27 | ;;;
28 | ;;;   (load-contrib "contrib-example.lisp")
29 | ;;;
30 | ;;; --------------------------------------------------------------------------
31 | 
32 | (in-package :clfswm)
33 | 
34 | (format t "Loading Contrib Example code... ")
35 | 
36 | (format t "~&My contribution code start here~%")
37 | 
38 | (format t "done~%")
39 | 


--------------------------------------------------------------------------------
/contrib/fcitx.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :clfswm)
 2 | 
 3 | (format t "Loading fcitx code...")
 4 | 
 5 | (defconfig *fcitx-remote-command* "fcitx-remote"
 6 |   'fcitx "Command for fcitx remote program")
 7 | 
 8 | (defun fcitx-status ()
 9 |   (let ((code (car (do-shell-output *fcitx-remote-command*))))
10 |     (if (or (string-equal "0" code) nil t))))
11 | 
12 | (defun fcitx-toggle ()
13 |   "Toogle fxitx"
14 |   (do-shell (concatenate 'string *fcitx-remote-command*
15 |                          (if (fcitx-status) "-c" "-o"))))
16 | 
17 | (defun set-fcitx-keys ()
18 |   (define-main-key ("Shift" :mod-4) 'fcitx-toggle))
19 | 
20 | (add-hook *binding-hook* 'set-fcitx-keys)
21 | 
22 | (format t "done~%")
23 | 


--------------------------------------------------------------------------------
/contrib/keyb_fr.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: Define some keybindings for an azerty french keyboard
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; Documentation: French keyboard layout.
25 | ;;;   If you want to use this file, just add this line in
26 | ;;; your configuration file:
27 | ;;;
28 | ;;;   (load-contrib "keyb_fr.lisp")
29 | ;;;
30 | ;;; --------------------------------------------------------------------------
31 | 
32 | (in-package :clfswm)
33 | 
34 | (format t "Loading French Keyboard code... ")
35 | 
36 | (defun fr-binding ()
37 |   ;; For an azery keyboard:
38 |   ;; Main mode
39 |   (undefine-main-multi-keys ("1" :mod-1) ("2" :mod-1) ("3" :mod-1)
40 | 			    ("4" :mod-1) ("5" :mod-1) ("6" :mod-1)
41 | 			    ("7" :mod-1) ("8" :mod-1) ("9" :mod-1) ("0" :mod-1))
42 |   (define-main-key ("twosuperior") 'banish-pointer)
43 |   (define-main-key ("ampersand" :mod-1) 'bind-or-jump 1)
44 |   (define-main-key ("eacute" :mod-1) 'bind-or-jump 2)
45 |   (define-main-key ("quotedbl" :mod-1) 'bind-or-jump 3)
46 |   (define-main-key ("quoteright" :mod-1) 'bind-or-jump 4)
47 |   (define-main-key ("parenleft" :mod-1) 'bind-or-jump 5)
48 |   (define-main-key ("minus" :mod-1) 'bind-or-jump 6)
49 |   (define-main-key ("egrave" :mod-1) 'bind-or-jump 7)
50 |   (define-main-key ("underscore" :mod-1) 'bind-or-jump 8)
51 |   (define-main-key ("ccedilla" :mod-1) 'bind-or-jump 9)
52 |   (define-main-key ("agrave" :mod-1) 'bind-or-jump 10)
53 |   ;; Second mode
54 |   (undefine-second-multi-keys ("1" :mod-1) ("2" :mod-1) ("3" :mod-1)
55 | 			      ("4" :mod-1) ("5" :mod-1) ("6" :mod-1)
56 | 			      ("7" :mod-1) ("8" :mod-1) ("9" :mod-1) ("0" :mod-1))
57 |   (define-second-key ("twosuperior") 'banish-pointer)
58 |   (define-second-key ("ampersand" :mod-1) 'bind-or-jump 1)
59 |   (define-second-key ("eacute" :mod-1) 'bind-or-jump 2)
60 |   (define-second-key ("quotedbl" :mod-1) 'bind-or-jump 3)
61 |   (define-second-key ("quoteright" :mod-1) 'bind-or-jump 4)
62 |   (define-second-key ("parenleft" :mod-1) 'bind-or-jump 5)
63 |   (define-second-key ("minus" :mod-1) 'bind-or-jump 6)
64 |   (define-second-key ("egrave" :mod-1) 'bind-or-jump 7)
65 |   (define-second-key ("underscore" :mod-1) 'bind-or-jump 8)
66 |   (define-second-key ("ccedilla" :mod-1) 'bind-or-jump 9)
67 |   (define-second-key ("agrave" :mod-1) 'bind-or-jump 10))
68 | 
69 | (unless (member 'fr-binding *binding-hook*)
70 |   (add-hook *binding-hook* 'fr-binding))
71 | 
72 | (format t "done~%")
73 | 


--------------------------------------------------------------------------------
/contrib/moc.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: MOC - Console audio player - interface
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; Documentation: If you want to use this file, just add this line in
 25 | ;;; your configuration file:
 26 | ;;;
 27 | ;;;   (load-contrib "moc.lisp")
 28 | ;;;
 29 | ;;; --------------------------------------------------------------------------
 30 | 
 31 | (in-package :clfswm)
 32 | 
 33 | (format t "Loading MOC code... ")
 34 | 
 35 | 
 36 | (defun moc-menu ()
 37 |   "Open the MOC menu"
 38 |   (open-menu (find-menu 'moc-menu)))
 39 | 
 40 | 
 41 | (defun start-mocp ()
 42 |   "Start mocp"
 43 |   (do-shell "xterm -e 'mocp 2> /dev/null'"))
 44 | 
 45 | 
 46 | (defun show-moc-info ()
 47 |   "Show MOC informations"
 48 |   (info-on-shell "MOC informations:" "mocp --info")
 49 |   (moc-menu))
 50 | 
 51 | (defun moc-previous (&optional (in-menu t))
 52 |   "Play the previous song in the current playlist"
 53 |   (do-shell "mocp --previous" nil t)
 54 |   (when in-menu
 55 |     (moc-menu)))
 56 | 
 57 | (defun moc-next (&optional (in-menu t))
 58 |   "Play the next song in the current playlist"
 59 |   (do-shell "mocp --next" nil t)
 60 |   (when in-menu
 61 |     (moc-menu)))
 62 | 
 63 | (defun moc-toggle ()
 64 |   "Toggles Play/Pause, plays if stopped"
 65 |   (do-shell "mocp --toggle-pause"))
 66 | 
 67 | (defun moc-play ()
 68 |   "Start playing"
 69 |   (do-shell "mocp --play"))
 70 | 
 71 | (defun moc-stop ()
 72 |   "Stop the currently playing playlists"
 73 |   (do-shell "mocp --stop"))
 74 | 
 75 | 
 76 | (defun moc-seek-+5s (&optional (in-menu t))
 77 |   "Seeks to +5s"
 78 |   (if in-menu
 79 |       (progn
 80 |         (do-shell "mocp --seek +5")
 81 |         (moc-menu))
 82 |       (do-shell "mocp --seek +5" nil t)))
 83 | 
 84 | (defun moc-seek--5s (&optional (in-menu t))
 85 |   "Seeks to -5s"
 86 |   (if in-menu
 87 |       (progn
 88 |         (do-shell "mocp --seek -5")
 89 |         (moc-menu))
 90 |       (do-shell "mocp --seek -5" nil t)))
 91 | 
 92 | (unless (find-menu 'moc-menu)
 93 |   (add-sub-menu 'help-menu "F3" 'moc-menu "MOC - Console audio player - menu")
 94 | 
 95 |   (add-menu-key 'moc-menu "i" 'show-moc-info)
 96 |   (add-menu-key 'moc-menu "p" 'moc-previous)
 97 |   (add-menu-key 'moc-menu "n" 'moc-next)
 98 |   (add-menu-key 'moc-menu "t" 'moc-toggle)
 99 |   (add-menu-key 'moc-menu "y" 'moc-play)
100 |   (add-menu-key 'moc-menu "k" 'moc-stop)
101 |   (add-menu-key 'moc-menu "x" 'moc-seek-+5s)
102 |   (add-menu-key 'moc-menu "w" 'moc-seek--5s)
103 |   (add-menu-key 'moc-menu "m" 'start-mocp))
104 | 
105 | 
106 | (defun moc-binding ()
107 |   (define-main-key ("F3" :alt) 'moc-menu))
108 | 
109 | (add-hook *binding-hook* 'moc-binding)
110 | 
111 | (format t "done~%")
112 | 


--------------------------------------------------------------------------------
/contrib/mpd.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Music Player Daemon (MPD) interface
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; Documentation: If you want to use this file, just add this line in
 25 | ;;; your configuration file:
 26 | ;;;
 27 | ;;;   (load-contrib "mpd.lisp")
 28 | ;;;
 29 | ;;; --------------------------------------------------------------------------
 30 | 
 31 | (in-package :clfswm)
 32 | 
 33 | (format t "Loading MPD code... ")
 34 | 
 35 | 
 36 | (defun mpd-menu ()
 37 |   "Open the Music Player Daemon (MPD) menu"
 38 |   (open-menu (find-menu 'mpd-menu)))
 39 | 
 40 | 
 41 | (defun start-sonata ()
 42 |   "Start sonata"
 43 |   (do-shell "exec sonata"))
 44 | 
 45 | (defun start-gmpc ()
 46 |   "Start gmpc"
 47 |   (do-shell "exec gmpc"))
 48 | 
 49 | 
 50 | (defun show-mpd-info ()
 51 |   "Show MPD informations"
 52 |   (info-on-shell "MPD informations:" "mpc")
 53 |   (mpd-menu))
 54 | 
 55 | (defun mpd-previous (&optional (in-menu t))
 56 |   "Play the previous song in the current playlist"
 57 |   (if in-menu
 58 |       (progn
 59 |         (info-on-shell "MPD:" "mpc prev")
 60 |         (mpd-menu))
 61 |       (do-shell "mpc prev" nil t)))
 62 | 
 63 | (defun mpd-next (&optional (in-menu t))
 64 |   "Play the next song in the current playlist"
 65 |   (if in-menu
 66 |       (progn
 67 |         (info-on-shell "MPD:" "mpc next")
 68 |         (mpd-menu))
 69 |       (do-shell "mpc next" nil t)))
 70 | 
 71 | (defun mpd-toggle ()
 72 |   "Toggles Play/Pause, plays if stopped"
 73 |   (do-shell "mpc toggle"))
 74 | 
 75 | (defun mpd-play ()
 76 |   "Start playing"
 77 |   (do-shell "mpc play"))
 78 | 
 79 | (defun mpd-stop ()
 80 |   "Stop the currently playing playlists"
 81 |   (do-shell "mpc stop"))
 82 | 
 83 | 
 84 | (defun mpd-seek-+5% (&optional (in-menu t))
 85 |   "Seeks to +5%"
 86 |   (if in-menu
 87 |       (progn
 88 |         (do-shell "mpc seek +5%")
 89 |         (mpd-menu))
 90 |       (do-shell "mpc seek +5%" nil t)))
 91 | 
 92 | (defun mpd-seek--5% (&optional (in-menu t))
 93 |   "Seeks to -5%"
 94 |   (if in-menu
 95 |       (progn
 96 |         (do-shell "mpc seek -5%")
 97 |         (mpd-menu))
 98 |       (do-shell "mpc seek -5%" nil t)))
 99 | 
100 | (defun show-mpd-playlist ()
101 |   "Show the current MPD playlist"
102 |   (info-on-shell "Current MPD playlist:" "mpc playlist")
103 |   (mpd-menu))
104 | 
105 | (unless (find-menu 'mpd-menu)
106 |   (add-sub-menu 'help-menu "F2" 'mpd-menu "Music Player Daemon (MPD) menu")
107 | 
108 |   (add-menu-key 'mpd-menu "i" 'show-mpd-info)
109 |   (add-menu-key 'mpd-menu "p" 'mpd-previous)
110 |   (add-menu-key 'mpd-menu "n" 'mpd-next)
111 |   (add-menu-key 'mpd-menu "t" 'mpd-toggle)
112 |   (add-menu-key 'mpd-menu "y" 'mpd-play)
113 |   (add-menu-key 'mpd-menu "k" 'mpd-stop)
114 |   (add-menu-key 'mpd-menu "x" 'mpd-seek-+5%)
115 |   (add-menu-key 'mpd-menu "w" 'mpd-seek--5%)
116 |   (add-menu-key 'mpd-menu "l" 'show-mpd-playlist)
117 |   (add-menu-key 'mpd-menu "s" 'start-sonata)
118 |   (add-menu-key 'mpd-menu "g" 'start-gmpc))
119 | 
120 | 
121 | (defun mpd-binding ()
122 |   (define-main-key ("F2" :alt) 'mpd-menu))
123 | 
124 | (add-hook *binding-hook* 'mpd-binding)
125 | 
126 | 
127 | 
128 | #+:clfswm-toolbar
129 | (progn
130 |   (defconfig *mpd-toolbar* '((mpd-buttons 1)
131 |                              (mpd-info 60))
132 |     'Toolbar "MPD toolbar modules")
133 | 
134 |   (defconfig *mpd-toolbar-client* "gmpc"
135 |     'Toolbar "MPD client")
136 | 
137 |   (define-toolbar-color mpd-info "MPD - Music Player Daemon information color")
138 |   (define-toolbar-color mpd-buttons "MPD - Music Player Daemon buttons color")
139 | 
140 |   (define-toolbar-module (mpd-info small)
141 |     "(small) - MPD (Music Player Daemon) informations"
142 |     (let* ((lines (do-shell "mpc" nil t))
143 |            (mpd-line (loop for line = (read-line lines nil nil)
144 |                         while line
145 |                         collect line)))
146 |       (if (>= (length mpd-line) 3)
147 |           (if small
148 |               (toolbar-module-text toolbar module (tb-color mpd-info)
149 |                                "~A"
150 |                                (ensure-printable (first mpd-line)))
151 |               (toolbar-module-text toolbar module (tb-color mpd-info)
152 |                                    "~A - ~A"
153 |                                    (ensure-printable (first mpd-line))
154 |                                    (ensure-printable (second mpd-line))))
155 |           (toolbar-module-text toolbar module (tb-color mpd-info)
156 |                                "MPD - Not playing"))))
157 | 
158 |   (define-toolbar-module (mpd-buttons small)
159 |     "(small) - MPD (Music Player Daemon) buttons"
160 |     (with-set-toolbar-module-rectangle (module)
161 |       (toolbar-module-text toolbar module (tb-color mpd-buttons)
162 |                            (if small
163 |                                "PNT<>C"
164 |                                "P N T < > C"))))
165 | 
166 |   (define-toolbar-module-click (mpd-buttons small)
167 |     "P=Previous, N=Next, T=Toogle, <=seek-5% >=seek+5% C=start MPD client"
168 |     (declare (ignore state small))
169 |     (when (= code 1)
170 |       (let ((pos (toolbar-module-subdiv toolbar module root-x root-y 6)))
171 |         (case pos
172 |           (0 (mpd-previous nil))
173 |           (1 (mpd-next nil))
174 |           (2 (mpd-toggle))
175 |           (3 (mpd-seek--5% nil))
176 |           (4 (mpd-seek-+5% nil))
177 |           (5 (do-shell *mpd-toolbar-client*))))
178 |       (refresh-toolbar toolbar))))
179 | 
180 | 
181 | (format t "done~%")
182 | 


--------------------------------------------------------------------------------
/contrib/osd.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: OSD (On Screen Display) for presentations.
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | ;; Uncomment the line above if you want to use the old OSD method
 29 | ;;(pushnew :DISPLAY-OSD *features*)
 30 | 
 31 | #-DISPLAY-OSD
 32 | (progn
 33 |   (defparameter *osd-window* nil)
 34 |   (defparameter *osd-gc* nil)
 35 |   (defparameter *osd-font* nil)
 36 |   (defparameter *osd-font-string* "-*-fixed-*-*-*-*-14-*-*-*-*-*-*-1"))
 37 | 
 38 | 
 39 | ;;; A more complex example I use to record my desktop and show
 40 | ;;; documentation associated to each key press.
 41 | #+DISPLAY-OSD
 42 | (defun display-doc (function code state)
 43 |   (let* ((modifiers (state->modifiers state))
 44 | 	 (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
 45 |     (do-shell "pkill osd_cat")
 46 |     (do-shell (format nil "( echo '~A~A' | osd_cat -d 3 -p bottom -c white -o -50 -f -*-fixed-*-*-*-*-14-*-*-*-*-*-*-1 ) &"
 47 | 		      (if keysym
 48 | 			  (format nil "~:(~{~A+~}~A~)" modifiers keysym)
 49 | 			  "Menu")
 50 | 		      (aif (documentation (first function) 'function)
 51 | 			   (format nil ": ~A" it) "")))))
 52 | 
 53 | #-DISPLAY-OSD
 54 | (defun is-osd-window-p (win)
 55 |   (xlib:window-equal win *osd-window*))
 56 | 
 57 | 
 58 | #-DISPLAY-OSD
 59 | (defun display-doc (function code state &optional button-p)
 60 |   (unless *osd-window*
 61 |     (setf *osd-window* (xlib:create-window :parent *root*
 62 | 					   :x 0 :y (- (xlib:drawable-height *root*) 25)
 63 | 					   :width (xlib:drawable-width *root*) :height 25
 64 | 					   :background (get-color "black")
 65 | 					   :border-width 1
 66 | 					   :border (get-color "black")
 67 | 					   :colormap (xlib:screen-default-colormap *screen*)
 68 | 					   :event-mask '(:exposure))
 69 | 	  *osd-font* (xlib:open-font *display* *osd-font-string*)
 70 | 	  *osd-gc* (xlib:create-gcontext :drawable *osd-window*
 71 | 					 :foreground (get-color "white")
 72 | 					 :background (get-color "gray10")
 73 | 					 :font *osd-font*
 74 | 					 :line-style :solid))
 75 |     (map-window *osd-window*))
 76 |   (let* ((modifiers (state->modifiers state))
 77 | 	 (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
 78 |     (when (frame-p (current-child))
 79 |       (push (list #'is-osd-window-p nil) *never-managed-window-list*))
 80 |     (raise-window *osd-window*)
 81 |     (rotatef (xlib:gcontext-foreground *osd-gc*) (xlib:gcontext-background *osd-gc*))
 82 |     (xlib:draw-rectangle *osd-window* *osd-gc*
 83 | 			 0 0 (xlib:drawable-width *osd-window*) (xlib:drawable-height *osd-window*)
 84 | 			 t)
 85 |     (rotatef (xlib:gcontext-foreground *osd-gc*) (xlib:gcontext-background *osd-gc*))
 86 |     (xlib:draw-glyphs *osd-window* *osd-gc* 20 15
 87 |                       (format nil "~A~A"
 88 |                               (cond (button-p (format nil "~:(~{~A+~}Button-~A~)" modifiers code))
 89 |                                     (keysym (format nil "~:(~{~A+~}~A~)" modifiers keysym))
 90 |                                     (t "Menu"))
 91 |                               (aif (documentation (first function) 'function)
 92 |                                    (format nil ": ~A" (substitute #\Space #\Newline it)) "")))
 93 |     (xlib:display-finish-output *display*)))
 94 | 
 95 | 
 96 | (fmakunbound 'funcall-key-from-code)
 97 | (defun funcall-key-from-code (hash-table-key code state &rest args)
 98 |   (let ((function (find-key-from-code hash-table-key code state)))
 99 |     (when function
100 |       (display-doc function code state)
101 |       (apply (first function) (append args (second function)))
102 |       t)))
103 | 
104 | 
105 | (fmakunbound 'funcall-button-from-code)
106 | (defun funcall-button-from-code (hash-table-key code state window root-x root-y
107 | 				 &optional (action *fun-press*) args)
108 |   (let ((state (modifiers->state (set-difference (state->modifiers state)
109 | 						 '(:button-1 :button-2 :button-3 :button-4 :button-5)))))
110 |     (multiple-value-bind (function foundp)
111 | 	(gethash (list code state) hash-table-key)
112 |       (if (and foundp (funcall action function))
113 | 	  (progn
114 |             (unless (equal code 'motion)
115 |               (display-doc function code state t))
116 | 	    (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function))))
117 | 	    t)
118 | 	  nil))))
119 | 
120 | 
121 | (fmakunbound 'get-fullscreen-size)
122 | ;;; CONFIG - Screen size
123 | (defun get-fullscreen-size ()
124 |   "Return the size of root child (values rx ry rw rh)
125 | You can tweak this to what you want"
126 |   (values -2 -2 (+ (xlib:screen-width *screen*) 2) (- (xlib:screen-height *screen*) 25)))
127 | 
128 | 
129 | (fmakunbound 'open-menu-do-action)
130 | ;;; Display menu functions
131 | (defun open-menu-do-action (action menu parent)
132 |   (typecase action
133 |     (menu (open-menu action (cons menu parent)))
134 |     (null (awhen (first parent)
135 | 	    (open-menu it (rest parent))))
136 |     (t (when (fboundp action)
137 | 	 (display-doc (list action) 0 0)
138 | 	 (funcall action)))))
139 | 
140 | (fmakunbound 'bottom-left-placement)
141 | (defun bottom-left-placement (&optional (width 0) (height 0))
142 |   (declare (ignore width))
143 |   (values 0
144 | 	  (- (xlib:screen-height *screen*) height 26)))
145 | 
146 | (fmakunbound 'bottom-middle-placement)
147 | (defun bottom-middle-placement (&optional (width 0) (height 0))
148 |   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
149 | 	  (- (xlib:screen-height *screen*) height 26)))
150 | 
151 | (fmakunbound 'bottom-right-placement)
152 | (defun bottom-right-placement (&optional (width 0) (height 0))
153 |   (values (- (xlib:screen-width *screen*) width 1)
154 | 	  (- (xlib:screen-height *screen*) height 26)))
155 | 


--------------------------------------------------------------------------------
/contrib/reboot-halt.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: Reboot and halt menu
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; Documentation: If you want to use this file, just add this line in
25 | ;;; your configuration file:
26 | ;;;
27 | ;;;   (load-contrib "mpd.lisp")
28 | ;;;
29 | ;;; --------------------------------------------------------------------------
30 | 
31 | (in-package :clfswm)
32 | 
33 | (format t "Loading Reboot/Halt code... ")
34 | 
35 | (defconfig *power-suspend-to-ram-cmd* "sudo pm-suspend"
36 |   'power-management "Suspend to ram command")
37 | (defconfig *power-suspend-to-disk-cmd* "sudo pm-hibernate"
38 |   'power-management "Suspend to disk command")
39 | (defconfig *power-reboot-cmd* "sudo /sbin/reboot"
40 |   'power-management "Reboot command")
41 | (defconfig *power-halt-cmd* "sudo /sbin/halt"
42 |   'power-management "Halt command")
43 | 
44 | (defun reboot-halt-menu ()
45 |   "Open the Reboot/Halt menu"
46 |   (open-menu (find-menu 'reboot-halt-menu)))
47 | 
48 | 
49 | (defun do-with-terminal (command)
50 |   (do-shell (format nil "xterm -e '~A'" command)))
51 | ;;(do-shell (format nil "xterm -e 'echo ~A; sleep 3'" command)))  ;; test
52 | 
53 | (defun do-nothing ()
54 |   "Do nothing"
55 |   ())
56 | 
57 | (defun do-suspend ()
58 |   "Suspend the computer to RAM"
59 |   (do-with-terminal *power-suspend-to-ram-cmd*))
60 | 
61 | (defun do-hibernate ()
62 |   "Suspend the computer to DISK"
63 |   (do-with-terminal *power-suspend-to-disk-cmd*))
64 | 
65 | (defun do-reboot ()
66 |   "Reboot the computer"
67 |   (do-with-terminal *power-reboot-cmd*))
68 | 
69 | (defun do-halt ()
70 |   "Halt the computer"
71 |   (do-with-terminal *power-halt-cmd*))
72 | 
73 | (unless (find-menu 'reboot-halt-menu)
74 |   (add-sub-menu 'clfswm-menu "Pause" 'reboot-halt-menu "Suspend/Reboot/Halt menu")
75 |   (add-menu-key 'reboot-halt-menu "-" 'do-nothing)
76 |   (add-menu-key 'reboot-halt-menu "s" 'do-suspend)
77 |   (add-menu-key 'reboot-halt-menu "d" 'do-hibernate)
78 |   (add-menu-key 'reboot-halt-menu "r" 'do-reboot)
79 |   (add-menu-key 'reboot-halt-menu "h" 'do-halt))
80 | 
81 | 
82 | (defun reboot-halt-binding ()
83 |   (define-main-key ("Pause") 'reboot-halt-menu))
84 | 
85 | (add-hook *binding-hook* 'reboot-halt-binding)
86 | 
87 | (format t "done~%")
88 | 


--------------------------------------------------------------------------------
/contrib/server/clfswm-client.asd:
--------------------------------------------------------------------------------
 1 | ;;;; -*- Mode: Lisp -*-
 2 | ;;;; ASDF System Definition
 3 | ;;;
 4 | 
 5 | (in-package #:asdf)
 6 | 
 7 | (defsystem clfswm-client
 8 |   :description ""
 9 |   :licence "GNU Lesser General Public License (LGPL)"
10 |   :components ((:file "md5")
11 | 	       (:file "net")
12 | 	       (:file "crypt")
13 | 	       (:file "key"
14 | 		      :depends-on ("crypt"))
15 | 	       (:file "clfswm-client"
16 | 		      :depends-on ("md5" "net" "crypt" "key"))))
17 | 
18 | 
19 | 


--------------------------------------------------------------------------------
/contrib/server/clfswm-client.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Client/server connection.
  6 | ;;; The connection is crypted and you can only connect to the server with the
  7 | ;;; same clfswm binary.
  8 | ;;; --------------------------------------------------------------------------
  9 | ;;;
 10 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 11 | ;;;
 12 | ;;; This program is free software; you can redistribute it and/or modify
 13 | ;;; it under the terms of the GNU General Public License as published by
 14 | ;;; the Free Software Foundation; either version 3 of the License, or
 15 | ;;; (at your option) any later version.
 16 | ;;;
 17 | ;;; This program is distributed in the hope that it will be useful,
 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 20 | ;;; GNU General Public License for more details.
 21 | ;;;
 22 | ;;; You should have received a copy of the GNU General Public License
 23 | ;;; along with this program; if not, write to the Free Software
 24 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 25 | ;;;
 26 | ;;; --------------------------------------------------------------------------
 27 | ;;; Server protocole:
 28 | ;;;  Server ->  Client:  orig_key=a generated key crypted with *key*
 29 | ;;;  Client           :  build its new_key with orig_key+*key*
 30 | ;;;  Client ->  Server:  new_key+(md5 new_key) crypted with new_key
 31 | ;;;  Server ->  Client:  check if the keys match and then authenticate the client.
 32 | ;;;  Server <-> Client:  All connections are crypted with new_key
 33 | ;;; --------------------------------------------------------------------------
 34 | 
 35 | (in-package :common-lisp-user)
 36 | 
 37 | (defpackage :clfswm-client
 38 |   (:use :common-lisp :crypt)
 39 |   (:export :start-client))
 40 | 
 41 | (in-package :clfswm-client)
 42 | 
 43 | (defun uquit ()
 44 |   #+(or clisp cmu) (ext:quit)
 45 |   #+sbcl (sb-ext:quit)
 46 |   #+ecl (si:quit)
 47 |   #+gcl (lisp:quit)
 48 |   #+lispworks (lw:quit)
 49 |   #+(or allegro-cl allegro-cl-trial) (excl:exit)
 50 |   #+ccl (ccl:quit))
 51 | 
 52 | 
 53 | ;;(defparameter *server-port* 33333)
 54 | 
 55 | (defun print-output (sock &optional wait)
 56 |   (when (or wait (ignore-errors (listen sock)))
 57 |     (let ((line (ignore-errors (string-trim '(#\newline) (read-line sock nil nil)))))
 58 |       (when line
 59 | 	(format t "~&~A" (decrypt line *key*))
 60 | 	(force-output)))))
 61 | 
 62 | 
 63 | (defun quit-on-command (line sock)
 64 |   (when (member line '("quit" "close" "bye") :test #'string-equal)
 65 |     (loop for line = (read-line sock nil nil)
 66 |        while line
 67 |        do (format t "~&~A" (decrypt line *key*))
 68 | 	 (force-output))
 69 |     (terpri)
 70 |     (uquit)))
 71 | 
 72 | 
 73 | (defun parse-args (sock args)
 74 |   (unless (string= args "")
 75 |     (multiple-value-bind (form pos)
 76 | 	(read-from-string args)
 77 |       (let ((str (format nil "~A" form)))
 78 | 	(format t "~A~% " str)
 79 | 	(format sock "~A~%" (crypt str *key*))
 80 | 	(force-output sock)
 81 | 	(print-output sock t)
 82 | 	(quit-on-command str sock)
 83 | 	(parse-args sock (subseq args pos))))))
 84 | 
 85 | 
 86 | (defun start-client (args &optional (url "127.0.0.1") (port clfswm::*server-port*))
 87 |   (load-new-key)
 88 |   (let* ((sock (port:open-socket url port))
 89 | 	 (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*))))
 90 |     (setf *key* (concatenate 'string key *key*))
 91 |     (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock)
 92 |     (force-output sock)
 93 |     (print-output sock t)
 94 |     (dolist (a args)
 95 |       (parse-args sock a))
 96 |     (loop
 97 |        (print-output sock)
 98 |        (when (listen)
 99 | 	 (let ((line (read-line)))
100 | 	   (write-line (crypt line *key*) sock)
101 | 	   (force-output sock)
102 | 	   (quit-on-command line sock)))
103 |        (sleep 0.01))))
104 | 


--------------------------------------------------------------------------------
/contrib/server/crypt.lisp:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/LdBeth/CLFSWM/4e936552d1388718d2947a5f6ca3eada19643e75/contrib/server/crypt.lisp


--------------------------------------------------------------------------------
/contrib/server/key.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Client/server connection.
  6 | ;;; The connection is crypted and you can only connect to the server with the
  7 | ;;; same clfswm binary.
  8 | ;;; --------------------------------------------------------------------------
  9 | ;;;
 10 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 11 | ;;;
 12 | ;;; This program is free software; you can redistribute it and/or modify
 13 | ;;; it under the terms of the GNU General Public License as published by
 14 | ;;; the Free Software Foundation; either version 3 of the License, or
 15 | ;;; (at your option) any later version.
 16 | ;;;
 17 | ;;; This program is distributed in the hope that it will be useful,
 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 20 | ;;; GNU General Public License for more details.
 21 | ;;;
 22 | ;;; You should have received a copy of the GNU General Public License
 23 | ;;; along with this program; if not, write to the Free Software
 24 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 25 | ;;;
 26 | ;;; --------------------------------------------------------------------------
 27 | ;;; Server protocole:
 28 | ;;;  Server ->  Client:  orig_key=a generated key crypted with *key*
 29 | ;;;  Client           :  build its new_key with orig_key+*key*
 30 | ;;;  Client ->  Server:  new_key+(md5 new_key) crypted with new_key
 31 | ;;;  Server ->  Client:  check if the keys match and then authenticate the client.
 32 | ;;;  Server <-> Client:  All connections are crypted with new_key
 33 | ;;; --------------------------------------------------------------------------
 34 | 
 35 | (in-package :crypt)
 36 | 
 37 | (export '(load-new-key
 38 | 	  save-new-key
 39 | 	  *key*))
 40 | 
 41 | (defparameter *key-filename* "/tmp/.clfswm-server.key")
 42 | 
 43 | (defparameter *key* "Automatically changed")
 44 | 
 45 | (defparameter *initial-key-perms* "0600")
 46 | (defparameter *final-key-perms* "0400")
 47 | 
 48 | 
 49 | 
 50 | 
 51 | (defun ushell-sh (formatter &rest args)
 52 |   (labels ((remove-plist (plist &rest keys)
 53 | 	     "Remove the keys from the plist.
 54 | Useful for re-using the &REST arg after removing some options."
 55 | 	     (do (copy rest)
 56 | 		 ((null (setq rest (nth-value 2 (get-properties plist keys))))
 57 | 		  (nreconc copy plist))
 58 | 	       (do () ((eq plist rest))
 59 | 		 (push (pop plist) copy)
 60 | 		 (push (pop plist) copy))
 61 | 	       (setq plist (cddr plist))))
 62 | 	   (urun-prog (prog &rest opts &key args (wait t) &allow-other-keys)
 63 | 	     "Common interface to shell. Does not return anything useful."
 64 | 	     #+gcl (declare (ignore wait))
 65 | 	     (setq opts (remove-plist opts :args :wait))
 66 | 	     #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
 67 | 			      :wait wait opts)
 68 | 	     #+(and clisp      lisp=cl)
 69 | 	     (apply #'ext:run-program prog :arguments args :wait wait opts)
 70 | 	     #+(and clisp (not lisp=cl))
 71 | 	     (if wait
 72 | 		 (apply #'lisp:run-program prog :arguments args opts)
 73 | 		 (lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
 74 | 	     #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts)
 75 | 	     #+gcl (apply #'si:run-process prog args)
 76 | 	     #+liquid (apply #'lcl:run-program prog args)
 77 | 	     #+lispworks (apply #'sys::call-system-showing-output
 78 | 				(format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
 79 | 				opts)
 80 | 	     #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
 81 | 	     #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
 82 | 	     #+ecl (apply #'ext:run-program prog args opts)
 83 | 	     #+ccl (apply #'ccl:run-program prog args opts)
 84 | 	     #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ccl ecl)
 85 | 	     (error "Error: urun-prog not implemented")))
 86 |     (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args)))))
 87 | 
 88 | 
 89 | (defun save-new-key ()
 90 |   (when (probe-file *key-filename*)
 91 |     (delete-file *key-filename*))
 92 |   (with-open-file (stream *key-filename* :direction :output :if-exists :supersede
 93 | 			  :if-does-not-exist :create)
 94 |     (format stream "Nothing useful~%"))
 95 |   (ushell-sh "chmod ~A ~A" *initial-key-perms* *key-filename*)
 96 |   (setf *key* (generate-key))
 97 |   (with-open-file (stream *key-filename* :direction :output :if-exists :supersede
 98 | 			  :if-does-not-exist :create)
 99 |     (format stream "~A~%" *key*))
100 |   (ushell-sh "chmod ~A ~A" *final-key-perms* *key-filename*))
101 | 
102 | (defun load-new-key ()
103 |   (if (probe-file *key-filename*)
104 |       (with-open-file (stream *key-filename* :direction :input)
105 | 	(setf *key* (read-line stream nil nil)))
106 |       (error "Key file ~S not found" *key-filename*)))
107 | 


--------------------------------------------------------------------------------
/contrib/server/load.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: CLFSWM Client
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; --------------------------------------------------------------------------
25 | 
26 | (defparameter *base-dir* (directory-namestring *load-truename*))
27 | (export '*base-dir*)
28 | 
29 | #+CMU
30 | (setf ext:*gc-verbose* nil)
31 | 
32 | #+SBCL
33 | (require :asdf)
34 | 
35 | #+SBCL
36 | (require :sb-posix)
37 | 
38 | #-ASDF
39 | (let ((asdf-file (make-pathname :host (pathname-host *base-dir*)
40 | 				:device (pathname-device *base-dir*)
41 | 				:directory (pathname-directory *base-dir*)
42 | 				:name "asdf" :type "lisp")))
43 |   (if (probe-file asdf-file)
44 |       (load asdf-file)
45 |       (load (make-pathname :host (pathname-host *base-dir*)
46 | 			   :device (pathname-device *base-dir*)
47 | 			   :directory (butlast (pathname-directory *base-dir*))
48 | 			   :name "asdf" :type "lisp"))))
49 | 
50 | (push *base-dir* asdf:*central-registry*)
51 | 
52 | (asdf:oos 'asdf:load-op :clfswm-client)
53 | 
54 | (in-package :clfswm-client)
55 | 
56 | 
57 | (start-client nil)
58 | 


--------------------------------------------------------------------------------
/contrib/server/server.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Client/server connection.
  6 | ;;; The connection is crypted and you can only connect to the server with the
  7 | ;;; same clfswm binary.
  8 | ;;; --------------------------------------------------------------------------
  9 | ;;;
 10 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 11 | ;;;
 12 | ;;; This program is free software; you can redistribute it and/or modify
 13 | ;;; it under the terms of the GNU General Public License as published by
 14 | ;;; the Free Software Foundation; either version 3 of the License, or
 15 | ;;; (at your option) any later version.
 16 | ;;;
 17 | ;;; This program is distributed in the hope that it will be useful,
 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 20 | ;;; GNU General Public License for more details.
 21 | ;;;
 22 | ;;; You should have received a copy of the GNU General Public License
 23 | ;;; along with this program; if not, write to the Free Software
 24 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 25 | ;;;
 26 | ;;; --------------------------------------------------------------------------
 27 | ;;; Server protocole:
 28 | ;;;  Server ->  Client:  orig_key=a generated key crypted with *key*
 29 | ;;;  Client           :  build its new_key with orig_key+*key*
 30 | ;;;  Client ->  Server:  new_key+(md5 new_key) crypted with new_key
 31 | ;;;  Server ->  Client:  check if the keys match and then authenticate the client.
 32 | ;;;  Server <-> Client:  All connections are crypted with new_key
 33 | ;;; --------------------------------------------------------------------------
 34 | 
 35 | (in-package :clfswm)
 36 | 
 37 | (defparameter *server-port* 33333)
 38 | 
 39 | (format t "Loading the clfswm server code... ")
 40 | 
 41 | (pushnew (truename (merge-pathnames "server/" *contrib-dir*)) asdf:*central-registry*)
 42 | 
 43 | (dbg asdf:*central-registry*)
 44 | 
 45 | (asdf:oos 'asdf:load-op :clfswm-client)
 46 | 
 47 | (in-package :clfswm)
 48 | 
 49 | (use-package :crypt)
 50 | 
 51 | (defstruct server-socket stream auth form key)
 52 | (defparameter *server-socket* nil)
 53 | 
 54 | (defparameter *server-allowed-host* '("127.0.0.1"))
 55 | (defparameter *server-wait-timeout* 0.001d0)
 56 | 
 57 | (defparameter *server-connection* nil)
 58 | 
 59 | (defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]"))
 60 | 
 61 | 
 62 | 
 63 | 
 64 | (defun server-show-prompt (sock)
 65 |   ;;(send-to-client sock nil (format nil "~A> " (package-name *package*))))
 66 |   (format (server-socket-stream sock) "~A~%"
 67 |           (crypt (format nil"~A> " (package-name *package*)) (server-socket-key sock)))
 68 |   (force-output (server-socket-stream sock)))
 69 | 
 70 | 
 71 | (defun send-to-client (sock show-prompt-p &rest msg)
 72 |   (dolist (m (if (consp (car msg)) (car msg) msg))
 73 |     (format (server-socket-stream sock) "~A~%" (crypt m (server-socket-key sock)))
 74 |     (force-output (server-socket-stream sock)))
 75 |   (when show-prompt-p
 76 |     (server-show-prompt sock)))
 77 | 
 78 | ;;(defun server-show-prompt (sock)
 79 | ;;  (send-to-client sock nil (format nil "~A> " (package-name *package*))))
 80 | 
 81 | 
 82 | 
 83 | (defun read-from-client (sock)
 84 |   (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock)))
 85 | 
 86 | 
 87 | 
 88 | (defun server-remove-connection (sock)
 89 |   (send-to-client sock nil "Connection closed by server")
 90 |   (multiple-value-bind (local-host local-port remote-host remote-port)
 91 |       (port:socket-host/port (server-socket-stream sock))
 92 |     (declare (ignore local-host local-port))
 93 |     (format t "~&Connection from ~A:~A closed.~%" remote-host remote-port))
 94 |   (close (server-socket-stream sock))
 95 |   (setf *server-connection* (remove sock *server-connection*)))
 96 | 
 97 | (defun server-show-info (sock)
 98 |   (send-to-client sock t (format nil "~A" *server-connection*)))
 99 | 
100 | 
101 | (defun server-clear-connection ()
102 |   (dolist (sock *server-connection*)
103 |     (handler-case
104 | 	(send-to-client sock t "Server clear connection in progress.")
105 |       (error ()
106 | 	(server-remove-connection sock)))))
107 | 
108 | 
109 | (defun server-show-help (sock)
110 |   (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*)))
111 | 
112 | 
113 | (defun server-ls (sock line ls-word var-p fun-p &optional show-doc)
114 |   (let* ((pattern (string-trim '(#\space #\tab) (subseq (string-trim '(#\space #\tab) line) (length ls-word))))
115 | 	 (all-search (string= pattern "")))
116 |     (with-all-internal-symbols (symbol :clfswm)
117 |       (when (or all-search (symbol-search pattern symbol))
118 | 	(cond ((and var-p (boundp symbol))
119 | 	       (send-to-client sock nil (format nil "~A (variable) ~A" symbol
120 | 						(if show-doc
121 | 						    (format nil "~&  ~A~&  => ~A"
122 | 							    (documentation symbol 'variable)
123 | 							    (symbol-value symbol))
124 | 						    ""))))
125 | 	      ((and fun-p (fboundp symbol))
126 | 	       (send-to-client sock nil (format nil "~A (function) ~A" symbol
127 | 						(if show-doc
128 | 						    (documentation symbol 'function)
129 | 						    "")))))))
130 |     (send-to-client sock t "Done.")))
131 | 
132 | 
133 | 
134 | (defun server-is-allowed-host (stream)
135 |   (multiple-value-bind (local-host local-port remote-host remote-port)
136 |       (port:socket-host/port stream)
137 |     (declare (ignore local-host local-port))
138 |     (and (member remote-host *server-allowed-host* :test #'string-equal)
139 | 	 (equal remote-port *server-port*))))
140 | 
141 | 
142 | (defun server-handle-new-connection ()
143 |   (handler-case
144 |       (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait *server-wait-timeout*))))
145 | 	(when stream
146 | 	  (if (server-is-allowed-host stream)
147 | 	      (multiple-value-bind (local-host local-port remote-host remote-port)
148 | 		  (port:socket-host/port stream)
149 | 		(declare (ignore local-host local-port))
150 | 		(format t "~&New connection from ~A:~A " remote-host remote-port)
151 | 		(let ((new-sock (make-server-socket :stream stream :auth nil :form "" :key *key*))
152 | 		      (key (generate-key)))
153 | 		  (push  new-sock *server-connection*)
154 | 		  (send-to-client new-sock nil key)
155 | 		  (setf (server-socket-key new-sock) (concatenate 'string key *key*))))
156 | 	      (close stream))))
157 |     (error (c)
158 |       (format t "Connection rejected: ~A~%" c)
159 |       (force-output))))
160 | 
161 | 
162 | (defun server-line-is (line &rest strings)
163 |   (dolist (str strings)
164 |     (when (string-equal line str)
165 |       (return-from server-line-is t)))
166 |   nil)
167 | 
168 | 
169 | (defun server-complet-from (sock)
170 |   (ignore-errors
171 |     (when (listen (server-socket-stream sock))
172 |       (let ((line (read-from-client sock)))
173 | 	(cond ((server-line-is line "help") (server-show-help sock))
174 | 	      ((server-line-is line "bye" "close" "quit") (server-remove-connection sock))
175 | 	      ((server-line-is line "info") (server-show-info sock))
176 | 	      ((server-line-is line "clear") (server-clear-connection))
177 | 	      ((first-position "lsdv" line) (server-ls sock line  "lsdv" t nil t))
178 | 	      ((first-position "lsdf" line) (server-ls sock line  "lsdf" nil t t))
179 | 	      ((first-position "lsd" line) (server-ls sock line  "lsd" t t t))
180 | 	      ((first-position "lsv" line) (server-ls sock line  "lsv" t nil nil))
181 | 	      ((first-position "lsf" line) (server-ls sock line  "lsf" nil t nil))
182 | 	      ((first-position "ls" line) (server-ls sock line "ls" t t nil))
183 | 	      (t (setf (server-socket-form sock) (format nil "~A~A~%" (server-socket-form sock) line))))))))
184 | 
185 | 
186 | 
187 | 
188 | 
189 | (defun server-eval-form (sock)
190 |   (let* ((result nil)
191 | 	 (printed-result
192 | 	  (with-output-to-string (*standard-output*)
193 | 	    (setf result (handler-case
194 | 			     (loop for i in (multiple-value-list
195 | 					     (eval (read-from-string (server-socket-form sock))))
196 | 				collect (format nil "~S" i))
197 | 			   (error (condition)
198 | 			     (format nil "~A" condition)))))))
199 |     (send-to-client sock nil (ensure-list printed-result))
200 |     (send-to-client sock t (ensure-list result))
201 |     (setf (server-socket-form sock) "")))
202 | 
203 | 
204 | (defun server-handle-form (sock)
205 |   (server-complet-from sock)
206 |   (if (server-socket-key sock)
207 |       (when (ignore-errors (read-from-string (server-socket-form sock)))
208 | 	(server-eval-form sock))
209 |       (server-show-prompt sock)))
210 | 
211 | (defun server-handle-auth (sock)
212 |   (loop for line = (read-from-client sock)
213 |      while line
214 |        do
215 |        (if (string= line (format nil "~A~A" (server-socket-key sock)
216 | 				 (md5:md5 (server-socket-key sock))))
217 | 	   (progn
218 | 	     (setf (server-socket-auth sock) t)
219 | 	     (setf (server-socket-form sock) (format nil "~S" "You are now authenticated!"))
220 | 	     (server-handle-form sock)
221 | 	     (format t "Connection accepted~%")
222 | 	     (return-from server-handle-auth nil))
223 | 	   (progn
224 | 	     (format t "Connection closed~%")
225 | 	     (close (server-socket-stream sock))))))
226 | 
227 | 
228 | (defun server-handle-connection (sock)
229 |   (handler-case
230 |       (when (listen (server-socket-stream sock))
231 | 	(if (server-socket-auth sock)
232 | 	    (server-handle-form sock)
233 | 	    (server-handle-auth sock)))
234 |     (error (c)
235 |       (format t "*** Error: ~A~%" c) (force-output)
236 |       (close (server-socket-stream sock))
237 |       (setf *server-connection* (remove sock *server-connection*)))))
238 | 
239 | (defun handle-server ()
240 |   (server-handle-new-connection)
241 |   (dolist (sock *server-connection*)
242 |     (server-handle-connection sock)))
243 | 
244 | 
245 | 
246 | (defun start-server (&optional port)
247 |   (when port
248 |     (setf *server-port* port))
249 |   (setf *server-socket* (port:open-socket-server *server-port*))
250 |   (add-hook *loop-hook* 'handle-server)
251 |   (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%"
252 | 	  *server-port* *server-allowed-host*)
253 |   (save-new-key))
254 | 
255 | 
256 | 
257 | 
258 | (format t "done.
259 | 
260 | You can now start a clfswm server with the command (start-server &optional port).
261 | Only [~{~A~^, ~}] ~A allowed to login on the server. The connection is crypted.
262 | You can start the client with the '--client' command line option.~%"
263 | 	*server-allowed-host*
264 | 	(if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1))
265 | 	    "is" "are"))
266 | 
267 | (defun server-parse-cmdline ()
268 |   (let ((args (get-command-line-words)))
269 |     (when (member "--client" args :test #'string-equal)
270 |       (clfswm-client:start-client (remove "--client" args :test #'string-equal))
271 |       (uquit))))
272 | 
273 | (defun is-started-as-client-p ()
274 |   (member "--client" (get-command-line-words) :test #'string-equal))
275 | 
276 | (add-hook *main-entrance-hook* 'server-parse-cmdline)
277 | 


--------------------------------------------------------------------------------
/contrib/server/test.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :clfswm)
 2 | 
 3 | (leave-frame)
 4 | (select-previous-level)
 5 | 
 6 | (let ((frame (create-frame \:name \"Test root\" \:x 0.05 \:y 0.05)))
 7 |   (add-frame frame (current-child))
 8 |   (add-frame (create-frame \:name \"Test 1\" \:x 0.3 \:y 0 \:w 0.7 \:h 1) frame)
 9 |   (add-frame (create-frame \:name \"Test 2\" \:x 0 \:y 0 \:w 0.3 \:h 1) frame)
10 |   (setf (current-child) (first (frame-child frame))))
11 | 
12 | (show-all-children *current-root*)
13 | 
14 | 
15 | 
16 | 


--------------------------------------------------------------------------------
/contrib/wallpaper.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Wallpaper utilities
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; Documentation: If you want to use this file, just add this line in
 25 | ;;; your configuration file:
 26 | ;;;
 27 | ;;;   (load-contrib "wallpaper.lisp")
 28 | ;;;
 29 | ;;; Note: You need the 'convert' program from the ImageMagick package and the
 30 | ;;;   'Esetroot' program. But you can change this last one.
 31 | ;;;
 32 | ;;; Usage example:
 33 | ;;;
 34 | ;;;  (defun my-wallpaper ()
 35 | ;;;    (wallpaper "/home/you/.background-full" nil
 36 | ;;;               "background-1.png"
 37 | ;;;               "background-2.png"))
 38 | ;;;
 39 | ;;;  (add-hook *init-hook* 'my-wallpaper)
 40 | ;;;
 41 | ;;; You can have more screen heads than wallpaper images listed in the
 42 | ;;; wallpaper function.
 43 | ;;;
 44 | ;;; You can force the wallpaper creation by replacing the nil value after the
 45 | ;;; wallpaper basename with a true (t) value.
 46 | ;;; --------------------------------------------------------------------------
 47 | 
 48 | (in-package :clfswm)
 49 | 
 50 | (format t "Loading Wallpaper code... ")
 51 | 
 52 | 
 53 | (defconfig *wallpaper-command* "Esetroot -scale"
 54 |   'Wallpaper "Command to install the wallpaper")
 55 | 
 56 | ;;; Example of generated line
 57 | ;;; convert -size 1000x1000 xc:skyblue background.png -geometry 700x600+150+10! -composite  Tux_Wallpaper_by_Narcoblix.png -geometry 500x300+100+620!  -composite composite.png
 58 | 
 59 | (defun generate-wallpaper (filename width height root-list image-filename-list &optional (background "black"))
 60 |   (let ((command (with-output-to-string (str)
 61 |                    (format str "convert -size ~Ax~A xc:~A " width height background)
 62 |                    (let ((ind 0)
 63 |                          (len (1- (length image-filename-list))))
 64 |                      (dolist (root root-list)
 65 |                        (format str "~A -geometry ~Ax~A+~A+~A! -composite " (nth ind image-filename-list)
 66 |                                (third root) (fourth root) (first root) (second root))
 67 |                        (setf ind (if (< ind len) (1+ ind) 0))))
 68 |                    (format str "~A" filename))))
 69 |     (format t "~A~%" command)
 70 |     (do-shell-output "~A" command)))
 71 | 
 72 | 
 73 | (defun create-wallpaper (filename &rest images)
 74 |   (format t "Creating wallpaper ~A from ~{~A ~}~%" filename images)
 75 |   (generate-wallpaper filename (x-drawable-width *root*) (x-drawable-height *root*)
 76 |                       (or (get-connected-heads-size)
 77 |                           `((0 0 ,(x-drawable-width *root*) ,(x-drawable-height *root*))))
 78 |                       images)
 79 |   (format t "Done.~%"))
 80 | 
 81 | 
 82 | (defun use-wallpaper (filename)
 83 |   (when (probe-file filename)
 84 |     (format t "Using wallpaper ~A~%" filename)
 85 |     (do-shell (format nil "~A ~A" *wallpaper-command* filename) nil t)
 86 |     (format t "Done.~%")))
 87 | 
 88 | 
 89 | 
 90 | (defun wallpaper-name (basename)
 91 |   (let ((sizes (or (get-connected-heads-size)
 92 |                    `((0 0 ,(x-drawable-width *root*) ,(x-drawable-height *root*)))))
 93 |         (count 0))
 94 |     (dolist (s sizes)
 95 |       (dolist (v s)
 96 |         (incf count (+ v count))))
 97 |     (format nil "~A-~A.png" basename count)))
 98 | 
 99 | (defun wallpaper (basename force-create &rest images)
100 |   (let* ((filename (wallpaper-name basename)))
101 |     (when (or force-create (not (probe-file filename)))
102 |       (open-notify-window '(" " " " "          Please wait. Updating wallpaper...        " " " " "))
103 |       (apply #'create-wallpaper filename images)
104 |       (close-notify-window))
105 |     (use-wallpaper filename)))
106 | 
107 | ;;;
108 | ;;; End of code
109 | ;;;
110 | (format t "done~%")
111 | 


--------------------------------------------------------------------------------
/contrib/xmms.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: Music Player Daemon (MPD) interface
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; Documentation: Handle the XMMS player
25 | ;;;   This code needs xmmsctrl.
26 | ;;    If you want to use this file, just add this line in
27 | ;;;   your configuration file:
28 | ;;;
29 | ;;;     (load-contrib "xmms.lisp")
30 | ;;;
31 | ;;; --------------------------------------------------------------------------
32 | 
33 | (in-package :clfswm)
34 | 
35 | (format t "Loading XMMS code... ")
36 | 
37 | (defun xmms-menu ()
38 |   "Open the XMMS menu"
39 |   (open-menu (find-menu 'xmms-menu)))
40 | 
41 | (defun launch-xmms ()
42 |   "Lanch XMMS"
43 |   (do-shell "xmmsctrl launch"))
44 | 
45 | (defun show-xmms-status ()
46 |   "Show the current xmms status"
47 |   (info-on-shell "XMMS status:" "xmmsctrl cur"))
48 | 
49 | (defun show-xmms-playlist ()
50 |   "Show the current xmms playlist"
51 |   (info-on-shell "XMMS Playlist:" "xmmsctrl playlist"))
52 | 
53 | (defun xmms-next-track ()
54 |   "Play the next XMMS track"
55 |   (do-shell "xmmsctrl next")
56 |   (show-xmms-status)
57 |   (xmms-menu))
58 | 
59 | (defun xmms-previous-track ()
60 |   "Play the previous XMMS track"
61 |   (do-shell "xmmsctrl previous")
62 |   (show-xmms-status)
63 |   (xmms-menu))
64 | 
65 | (defun xmms-load-file ()
66 |   "open xmms \"Load file(s)\" dialog window."
67 |   (do-shell "xmmsctrl eject"))
68 | 
69 | (unless (find-menu 'xmms-menu)
70 |   (add-sub-menu 'help-menu "x" 'xmms-menu "XMMS menu")
71 | 
72 |   (add-menu-key 'xmms-menu "r" 'launch-xmms)
73 |   (add-menu-key 'xmms-menu "s" 'show-xmms-status)
74 |   (add-menu-key 'xmms-menu "l" 'show-xmms-playlist)
75 |   (add-menu-key 'xmms-menu "n" 'xmms-next-track)
76 |   (add-menu-key 'xmms-menu "p" 'xmms-previous-track)
77 |   (add-menu-key 'xmms-menu "e" 'xmms-load-file))
78 | 
79 | (format t "done~%")
80 | 


--------------------------------------------------------------------------------
/doc/README:
--------------------------------------------------------------------------------
1 | TODO
2 | 


--------------------------------------------------------------------------------
/doc/clfswm.1.txt:
--------------------------------------------------------------------------------
 1 | // -*- mode: doc -*-
 2 | // Use "a2x -f manpage clfswm.1.txt" to generate the man page.
 3 | CLFSWM(1)
 4 | =========
 5 | :doctype: manpage
 6 | 
 7 | 
 8 | NAME
 9 | ----
10 | clfswm - A(nother) Common Lisp Full Screen Window Manager
11 | 
12 | 
13 | SYNOPSIS
14 | --------
15 | *clfswm* ['implementation']
16 | 
17 | 
18 | DESCRIPTION
19 | -----------
20 | CLFSWM is a 100% Common Lisp X11 window manager (based on Tinywm and
21 | Stumpwm. Many thanks to them).  It can be driven only with the
22 | keyboard or with the mouse.
23 | 
24 | CLFSWM uses the following rules to determine which implementation
25 | should be used:
26 | 
27 | . the first command line argument.
28 | . environment variable $LISP
29 | . the first line like "debian=<impl>" in its configuration file.
30 | . clisp
31 | 
32 | CLFSWM handles clisp, sbcl and cmucl internally.  If you specify a
33 | different implementation, CLFSWM will try to execute the command
34 | `clfswm-<implementation>`.  See /usr/share/doc/clfswm/README.Debian
35 | for details.
36 | 
37 | 
38 | OPTIONS
39 | -------
40 | 'implementation'::
41 | 	Indicates which implementation should be used.
42 | 
43 | 
44 | ENVIRONMENT
45 | -----------
46 | 'LISP'::
47 | 	Indicates which implementation should be used.
48 | 
49 | 
50 | FILES
51 | -----
52 | '$XDG_CONFIG_HOME/clfswm/clfswmrc'::
53 | 	User configuration file.  If XDG_CONFIG_HOME is undefined,
54 | 	'$HOME/.config/clfswm/clfswmrc' will be used.
55 | 
56 | '$HOME/.clfswmrc'::
57 | 	Deprecated.  This file will be used only if the previous file
58 | 	does not exist.
59 | 
60 | '/etc/clfswmrc'::
61 | 	System-wide configuration file.
62 | 
63 | 
64 | SEE ALSO
65 | --------
66 | clisp(1), sbcl(1), cmucl(1).
67 | 
68 | AUTHOR
69 | ------
70 | CLFSWM was written by Philippe Brochard <pbrochard@common-lisp.net>.
71 | 
72 | This manual page was written by Desmond O. Chang <dochang@gmail.com>,
73 | for the Debian project (and may be used by others).
74 | 


--------------------------------------------------------------------------------
/doc/corner.html:
--------------------------------------------------------------------------------
  1 | <html>
  2 |   <head>
  3 |     <title>
  4 |       CLFSWM Corners
  5 |     </title>
  6 |   </head>
  7 |   <body>
  8 |     <h1>
  9 |       <a name="top">
 10 |         CLFSWM Corners
 11 |       </a>
 12 |     </h1>
 13 |     <p>
 14 |       Here are the actions associated to screen corners in CLFSWM:
 15 |     </p>
 16 |     <h3>
 17 |       *corner-main-mode-left-button*
 18 |     </h3>
 19 |     <table class="ex" cellspacing="5" border="0" width="100%">
 20 |       <tr>
 21 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 22 |           Top-Left:
 23 |         </td>
 24 |         <td style="color:#0000ff" nowrap>
 25 |           Open the main menu
 26 |         </td>
 27 |       </tr>
 28 |       <tr>
 29 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 30 |           Top-Right:
 31 |         </td>
 32 |         <td style="color:#0000ff" nowrap>
 33 |           Present a virtual keyboard
 34 |         </td>
 35 |       </tr>
 36 |       <tr>
 37 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 38 |           Bottom-Right:
 39 |         </td>
 40 |         <td style="color:#0000ff" nowrap>
 41 |           Present all windows in currents roots (An expose like)
 42 |         </td>
 43 |       </tr>
 44 |       <tr>
 45 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 46 |           Bottom-Left:
 47 |         </td>
 48 |         <td style="color:#0000ff" nowrap>
 49 |           ---
 50 |         </td>
 51 |       </tr>
 52 |     </table>
 53 |     <h3>
 54 |       *corner-main-mode-middle-button*
 55 |     </h3>
 56 |     <table class="ex" cellspacing="5" border="0" width="100%">
 57 |       <tr>
 58 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 59 |           Top-Left:
 60 |         </td>
 61 |         <td style="color:#0000ff" nowrap>
 62 |           Open the help and info window
 63 |         </td>
 64 |       </tr>
 65 |       <tr>
 66 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 67 |           Top-Right:
 68 |         </td>
 69 |         <td style="color:#0000ff" nowrap>
 70 |           Close or kill the current window (ask before doing anything)
 71 |         </td>
 72 |       </tr>
 73 |       <tr>
 74 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 75 |           Bottom-Right:
 76 |         </td>
 77 |         <td style="color:#0000ff" nowrap>
 78 |           ---
 79 |         </td>
 80 |       </tr>
 81 |       <tr>
 82 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 83 |           Bottom-Left:
 84 |         </td>
 85 |         <td style="color:#0000ff" nowrap>
 86 |           ---
 87 |         </td>
 88 |       </tr>
 89 |     </table>
 90 |     <h3>
 91 |       *corner-main-mode-right-button*
 92 |     </h3>
 93 |     <table class="ex" cellspacing="5" border="0" width="100%">
 94 |       <tr>
 95 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
 96 |           Top-Left:
 97 |         </td>
 98 |         <td style="color:#0000ff" nowrap>
 99 |           Hide/Unhide a terminal
100 |         </td>
101 |       </tr>
102 |       <tr>
103 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
104 |           Top-Right:
105 |         </td>
106 |         <td style="color:#0000ff" nowrap>
107 |           Close or kill the current window (ask before doing anything)
108 |         </td>
109 |       </tr>
110 |       <tr>
111 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
112 |           Bottom-Right:
113 |         </td>
114 |         <td style="color:#0000ff" nowrap>
115 |           Present all windows in all frames (An expose like)
116 |         </td>
117 |       </tr>
118 |       <tr>
119 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
120 |           Bottom-Left:
121 |         </td>
122 |         <td style="color:#0000ff" nowrap>
123 |           ---
124 |         </td>
125 |       </tr>
126 |     </table>
127 |     <h3>
128 |       *corner-second-mode-left-button*
129 |     </h3>
130 |     <table class="ex" cellspacing="5" border="0" width="100%">
131 |       <tr>
132 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
133 |           Top-Left:
134 |         </td>
135 |         <td style="color:#0000ff" nowrap>
136 |           ---
137 |         </td>
138 |       </tr>
139 |       <tr>
140 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
141 |           Top-Right:
142 |         </td>
143 |         <td style="color:#0000ff" nowrap>
144 |           ---
145 |         </td>
146 |       </tr>
147 |       <tr>
148 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
149 |           Bottom-Right:
150 |         </td>
151 |         <td style="color:#0000ff" nowrap>
152 |           Present all windows in currents roots (An expose like)
153 |         </td>
154 |       </tr>
155 |       <tr>
156 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
157 |           Bottom-Left:
158 |         </td>
159 |         <td style="color:#0000ff" nowrap>
160 |           ---
161 |         </td>
162 |       </tr>
163 |     </table>
164 |     <h3>
165 |       *corner-second-mode-middle-button*
166 |     </h3>
167 |     <table class="ex" cellspacing="5" border="0" width="100%">
168 |       <tr>
169 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
170 |           Top-Left:
171 |         </td>
172 |         <td style="color:#0000ff" nowrap>
173 |           Open the help and info window
174 |         </td>
175 |       </tr>
176 |       <tr>
177 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
178 |           Top-Right:
179 |         </td>
180 |         <td style="color:#0000ff" nowrap>
181 |           ---
182 |         </td>
183 |       </tr>
184 |       <tr>
185 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
186 |           Bottom-Right:
187 |         </td>
188 |         <td style="color:#0000ff" nowrap>
189 |           ---
190 |         </td>
191 |       </tr>
192 |       <tr>
193 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
194 |           Bottom-Left:
195 |         </td>
196 |         <td style="color:#0000ff" nowrap>
197 |           ---
198 |         </td>
199 |       </tr>
200 |     </table>
201 |     <h3>
202 |       *corner-second-mode-right-button*
203 |     </h3>
204 |     <table class="ex" cellspacing="5" border="0" width="100%">
205 |       <tr>
206 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
207 |           Top-Left:
208 |         </td>
209 |         <td style="color:#0000ff" nowrap>
210 |           ---
211 |         </td>
212 |       </tr>
213 |       <tr>
214 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
215 |           Top-Right:
216 |         </td>
217 |         <td style="color:#0000ff" nowrap>
218 |           ---
219 |         </td>
220 |       </tr>
221 |       <tr>
222 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
223 |           Bottom-Right:
224 |         </td>
225 |         <td style="color:#0000ff" nowrap>
226 |           Present all windows in all frames (An expose like)
227 |         </td>
228 |       </tr>
229 |       <tr>
230 |         <td align="left" width="1%" style="color:#ff0000" nowrap>
231 |           Bottom-Left:
232 |         </td>
233 |         <td style="color:#0000ff" nowrap>
234 |           ---
235 |         </td>
236 |       </tr>
237 |     </table>
238 |     <p>
239 |       <small>
240 |         This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-corner-doc-html-in-file or
241 | the produce-all-docs function from the Lisp REPL.
242 |       </small>
243 |     </p>
244 |     <p>
245 |       <small>
246 |         Something like this:<br>
247 | LISP> (in-package :clfswm)<br>
248 | CLFSWM> (produce-corner-doc-html-in-file "my-corner.html")<br>
249 | or<br> CLFSWM> (produce-all-docs)
250 |       </small>
251 |     </p>
252 |   </body>
253 | </html>
254 | 


--------------------------------------------------------------------------------
/doc/corner.txt:
--------------------------------------------------------------------------------
 1 | Here are the actions associated to screen corners in CLFSWM:
 2 | 
 3 | *Corner-Main-Mode-Left-Button*:
 4 |   Top-Left: Open the main menu
 5 |   Top-Right: Present a virtual keyboard
 6 |   Bottom-Right: Present all windows in currents roots (An expose like)
 7 |   Bottom-Left: ---
 8 | 
 9 | *Corner-Main-Mode-Middle-Button*:
10 |   Top-Left: Open the help and info window
11 |   Top-Right: Close or kill the current window (ask before doing anything)
12 |   Bottom-Right: ---
13 |   Bottom-Left: ---
14 | 
15 | *Corner-Main-Mode-Right-Button*:
16 |   Top-Left: Hide/Unhide a terminal
17 |   Top-Right: Close or kill the current window (ask before doing anything)
18 |   Bottom-Right: Present all windows in all frames (An expose like)
19 |   Bottom-Left: ---
20 | 
21 | *Corner-Second-Mode-Left-Button*:
22 |   Top-Left: ---
23 |   Top-Right: ---
24 |   Bottom-Right: Present all windows in currents roots (An expose like)
25 |   Bottom-Left: ---
26 | 
27 | *Corner-Second-Mode-Middle-Button*:
28 |   Top-Left: Open the help and info window
29 |   Top-Right: ---
30 |   Bottom-Right: ---
31 |   Bottom-Left: ---
32 | 
33 | *Corner-Second-Mode-Right-Button*:
34 |   Top-Left: ---
35 |   Top-Right: ---
36 |   Bottom-Right: Present all windows in all frames (An expose like)
37 |   Bottom-Left: ---
38 | 
39 | 
40 | This documentation was produced with the CLFSWM auto-doc functions.
41 | To reproduce it, use the produce-corner-doc-in-file or
42 | the produce-all-docs function from the Lisp REPL.
43 | 
44 | Something like this:
45 | LISP> (in-package :clfswm)
46 | CLFSWM> (produce-corner-doc-in-file "my-corner.txt")
47 | or
48 | CLFSWM> (produce-all-docs)
49 | 
50 | 


--------------------------------------------------------------------------------
/doc/dot-clfswmrc:
--------------------------------------------------------------------------------
  1 | ;;; -*- lisp -*-
  2 | ;;;
  3 | ;;; CLFSWM configuration file example
  4 | ;;;
  5 | ;;; Send me your configuration file at pbrochard _at_ common-lisp -dot- net
  6 | ;;; if you want to share it with others.
  7 | 
  8 | (in-package :clfswm)
  9 | 
 10 | 
 11 | 
 12 | ;;;; Uncomment the line above if you need default modifiers (or not)
 13 | ;;(with-capslock)
 14 | ;;(with-numlock)
 15 | ;;(without-capslock)
 16 | ;;(without-numlock)
 17 | 
 18 | ;;;; Uncomment the line above if you want to enable the notify event compression.
 19 | ;;;; This variable may be useful to speed up some slow version of CLX
 20 | ;;;; It is particulary useful with CLISP/MIT-CLX.
 21 | ;; (setf *have-to-compress-notify* t)
 22 | 
 23 | 
 24 | ;;; Color configuration example
 25 | ;;;
 26 | ;;; See in package.lisp or config.lisp for all variables
 27 | ;;(setf *color-unselected* "Blue")
 28 | 
 29 | 
 30 | ;;; How to change the default fullscreen size
 31 | ;;(defun get-fullscreen-size ()
 32 | ;;  "Return the size of root child (values rx ry rw rh)
 33 | ;;You can tweak this to what you want"
 34 | ;;  (values -2 -2 (+ (xlib:screen-width *screen*) 2) (- (xlib:screen-height *screen*) 20)))
 35 | 
 36 | 
 37 | ;;; Contributed code example
 38 | ;;; See in the clfswm/contrib directory to find some contributed code
 39 | ;;; and se load-contrib to load them. For example:
 40 | ;;(load-contrib "contrib-example.lisp")
 41 | 
 42 | ;;(load-contrib "mpd.lisp")
 43 | ;;(load-contrib "keyb_fr.lisp")
 44 | ;;(load-contrib "xmms.lisp")
 45 | ;;(load-contrib "cd-player.lisp")
 46 | ;;(load-contrib "reboot-halt.lisp")
 47 | 
 48 | 
 49 | ;;;; Client/server connection - the connection is crypted and you can only
 50 | ;;;; connect to the server with the same clfswm binary.
 51 | ;;(load-contrib "server/server.lisp")
 52 | ;;(unless (is-started-as-client-p)
 53 | ;;  (start-server))
 54 | 
 55 | 
 56 | 
 57 | ;;; Binding example: Undefine Control-F1 and define  Control-F5 as a
 58 | ;;; new binding in main mode
 59 | ;;;
 60 | ;;; See bindings.lisp, bindings-second-mode.lisp for all default bindings definitions.
 61 | ;;
 62 | ;;(defun $start-emacs ()
 63 | ;;  "Run or raise emacs"
 64 | ;;  (setf *second-mode-leave-function*
 65 | ;;        (lambda ()
 66 | ;;          (run-or-raise (lambda (win) (string-equal "emacs"
 67 | ;;						    (xlib:get-wm-class win)))
 68 | ;;                        (lambda () (do-shell "cd $HOME && exec emacsclient -c")))))
 69 | ;;  (leave-second-mode))
 70 | ;;
 71 | ;;(defun $start-conkeror ()
 72 | ;;  "Run or raise conkeror"
 73 | ;;  (setf *second-mode-leave-function*
 74 | ;;        (lambda ()
 75 | ;;          (run-or-raise (lambda (win) (string-equal "Navigator"
 76 | ;;						    (xlib:get-wm-class win)))
 77 | ;;                        (lambda () (do-shell "cd $HOME && exec conkeror")))))
 78 | ;;  (leave-second-mode))
 79 | ;;
 80 | ;;(defun binding-example ()
 81 | ;;  (undefine-main-key ("F1" :mod-1))
 82 | ;;  (define-main-key ("F5" :mod-1) 'help-on-clfswm)
 83 | ;;  (define-second-key ("e") '$start-emacs)
 84 | ;;  (define-second-key ("c") '$start-conkeror)
 85 | ;;  ;; Binding example for apwal
 86 | ;;  (define-second-key (#\Space)
 87 | ;;      (defun tpm-apwal ()
 88 | ;;	"Run Apwal"
 89 | ;;	(do-shell "exec apwal")
 90 | ;;	(show-all-windows-in-workspace (current-workspace))
 91 | ;;	(throw 'exit-second-loop nil))))
 92 | ;;
 93 | ;;(add-hook *binding-hook* 'binding-example)
 94 | 
 95 | 
 96 | ;;; Set up an UZBL frame where all uzbl windows will be absorbed.
 97 | ;;;
 98 | ;;(defun set-uzbl-frame-nw-hook (&optional (frame *current-child*))
 99 | ;;  "Open the window in the UZBL frame if it match uzbl absorb-nw-test"
100 | ;;  (when (frame-p frame)
101 | ;;    (setf (frame-nw-hook frame) 'absorb-window-nw-hook
102 | ;;	  (frame-data-slot frame :nw-absorb-test)  (nw-absorb-test-class "uzbl-core"))))
103 | ;;
104 | ;;#-:uzbl-menu-added
105 | ;;(add-menu-key 'frame-nw-hook-menu "z" 'set-uzbl-frame-nw-hook)
106 | ;;
107 | ;;(pushnew :uzbl-menu-added *features*)
108 | ;;
109 | ;;
110 | ;;(defun init-uzbl-frame ()
111 | ;;  (let ((frame (first (frame-child *root-frame*))))
112 | ;;    (setf (frame-data-slot frame :tile-size) 0.7)
113 | ;;    (setf *current-child* frame)
114 | ;;    (bind-on-slot 0)
115 | ;;    (let ((uzbl-frame (create-frame :name "Uzbl" :x 0.01 :y 0.01 :w 0.98 :h 0.98)))
116 | ;;      (add-frame uzbl-frame frame)
117 | ;;      (set-uzbl-frame-nw-hook uzbl-frame))))
118 | ;;
119 | ;;(unless (member 'init-uzbl-frame *init-hook*)
120 | ;;  (add-hook *init-hook* 'init-uzbl-frame))
121 | ;;; End UZBL setup.
122 | 
123 | 
124 | ;;; A more complex example I use to record my desktop and show
125 | ;;; documentation associated to each key press.
126 | ;;;See contrib/osd.lisp
127 | ;;(load-contrib "osd.lisp")
128 | ;;;;; -- Doc example end --
129 | 
130 | 
131 | 
132 | ;;;;; Init hook examples:
133 | ;;(defun my-init-hook-1 ()
134 | ;;  (dbg 'my-init-hook)
135 | ;;  ;;(add-frame (create-frame :name "Default" :layout #'tile-left-layout :data (list '(:tile-size 0.6))) *root-frame*)
136 | ;;  (add-frame (create-frame :name "The Gimp" :x 0.6 :y 0 :w 0.3 :h 0.2) *root-frame*)
137 | ;;  (add-frame (create-frame :name "Net" :x 0.52 :y 0.3 :w 0.4 :h 0.3) *root-frame*)
138 | ;;  (add-frame (create-frame :x 0.4 :y 0 :w 0.2 :h 0.3) (first (frame-child *root-frame*)))
139 | ;;  (add-frame (create-frame :x 0.6 :y 0.4 :w 0.4 :h 0.2) (first (frame-child *root-frame*)))
140 | ;;  (add-frame (create-frame :x 0.4 :y 0.7 :w 0.2 :h 0.3) (first (frame-child *root-frame*)))
141 | ;;  (let ((frame (create-frame :name "The Qiv" :x 0 :y 0.4 :w 0.4 :h 0.2)))
142 | ;;    (add-frame frame (first (frame-child *root-frame*)))
143 | ;;    (add-frame (create-frame) frame))
144 | ;;  (add-frame (create-frame :x 0.1 :y 0.55 :w 0.8 :h 0.43) *root-frame*)
145 | ;;  (add-frame (create-frame :x 0.2 :y 0.1 :w 0.6 :h 0.4) (first (frame-child *root-frame*)))
146 | ;;  (add-frame (create-frame :x 0.3 :y 0.55 :w 0.4 :h 0.3) (first (frame-child *root-frame*)))
147 | ;;  (add-frame (create-frame :x 0.1 :y 0.1 :w 0.3 :h 0.6) (first (frame-child (first (frame-child *root-frame*)))))
148 | ;;  (setf (frame-layout *current-child*) #'tile-layout))
149 | ;;
150 | ;;(defun my-init-hook-2 ()
151 | ;;  (dbg 'my-init-hook)
152 | ;;  (add-frame (create-frame :name "Default" :layout #'tile-left-layout :data (list '(:tile-size 0.6))) *root-frame*)
153 | ;;  (setf (frame-layout *current-child*) #'tile-layout))
154 | ;;
155 | ;;
156 | ;;(defun my-init-hook-3 ()
157 | ;;  (dbg 'my-init-hook)
158 | ;;  (add-frame (create-frame :name "plop" :x 0.1 :y 0.4 :w 0.7 :h 0.3) *root-frame*)
159 | ;;  (add-frame (create-frame :name "Default" :layout nil :x 0.1 :y 0.5 :w 0.8 :h 0.5)
160 | ;;	     *root-frame*)
161 | ;;  (setf (frame-layout *root-frame*) nil))
162 | ;;
163 | ;;
164 | ;;
165 | ;;(defun my-init-hook-4 ()
166 | ;;  (let ((frame (add-frame (create-frame :name "Default"
167 | ;;                                        :layout #'tile-left-layout
168 | ;;					:x 0.05 :y 0.05 :w 0.9 :h 0.9)
169 | ;;			  *root-frame*)))
170 | ;;    (setf *current-child* frame)))
171 | ;;
172 | ;;
173 | ;;;;; Use this hook and prevent yourself to create a new frame to emulate
174 | ;;;;; the MS Windows desktop style :)
175 | ;;(defun my-init-hook-ms-windows-style ()
176 | ;;  (setf (frame-managed-type *root-frame*) nil))
177 | ;;
178 | ;;
179 | ;;;;; Here is another example useful with the ROX filer: Only the
180 | ;;;;; root frame fullscreen with some space on the left for icons.
181 | ;;(defun my-init-hook-rox-filer ()
182 | ;;  (setf (frame-layout *root-frame*) #'tile-left-space-layout
183 | ;;	(frame-data-slot *root-frame* :tile-size) 0.9))
184 | ;;
185 | ;;
186 | ;;
187 | ;;
188 | ;;(setf *init-hook* '(my-init-hook-4))  ;; <- choose one in 1 to 4,
189 | ;;;;                                             my-init-hook-ms-windows-style
190 | ;;;;                                             my-init-hook-rox-filer
191 | ;;;;(setf *init-hook* nil)
192 | ;;;;; Init hook end
193 | 
194 | 
195 | ;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
196 | ;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
197 | ;;; mod-2 is the numlock key on some keyboards.
198 | ;;(setf *default-modifiers* '(:mod-2))
199 | ;;
200 | ;;(defun my-add-escape ()
201 | ;;  (define-main-key ("Escape" :mod-2) 'exit-clfswm))
202 | ;;
203 | ;;(add-hook *binding-hook* 'my-add-escape)
204 | ;;
205 | ;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug")
206 | 


--------------------------------------------------------------------------------
/load.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: System loading functions
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <hocwp@free.fr>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | ;;;
 26 | ;;; Edit this file (or its copy) and load it with your lisp implementation.
 27 | ;;; If you want, it can download ASDF and CLX for you. You'll need wget and
 28 | ;;; git program.
 29 | ;;;
 30 | ;;; Here are command line reference:
 31 | ;;;
 32 | ;;; clisp -E iso-8859-1 load.lisp
 33 | ;;; sbcl --load load.lisp
 34 | ;;; cmucl -load load.lisp
 35 | ;;; ccl -l load.lisp
 36 | ;;; ecl -load load.lisp
 37 | ;;;
 38 | ;;; --------------------------------------------------------------------------
 39 | 
 40 | ;;;------------------
 41 | ;;; Customization part
 42 | ;;;------------------
 43 | (defparameter *interactive* t)
 44 | 
 45 | (defparameter *build-original-doc* t
 46 |   "Set to t to use original configuration or to nil to use your own configuration
 47 | from $XDG_CONFIG_HOME/clfswm/clfswmrc")
 48 | 
 49 | 
 50 | ;;; Comment or uncomment the lines above to fit your needs.
 51 | (pushnew :clfswm-compile *features*)
 52 | ;;(pushnew :clfswm-run *features*)
 53 | (pushnew :clfswm-build-image *features*)
 54 | ;;(pushnew :clfswm-build-doc *features*)
 55 | 
 56 | (defparameter *binary-name* "clfswm")
 57 | 
 58 | ;;;;; Uncomment the line below if you want to see all ignored X errors
 59 | ;;(pushnew :xlib-debug *features*)
 60 | 
 61 | ;;;;; Uncomment the line below if you want to see all event debug messages
 62 | ;;(pushnew :event-debug *features*)
 63 | 
 64 | 
 65 | 
 66 | #+:CMU (setf ext:*gc-verbose* nil)
 67 | 
 68 | #+:SBCL
 69 | (require :sb-posix)
 70 | 
 71 | ;; (load (compile-file "src/tools.lisp"))
 72 | 
 73 | (defun load-info (formatter &rest args)
 74 |   (format t "~&  ==> ~A~%" (apply #'format nil formatter args))
 75 |   (force-output))
 76 | 
 77 | (defun interactive-ask (formatter &rest args)
 78 |   (when *interactive*
 79 |     (y-or-n-p (apply #'format nil formatter args))))
 80 | 
 81 | ;;;------------------
 82 | ;;; XLib part 1
 83 | ;;;------------------
 84 | #+(or :CMU :ECL)
 85 | (require :clx)
 86 | 
 87 | 
 88 | ;;;------------------
 89 | ;;; ASDF part
 90 | ;;;------------------
 91 | ;;;; Loading ASDF
 92 | (load-info "Requiring ASDF")
 93 | 
 94 | #+(or :SBCL :CMUCL :CCL :ECL)
 95 | (require :asdf)
 96 | 
 97 | #-ASDF
 98 | (when (probe-file "asdf.lisp")
 99 |   (load "asdf.lisp"))
100 | 
101 | #-:ASDF
102 | (let ((asdf-url "http://common-lisp.net/project/asdf/asdf.lisp"))
103 |   (when (interactive-ask "ASDF not found. Do you want to download it from ~A ?" asdf-url)
104 |     (tools:do-shell-output "wget ~A" asdf-url)
105 |     (load "asdf.lisp")))
106 | 
107 | (format t "ASDF version: ~A~%" (asdf:asdf-version))
108 | 
109 | ;;;------------------
110 | ;;; XLib part 2
111 | ;;;------------------
112 | (load-info "Requiring CLX")
113 | 
114 | ;;; Loading clisp dynamic module. This part needs clisp >= 2.50
115 | ;;#+(AND CLISP (not CLX))
116 | ;;(when (fboundp 'require)
117 | ;;  (require "clx.lisp"))
118 | #-CLX
119 | (progn
120 |   (when (probe-file "clx/clx.asd")
121 |     (load "clx/clx.asd")
122 |     (asdf:oos 'asdf:load-op :clx)))
123 | 
124 | #-CLX
125 | (progn
126 |   (let ((clx-url "git://github.com/sharplispers/clx.git"))
127 |     (when (interactive-ask "CLX not found. Do you want to download it from ~A ?" clx-url)
128 |       (unless (probe-file "clx/clx.asd")
129 |         (tools:do-shell-output "git clone ~A" clx-url))
130 |       (load "clx/clx.asd")
131 |       (asdf:oos 'asdf:load-op :clx))))
132 | 
133 | ;;;------------------
134 | ;;; CLFSWM loading
135 | ;;;------------------
136 | #+:clfswm-compile
137 | (progn
138 |   (load-info "Compiling CLFSWM")
139 |   (load "clfswm.asd")
140 |   (asdf:oos 'asdf:load-op :clfswm))
141 | 
142 | 
143 | ;;;-------------------------
144 | ;;; Starting clfswm
145 | ;;;-------------------------
146 | #+(or :clfswm-run :clfswm-build-doc :clfswm-build-image)
147 | (in-package :clfswm)
148 | 
149 | #+(or :clfswm-run :clfswm-build-doc)
150 | (progn
151 |   (cl-user::load-info "Running CLFSWM")
152 |   (ignore-errors
153 |     (main :read-conf-file-p (not cl-user::*build-original-doc*))))
154 | 
155 | 
156 | ;;;-------------------------
157 | ;;; Building documentation
158 | ;;;-------------------------
159 | #+:clfswm-build-doc
160 | (progn
161 |   (cl-user::load-info "Building documentation")
162 |   (produce-all-docs))
163 | 
164 | ;;;-----------------------
165 | ;;; Building image part
166 | ;;;-----------------------
167 | 
168 | ;;; Uncomment the line below to set the contrib directory in the image
169 | ;; (setf *contrib-dir* "/usr/local/lib/clfswm/")
170 | 
171 | #+:clfswm-build-image
172 | (progn
173 |   (cl-user::load-info "Building CLFSWM executable image")
174 |   (build-lisp-image "clfswm"))
175 | 


--------------------------------------------------------------------------------
/src/bindings.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Bindings keys and mouse
  6 | ;;;
  7 | ;;; Note: prefix is the Alt or Meta key, Mod-2 is the Numlock key.
  8 | ;;; --------------------------------------------------------------------------
  9 | ;;;
 10 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
 11 | ;;;
 12 | ;;; This program is free software; you can redistribute it and/or modify
 13 | ;;; it under the terms of the GNU General Public License as published by
 14 | ;;; the Free Software Foundation; either version 3 of the License, or
 15 | ;;; (at your option) any later version.
 16 | ;;;
 17 | ;;; This program is distributed in the hope that it will be useful,
 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 20 | ;;; GNU General Public License for more details.
 21 | ;;;
 22 | ;;; You should have received a copy of the GNU General Public License
 23 | ;;; along with this program; if not, write to the Free Software
 24 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 25 | ;;;
 26 | ;;; --------------------------------------------------------------------------
 27 | 
 28 | (in-package :clfswm)
 29 | 
 30 | ;;;,-----
 31 | ;;;| CONFIG - Bindings main mode
 32 | ;;;`-----
 33 | 
 34 | 
 35 | (add-hook *binding-hook* 'init-*main-keys* 'init-*main-mouse*)
 36 | 
 37 | 
 38 | (defun help-on-clfswm ()
 39 |   "Open the help and info window"
 40 |   (open-menu (find-menu 'help-menu)))
 41 | 
 42 | 
 43 | (defun set-default-main-keys ()
 44 |   (define-main-key ("F1" :alt) 'help-on-clfswm)
 45 |   (define-main-key ("Home" :prefix :control :shift) 'exit-clfswm)
 46 |   (define-main-key ("Right" :prefix) 'select-next-brother)
 47 |   (define-main-key ("Left" :prefix) 'select-previous-brother)
 48 |   (define-main-key ("Down" :prefix) 'select-previous-level)
 49 |   (define-main-key ("Up" :prefix) 'select-next-level)
 50 | 
 51 |   (define-main-key ("Right" :prefix :shift) 'select-next-brother-take-current)
 52 |   (define-main-key ("Left" :prefix :shift) 'select-previous-brother-take-current)
 53 | 
 54 |   (define-main-key ("Left" :control :prefix) 'select-brother-spatial-move-left)
 55 |   (define-main-key ("Right" :control :prefix) 'select-brother-spatial-move-right)
 56 |   (define-main-key ("Up" :control :prefix) 'select-brother-spatial-move-up)
 57 |   (define-main-key ("Down" :control :prefix) 'select-brother-spatial-move-down)
 58 | 
 59 |   (define-main-key ("Left" :control :prefix :shift) 'select-brother-spatial-move-left-take-current)
 60 |   (define-main-key ("Right" :control :prefix :shift) 'select-brother-spatial-move-right-take-current)
 61 |   (define-main-key ("Up" :control :prefix :shift) 'select-brother-spatial-move-up-take-current)
 62 |   (define-main-key ("Down" :control :prefix :shift) 'select-brother-spatial-move-down-take-current)
 63 | 
 64 |   (define-main-key ("Tab" :prefix) 'select-next-child)
 65 |   (define-main-key ("Tab" :prefix :shift) 'select-previous-child)
 66 |   (define-main-key ("Tab" :prefix :control) 'select-next-subchild)
 67 |   (define-main-key ("Return" :prefix) 'enter-frame)
 68 |   (define-main-key ("Return" :prefix :shift) 'leave-frame)
 69 |   (define-main-key ("Return" :prefix :control) 'frame-toggle-maximize)
 70 |   (define-main-key ("Return" :mod-5) 'frame-toggle-maximize)
 71 |   (define-main-key ("Page_Up" :prefix) 'frame-select-previous-child)
 72 |   (define-main-key ("Page_Down" :prefix) 'frame-select-next-child)
 73 |   (define-main-key ("Page_Up" :prefix :control) 'frame-lower-child)
 74 |   (define-main-key ("Page_Down" :prefix :control) 'frame-raise-child)
 75 |   (define-main-key ("Home" :prefix) 'switch-to-root-frame)
 76 |   (define-main-key ("Home" :prefix :shift) 'switch-and-select-root-frame)
 77 |   (define-main-key ("Menu") 'fastswitch-mode)
 78 |   (define-main-key ("F4") 'fastswitch-mode)
 79 |   (define-main-key ("Menu" :control) 'fastswitch-move-mode)
 80 |   (define-main-key ("Menu" :mod-5) 'expose-current-child-mode)
 81 |   (define-main-key ("F10" :alt) 'fast-layout-switch)
 82 |   (define-main-key ("F10" :shift :control) 'toggle-show-root-frame)
 83 |   (define-main-key ("F10") 'expose-windows-mode)
 84 |   (define-main-key ("F10" :control) 'expose-all-windows-mode)
 85 |   (define-main-key ("F12" :control) 'present-clfswm-terminal)
 86 |   (define-main-key ("F12" :shift) 'show-all-frames-info-key)
 87 |   (define-main-key ("F12" :shift :prefix) 'show-all-frames-info)
 88 |   (define-main-key ("b" :prefix) 'banish-pointer)
 89 |   ;; Escape
 90 |   (define-main-key ("Escape" :control) 'ask-close/kill-current-window)
 91 |   ;; Second mode
 92 |   (define-main-key (#\t :prefix) 'second-key-mode)
 93 |   (define-main-key ("less" :control) 'second-key-mode)
 94 |   ;; Bind or jump functions
 95 |   (define-main-key ("1" :prefix) 'bind-or-jump 1)
 96 |   (define-main-key ("2" :prefix) 'bind-or-jump 2)
 97 |   (define-main-key ("3" :prefix) 'bind-or-jump 3)
 98 |   (define-main-key ("4" :prefix) 'bind-or-jump 4)
 99 |   (define-main-key ("5" :prefix) 'bind-or-jump 5)
100 |   (define-main-key ("6" :prefix) 'bind-or-jump 6)
101 |   (define-main-key ("7" :prefix) 'bind-or-jump 7)
102 |   (define-main-key ("8" :prefix) 'bind-or-jump 8)
103 |   (define-main-key ("9" :prefix) 'bind-or-jump 9)
104 |   (define-main-key ("0" :prefix) 'bind-or-jump 10))
105 | 
106 | (add-hook *binding-hook* 'set-default-main-keys)
107 | 
108 | 
109 | 
110 | 
111 | 
112 | ;;; Mouse actions
113 | (defun mouse-click-to-focus-and-move-window (window root-x root-y)
114 |   "Move and focus the current child - Create a new frame on the root window"
115 |   (declare (ignore window))
116 |   (stop-button-event)
117 |   (mouse-focus-move/resize-generic root-x root-y #'move-frame t))
118 | 
119 | 
120 | (defun mouse-click-to-focus-and-resize-window (window root-x root-y)
121 |   "Resize and focus the current child - Create a new frame on the root window"
122 |   (declare (ignore window))
123 |   (stop-button-event)
124 |   (mouse-focus-move/resize-generic root-x root-y #'resize-frame t))
125 | 
126 | 
127 | (defun mouse-click-to-focus-and-move-window-constrained (window root-x root-y)
128 |   "Move (constrained by other frames) and focus the current child - Create a new frame on the root window"
129 |   (declare (ignore window))
130 |   (stop-button-event)
131 |   (mouse-focus-move/resize-generic root-x root-y #'move-frame-constrained t))
132 | 
133 | 
134 | (defun mouse-click-to-focus-and-resize-window-constrained (window root-x root-y)
135 |   "Resize (constrained by other frames) and focus the current child - Create a new frame on the root window"
136 |   (declare (ignore window))
137 |   (stop-button-event)
138 |   (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t))
139 | 
140 | 
141 | 
142 | (defun set-default-main-mouse ()
143 |   (define-main-mouse (1) 'mouse-click-to-focus-and-move)
144 |   (define-main-mouse (2) 'mouse-middle-click)
145 |   (define-main-mouse (3) 'mouse-click-to-focus-and-resize)
146 |   (define-main-mouse (1 :prefix) 'mouse-click-to-focus-and-move-window)
147 |   (define-main-mouse (3 :prefix) 'mouse-click-to-focus-and-resize-window)
148 |   (define-main-mouse (1 :prefix :shift) 'mouse-click-to-focus-and-move-window-constrained)
149 |   (define-main-mouse (3 :prefix :shift) 'mouse-click-to-focus-and-resize-window-constrained)
150 |   (define-main-mouse (1 :control :prefix) 'mouse-move-child-over-frame)
151 |   (define-main-mouse (4) 'mouse-select-next-level)
152 |   (define-main-mouse (5) 'mouse-select-previous-level)
153 |   (define-main-mouse (4 :prefix) 'mouse-enter-frame)
154 |   (define-main-mouse (5 :prefix) 'mouse-leave-frame)
155 |   (define-main-mouse (4 :prefix :control) 'dec-transparency)
156 |   (define-main-mouse (5 :prefix :control) 'inc-transparency)
157 |   (define-main-mouse (4 :prefix :control :shift) 'dec-transparency-slow)
158 |   (define-main-mouse (5 :prefix :control :shift) 'inc-transparency-slow))
159 | 
160 | (add-hook *binding-hook* 'set-default-main-mouse)
161 | 


--------------------------------------------------------------------------------
/src/clfswm-configuration.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Configuration definitions and Menu generation
  6 | ;;;
  7 | ;;; --------------------------------------------------------------------------
  8 | ;;;
  9 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
 10 | ;;;
 11 | ;;; This program is free software; you can redistribute it and/or modify
 12 | ;;; it under the terms of the GNU General Public License as published by
 13 | ;;; the Free Software Foundation; either version 3 of the License, or
 14 | ;;; (at your option) any later version.
 15 | ;;;
 16 | ;;; This program is distributed in the hope that it will be useful,
 17 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 19 | ;;; GNU General Public License for more details.
 20 | ;;;
 21 | ;;; You should have received a copy of the GNU General Public License
 22 | ;;; along with this program; if not, write to the Free Software
 23 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 24 | ;;;
 25 | ;;; --------------------------------------------------------------------------
 26 | 
 27 | (in-package :clfswm)
 28 | 
 29 | (defun find-configuration-variables ()
 30 |   (let ((all-groups nil)
 31 | 	(all-variables nil))
 32 |     (maphash (lambda (key val)
 33 |                (pushnew  (configvar-group val) all-groups :test #'string-equal)
 34 |                (push (list key (configvar-group val)) all-variables))
 35 |              *config-var-table*)
 36 |     (values all-groups all-variables)))
 37 | 
 38 | 
 39 | (defun find-symbol-function (function)
 40 |   (with-all-internal-symbols (symbol :clfswm)
 41 |     (when (and (fboundp symbol) (equal (symbol-function symbol) function))
 42 |       (return-from find-symbol-function symbol))))
 43 | 
 44 | (defun escape-conf-value (value)
 45 |   (cond ((or (equal value t) (equal value nil))
 46 |          (format nil "~S" value))
 47 |         ((consp value)
 48 |          (format nil "(quote ~S)" value))
 49 |         ((symbolp value)
 50 |          (format nil "'~S" value))
 51 |         ((functionp value)
 52 |          (format nil "'~S" (find-symbol-function value)))
 53 |         ((xlib:color-p value)
 54 |          (format nil "(->color #x~X)" (color->rgb value)))
 55 |         (t (format nil "~S" value))))
 56 | 
 57 | (defun escape-conf-symbol-value (symbol)
 58 |   (let ((value (symbol-value symbol)))
 59 |     (escape-conf-value value)))
 60 | 
 61 | (defun get-config-value (value)
 62 |   (ignore-errors (eval (read-from-string value))))
 63 | 
 64 | (defun reset-config-to-default-value (symbol)
 65 |   (setf (symbol-value symbol) (config-default-value symbol)))
 66 | 
 67 | 
 68 | ;;; Save configuration variables part
 69 | (defun temp-conf-file-name ()
 70 |   (let ((name (conf-file-name)))
 71 |     (make-pathname :directory (pathname-directory name)
 72 | 		   :name (concatenate 'string (pathname-name name) "-tmp"))))
 73 | 
 74 | 
 75 | (defun copy-previous-conf-file-begin (stream-in stream-out)
 76 |   (loop for line = (read-line stream-in nil nil)
 77 |      while line
 78 |      until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
 79 |      do (format stream-out "~A~%" line)))
 80 | 
 81 | (defun copy-previous-conf-file-end (stream-in stream-out)
 82 |   (loop for line = (read-line stream-in nil nil)
 83 |      while line
 84 |      until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
 85 |   (loop for line = (read-line stream-in nil nil)
 86 |      while line
 87 |      do (format stream-out "~A~%" line)))
 88 | 
 89 | 
 90 | 
 91 | (defun save-variables-in-conf-file (stream)
 92 |   (multiple-value-bind (all-groups all-variables)
 93 |       (find-configuration-variables)
 94 |     (format stream "~&;;; ### Internal variables definitions                    ### ;;;~%")
 95 |     (format stream ";;; ### You can edit this part when clfswm is not running ### ;;;~%")
 96 |     (format stream ";;; ### And you can remove this part to revert to the     ### ;;;~%")
 97 |     (format stream ";;; ### original configuration variables values.          ### ;;;~%")
 98 |     (format stream "(in-package :clfswm)~2%")
 99 |     (format stream "(setf~%")
100 |     (dolist (group all-groups)
101 |       (format stream "  ;; ~A:~%" (config-group->string group))
102 |       (dolist (var all-variables)
103 |         (unless (equal (escape-conf-symbol-value (first var))
104 |                        (escape-conf-value (config-default-value (first var))))
105 |           (when (string-equal (second var) group)
106 |             (format stream "  ~A ~A~%" (first var)
107 |                     (escape-conf-symbol-value (first var))))))
108 |       (format stream "~%"))
109 |     (format stream ")~%")
110 |     (format stream ";;; ### End of internal variables definitions ### ;;;~%")))
111 | 
112 | 
113 | 
114 | 
115 | (defun save-configuration-variables ()
116 |   "Save all configuration variables in clfswmrc"
117 |   (let ((conffile (conf-file-name))
118 | 	(tempfile (temp-conf-file-name)))
119 |     (with-open-file (stream-in conffile :direction :input :if-does-not-exist :create)
120 |       (with-open-file (stream-out tempfile :direction :output :if-exists :supersede)
121 | 	(copy-previous-conf-file-begin stream-in stream-out)
122 | 	(save-variables-in-conf-file stream-out)
123 | 	(copy-previous-conf-file-end stream-in stream-out)))
124 |     (delete-file conffile)
125 |     (rename-file tempfile conffile)
126 |     nil))
127 | 
128 | 
129 | ;;; Configuration menu definition
130 | 
131 | (defun group->menu (group)
132 |   (intern (string-upcase (format nil "conf-~A" group)) :clfswm))
133 | 
134 | (defun query-conf-value (var string original)
135 |   (labels ((warn-wrong-type (result original)
136 | 	     (if (equal (simple-type-of result) (simple-type-of original))
137 | 		 result
138 | 		 (if (query-yes-or-no "~A and ~A are not of the same type (~A and ~A). Do you really want to use this value?"
139 | 				      (escape-conf-value result) (escape-conf-value original)
140 |                                       (type-of result) (type-of original))
141 | 		     result
142 | 		     original)))
143 | 	   (ask-set-default-value (original-val)
144 | 	     (let ((default (config-default-value var)))
145 | 	       (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original (escape-conf-value default))
146 | 		   default
147 | 		   original-val))))
148 |     (multiple-value-bind (result return)
149 | 	(query-string (format nil "Configure ~A - ~A (blank=Default: ~A)" string
150 | 			      (documentation var 'variable)
151 |                               (escape-conf-value (config-default-value var)))
152 | 		      original)
153 |       (let ((original-val (get-config-value original)))
154 | 	(if (equal return :Return)
155 | 	    (if (string= result "")
156 | 		(ask-set-default-value original-val)
157 | 		(let ((result-val (get-config-value result)))
158 | 		  (warn-wrong-type result-val original-val)))
159 | 	    original-val)))))
160 | 
161 | 
162 | (defun create-conf-function (var)
163 |   (let* ((string (remove #\* (format nil "~A" var)))
164 | 	 (symbol (intern (format nil "CONFIGURE-~A" string) :clfswm)))
165 |     (setf (symbol-function symbol) (lambda ()
166 | 				     (setf (symbol-value var) (query-conf-value var string (escape-conf-symbol-value var)))
167 | 				     (open-menu (find-menu 'configuration-menu)))
168 | 	  (documentation symbol 'function) (format nil "Configure ~A" string))
169 |     symbol))
170 | 
171 | 
172 | (defun create-configuration-menu (&key clear)
173 |   "Configuration menu"
174 |   (when clear
175 |     (clear-sub-menu 'main 'configuration-menu))
176 |   (multiple-value-bind (all-groups all-variables)
177 |       (find-configuration-variables)
178 |     (loop for group in all-groups
179 |        for i from 0
180 |        do (let ((menu (group->menu group)))
181 | 	    (add-sub-menu 'configuration-menu (number->char i) menu (config-group->string group))
182 | 	    (loop for var in all-variables
183 | 	       with j = -1
184 | 	       do (when (equal (second var) group)
185 | 		    (add-menu-key menu (number->char (incf j))
186 | 				  (create-conf-function (first var))))))))
187 |   (add-menu-key 'configuration-menu "F2" 'save-configuration-variables)
188 |   (add-menu-key 'configuration-menu "F3" 'reset-all-config-variables))
189 | 
190 | 
191 | 
192 | (defun reset-all-config-variables ()
193 |   "Reset all configuration variables to their default values"
194 |   (when (query-yes-or-no "Do you really want to reset all values to their default?")
195 |     (maphash (lambda (key val)
196 |                (declare (ignore val))
197 |                (reset-config-to-default-value key))
198 |              *config-var-table*))
199 |   (open-menu (find-menu 'configuration-menu)))
200 | 


--------------------------------------------------------------------------------
/src/clfswm-corner.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Corner functions
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | 
 29 | 
 30 | (symbol-macrolet ((sw (screen-width))
 31 | 		  (sh (screen-height))
 32 | 		  (cs *corner-size*))
 33 |   (defun in-corner (corner x y)
 34 |     "Return t if (x, y) is in corner.
 35 | Corner is one of :bottom-right :bottom-left :top-right :top-left"
 36 |     (multiple-value-bind (xmin ymin xmax ymax)
 37 | 	(case corner
 38 | 	  (:bottom-right (values (- sw cs)  (- sh cs)  sw  sh))
 39 | 	  (:bottom-left (values 0  (- sh cs)  cs  sh))
 40 | 	  (:top-left (values 0 0 cs cs))
 41 | 	  (:top-right (values (- sw cs)  0  sw  cs))
 42 | 	  (t (values 10 10 0 0)))
 43 |       (and (<= xmin x xmax)
 44 | 	   (<= ymin y ymax)))))
 45 | 
 46 | 
 47 | (symbol-macrolet ((sw (screen-width))
 48 | 		  (sh (screen-height))
 49 | 		  (cs *corner-size*))
 50 |   (defun find-corner (x y)
 51 |     (cond ((and (< cs x (- sw cs)) (< cs y (- sh cs))) nil)
 52 | 	  ((and (<= 0 x cs) (<= 0 y cs)) :top-left)
 53 | 	  ((and (<= (- sw cs) x sw) (<= 0 y cs)) :top-right)
 54 | 	  ((and (<= 0 x cs) (<= (- sh cs) y sh)) :bottom-left)
 55 | 	  ((and (<= (- sw cs) x sw) (<= (- sh cs) y sh)) :bottom-right)
 56 | 	  (t nil))))
 57 | 
 58 | 
 59 | 
 60 | 
 61 | (defun do-corner-action (x y corner-list)
 62 |   "Do the action associated with corner. The corner function must return T to
 63 | stop the button event"
 64 |   (when (frame-p (find-current-root))
 65 |     (let ((corner (find-corner x y)))
 66 |       (when corner
 67 | 	(let ((fun (second (assoc corner corner-list))))
 68 | 	  (when fun
 69 | 	    (funcall fun)))))))
 70 | 
 71 | 
 72 | 
 73 | 
 74 | 
 75 | ;;;***************************************;;;
 76 | ;;; CONFIG - Corner actions definitions:  ;;;
 77 | ;;;***************************************;;;
 78 | (defun find-window-in-query-tree (target-win)
 79 |   (when target-win
 80 |     (dolist (win (xlib:query-tree *root*))
 81 |       (when (child-equal-p win target-win)
 82 |         (return t)))))
 83 | 
 84 | (defun wait-window-in-query-tree (wait-test)
 85 |   (dotimes (try *corner-command-try-number*)
 86 |      (dolist (win (xlib:query-tree *root*))
 87 |        (when (funcall wait-test win)
 88 | 	 (return-from wait-window-in-query-tree win)))
 89 |      (sleep *corner-command-try-delay*)))
 90 | 
 91 | 
 92 | (defun generic-present-body (cmd wait-test win &optional focus-p)
 93 |   (stop-button-event)
 94 |   (unless (find-window-in-query-tree win)
 95 |     (do-shell cmd)
 96 |     (setf win (wait-window-in-query-tree wait-test))
 97 |     (if win
 98 |         (progn
 99 |           (grab-all-buttons win)
100 |           (hide-window win))
101 |         (notify-message *corner-error-message-delay*
102 |                         (list (format nil "Error with command ~S" cmd)
103 |                               *corner-error-message-color*))))
104 |   (when win
105 |     (cond ((window-hidden-p win)
106 |            (unhide-window win)
107 |            (when focus-p
108 |              (focus-window win))
109 |            (raise-window win))
110 |           (t (hide-window win)
111 |              (show-all-children))))
112 |   win)
113 | 
114 | 
115 | 
116 | (let (win)
117 |   (defun close-virtual-keyboard ()
118 |     (when win
119 |       (xlib:destroy-window win)
120 |       (xlib:display-finish-output *display*)
121 |       (setf win nil)))
122 |   (defun present-virtual-keyboard ()
123 |     "Present a virtual keyboard"
124 |     (setf win (generic-present-body *virtual-keyboard-cmd*
125 | 				    (lambda (win)
126 | 				      (string-equal (xlib:get-wm-class win) "xvkbd"))
127 | 				    win))
128 |     t))
129 | 
130 | 
131 | (let (win)
132 |   (defun equal-clfswm-terminal (window)
133 |     (when (and win (xlib:window-p window))
134 |       (xlib:window-equal window win)))
135 |   (defun close-clfswm-terminal ()
136 |     (when win
137 |       (xlib:destroy-window win)
138 |       (xlib:display-finish-output *display*)
139 |       (setf win nil)))
140 |   (defun present-clfswm-terminal ()
141 |     "Hide/Unhide a terminal"
142 |     (setf win (generic-present-body *clfswm-terminal-cmd*
143 | 				    (lambda (win)
144 | 				      (string-equal (xlib:wm-name win) *clfswm-terminal-name*))
145 | 				    win
146 | 				    t))
147 |     t))
148 | 


--------------------------------------------------------------------------------
/src/clfswm-expose-mode.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Expose functions - An expose like.
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | (defparameter *expose-font* nil)
 29 | (defparameter *expose-selected-child* nil)
 30 | 
 31 | (defstruct expose-child number child key window gc string)
 32 | 
 33 | (defun leave-expose-mode ()
 34 |   "Leave the expose mode"
 35 |   (throw 'exit-expose-loop nil))
 36 | 
 37 | (defun valid-expose-mode ()
 38 |   "Valid the expose mode"
 39 |   (throw 'exit-expose-loop t))
 40 | 
 41 | (defun mouse-leave-expose-mode (window root-x root-y)
 42 |   "Leave the expose mode"
 43 |   (declare (ignore window root-x root-y))
 44 |   (throw 'exit-expose-loop nil))
 45 | 
 46 | (defun mouse-valid-expose-mode (window root-x root-y)
 47 |   "Valid the expose mode"
 48 |   (declare (ignore window root-x root-y))
 49 |   (throw 'exit-expose-loop t))
 50 | 
 51 | 
 52 | (defun expose-associate-keys ()
 53 |   (let* ((all nil)
 54 |          (new nil)
 55 | 	 (all-numbers (loop for ec in *expose-child-list*
 56 | 			 collect (expose-child-number ec))))
 57 |     (with-all-children-reversed (*root-frame* child)
 58 |       (unless (child-equal-p child *root-frame*)
 59 |         (push child all)
 60 |         (unless (member child *expose-child-list* :test #'child-equal-p :key #'expose-child-child)
 61 | 	  (let ((number (find-free-number all-numbers)))
 62 | 	    (push (make-expose-child :child child :number number :key (number->letter number)) new)
 63 | 	    (push number all-numbers)))))
 64 |     (append (remove-if-not (lambda (x) (member x all :test #'child-equal-p)) *expose-child-list*
 65 |                            :key #'expose-child-child)
 66 |             (nreverse new))))
 67 | 
 68 | 
 69 | 
 70 | 
 71 | 
 72 | (defun expose-draw-letter ()
 73 |   (dolist (ex-child *expose-child-list*)
 74 |     (let ((window (expose-child-window ex-child))
 75 |           (gc (expose-child-gc ex-child)))
 76 |       (when (and window gc)
 77 |         (clear-pixmap-buffer window gc)
 78 |         (xlib:with-gcontext (gc :foreground (get-color (if (substring-equal *query-string* (expose-child-key ex-child))
 79 |                                                            *expose-foreground-letter*
 80 |                                                            *expose-foreground-letter-nok*))
 81 |                                 :background (get-color (if (string-equal *query-string* (expose-child-key ex-child))
 82 |                                                            *expose-background-letter-match*
 83 |                                                            *expose-background*)))
 84 |           (xlib:draw-image-glyphs *pixmap-buffer* gc
 85 |                                   (xlib:max-char-width *expose-font*)
 86 |                                   (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*))
 87 |                                   (expose-child-key ex-child)))
 88 |         (xlib:draw-glyphs *pixmap-buffer* gc
 89 |                           (xlib:max-char-width *expose-font*)
 90 |                           (+ (* 2 (xlib:font-ascent *expose-font*)) (xlib:font-descent *expose-font*) 1)
 91 |                           (expose-child-string ex-child))
 92 |         (copy-pixmap-buffer window gc)))))
 93 | 
 94 | 
 95 | (defun expose-create-window (ex-child)
 96 |   (let ((child (expose-child-child ex-child)))
 97 |     (with-current-child (child)
 98 |       (let* ((string (format nil "~A"
 99 |                              (if *expose-show-window-title*
100 |                                  (ensure-printable (child-fullname child))
101 |                                  "")))
102 |              (width (if *expose-show-window-title*
103 |                         (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2))
104 |                              (- (child-width child) 4))
105 |                         (* (xlib:max-char-width *expose-font*) 3)))
106 |              (height (* (xlib:font-ascent *expose-font*) 3)))
107 |         (with-placement (*expose-mode-placement* x y width height)
108 |           (let* ((window (xlib:create-window :parent *root*
109 |                                              :x x   :y y
110 |                                              :width width   :height height
111 |                                              :background (get-color *expose-background*)
112 |                                              :border-width *border-size*
113 |                                              :border (get-color *expose-border*)
114 |                                              :colormap (xlib:screen-default-colormap *screen*)
115 |                                              :event-mask '(:exposure :key-press)))
116 |                  (gc (xlib:create-gcontext :drawable window
117 |                                            :foreground (get-color *expose-foreground*)
118 |                                            :background (get-color *expose-background*)
119 |                                            :font *expose-font*
120 |                                            :line-style :solid)))
121 |             (setf (window-transparency window) *expose-transparency*)
122 |             (map-window window)
123 |             (setf (expose-child-window ex-child) window
124 |                   (expose-child-gc ex-child) gc
125 |                   (expose-child-string ex-child) string)))))))
126 | 
127 | 
128 | 
129 | 
130 | (defun expose-query-key-press-hook (code state)
131 |   (declare (ignore code state))
132 |   (expose-draw-letter)
133 |   (let ((two-letters-key (dolist (child *expose-child-list*)
134 | 			   (when (> (length (expose-child-key child)) 1)
135 | 			     (return t)))))
136 |     (when (and *expose-direct-select* (not two-letters-key))
137 |       (leave-query-mode :return))))
138 | 
139 | (defun expose-query-button-press-hook (code state x y)
140 |   (declare (ignore state))
141 |   (when (= code 1)
142 |     (setf *expose-selected-child*
143 |           (find (find-child-under-mouse x y) *expose-child-list* :test #'child-equal-p :key #'expose-child-child)))
144 |   (leave-query-mode :click))
145 | 
146 | 
147 | (defun expose-init ()
148 |   (setf *expose-font* (xlib:open-font *display* *expose-font-string*)
149 | 	*expose-child-list* (expose-associate-keys)
150 | 	*expose-selected-child* nil
151 |         *query-string* "")
152 |   (xlib:warp-pointer *root* (truncate (/ (screen-width) 2))
153 | 		     (truncate (/ (screen-height) 2)))
154 |   (add-hook *query-key-press-hook* 'expose-query-key-press-hook)
155 |   (add-hook *query-button-press-hook* 'expose-query-button-press-hook))
156 | 
157 | (defun expose-present-windows ()
158 |   (dolist (ex-child *expose-child-list*)
159 |     (let ((child (expose-child-child ex-child)))
160 |       (when (frame-p child)
161 |         (setf (frame-data-slot child :old-layout) (frame-layout child)
162 |               (frame-layout child) #'tile-space-layout))))
163 |   (show-all-children t))
164 | 
165 | (defun expose-unpresent-windows ()
166 |   (dolist (ex-child *expose-child-list*)
167 |     (let ((child (expose-child-child ex-child)))
168 |       (when (frame-p child)
169 |         (setf (frame-layout child) (frame-data-slot child :old-layout)
170 |               (frame-data-slot child :old-layout) nil)))))
171 | 
172 | (defun expose-mode-display-accel-windows ()
173 |   (let ((all-hidden-windows (get-hidden-windows)))
174 | 	(with-all-root-child (root)
175 | 	  (with-all-children-reversed (root child)
176 | 		(let ((ex-child (find child *expose-child-list* :test #'child-equal-p :key #'expose-child-child)))
177 | 		  (when ex-child
178 | 			(if (or (frame-p (expose-child-child ex-child))
179 | 					(managed-window-p (expose-child-child ex-child)
180 | 									  (find-parent-frame (expose-child-child ex-child) *root-frame*)))
181 | 				(unless (child-member (expose-child-child ex-child) all-hidden-windows)
182 | 				  (expose-create-window ex-child))
183 | 				(hide-child (expose-child-child ex-child)))))))
184 | 	(expose-draw-letter)))
185 | 
186 | 
187 | (defun expose-find-child-from-letters (letters)
188 |   (find letters *expose-child-list* :test #'string-equal :key #'expose-child-key))
189 | 
190 | (defun expose-select-child ()
191 |   (let ((*query-mode-placement* *expose-query-placement*))
192 |     (multiple-value-bind (letters return)
193 |         (query-string "Which child ?")
194 |       (let ((ex-child (case return
195 |                         (:return (expose-find-child-from-letters letters))
196 |                         (:click *expose-selected-child*))))
197 |         (when ex-child
198 |           (expose-child-child ex-child))))))
199 | 
200 | 
201 | (defun expose-restore-windows (&optional (present-window t))
202 |   (remove-hook *query-key-press-hook* 'expose-query-key-press-hook)
203 |   (remove-hook *query-button-press-hook* 'expose-query-button-press-hook)
204 |   (dolist (ex-child *expose-child-list*)
205 |     (awhen (expose-child-gc ex-child)
206 |       (xlib:free-gcontext it))
207 |     (awhen (expose-child-window ex-child)
208 |       (xlib:destroy-window it))
209 |     (setf (expose-child-gc ex-child) nil
210 |           (expose-child-window ex-child) nil))
211 |   (when *expose-font*
212 |     (xlib:close-font *expose-font*))
213 |   (when present-window
214 | 	(expose-unpresent-windows)))
215 | 
216 | (defun expose-focus-child (child)
217 |   (let ((parent (typecase child
218 |                   (xlib:window (find-parent-frame child))
219 |                   (frame child))))
220 |     (when (and child parent)
221 | 	  (change-root (find-root parent) parent)
222 |       (setf (current-child) child)
223 |       (focus-all-children child parent t))))
224 | 
225 | (defun expose-do-main (&optional (present-window t))
226 |   (stop-button-event)
227 |   (expose-init)
228 |   (when present-window
229 | 	(expose-present-windows))
230 |   (expose-mode-display-accel-windows)
231 |   (let ((child (expose-select-child)))
232 | 	(expose-restore-windows present-window)
233 | 	child))
234 | 
235 | 
236 | (defun expose-windows-mode ()
237 |   "Present all windows in currents roots (An expose like)"
238 |   (awhen (expose-do-main)
239 |     (expose-focus-child it))
240 |   (show-all-children)
241 |   t)
242 | 
243 | 
244 | (defun expose-all-windows-mode ()
245 |   "Present all windows in all frames (An expose like)"
246 |   (let ((child nil))
247 |     (with-saved-root-list ()
248 |       (dolist (root (get-root-list))
249 |         (change-root root (root-original root)))
250 |       (setf child (expose-do-main)))
251 |     (when child
252 |       (expose-focus-child child)))
253 |   (show-all-children)
254 |   t)
255 | 
256 | (defun expose-current-child-mode ()
257 |   "Present all windows in currents roots (An expose like)"
258 |   (with-saved-root-list ()
259 | 	(awhen (expose-do-main nil)
260 | 	  (expose-focus-child it)))
261 |   (show-all-children)
262 |   t)
263 | 


--------------------------------------------------------------------------------
/src/clfswm-generic-mode.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: Main functions
 6 | ;;; --------------------------------------------------------------------------
 7 | ;;;
 8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
 9 | ;;;
10 | ;;; This program is free software; you can redistribute it and/or modify
11 | ;;; it under the terms of the GNU General Public License as published by
12 | ;;; the Free Software Foundation; either version 3 of the License, or
13 | ;;; (at your option) any later version.
14 | ;;;
15 | ;;; This program is distributed in the hope that it will be useful,
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 | ;;; GNU General Public License for more details.
19 | ;;;
20 | ;;; You should have received a copy of the GNU General Public License
21 | ;;; along with this program; if not, write to the Free Software
22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 | ;;;
24 | ;;; --------------------------------------------------------------------------
25 | 
26 | (in-package :clfswm)
27 | 
28 | (defun generic-mode (mode exit-tag &key enter-function loop-function leave-function
29 |                      (loop-hook *loop-hook*) original-mode)
30 |   "Enter in a generic mode"
31 |   (let ((last-mode *current-event-mode*))
32 |     (unwind-protect
33 |          (progn
34 |            (unassoc-keyword-handle-event)
35 |            (when original-mode
36 |              (dolist (add-mode (ensure-list original-mode))
37 |                (assoc-keyword-handle-event add-mode)))
38 |            (assoc-keyword-handle-event mode)
39 |            (with-xlib-protect ()
40 |              (nfuncall enter-function)
41 |              (catch exit-tag
42 |                (loop
43 |                   (with-xlib-protect (:generic-mode exit-tag)
44 |                     (call-hook loop-hook)
45 |                     (process-timers)
46 |                     (nfuncall loop-function)
47 |                     (when (xlib:event-listen *display* *loop-timeout*)
48 |                       (xlib:process-event *display* :handler #'handle-event))
49 |                     (xlib:display-finish-output *display*))))))
50 |       (with-xlib-protect ()
51 |         (nfuncall leave-function))
52 |       (unassoc-keyword-handle-event)
53 |       (assoc-keyword-handle-event last-mode))))
54 | 


--------------------------------------------------------------------------------
/src/clfswm-keys.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Keys functions definition
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | 
 29 | (defparameter *fun-press* #'first)
 30 | (defparameter *fun-release* #'second)
 31 | 
 32 | 
 33 | 
 34 | (defun with-capslock ()
 35 |   (pushnew :lock *default-modifiers*))
 36 | 
 37 | (defun without-capslock ()
 38 |   (setf *default-modifiers* (remove :lock *default-modifiers*)))
 39 | 
 40 | (defun with-numlock ()
 41 |   (pushnew :mod-2 *default-modifiers*))
 42 | 
 43 | (defun without-numlock ()
 44 |   (setf *default-modifiers* (remove :mod-2 *default-modifiers*)))
 45 | 
 46 | 
 47 | 
 48 | ;;; CONFIG - Key mode names
 49 | (defmacro define-init-hash-table-key (hash-table name)
 50 |   (let ((init-name (create-symbol "init-" (format nil "~A" hash-table))))
 51 |     `(progn
 52 |       (defun ,init-name ()
 53 | 	(setf ,hash-table (make-hash-table :test 'equal))
 54 | 	(setf (gethash 'name ,hash-table) ,name))
 55 |       (,init-name))))
 56 | 
 57 | (define-init-hash-table-key *main-keys* "Main mode keys")
 58 | (define-init-hash-table-key *main-mouse* "Mouse buttons actions in main mode")
 59 | (define-init-hash-table-key *second-keys* "Second mode keys")
 60 | (define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode")
 61 | (define-init-hash-table-key *info-keys* "Info mode keys")
 62 | (define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode")
 63 | (define-init-hash-table-key *query-keys* "Query mode keys")
 64 | 
 65 | (define-init-hash-table-key *circulate-keys* "Circulate mode keys")
 66 | (define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys")
 67 | 
 68 | (define-init-hash-table-key *expose-keys* "Expose windows mode keys")
 69 | (define-init-hash-table-key *expose-mouse* "Mouse buttons actions in expose windows mode")
 70 | 
 71 | (defun unalias-modifiers (list)
 72 |   (dolist (mod *modifier-alias*)
 73 |     (setf list (substitute (second mod) (first mod) list)))
 74 |   list)
 75 | 
 76 | (defun key->list (key)
 77 |   (list (first key) (modifiers->state (append (unalias-modifiers (rest key))
 78 | 					      (unalias-modifiers *default-modifiers*)))))
 79 | 
 80 | (defmacro define-define-key (name hashtable)
 81 |   (let ((name-key-fun (create-symbol "define-" name "-key-fun"))
 82 | 	(name-key (create-symbol "define-" name "-key"))
 83 | 	(undefine-name-fun (create-symbol "undefine-" name "-key-fun"))
 84 | 	(undefine-name (create-symbol "undefine-" name "-key"))
 85 | 	(undefine-multi-name (create-symbol "undefine-" name "-multi-keys")))
 86 |     `(progn
 87 |       (defun ,name-key-fun (key function &rest args)
 88 | 	"Define a new key, a key is '(char modifier1 modifier2...))"
 89 | 	(setf (gethash (key->list key) ,hashtable) (list function args)))
 90 |       (defmacro ,name-key ((key &rest modifiers) function &rest args)
 91 | 	`(,',name-key-fun (list ,key ,@modifiers) ,function ,@args))
 92 |       (defun ,undefine-name-fun (key)
 93 | 	"Undefine a new key, a key is '(char modifier1 modifier2...))"
 94 | 	(remhash (key->list key) ,hashtable))
 95 |       (defmacro ,undefine-name ((key &rest modifiers))
 96 | 	`(,',undefine-name-fun (list ,key ,@modifiers)))
 97 |       (defmacro ,undefine-multi-name (&rest keys)
 98 | 	`(progn
 99 | 	  ,@(loop for k in keys
100 | 		  collect `(,',undefine-name ,k)))))))
101 | 
102 | 
103 | (defmacro define-define-mouse (name hashtable)
104 |   (let ((name-mouse-fun (create-symbol "define-" name "-fun"))
105 | 	(name-mouse (create-symbol "define-" name))
106 | 	(undefine-name (create-symbol "undefine-" name)))
107 |     `(progn
108 |        (defun ,name-mouse-fun (button function-press &optional function-release &rest args)
109 | 	 "Define a new mouse button action, a button is '(button number '(modifier list))"
110 | 	 (setf (gethash (key->list button) ,hashtable) (list function-press function-release args)))
111 |        (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release &rest args)
112 | 	 `(,',name-mouse-fun (list ,button ,@modifiers) ,function-press ,function-release ,@args))
113 |        (defmacro ,undefine-name ((key &rest modifiers))
114 | 	 `(remhash (list ,key ,@modifiers) ,',hashtable)))))
115 | 
116 | 
117 | 
118 | (define-define-key "main" *main-keys*)
119 | (define-define-key "second" *second-keys*)
120 | (define-define-key "info" *info-keys*)
121 | (define-define-key "query" *query-keys*)
122 | 
123 | (define-define-key "circulate" *circulate-keys*)
124 | (define-define-key "circulate-release" *circulate-keys-release*)
125 | 
126 | (define-define-key "expose" *expose-keys*)
127 | 
128 | (define-define-mouse "main-mouse" *main-mouse*)
129 | (define-define-mouse "second-mouse" *second-mouse*)
130 | (define-define-mouse "info-mouse" *info-mouse*)
131 | (define-define-mouse "expose-mouse" *expose-mouse*)
132 | 
133 | 
134 | 
135 | 
136 | 
137 | 
138 | (defun add-in-state (state modifier)
139 |   "Add a modifier in a state"
140 |   (modifiers->state (append (state->modifiers state) (list modifier))))
141 | 
142 | (defmacro define-ungrab/grab (name function hashtable)
143 |   `(defun ,name ()
144 |      (maphash #'(lambda (k v)
145 | 		  (declare (ignore v))
146 | 		  (when (consp k)
147 | 		    (handler-case
148 | 			(let* ((key (first k))
149 | 			       (modifiers (second k))
150 | 			       (keycode (typecase key
151 | 					  (character (multiple-value-list (char->keycode key)))
152 | 					  (number key)
153 | 					  (string (let* ((keysym (keysym-name->keysym key))
154 | 							 (ret-keycode (multiple-value-list
155 |                                                                        (xlib:keysym->keycodes *display* keysym))))
156 | 						    (let ((found nil))
157 | 						      (dolist (kc ret-keycode)
158 | 							(when (= keysym (xlib:keycode->keysym *display* kc 0))
159 | 							  (setf found t)))
160 |                                                       (unless found
161 |                                                         (setf modifiers (add-in-state modifiers :shift))))
162 | 						    ret-keycode)))))
163 | 			  (if keycode
164 | 			      (if (consp keycode)
165 | 				  (dolist (kc (remove-duplicates keycode))
166 | 				    (,function *root* kc :modifiers modifiers))
167 | 				  (,function *root* keycode :modifiers modifiers))
168 | 			      (format t "~&Grabbing error: Can't find key '~A'~%" key)))
169 | 		      (error (c)
170 | 			;;(declare (ignore c))
171 | 			(format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c)))
172 | 		    (force-output)))
173 | 	      ,hashtable)))
174 | 
175 | (define-ungrab/grab grab-main-keys xlib:grab-key *main-keys*)
176 | (define-ungrab/grab ungrab-main-keys xlib:ungrab-key *main-keys*)
177 | 
178 | 
179 | 
180 | 
181 | 
182 | 
183 | 
184 | 
185 | 
186 | 
187 | (defun find-key-from-code (hash-table-key code state)
188 |   "Return the function associated to code/state"
189 |   (labels ((function-from (key &optional (new-state state))
190 | 	     (multiple-value-bind (function foundp)
191 | 		 (gethash (list key new-state) hash-table-key)
192 | 	       (when (and foundp (first function))
193 | 		 function)))
194 | 	   (from-code ()
195 | 	     (function-from code))
196 | 	   (from-char ()
197 | 	     (let ((char (keycode->char code state)))
198 | 	       (function-from char)))
199 | 	   (from-string ()
200 | 	     (let ((string (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
201 | 	       (function-from string)))
202 | 	   (from-string-shift ()
203 | 	     (let* ((modifiers (state->modifiers state))
204 | 		    (string (keysym->keysym-name (keycode->keysym code modifiers))))
205 | 	       (function-from string)))
206 | 	   (from-string-no-shift ()
207 | 	     (let* ((modifiers (state->modifiers state))
208 | 		    (string (keysym->keysym-name (keycode->keysym code modifiers))))
209 | 	       (function-from string (modifiers->state (remove :shift modifiers))))))
210 |     (or (from-code) (from-char) (from-string) (from-string-shift) (from-string-no-shift))))
211 | 
212 | 
213 | 
214 | (defun funcall-key-from-code (hash-table-key code state &rest args)
215 |   (let ((function (find-key-from-code hash-table-key code state)))
216 |     (when function
217 |       (apply (first function) (append args (second function)))
218 |       t)))
219 | 
220 | 
221 | (defun funcall-button-from-code (hash-table-key code state window root-x root-y
222 | 				 &optional (action *fun-press*) args)
223 |   (let ((state (modifiers->state (set-difference (state->modifiers state)
224 | 						 '(:button-1 :button-2 :button-3 :button-4 :button-5)))))
225 |     (multiple-value-bind (function foundp)
226 | 	(gethash (list code state) hash-table-key)
227 |       (if (and foundp (funcall action function))
228 | 	  (progn
229 | 	    (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function))))
230 | 	    t)
231 | 	  nil))))
232 | 
233 | 
234 | 
235 | 
236 | (defun binding-substitute-modifier (to from &optional (hashtables (list *main-keys* *main-mouse*
237 | 									*second-keys* *second-mouse*
238 | 									*info-keys* *info-mouse*
239 | 									*query-keys*
240 | 									*circulate-keys* *circulate-keys-release*
241 | 									*expose-keys* *expose-mouse*)))
242 |   "Utility to change modifiers after binding definition"
243 |   (labels ((change (&optional (hashtable *main-keys*) to from)
244 | 	     (maphash (lambda (k v)
245 | 			(when (consp k)
246 | 			  (let ((state (modifiers->state (substitute to from (state->modifiers (second k))))))
247 | 			    (remhash k hashtable)
248 | 			    (setf (gethash (list (first k) state) hashtable) v))))
249 | 		      hashtable)))
250 |     (dolist (h hashtables)
251 |       (change h to from))))
252 | 
253 | 
254 | (defmacro define-keys ((mode) &body keys)
255 |   (let ((symbol (create-symbol "DEFINE-" mode "-KEY")))
256 |     `(progn
257 |        ,@(loop for k in keys collect `(,symbol ,@k)))))
258 | 
259 | 
260 | (defun find-associated-key-bindings (function)
261 |   "Return keys in main and second mode bounds to function"
262 |   (labels ((key-string (hash)
263 |              (let ((binding (or (find-in-hash function hash)
264 |                                 (search-in-hash function hash))))
265 |                (when binding
266 |                  (let ((key (first binding))
267 |                        (modifier (and (second binding) (state->modifiers (second binding)))))
268 |                    (with-output-to-string (str)
269 |                      (when key
270 |                        (dolist (mod modifier)
271 |                          (format str "~A-" (cond
272 |                                              ((string-equal mod "MOD-1") "M")
273 |                                              ((string-equal mod "CONTROL") "C")
274 |                                              ((string-equal mod "SHIFT") "S")
275 |                                              (t mod))))
276 |                        (format str "~A" key))))))))
277 |     (let ((main-string (key-string *main-keys*))
278 |           (second-string (key-string *second-keys*)))
279 |       (if (or main-string second-string)
280 |           (if (string-equal main-string second-string)
281 |               (format nil "[~A]" main-string)
282 |               (format nil "[~A|~A]" (or main-string "-") (or second-string "-")))
283 |           ""))))
284 | 


--------------------------------------------------------------------------------
/src/clfswm-menu.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Menu functions
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | 
 29 | (defmacro with-all-menu ((menu item) &body body)
 30 |   (let ((rec (gensym))
 31 | 	(subm (gensym)))
 32 |     `(labels ((,rec (,item)
 33 | 		,@body
 34 | 		(when (menu-p ,item)
 35 | 		  (dolist (,subm (menu-item ,item))
 36 | 		    (,rec ,subm)))
 37 | 		(when (and (menu-item-p ,item) (menu-p (menu-item-value ,item)))
 38 | 		  (,rec (menu-item-value ,item)))))
 39 |        (,rec ,menu))))
 40 | 
 41 | (defun add-item (item &optional (menu *menu*))
 42 |   (setf (menu-item menu) (nconc (menu-item menu) (list item))))
 43 | 
 44 | (defun del-item (item &optional (menu *menu*))
 45 |   (setf (menu-item menu) (remove item (menu-item menu))))
 46 | 
 47 | 
 48 | 
 49 | ;;; Finding functions
 50 | (defun find-menu (name  &optional (root *menu*))
 51 |   (with-all-menu (root item)
 52 |     (when (and (menu-p item)
 53 | 	       (equal name (menu-name item)))
 54 |       (return-from find-menu item))))
 55 | 
 56 | (defun find-toplevel-menu (name &optional (root *menu*))
 57 |   (when (menu-p root)
 58 |     (dolist (item (menu-item root))
 59 |       (when (and (menu-item-p item)
 60 | 		 (menu-p (menu-item-value item)))
 61 | 	(when (equal name (menu-name (menu-item-value item)))
 62 | 	  (return (menu-item-value item)))))))
 63 | 
 64 | 
 65 | (defun find-item-by-key (key &optional (root *menu*))
 66 |   (with-all-menu (root item)
 67 |     (when (and (menu-item-p item)
 68 | 	       (equal (menu-item-key item) key))
 69 |       (return-from find-item-by-key item))))
 70 | 
 71 | (defun find-item-by-value (value &optional (root *menu*))
 72 |   (with-all-menu (root item)
 73 |     (when (and (menu-item-p item)
 74 | 	       (equal (menu-item-value item) value))
 75 |       (return-from find-item-by-value item))))
 76 | 
 77 | 
 78 | (defun del-item-by-key (key &optional (menu *menu*))
 79 |   (del-item (find-item-by-key key menu) menu))
 80 | 
 81 | (defun del-item-by-value (value &optional (menu *menu*))
 82 |   (del-item (find-item-by-value value menu) menu))
 83 | 
 84 | 
 85 | 
 86 | ;;; Convenient functions
 87 | (defun find-next-menu-key (key menu)
 88 |   "key is :next for the next free key in menu or a string"
 89 |   (if (eql key :next)
 90 |       (string (number->char (length (menu-item menu))))
 91 |       key))
 92 | 
 93 | 
 94 | (defun add-menu-key (menu-name key value &optional (root *menu*))
 95 |   (let ((menu (find-menu menu-name root)))
 96 |     (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root))))
 97 | 
 98 | (defun add-sub-menu (menu-or-name key sub-menu-name &optional (doc "Sub menu") (root *menu*))
 99 |   (let ((menu (if (or (stringp menu-or-name) (symbolp menu-or-name))
100 | 		  (find-menu menu-or-name root)
101 | 		  menu-or-name))
102 | 	(submenu (make-menu :name sub-menu-name :doc doc)))
103 |     (add-item (make-menu-item :key (find-next-menu-key key menu) :value submenu) menu)
104 |     submenu))
105 | 
106 | 
107 | 
108 | (defun del-menu-key (menu-name key &optional (root *menu*))
109 |   (del-item-by-key key (find-menu menu-name root)))
110 | 
111 | (defun del-menu-value (menu-name value &optional (root *menu*))
112 |   (del-item-by-value value (find-menu menu-name root)))
113 | 
114 | (defun del-sub-menu (menu-name sub-menu-name &optional (root *menu*))
115 |   (del-item-by-value (find-menu sub-menu-name) (find-menu menu-name root)))
116 | 
117 | (defun clear-sub-menu (menu-name sub-menu-name &optional (root *menu*))
118 |   (setf (menu-item (find-menu sub-menu-name (find-menu menu-name root))) nil))
119 | 
120 | 
121 | (defun add-menu-comment (menu-name &optional (comment "---") (root *menu*))
122 |   (add-item (make-menu-item :key nil :value comment) (find-menu menu-name root)))
123 | 
124 | 
125 | 
126 | (defun init-menu ()
127 |   (setf *menu* (make-menu :name 'main :doc "Main menu")))
128 | 
129 | 
130 | ;;; Display menu functions
131 | (defun open-menu-do-action (action menu parent)
132 |   (typecase action
133 |     (menu (open-menu action (cons menu parent)))
134 |     (null (awhen (first parent)
135 | 	    (open-menu it (rest parent))))
136 |     (t (when (fboundp action)
137 | 	 (funcall action)))))
138 | 
139 | 
140 | (let ((menu-oppened nil))
141 |   (defun reset-open-menu ()
142 |     (setf menu-oppened nil))
143 | 
144 |   (defun open-menu (&optional (menu *menu*) (parent nil))
145 |     "Open the main menu"
146 |     (unless menu-oppened
147 |       (setf menu-oppened t)
148 |       (when menu
149 |         (let ((action nil)
150 |               (old-info-keys (copy-hash-table *info-keys*)))
151 |           (labels ((menu-entry (item value)
152 |                      (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
153 |                            (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)
154 |                            (list (format nil " ~A" (find-associated-key-bindings
155 |                                                     (create-symbol 'open- (menu-name value))))
156 |                                  *menu-key-bound-color*)))
157 |                    (menu-comment (item)
158 |                      (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
159 |                    (menu-line (item value)
160 |                      (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
161 |                            (format nil ": ~A" (documentation value 'function))
162 |                            (list (format nil " ~A" (find-associated-key-bindings value))
163 |                                  *menu-key-bound-color*)))
164 |                    (populate-menu ()
165 |                      (let ((info-list nil))
166 |                        (dolist (item (menu-item menu))
167 |                          (let ((value (menu-item-value item)))
168 |                            (push (typecase value
169 |                                    (menu (menu-entry item value))
170 |                                    (string (menu-comment item))
171 |                                    (t (menu-line item value)))
172 |                                  info-list)
173 |                            (when (menu-item-key item)
174 |                              (define-info-key-fun (list (menu-item-key item))
175 |                                  (lambda (&optional args)
176 |                                    (declare (ignore args))
177 |                                    (setf action value)
178 |                                    (leave-info-mode nil))))))
179 |                        (nreverse info-list))))
180 |             (let ((selected-item (info-mode (populate-menu))))
181 |               (setf *info-keys* old-info-keys)
182 |               (when (and selected-item (>= selected-item 0))
183 |                 (awhen (nth selected-item (menu-item menu))
184 |                   (setf action (menu-item-value it)))))
185 |             (setf menu-oppened nil)
186 |             (open-menu-do-action action menu parent)))))))
187 | 


--------------------------------------------------------------------------------
/src/clfswm-nw-hooks.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: New window Hooks
  6 | ;;;
  7 | ;;;  Those hooks can be set for each frame to manage new window when they are
  8 | ;;;  mapped.
  9 | ;;; --------------------------------------------------------------------------
 10 | ;;;
 11 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
 12 | ;;;
 13 | ;;; This program is free software; you can redistribute it and/or modify
 14 | ;;; it under the terms of the GNU General Public License as published by
 15 | ;;; the Free Software Foundation; either version 3 of the License, or
 16 | ;;; (at your option) any later version.
 17 | ;;;
 18 | ;;; This program is distributed in the hope that it will be useful,
 19 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 20 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 21 | ;;; GNU General Public License for more details.
 22 | ;;;
 23 | ;;; You should have received a copy of the GNU General Public License
 24 | ;;; along with this program; if not, write to the Free Software
 25 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 26 | ;;;
 27 | ;;; --------------------------------------------------------------------------
 28 | 
 29 | (in-package :clfswm)
 30 | 
 31 | 
 32 | ;;; CONFIG - New window menu
 33 | ;;;
 34 | ;;; To add a new window hook (nw-hook):
 35 | ;;;   1- define your own nw-hook
 36 | ;;;   2- Define a seter function for your new hook
 37 | ;;;   3- Register your new hook with register-nw-hook.
 38 | 
 39 | 
 40 | (defparameter *nw-hook-current-key* (char-code #\a))
 41 | (defparameter *permanent-nw-hook-frames* nil)
 42 | 
 43 | 
 44 | (defun set-nw-hook (hook)
 45 |   "Set the hook of the current child"
 46 |   (let ((frame (if (xlib:window-p (current-child))
 47 | 		   (find-parent-frame (current-child))
 48 | 		   (current-child))))
 49 |     (unless (or (child-member frame *permanent-nw-hook-frames*)
 50 |                 (child-original-root-p frame))
 51 |       (setf (frame-nw-hook frame) hook)
 52 |       (leave-second-mode))))
 53 | 
 54 | (defun register-nw-hook (hook)
 55 |   (add-menu-key 'frame-nw-hook-menu (code-char *nw-hook-current-key*) hook)
 56 |   (incf *nw-hook-current-key*))
 57 | 
 58 | 
 59 | (defun default-window-placement (frame window)
 60 |   (if (managed-window-p window frame)
 61 |       (adapt-child-to-parent window frame)
 62 |       (place-window-from-hints window)))
 63 | 
 64 | (defun leave-if-not-frame (child)
 65 |   "Leave the child if it's not a frame"
 66 |   (unless (frame-p child)
 67 |     (leave-frame)
 68 |     (select-previous-level)))
 69 | 
 70 | (defun clear-nw-hook (frame)
 71 |   "Clear the frame new window hook"
 72 |   (unless (child-member frame *permanent-nw-hook-frames*)
 73 |     (setf (frame-nw-hook frame) nil)))
 74 | 
 75 | 
 76 | (defun clear-all-nw-hooks ()
 77 |   "Clear all new window hooks for all frames"
 78 |   (with-all-frames (*root-frame* frame)
 79 |     (clear-nw-hook frame)))
 80 | 
 81 | 
 82 | (defun make-permanent-nw-hook-frame (frame)
 83 |   "Prevent to add or delete a new window hook for this frame"
 84 |   (when (frame-p frame)
 85 |     (push frame *permanent-nw-hook-frames*)))
 86 | 
 87 | 
 88 | ;;; Default frame new window hook
 89 | (defun default-frame-nw-hook (frame window)
 90 |   "Open the next window in the current frame"
 91 |   (declare (ignore frame))
 92 |   (leave-if-not-frame (current-child))
 93 |   (when (frame-p (current-child))
 94 |     (pushnew window (frame-child (current-child))))
 95 |   (default-window-placement (current-child) window)
 96 |   t)
 97 | 
 98 | (defun set-default-frame-nw-hook ()
 99 |   "Open the next window in the current frame"
100 |   (set-nw-hook #'default-frame-nw-hook))
101 | 
102 | (register-nw-hook 'set-default-frame-nw-hook)
103 | 
104 | 
105 | ;;; Open new window in current root hook
106 | (defun open-in-current-root-nw-hook (frame window)
107 |   "Open the next window in the current root"
108 |   (clear-nw-hook frame)
109 |   (leave-if-not-frame (find-current-root))
110 |   (let ((root (find-current-root)))
111 |     (pushnew window (frame-child root))
112 |     (setf (current-child) (frame-selected-child root))
113 |     (default-window-placement root window))
114 |   t)
115 | 
116 | (defun set-open-in-current-root-nw-hook ()
117 |   "Open the next window in the current root"
118 |   (set-nw-hook #'open-in-current-root-nw-hook))
119 | 
120 | (register-nw-hook 'set-open-in-current-root-nw-hook)
121 | 
122 | 
123 | ;;; Open new window in a new frame in the current root hook
124 | (defun open-in-new-frame-in-current-root-nw-hook (frame window)
125 |   "Open the next window in a new frame in the current root"
126 |   (clear-nw-hook frame)
127 |   (leave-if-not-frame (find-current-root))
128 |   (let ((new-frame (create-frame))
129 |         (root (find-current-root)))
130 |     (pushnew new-frame (frame-child root))
131 |     (pushnew window (frame-child new-frame))
132 |     (setf (current-child) new-frame)
133 |     (default-window-placement new-frame window))
134 |   t)
135 | 
136 | (defun set-open-in-new-frame-in-current-root-nw-hook ()
137 |   "Open the next window in a new frame in the current root"
138 |   (set-nw-hook #'open-in-new-frame-in-current-root-nw-hook))
139 | 
140 | (register-nw-hook 'set-open-in-new-frame-in-current-root-nw-hook)
141 | 
142 | 
143 | ;;; Open new window in a new frame in the root frame hook
144 | (defun open-in-new-frame-in-root-frame-nw-hook (frame window)
145 |   "Open the next window in a new frame in the root frame"
146 |   (clear-nw-hook frame)
147 |   (let ((new-frame (create-frame))
148 |         (root (find-current-root)))
149 |     (pushnew new-frame (frame-child root))
150 |     (pushnew window (frame-child new-frame))
151 |     (switch-to-root-frame :show-later t)
152 |     (setf (current-child) root)
153 |     (set-layout-once #'tile-space-layout)
154 |     (setf (current-child) new-frame)
155 |     (default-window-placement new-frame window))
156 |   t)
157 | 
158 | (defun set-open-in-new-frame-in-root-frame-nw-hook ()
159 |   "Open the next window in a new frame in the root frame"
160 |   (set-nw-hook #'open-in-new-frame-in-root-frame-nw-hook))
161 | 
162 | (register-nw-hook 'set-open-in-new-frame-in-root-frame-nw-hook)
163 | 
164 | 
165 | ;;; Open new window in a new frame in the parent frame hook
166 | (defun open-in-new-frame-in-parent-frame-nw-hook (frame window)
167 |   "Open the next window in a new frame in the parent frame"
168 |   (clear-nw-hook frame)
169 |   (let ((new-frame (create-frame))
170 | 	(parent (find-parent-frame frame)))
171 |     (when parent
172 |       (pushnew new-frame (frame-child parent))
173 |       (pushnew window (frame-child new-frame))
174 |       (change-root (find-root parent) parent)
175 |       (setf (current-child) parent)
176 |       (set-layout-once #'tile-space-layout)
177 |       (setf (current-child) new-frame)
178 |       (default-window-placement new-frame window)
179 |       (show-all-children t)
180 |       t)))
181 | 
182 | 
183 | (defun set-open-in-new-frame-in-parent-frame-nw-hook ()
184 |   "Open the next window in a new frame in the parent frame"
185 |   (set-nw-hook #'open-in-new-frame-in-parent-frame-nw-hook))
186 | 
187 | (register-nw-hook 'set-open-in-new-frame-in-parent-frame-nw-hook)
188 | 
189 | 
190 | 
191 | ;;; Open a new window but leave the focus on the current child
192 | (defun leave-focus-frame-nw-hook (frame window)
193 |   "Open the next window in the current frame and leave the focus on the current child"
194 |   (clear-nw-hook frame)
195 |   (leave-if-not-frame (current-child))
196 |   (when (frame-p (current-child))
197 |     (with-slots (child) (current-child)
198 |       (pushnew window child)
199 |       (setf child (rotate-list child))))
200 |   (default-window-placement (current-child) window)
201 |   t)
202 | 
203 | (defun set-leave-focus-frame-nw-hook ()
204 |   "Open the next window in the current frame and leave the focus on the current child"
205 |   (set-nw-hook #'leave-focus-frame-nw-hook))
206 | 
207 | (register-nw-hook 'set-leave-focus-frame-nw-hook)
208 | 
209 | 
210 | 
211 | 
212 | 
213 | (defun nw-hook-open-in-frame (window frame)
214 |   (when (frame-p frame)
215 |     (pushnew window (frame-child frame))
216 |     (unless (find-child-in-all-root frame)
217 |       (change-root (find-root frame) frame))
218 |     (setf (current-child) frame)
219 |     (focus-all-children window frame)
220 |     (default-window-placement frame window)
221 |     (show-all-children t)
222 |     t))
223 | 
224 | ;;; Open a new window in a named frame
225 | (defun named-frame-nw-hook (frame window)
226 |   (clear-nw-hook frame)
227 |   (let* ((frame-name (ask-frame-name "Open the next window in frame named:"))
228 | 	 (new-frame (find-frame-by-name frame-name)))
229 |     (nw-hook-open-in-frame window new-frame))
230 |   t)
231 | 
232 | (defun set-named-frame-nw-hook ()
233 |   "Open the next window in a named frame"
234 |   (set-nw-hook #'named-frame-nw-hook))
235 | 
236 | (register-nw-hook 'set-named-frame-nw-hook)
237 | 
238 | 
239 | ;;; Open a new window in a numbered frame
240 | (defun numbered-frame-nw-hook (frame window)
241 |   (clear-nw-hook frame)
242 |   (let ((new-frame (find-frame-by-number (query-number "Open a new frame in the group numbered:"))))
243 |     (nw-hook-open-in-frame window new-frame))
244 |   t)
245 | 
246 | (defun set-numbered-frame-nw-hook ()
247 |   "Open the next window in a numbered frame"
248 |   (set-nw-hook #'numbered-frame-nw-hook))
249 | 
250 | (register-nw-hook 'set-numbered-frame-nw-hook)
251 | 
252 | 
253 | ;;; Absorb window.
254 | ;;; The frame absorb the new window if it match the nw-absorb-test
255 | ;;; frame data slot.
256 | (defun absorb-window-nw-hook (frame window)
257 |   (let ((absorb-nw-test (frame-data-slot frame :nw-absorb-test)))
258 |     (when (and absorb-nw-test
259 | 	       (funcall absorb-nw-test window))
260 |       (pushnew window (frame-child frame))
261 |       (unless *in-process-existing-windows*
262 | 	(unless (find-child-in-all-root frame)
263 |           (change-root (find-root frame) frame))
264 | 	(setf (current-child) frame)
265 | 	(focus-all-children window frame)
266 | 	(default-window-placement frame window)
267 | 	(show-all-children t))
268 |       (throw 'nw-hook-loop t)))
269 |   nil)
270 | 
271 | (defun set-absorb-window-nw-hook ()
272 |   "Open the window in this frame if it match nw-absorb-test"
273 |   (set-nw-hook #'absorb-window-nw-hook))
274 | 
275 | (register-nw-hook 'set-absorb-window-nw-hook)
276 | 
277 | 
278 | (defun nw-absorb-test-class (class-string)
279 |   (lambda (c)
280 |     (and (xlib:window-p c)
281 | 	 (string-equal (xlib:get-wm-class c) class-string))))
282 | 


--------------------------------------------------------------------------------
/src/clfswm-placement.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Placement functions
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | (defun get-placement-values (placement &optional (width 0) (height 0) (border-size *border-size*))
 29 |   (typecase placement
 30 |     (list (values-list placement))
 31 |     (function (funcall placement width height border-size))
 32 |     (symbol
 33 |      (if (fboundp placement)
 34 | 	 (funcall placement width height border-size)
 35 | 	 (values 0 0 width height)))
 36 |     (t (values 0 0 width height))))
 37 | 
 38 | (defmacro with-placement ((placement x y &optional (width 0) (height 0) border-size) &body body)
 39 |   `(multiple-value-bind (,x ,y width height)
 40 |        ,(if border-size
 41 |             `(get-placement-values ,placement ,width ,height ,border-size)
 42 |             `(get-placement-values ,placement ,width ,height))
 43 |      (declare (ignorable width height))
 44 |      ,@body))
 45 | 
 46 | ;;;; Test functions
 47 | ;;
 48 | ;;(defun fun-placement (&optional width height)
 49 | ;;  (declare (ignore width height))
 50 | ;;  (values 30 40))
 51 | ;;
 52 | ;;(defparameter *placement-test* (list 10 20))
 53 | ;;;;(defparameter *placement-test* #'fun-placement)
 54 | ;;;;(defparameter *placement-test* 'fun-placement)
 55 | ;;
 56 | ;;(defun toto ()
 57 | ;;  (with-placement (*placement-test* x y)
 58 | ;;    (format t "X=~A  Y=~A~%" x y)))
 59 | 
 60 | ;;;
 61 | ;;; Absolute placement
 62 | ;;;
 63 | (defun root-screen-coord (border-size)
 64 |   (values (- (screen-width) (* 2 border-size))
 65 |           (- (screen-height) (* 2 border-size))))
 66 | 
 67 | (defmacro with-root-screen-coord ((border-size w h) &body body)
 68 |   `(multiple-value-bind (,w ,h)
 69 |        (root-screen-coord ,border-size)
 70 |      (let ((width (min width ,w))
 71 |            (height (min height ,h)))
 72 |        ,@body)))
 73 | 
 74 | 
 75 | (defun top-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
 76 |   (with-root-screen-coord (border-size w h)
 77 |     (values 0 0 width height)))
 78 | 
 79 | (defun top-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
 80 |   (with-root-screen-coord (border-size w h)
 81 |     (values (truncate (/ (- w width) 2)) 0 width height)))
 82 | 
 83 | (defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
 84 |   (with-root-screen-coord (border-size w h)
 85 |     (values (- w width) 0 width height)))
 86 | 
 87 | 
 88 | 
 89 | (defun middle-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
 90 |   (with-root-screen-coord (border-size w h)
 91 |     (values 0 (truncate (/ (- h height) 2)) width height)))
 92 | 
 93 | (defun middle-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
 94 |   (with-root-screen-coord (border-size w h)
 95 |     (values (truncate (/ (- w width) 2)) (truncate (/ (- h height) 2)) width height)))
 96 | 
 97 | (defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
 98 |   (with-root-screen-coord (border-size w h)
 99 |     (values (- w width) (truncate (/ (- h height) 2)) width height)))
100 | 
101 | 
102 | (defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
103 |   (with-root-screen-coord (border-size w h)
104 |     (values 0 (- h height) width height)))
105 | 
106 | (defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
107 |   (with-root-screen-coord (border-size w h)
108 |     (values (truncate (/ (- w width) 2)) (- h height) width height)))
109 | 
110 | (defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
111 |   (with-root-screen-coord (border-size w h)
112 |     (values (- w width) (- h height) width height)))
113 | 
114 | 
115 | 
116 | ;;;
117 | ;;; Here placement: Evaluates to current position of pointer.
118 | ;;;
119 | (defun here-placement (&optional (width 0) (height 0) (border-size *border-size*))
120 |   (declare (ignore border-size))
121 |   (with-x-pointer
122 |       (values x y width height)))
123 | 
124 | 
125 | ;;;
126 | ;;; Current child placement
127 | ;;;
128 | (defun current-child-coord (border-size)
129 |   (typecase (current-child)
130 |     (xlib:window (values (x-drawable-x (current-child))
131 | 			 (x-drawable-y (current-child))
132 | 			 (- (x-drawable-width (current-child)) (* 2 border-size))
133 | 			 (- (x-drawable-height (current-child)) (* 2 border-size))
134 |                          (x-drawable-border-width (current-child))))
135 |     (frame (values (frame-rx (current-child))
136 | 		   (frame-ry (current-child))
137 | 		   (- (frame-rw (current-child)) (* 2 border-size))
138 | 		   (- (frame-rh (current-child)) (* 2 border-size))
139 |                    (x-drawable-border-width (frame-window (current-child)))))
140 |     (t (values 0 0 10 10 1))))
141 | 
142 | (defmacro with-current-child-coord ((border-size x y w h bds) &body body)
143 |   "Bind x y w h bds to current child coordinates and border size"
144 |   `(multiple-value-bind (,x ,y ,w ,h ,bds)
145 |        (current-child-coord ,border-size)
146 |      (let ((width (min w width))
147 |            (height (min h height)))
148 |        ,@body)))
149 | 
150 | 
151 | (defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
152 |   (with-current-child-coord (border-size x y w h bds)
153 |     (values (+ x bds) (+ y bds) width height)))
154 | 
155 | (defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
156 |   (with-current-child-coord (border-size x y w h bds)
157 |     (values (+ x (truncate (/ (- w width) 2)) bds) (+ y bds) width height)))
158 | 
159 | (defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
160 |   (with-current-child-coord (border-size x y w h bds)
161 |     (values (+ x (- w width) bds) (+ y bds) width height)))
162 | 
163 | 
164 | 
165 | (defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
166 |   (with-current-child-coord (border-size x y w h bds)
167 |     (values (+ x bds) (+ y (truncate (/ (- h height) 2)) bds) width height)))
168 | 
169 | (defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
170 |   (with-current-child-coord (border-size x y w h bds)
171 |     (values (+ x (truncate (/ (- w width) 2)) bds) (+ y (truncate (/ (- h height) 2)) bds)
172 |             width height)))
173 | 
174 | (defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
175 |   (with-current-child-coord (border-size x y w h bds)
176 |     (values (+ x (- w width) bds) (+ y (truncate (/ (- h height) 2)) bds)
177 |             width height)))
178 | 
179 | 
180 | (defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
181 |   (with-current-child-coord (border-size x y w h bds)
182 |     (values (+ x bds) (+ y (- h height) bds) width height)))
183 | 
184 | (defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
185 |   (with-current-child-coord (border-size x y w h bds)
186 |     (values (+ x (truncate (/ (- w width) 2)) bds) (+ y (- h height) bds) width height)))
187 | 
188 | (defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
189 |   (with-current-child-coord (border-size x y w h bds)
190 |     (values (+ x (- w width) bds) (+ y (- h height) bds) width height)))
191 | 
192 | 
193 | ;;;
194 | ;;; Current root placement
195 | ;;;
196 | (defparameter *get-current-root-fun* (lambda ()
197 |                                        (find-root (current-child))))
198 | 
199 | (defun current-root-coord (border-size)
200 |   (let ((root (funcall *get-current-root-fun*)))
201 |     (values (root-x root) (root-y root)
202 |             (- (root-w root) (* 2 border-size))
203 |             (- (root-h root) (* 2 border-size)))))
204 | 
205 | 
206 | (defmacro with-current-root-coord ((border-size x y w h) &body body)
207 |   `(multiple-value-bind (,x ,y ,w ,h)
208 |        (current-root-coord ,border-size)
209 |      (let ((width (min w width))
210 |            (height (min h height)))
211 |        ,@body)))
212 | 
213 | 
214 | (defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
215 |   (with-current-root-coord (border-size x y w h)
216 |     (values x y width height)))
217 | 
218 | (defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
219 |   (with-current-root-coord (border-size x y w h)
220 |     (values (+ x (truncate (/ (- w width) 2))) y width height)))
221 | 
222 | (defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
223 |   (with-current-root-coord (border-size x y w h)
224 |     (values (+ x (- w width)) y width height)))
225 | 
226 | 
227 | 
228 | (defun middle-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
229 |   (with-current-root-coord (border-size x y w h)
230 |     (values x (+ y (truncate (/ (- h height) 2))) width height)))
231 | 
232 | (defun middle-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
233 |   (with-current-root-coord (border-size x y w h)
234 |     (values (+ x (truncate (/ (- w width) 2))) (+ y (truncate (/ (- h height) 2))) width height)))
235 | 
236 | (defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
237 |   (with-current-root-coord (border-size x y w h)
238 |     (values (+ x (- w width)) (+ y (truncate (/ (- h height) 2))) width height)))
239 | 
240 | 
241 | (defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
242 |   (with-current-root-coord (border-size x y w h)
243 |     (values x (+ y (- h height)) width height)))
244 | 
245 | (defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
246 |   (with-current-root-coord (border-size x y w h)
247 |     (values (+ x (truncate  (/ (- w width) 2))) (+ y (- h height)) width height)))
248 | 
249 | (defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
250 |   (with-current-root-coord (border-size x y w h)
251 |     (values (+ x (- w width)) (+ y (- h height)) width height)))
252 | 
253 | 
254 | ;;; Some tests
255 | (defun test-some-placement (placement)
256 |   (setf *second-mode-placement* placement
257 |         *query-mode-placement* placement))
258 | 


--------------------------------------------------------------------------------
/src/clfswm-second-mode.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Second mode functions
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | (in-package :clfswm)
 27 | 
 28 | 
 29 | (defparameter *second-mode-leave-function* nil
 30 |   "Execute the function if not nil")
 31 | 
 32 | 
 33 | (defun draw-second-mode-window ()
 34 |   (raise-window *sm-window*)
 35 |   (clear-pixmap-buffer *sm-window* *sm-gc*)
 36 |   (let* ((text (format nil "SECOND MODE"))
 37 | 	 (len (length text)))
 38 |     (xlib:draw-glyphs *pixmap-buffer* *sm-gc*
 39 | 		      (truncate (/ (- *sm-width* (* (xlib:max-char-width *sm-font*) len)) 2))
 40 | 		      (truncate (/ (+ *sm-height* (- (xlib:font-ascent *sm-font*) (xlib:font-descent *sm-font*))) 2))
 41 | 		      text))
 42 |   (copy-pixmap-buffer *sm-window* *sm-gc*)
 43 |   (no-focus))
 44 | 
 45 | 
 46 | 
 47 | 
 48 | ;;; Second mode handlers
 49 | (define-handler second-mode :key-press (code state)
 50 |   (funcall-key-from-code *second-keys* code state)
 51 |   (draw-second-mode-window))
 52 | 
 53 | (define-handler second-mode :enter-notify ()
 54 |   (draw-second-mode-window))
 55 | 
 56 | (define-handler second-mode :motion-notify (window root-x root-y)
 57 |   (unless (compress-motion-notify)
 58 |     (funcall-button-from-code *second-mouse* 'motion
 59 | 			      (modifiers->state *default-modifiers*)
 60 | 			      window root-x root-y *fun-press*)))
 61 | 
 62 | (define-handler second-mode :button-press (window root-x root-y code state)
 63 |   (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-press*)
 64 |   (draw-second-mode-window))
 65 | 
 66 | (define-handler second-mode :button-release (window root-x root-y code state)
 67 |   (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-release*)
 68 |   (draw-second-mode-window))
 69 | 
 70 | (define-handler second-mode :configure-request ()
 71 |   (apply #'handle-event-fun-main-mode-configure-request event-slots)
 72 |   (draw-second-mode-window))
 73 | 
 74 | 
 75 | (define-handler second-mode :configure-notify ()
 76 |   (draw-second-mode-window))
 77 | 
 78 | 
 79 | (define-handler second-mode :destroy-notify ()
 80 |   (apply #'handle-event-fun-main-mode-destroy-notify event-slots)
 81 |   (draw-second-mode-window))
 82 | 
 83 | (define-handler second-mode :map-request ()
 84 |   (apply #'handle-event-fun-main-mode-map-request event-slots)
 85 |   (draw-second-mode-window))
 86 | 
 87 | (define-handler second-mode :unmap-notify ()
 88 |   (apply #'handle-event-fun-main-mode-unmap-notify event-slots)
 89 |   (draw-second-mode-window))
 90 | 
 91 | (define-handler second-mode :exposure ()
 92 |   (apply #'handle-event-fun-main-mode-exposure event-slots)
 93 |   (draw-second-mode-window))
 94 | 
 95 | 
 96 | 
 97 | 
 98 | (defun sm-enter-function ()
 99 |   (with-placement (*second-mode-placement* x y *sm-width* *sm-height*)
100 |     (setf *in-second-mode* t
101 | 	  *sm-window* (xlib:create-window :parent *root*
102 | 					  :x x :y y
103 | 					  :width *sm-width* :height *sm-height*
104 | 					  :background (get-color *sm-background-color*)
105 | 					  :border-width *border-size*
106 | 					  :border (get-color *sm-border-color*)
107 | 					  :colormap (xlib:screen-default-colormap *screen*)
108 | 					  :event-mask '(:exposure))
109 | 	  *sm-font* (xlib:open-font *display* *sm-font-string*)
110 | 	  *sm-gc* (xlib:create-gcontext :drawable *sm-window*
111 | 					:foreground (get-color *sm-foreground-color*)
112 | 					:background (get-color *sm-background-color*)
113 | 					:font *sm-font*
114 | 					:line-style :solid)))
115 |   (setf (window-transparency *sm-window*) *sm-transparency*)
116 |   (map-window *sm-window*)
117 |   (draw-second-mode-window)
118 |   (no-focus)
119 |   (ungrab-main-keys)
120 |   (xgrab-keyboard *root*)
121 |   (xgrab-pointer *root* 66 67)
122 |   (speed-mouse-reset))
123 | 
124 | (defun sm-loop-function ()
125 |   (raise-window *sm-window*))
126 | 
127 | (defun sm-leave-function ()
128 |   (setf *in-second-mode* nil)
129 |   (when *sm-gc*
130 |     (xlib:free-gcontext *sm-gc*)
131 |     (setf *sm-gc* nil))
132 |   (when *sm-font*
133 |     (xlib:close-font *sm-font*)
134 |     (setf *sm-font* nil))
135 |   (when *sm-window*
136 |     (xlib:destroy-window *sm-window*)
137 |     (setf *sm-window* nil))
138 |   (xungrab-keyboard)
139 |   (xungrab-pointer)
140 |   (grab-main-keys)
141 |   (show-all-children)
142 |   (display-all-frame-info)
143 |   (raise-notify-window)
144 |   (wait-no-key-or-button-press))
145 | 
146 | (defun second-key-mode ()
147 |   "Switch to editing mode (second mode)"
148 |   (generic-mode 'second-mode
149 | 		'exit-second-loop
150 | 		:enter-function #'sm-enter-function
151 | 		:loop-function #'sm-loop-function
152 | 		:leave-function #'sm-leave-function)
153 |   (when *second-mode-leave-function*
154 |     (funcall *second-mode-leave-function*)
155 |     (setf *second-mode-leave-function* nil)))
156 | 
157 | (defun leave-second-mode ()
158 |   "Leave second mode"
159 |   (cond (*in-second-mode*
160 | 	 (setf *in-second-mode* nil)
161 | 	 (throw 'exit-second-loop nil))
162 | 	(t (setf *in-second-mode* nil)
163 | 	   (show-all-children))))
164 | 
165 | 
166 | (defun sm-delete-focus-window ()
167 |   "Close focus window: Delete the focus window in all frames and workspaces"
168 |   (setf *second-mode-leave-function* 'delete-focus-window)
169 |   (leave-second-mode))
170 | 
171 | (defun sm-ask-close/kill-current-window ()
172 |   "Close or kill the current window (ask before doing anything)"
173 |   (setf *second-mode-leave-function* #'ask-close/kill-current-window)
174 |   (leave-second-mode))
175 | 


--------------------------------------------------------------------------------
/src/my-html.lisp:
--------------------------------------------------------------------------------
  1 | ;;; --------------------------------------------------------------------------
  2 | ;;; CLFSWM - FullScreen Window Manager
  3 | ;;;
  4 | ;;; --------------------------------------------------------------------------
  5 | ;;; Documentation: Html generator helper
  6 | ;;; --------------------------------------------------------------------------
  7 | ;;;
  8 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
  9 | ;;;
 10 | ;;; This program is free software; you can redistribute it and/or modify
 11 | ;;; it under the terms of the GNU General Public License as published by
 12 | ;;; the Free Software Foundation; either version 3 of the License, or
 13 | ;;; (at your option) any later version.
 14 | ;;;
 15 | ;;; This program is distributed in the hope that it will be useful,
 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 | ;;; GNU General Public License for more details.
 19 | ;;;
 20 | ;;; You should have received a copy of the GNU General Public License
 21 | ;;; along with this program; if not, write to the Free Software
 22 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 23 | ;;;
 24 | ;;; --------------------------------------------------------------------------
 25 | 
 26 | 
 27 | 
 28 | (in-package :common-lisp-user)
 29 | 
 30 | (defpackage :my-html
 31 |   (:use :common-lisp :tools)
 32 |   (:export :insert-html-doctype
 33 |            :escape-html
 34 | 	   :produce-html
 35 | 	   :with-html
 36 | 	   :produce-html-string))
 37 | 
 38 | (in-package :my-html)
 39 | 
 40 | 
 41 | (defun insert-html-doctype ()
 42 |   "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 43 |      \"http://www.w3.org/TR/html4/transitional.dtd\">")
 44 | 
 45 | 
 46 | (defun escape-html (string &optional (replace '((">" "&gt;") ("<" "&lt;"))))
 47 |   (if replace
 48 |       (aif (search (caar replace) string)
 49 |            (escape-html (concatenate 'string (subseq string 0 it)
 50 |                                      (cadar replace)
 51 |                                      (subseq string (+ it (length (caar replace)))))
 52 |                 replace)
 53 |            (escape-html string (cdr replace)))
 54 |       string))
 55 | 
 56 | 
 57 | 
 58 | 
 59 | (defun produce-html (tree &optional (level 0) (stream *standard-output*))
 60 |   (cond ((listp tree)
 61 | 	 (print-space level stream)
 62 | 	 (format stream "~(<~A>~)~%" (first tree))
 63 | 	 (dolist (subtree (rest tree))
 64 | 	   (produce-html subtree (+ 2 level) stream))
 65 | 	 (print-space level stream)
 66 | 	 (format stream "~(</~A>~)~%"
 67 | 		 (if (stringp (first tree))
 68 | 		     (subseq (first tree) 0 (position #\Space (first tree)))
 69 | 		     (first tree))))
 70 | 	(t
 71 | 	 (print-space level stream)
 72 | 	 (format stream (if (stringp tree) "~A~%" "~(~A~)~%") tree))))
 73 | 
 74 | 
 75 | (defmacro with-html ((&optional (stream t)) &rest rest)
 76 |   `(produce-html ',@rest 0 ,stream))
 77 | 
 78 | 
 79 | (defun produce-html-string (tree &optional (level 0))
 80 |   (with-output-to-string (str)
 81 |     (produce-html tree level str)))
 82 | 
 83 | 
 84 | 
 85 | 
 86 | (defun test1 ()
 87 |   (produce-html `(html
 88 | 		  (head
 89 | 		   (title "Plop"))
 90 | 		  (body
 91 | 		   (h1 "A title")
 92 | 		   (h2 "plop")
 93 | 		   Plop ,(+ 2 2)
 94 | 		   ,(format nil "Plip=~A" (+ 3 5))
 95 | 		   ("a href=\"index.html\"" index)
 96 | 		   (ul
 97 | 		    (li "toto")
 98 | 		    (li "klm"))))))
 99 | 
100 | 
101 | (defun test2 ()
102 |   (with-html ()
103 |     (html
104 |      (head
105 |       (title "Plop"))
106 |      "<img src=\"toto.png\">"
107 |      (body
108 |       (h1 "Un titre")
109 |       (h2 "plop")
110 |       (ul
111 |        (li "toto")
112 |        (li "klm"))))))
113 | 
114 | 
115 | (defun test3 ()
116 |   (produce-html-string `(html
117 | 			 (head
118 | 			  (title "Plop"))
119 | 			 (body
120 | 			  (h1 "A title")
121 | 			  (h2 plop)
122 | 			  Plop ,(+ 2 2)
123 | 			  ,(format nil "Plip=~A" (+ 3 5))
124 | 			  |Foo Bar Baz|
125 | 			  ("a href=\"index.html\"" Index)
126 | 			  (ul
127 | 			   (li "toto")
128 | 			   (li "klm"))))
129 | 		       10))
130 | 


--------------------------------------------------------------------------------
/src/netwm-util.lisp:
--------------------------------------------------------------------------------
 1 | ;;; --------------------------------------------------------------------------
 2 | ;;; CLFSWM - FullScreen Window Manager
 3 | ;;;
 4 | ;;; --------------------------------------------------------------------------
 5 | ;;; Documentation: NetWM functions
 6 | ;;;   http://freedesktop.org/wiki/Specifications_2fwm_2dspec
 7 | ;;; --------------------------------------------------------------------------
 8 | ;;;
 9 | ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
10 | ;;;
11 | ;;; This program is free software; you can redistribute it and/or modify
12 | ;;; it under the terms of the GNU General Public License as published by
13 | ;;; the Free Software Foundation; either version 3 of the License, or
14 | ;;; (at your option) any later version.
15 | ;;;
16 | ;;; This program is distributed in the hope that it will be useful,
17 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 | ;;; GNU General Public License for more details.
20 | ;;;
21 | ;;; You should have received a copy of the GNU General Public License
22 | ;;; along with this program; if not, write to the Free Software
23 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 | ;;;
25 | ;;; --------------------------------------------------------------------------
26 | 
27 | (in-package :clfswm)
28 | 
29 | 
30 | ;;; Client List functions
31 | (defun netwm-set-client-list (id-list)
32 |   (xlib:change-property *root* :_NET_CLIENT_LIST id-list :window 32))
33 | 
34 | (defun netwm-get-client-list ()
35 |   (xlib:get-property *root* :_NET_CLIENT_LIST))
36 | 
37 | (defun netwm-add-in-client-list (window)
38 |   (let ((last-list (netwm-get-client-list)))
39 |     (pushnew (xlib:window-id window) last-list)
40 |     (netwm-set-client-list last-list)))
41 | 
42 | (defun netwm-remove-in-client-list (window)
43 |   (netwm-set-client-list (remove (xlib:window-id window) (netwm-get-client-list))))
44 | 
45 | 
46 | 
47 | ;;; Desktop functions ;; +PHIL
48 | (defun netwm-update-desktop-property ()
49 |   ;;  (xlib:change-property *root* :_NET_NUMBER_OF_DESKTOPS
50 |   ;;		   (list (length *workspace-list*)) :cardinal 32)
51 |   ;;  (xlib:change-property *root* :_NET_DESKTOP_GEOMETRY
52 |   ;;		   (list (screen-width)
53 |   ;;			 (screen-height))
54 |   ;;		   :cardinal 32)
55 |   ;;  (xlib:change-property *root* :_NET_DESKTOP_VIEWPORT
56 |   ;;		   (list 0 0) :cardinal 32)
57 |   ;;  (xlib:change-property *root* :_NET_CURRENT_DESKTOP
58 |   ;;		   (list 1) :cardinal 32)
59 | ;;; TODO
60 |   ;;(xlib:change-property *root* :_NET_DESKTOP_NAMES
61 |   ;;		   (list "toto" "klm" "poi") :string 8 :transform #'xlib:char->card8))
62 |   )
63 | 
64 | 
65 | 
66 | 
67 | ;;; Taken from stumpwm (thanks)
68 | (defun netwm-set-properties ()
69 |   "Set NETWM properties on the root window of the specified screen.
70 | FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK."
71 |   ;; _NET_SUPPORTED
72 |   (xlib:change-property *root* :_NET_SUPPORTED
73 | 			(mapcar (lambda (a)
74 | 				  (xlib:intern-atom *display* a))
75 | 				(append +netwm-supported+
76 | 					(mapcar 'car +netwm-window-types+)))
77 | 			:atom 32)
78 |   ;; _NET_SUPPORTING_WM_CHECK
79 |   (xlib:change-property *root* :_NET_SUPPORTING_WM_CHECK
80 | 			(list *no-focus-window*) :window 32
81 | 			:transform #'xlib:drawable-id)
82 |   (xlib:change-property *no-focus-window* :_NET_SUPPORTING_WM_CHECK
83 | 			(list *no-focus-window*) :window 32
84 | 			:transform #'xlib:drawable-id)
85 |   (xlib:change-property *no-focus-window* :_NET_WM_NAME
86 | 			*wm-name*
87 | 			:string 8 :transform #'xlib:char->card8)
88 |   (netwm-update-desktop-property))
89 | 


--------------------------------------------------------------------------------
/src/version.lisp:
--------------------------------------------------------------------------------
 1 | ;; Copyright (C) 2005-2015 Xavier Maillard <xma@gnu.org>
 2 | ;; Copyright (C) 2005-2015 Martin Bishop
 3 | ;;
 4 | ;;  Borrowed from Stumpwm
 5 | ;;  This file is part of clfswm.
 6 | ;;
 7 | ;; clfswm is free software; you can redistribute it and/or modify
 8 | ;; it under the terms of the GNU General Public License as published by
 9 | ;; the Free Software Foundation; either version 2, or (at your option)
10 | ;; any later version.
11 | 
12 | ;; clfswm is distributed in the hope that it will be useful,
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 | ;; GNU General Public License for more details.
16 | 
17 | ;; You should have received a copy of the GNU General Public License
18 | ;; along with this software; see the file COPYING.  If not, write to
19 | ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
20 | ;; Boston, MA 02111-1307 USA
21 | 
22 | ;; Commentary:
23 | ;;
24 | ;; This file contains version information.
25 | ;;
26 | ;; Code:
27 | 
28 | (in-package :common-lisp-user)
29 | 
30 | (defpackage version
31 |   (:use :common-lisp :tools)
32 |    (:export *version*))
33 | 
34 | (in-package :version)
35 | 
36 | (defparameter *version* #.(concatenate 'string "Version: 13??   built " (date-string)))
37 | 


--------------------------------------------------------------------------------