pax_global_header00006660000000000000000000000064143370120360014511gustar00rootroot0000000000000052 comment=fff2508fd54b4035b0d80bafbd75a13f1756130f stumpwm-22.11/000077500000000000000000000000001433701203600132325ustar00rootroot00000000000000stumpwm-22.11/.dir-locals.el000066400000000000000000000001211433701203600156550ustar00rootroot00000000000000((nil . ((indent-tabs-mode . nil))) (makefile-mode . ((indent-tabs-mode . t)))) stumpwm-22.11/.dockerignore000066400000000000000000000000421433701203600157020ustar00rootroot00000000000000tests/integration-tests/testcases stumpwm-22.11/.gitattributes000066400000000000000000000000211433701203600161160ustar00rootroot00000000000000*.lisp diff=lisp stumpwm-22.11/.github/000077500000000000000000000000001433701203600145725ustar00rootroot00000000000000stumpwm-22.11/.github/workflows/000077500000000000000000000000001433701203600166275ustar00rootroot00000000000000stumpwm-22.11/.github/workflows/test.yml000066400000000000000000000005611433701203600203330ustar00rootroot00000000000000name: Build and Test on: [push, pull_request] jobs: build_and_test: runs-on: ubuntu-latest steps: - uses: actions/checkout@v1 - name: Build run: docker build . --file Dockerfile -t stumpwm - name: Test run: docker run stumpwm make test - name: Integration_Testing run: cd tests/integration-tests; ./script ci stumpwm-22.11/.gitignore000066400000000000000000000007551433701203600152310ustar00rootroot00000000000000*.fas *.lib *.fasl *.a *.o *.*fasl *.*fsl *~ *.swp \#*# configure config.log config.status autom4te.cache /Makefile stumpwm stumpwm.info TAGS make-image.lisp load-stumpwm.lisp version.lisp stumpwm-*.tgz stumpwm-*.tgz.sig .dotest patches stumpwm.texi stumpwm.aux stumpwm.dvi stumpwm.fn stumpwm.fns stumpwm.log stumpwm.pdf stumpwm.toc stumpwm.vr stumpwm.vrs /tests/integration-tests/test-runner.iid /tests/integration-tests/testcases/*.results/ /tests/integration-tests/testcases/generated-*.sh stumpwm-22.11/.travis.yml000066400000000000000000000013651433701203600153500ustar00rootroot00000000000000language: common-lisp sudo: required env: matrix: - LISP=sbcl install: - sudo apt-get install info install-info - if [ -x ./install.sh ] && head -2 ./install.sh | grep '^#cl-travis' > /dev/null; then ./install.sh; else curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; fi - cl -l alexandria -l clx -l cl-ppcre -l fiasco -e '(ql-util:without-prompting (ql:add-to-init-file))' before_script: - ./autogen.sh - ./configure script: - make travis notifications: irc: "irc.libera.chat#stumpwm" urls: - https://webhooks.gitter.im/e/c1294f93beaf1b4f4f51 on_success: change on_failure: always on_start: never email: on_success: never on_failure: always stumpwm-22.11/AUTHORS000066400000000000000000000065101433701203600143040ustar00rootroot00000000000000The Stump Window Manager Authors -------------------------------- Shawn Betts sabetts at gmail com Ryan M. Golbeck rmgolbeck at uwaterloo ca Manuel Giraud manuel.giraud at univ-nantes fr Andreas Scholta andreas.scholta at gmail com Philippe Brochard hocwp at free fr Matthew Kennedy mkennedy at gentoo org Phil Gregory phil_g at pobox com Jeremy Hankins nowan at nowan org Martin Bishop martinbishop at bellsouth net David Hansen david.hansen at gmx net Gwern Branwen gwern0 at gmail com Jay Belanger belanger at truman edu Magnus Henoch mange at freemail hu Johannes Weiner Luca Capello luca at pca it Luigi Panzeri James Wright james at chumsley org Jonathan Liles wantingwaiting at users sf net Istvan Marko mi-stump at kismala com Tassilo Horn tassilo at member dot fsf dot org Morgan Veyret patzy at appart kicks-ass net Antonis Antoniadis cereal.killer.rules at gmail com Jeronimo Pellegrini j_p at aleph0 info James Wright james at chumsley org Vitaly Mayatskikh v.mayatskih at gmail com Ivy Foster ivy dot foster at gmail dot com Matt Shen synmantics at gmail com Patrick Pippen dabittweiler at gmail com Lionel Flandrin simias.n at gmail com Greg Pfeil greg at technomadic org Ian Ross Ian.Ross at bristol ac uk John Li jli at circularly org Jonathan Moore Liles wantingwaiting at users sf net Julian Stecklina js at alien8 de Scott Wolchok swolchok at umich edu Trent W. Buck trentbuck at gmail com Xan Lopez xan at gnome org Fredrik Tolf fredrik at dolda2000 com John Fremlin john at fremlin org Philip Fominykh philip at glyf org Michael Raskin 38a938c2 at rambler ru Ben Spencer dangerous.ben at gmail com Dirk Sondermann ds-stumpwm at dyximaq de Rupert Swarbrick rswarbrick at googlemail com David Vazquez davazp at es gnu org Antti Nykanen aon at iki.fi Friedrich Delgado Friedrichs friedel at nomaden org Egon Hyszczak gone404 at gmail com TC-Rucho tc.rucho at gmail com Raffael Mancini raffael.mancini at hcl-club lu Adlai Chandrasekhar munchking at gmail com Nils Anspach idnkmn at googlemail.com Krzysztof Drewniak krzysdrewniak at gmail com Josh Elsasser josh at elsasser org Matt Spear batman900 at gmail com David Bjergaard dbjergaard at gmail com Joram Schrijver i at joram io Yu Changyuan reivzy at gmail com Edward Trumbo trumboe at comcast net Javier Olaechea pirata at gmail com Caio Oliveira caioaao at gmail com Thomas Atkinson tnatkinson95 at gmail com Grayson Croom grayson at gmail com Sam Blumenthal sam.sam.42 at gmail com Moch Deden R moch.deden.r at gmail com Audun Hoem audun.hoem at gmail com Stuart Dilts stuart.dilts at gmail com Ram Krishnan kriyative at gmail.com Herbert Jones jones dot herbert at gmail.com Daniel Oliveira drdo at drdo.eu Panji Kusuma epanji at gmail dot com Andrin Bertschi hi at abertschi dot ch Spenser Max Truex web ate spensertruex.com Toby Worland toby dot worland at gmail.com Tomasz Jeneralczyk silicius at schwi dot pl Jeremiah LaRocco jeremiah_larocco at fastmail com Axel Svensson mail at axelsvensson dot com stumpwm-22.11/COPYING000066400000000000000000000432541433701203600142750ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. stumpwm-22.11/Dockerfile000066400000000000000000000010131433701203600152170ustar00rootroot00000000000000FROM ubuntu:20.04 ENV HOME /root/ RUN apt-get update \ && apt-get install -y sbcl curl build-essential autoconf git \ && curl -O https://beta.quicklisp.org/quicklisp.lisp \ && sbcl --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" \ && sbcl --load "/root/quicklisp/setup.lisp" --eval "(progn (setf ql-util::*do-not-prompt* t)(ql:add-to-init-file))" \ && sbcl --eval "(progn (ql:quickload '(clx cl-ppcre alexandria fiasco)))" COPY . . RUN ./autogen.sh \ && ./configure \ && make stumpwm-22.11/HACKING000066400000000000000000000000401433701203600142130ustar00rootroot00000000000000See the StumpWM Texinfo manual. stumpwm-22.11/Makefile.in000066400000000000000000000042041433701203600152770ustar00rootroot00000000000000LISP=@LISP_PROGRAM@ MAKEINFO=@MAKEINFO@ sbcl_BUILDOPTS=--non-interactive --eval "(setf sb-impl::*default-external-format* :UTF-8)" --load ./make-image.lisp sbcl_INFOOPTS=--non-interactive --eval "(setf sb-impl::*default-external-format* :UTF-8)" --eval "(progn (load \"load-stumpwm.lisp\") (load \"manual.lisp\"))" --eval "(progn (stumpwm::generate-manual) (sb-ext:quit))" sbcl_TESTOPTS=--non-interactive --eval "(setf sb-impl::*default-external-format* :UTF-8)" --eval "(progn (load \"load-stumpwm.lisp\") (asdf:load-system :stumpwm-tests))" --eval "(if (fiasco:all-tests) (uiop:quit 0) (uiop:quit 1))" datarootdir = @datarootdir@ prefix=@prefix@ exec_prefix= @exec_prefix@ bindir=@bindir@ infodir=@infodir@ # You shouldn't have to edit past this FILES=stumpwm.asd $(shell grep -o ":file \".*\"" stumpwm.asd | sed 's,:file ",,g' | sed 's,",.lisp,g' ) dynamic-mixins/dynamic-mixins.asd $(shell grep -o ":file \".*\"" dynamic-mixins/dynamic-mixins.asd | sed 's,:file ",dynamic-mixins/src/,g' | sed 's,",.lisp,g') all: stumpwm stumpwm.info travis: stumpwm test stumpwm.info: stumpwm.texi test "$(MAKEINFO)" = "no" || $(MAKEINFO) stumpwm.texi # FIXME: This rule is too hardcoded stumpwm.texi: stumpwm.texi.in $(FILES) $(LISP) $(@LISP@_INFOOPTS) stumpwm: $(FILES) $(LISP) $(@LISP@_BUILDOPTS) test: $(LISP) $(@LISP@_TESTOPTS) clean: rm -f *.fasl *.fas *.lib *.*fsl rm -f *.log *.fns *.fn *.aux *.cp *.ky *.log *.toc *.pg *.tp *.vr *.vrs rm -f stumpwm stumpwm.texi stumpwm.info install: stumpwm.info stumpwm test -z "$(destdir)$(bindir)" || mkdir -p "$(destdir)$(bindir)" install -m 755 stumpwm "$(destdir)$(bindir)" test -z "$(destdir)$(infodir)" || mkdir -p "$(destdir)$(infodir)" test "$(MAKEINFO)" = "no" || install -m 644 stumpwm.info "$(destdir)$(infodir)" test "$(MAKEINFO)" = "no" || install-info --info-dir="$(destdir)$(infodir)" "$(destdir)$(infodir)/stumpwm.info" install-modules: git clone https://github.com/stumpwm/stumpwm-contrib.git ~/.stumpwm.d/modules uninstall: rm "$(destdir)$(bindir)/stumpwm" install-info --info-dir="$(destdir)$(infodir)" --remove "$(destdir)$(infodir)/stumpwm.info" rm "$(destdir)$(infodir)/stumpwm.info" # End of file stumpwm-22.11/NEWS000066400000000000000000000127011433701203600137320ustar00rootroot00000000000000-*- outline -*- This file documents user visible changes between versions of StumpWM * Changes since 0.9.6 ** in float mode windows can be resized with the middle mouse button ** support for CCL added ** support for ECL added * Changes since 0.9.5 ** add frame-windowlist command ** add run-or-pull command ** add refresh and redisplay commands ** use ppcre for window placement rule matching ** add fmt-head-window-list colors hidden windows ** new contrib modules time.lisp, disk.lisp, sbclfix.lisp, net.lisp, mem.lisp, maildir.lisp, window-tags.lisp ** add automatic group creation/restoration ** add restart-hard command ** rename soft-restart to restart-soft ** new commands refresh and redisplay ** new command list-window-properties ** AltGr works ** new top/root keymaps The *root-map* keymap and *top-map* have been split into several based on what group it applies to, tiling, floating, both. ** new floating group StumpWM now has a floating window group mode. * Changes since 0.9.4.1 ** new module, aumix.lisp ** new command, repack-window-numbers ** new module, productivity.lisp ** _NET_FRAME_EXTENTS property is set on client windows ** define-key acts like undefine-key when nil is passed as the command ** new command, show-window-properties ** select-from-menu lets you type regex to match an item ** new commands, gnext-with-window and gprev-with-window ** run-or-raise now cycles through matching windows ** new function add-screen-mode-line-formatter ** new module wifi.lisp ** new module battery-portable.lisp ** new command load-module ** added install/uninstall Makefile rules ** added info command ** added g{next,prev}-with-window commands ** added show-window-properties command * Changes since 0.9.3 ** new %interactivep% variable see defcommand in the manual. ** The default package is now stumpwm-user stumpwm-user imports all exported stumpwm symbols. ** the pixmap error plaguing some users has been fixed If you are running sbcl, you need do nothing. If you're using clisp, ensure the version is 2.46 or later. ** New macro defprogram-shortcut * Changes since 0.9.2 ** C-t bindings moved to C-t C- To pull a window by number you now have to hold down Control. Just pressing the number now selects the window by number in its frame. ** new commands modifiers and copy-last-message ** new command grouplist and binding C-t g " ** New keybinding C-t h c bound to describe-command ** spelling mistake fixed One global variable was changed. *new-window-prefered-frame* is now called *new-window-preferred-frame*. ** new variable *window-border-style* ** new command exchange-windows ** new command type :direction ** define-stumpwm-command is deprecated Use defcommand instead ** pull-window-by-number arguments are reversed ** renumber function's arguments are reversed ** C-h lists keybindings too In any keymap C-h and ? will list the keybindings. ** New command bind Hang a key binding off the escape key. ** C-t TAB changed to fnext Maintain compatibility with the screen binding. * Changes since 0.9.1 ** key grab handling top level key binding are now grabbed "asynchronously." This should eliminate the keyboard freezes some have experiences. ** New command emacs ** AltGr modifier should be recognized now ** new command grename * Changes since 0.0.6 These changes are probably incomplete ** added color codes to message windows. ** added XRandR dynamic rotate/resize support ** added external panel/dock support ** added fullscren support ** added new rat focus models ** Xinerama support ** support hidden groups ** added frame save and restore ** added rule based window placement ** stumpwm now handles window roles ** move-focus now uses a heuristic to find the 'best' frame to focus ** format-time-string Now takes an optional format string as an argument! ** more netwm compliance stumpwm now exports its groups as netwm desktops. ** new var *default-package* This decides what package the eval command reads and executes things in. ** new var *new-window-prefered-frame* It controls what frame a new window appears in. ** "help" command prints bindings in columns And it doesn't timeout. ** new variable *suppress-abort-messages* Suppress abort message when non-nil. ** configure script Now you can use it to select a lisp and point the makefile to the location of your lisp. ** new command gmerge ** startup message configurable with *startup-message*. ** format string arguments can be cropped In the windows command, %20t will crop the window's title to 20 characters. This numeric prefix works for all % arguments. ** _NET_CLIENT_LIST works which means wmctl -l returns useful info. ** stumpwm executables the Makefile can now generate executables for sbcl and clisp. Edit the Makefile to choose you lisp. ** New global *new-frame-action* ** New commands describe-key, describe-variable, describe-function, where-is ** New prefix map *help-map* ** New command, title, bound to C-t A title sets the window's name. ** errors while reloading stumpwm A restarts menu now appears that allows you to select a restart, if you want. ** new function restarts-menu ** modeline update timer set to 60s by default. ** timers see run-with-timer and cancel-timer ** improved frame splitting, resizing and removing ** *run-or-raise-all-groups* variable * Changes since 0.0.5 ** quit command * Changes since 0.0.3 ** Frame support StumpWM now sports basic frame support. No resizing yet. * Changes since 0.0.2 * Changes since 0.0.1 stumpwm-22.11/README.md000066400000000000000000000164661433701203600145260ustar00rootroot00000000000000![](https://stumpwm.github.io/images/stumpwm-logo-stripe.png) # The Stump Window Manager ![](https://travis-ci.org/stumpwm/stumpwm.svg) [![Gitter](https://badges.gitter.im/stumpwm/community.svg)](https://gitter.im/stumpwm/community?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) StumpWM is a window manager written entirely in Common Lisp. It attempts to be highly customizable while relying entirely on the keyboard for input. You will not find buttons, icons, title bars, tool bars, or any of the other conventional GUI widgets. These design decisions reflect the growing popularity of productive, customizable lisp based systems. ## Philosophy StumpWM is a "everything-and-the-kitchen-sink WM" or "the Emacs of WMs." **StumpWM:Windows::Emacs:Text** * StumpWM is * Hackable * Written in Common Lisp * A multi paradigm window manager * A Superior window managing experience * StumpWM is *not* * Minimalist * Narrow scope * Configured by editing the source directly * A full blown desktop environment If you want a minimalist tiling window manager, then StumpWM is *not* what you're looking for. The code base is ~15k lines, the binaries produced are ~60mb. StumpWM manages windows the way emacs manages buffers, or the way screen manages terminals. If you want a flexible, customizable, hackable desktop experience, look no further. # Build & Start Stumpwm ## Prerequisites * [SBCL][sbcl] * quicklisp (for obtaining the following dependencies; not needed if you use your distribution's package manager.) * clx * cl-ppcre * alexandria The recommended way to install the dependencies is using Quicklisp. Follow the instructions at http://www.quicklisp.org/ to install it. In short: ``` $ curl -O https://beta.quicklisp.org/quicklisp.lisp $ sbcl --load quicklisp.lisp ``` Then at the REPL: ```lisp (quicklisp-quickstart:install) ``` Make sure you have added it to your lisp init file using: ```lisp (ql:add-to-init-file) ``` Then, in a repl: ```lisp (ql:quickload "clx") (ql:quickload "cl-ppcre") (ql:quickload "alexandria") ``` Note: The recommended way to install SBCL is by downloading one of their pre-built binaries available in their [web page][sbcl-platform-table] or build it from source. Please do _not_ install SBCL using your distributions package manager, especially Ubuntu. If you do so it is likely that you'll run into problems when building StumpWM due to using obsolete versions of the dependencies. ## Building Building stumpwm from git requires that you build the configure script: ``` ./autogen.sh ``` Then run it: ``` ./configure ``` Now build it: ``` make ``` If all goes well, you should have a stumpwm binary now. You can run the binary from where it is (starting it with X) or install it, along with the .info documentation, with: ``` make install ``` Now that you have a binary, call it from your ~/.xinitrc file: ``` # The default path is /usr/local/bin/stumpwm echo /path/to/stumpwm >> ~/.xinitrc startx ``` Hopefully that will put you in X running stumpwm! See [StartUp on the wiki](https://github.com/sabetts/stumpwm/wiki/StartUp) for more examples. # Contributing Pull requests are always welcome! Here are some guidelines to ensure that your contribution gets merged in a timely manner: * Do's * Add your name to the list of AUTHORS with your pull request. * Preserve comments or docstrings explaining what code does, and update them if your patch changes them in a significant way * Try to follow an "80 column rule." The current code base does not follow this all the time, so don't use it as an example * If you export a symbol, you *must* add it to the manual. * [Use lisp idioms][lisp-idioms] * If you are working on a major change to the internals, keep us informed on stumpwm-devel! Also, it will probably help if the changes are made and then incrementally applied to the codebase in order to avoid introducing show-stopping bugs. * Do not's * Include Emacs local variables * Change whitespace * Write lots of code without supporting comments/documentation * Delete comments or docstrings (yes this is a duplicate of above!) * Export symbols from packages that aren't widely useful (many times a little more thought will reveal how to implement your internal change without having to export/break encapsulation) * Make stylistic changes that suit your coding style/way of thinking If you aren't a lisp hacker, you can contribute in the form of documenting and organizing the wiki. There's a lot of information floating around; if you find it where you didn't expect it, move or link to it in a more logical place. # Wishlist Fancy yourself a lisp hacker? Here's a wishlist of features for the StumpWM universe (in no particular order): * float-splits (ie allow floating windows over tiled ones) * Float windows within parent applications (specifically dialogs in gimp or firefox). * tab-list showing the contents of the current frame at the side, top, or bottom of the frame * Emacs' iswitchb function implemented in emacs * Re-arranging windows between groups * Killing windows * Marking windows for batch operations * Deleting/adding groups * Import data from stumpwm to emacs, use an emacs minor mode to implement the above features, then export the data back to stumpwm and let stumpwm perform the appropriate actions * Emacs' completing-read-multiple function * Dynamic tiling * Lock Screen (with support for leaving notes, bonus points if emacs is involved) * Wallpapers! (support pulling from remote sources, changing based on timers, and other hacky features) * Shutdown, restart, suspend, and hibernate functions that don't require root access * Revamped, mouse-friendly mode-line. * Support fixed number of chars for window titles * Dynamically trim window titles to fit them all on the mode-line * Split the mode-line into multiple cells for containing different information * Implement widget icons to indicate system status (new mail, low battery, network etc) * Support raising windows when left-clicked, closing/killing when right-clicked # Help There's a texinfo manual, stumpwm.texi. The build scripts generate an info file you can read in emacs or with the `info' program. The manual for the latest git version (may be slightly out of date) is available to read online at: [The Manual](https://stumpwm.github.io/) And, as in Emacs, you can always get documentation with: | Key | Help | |--------------------|----------------------------------| | C-t h v | Variables | | C-t h f | Functions | | C-t h k | Key sequences | | C-t h c | Commands | | C-t h w | Find key sequences for a command | For other stuff (tips tricks and examples) visit the [stumpwm wiki](https://github.com/stumpwm/stumpwm/wiki) There's a **#stumpwm** channel on [irc.libera.chat](https://libera.chat), too. Finally, there's our mailing list (click to sign up) [stumpwm-devel@nongnu.org](https://lists.nongnu.org/mailman/listinfo/stumpwm-devel). [lisp-idioms]: (http://web.archive.org/web/20160101153032/http://people.ace.ed.ac.uk/staff/medward2/class/moz/cm/doc/contrib/lispstyle.html) [sbcl]: http://sbcl.org [sbcl-platform-table]: http://sbcl.org/platform-table.html stumpwm-22.11/autogen.sh000077500000000000000000000000651433701203600152340ustar00rootroot00000000000000#!/bin/sh # generate the configure script autoconf stumpwm-22.11/bindings.lisp000066400000000000000000000226141433701203600157250ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; define standard key bindings ;; ;; Code: (in-package #:stumpwm) (export '(*groups-map* *group-top-maps* *help-map* *help-keys* set-prefix-key)) (defvar *escape-key* (kbd "C-t") "The escape key. Any keymap that wants to hang off the escape key should use this specific key struct instead of creating their own C-t.") (defvar *help-keys* '("?" "C-h") "The list of keys used to invoke the help command.") (defvar *escape-fake-key* (kbd "t") "The binding that sends the fake escape key to the current window.") (defvar *groups-map* nil "The keymap that group related key bindings sit on. It is bound to @kbd{C-t g} by default.") (defvar *exchange-window-map* nil "The keymap that exchange-window key bindings sit on. It is bound to @kbd{C-t x} by default.") (defvar *help-map* nil "Help related bindings hang from this keymap") (defvar *group-top-maps* '((tile-group *tile-group-top-map*) (group *group-top-map*)) "An alist of the top level maps for each group type. For a given group, all maps whose type matches the given group are active. So for a tile-group, both the group map and tile-group map are active. Order is important. Each map is seached in the order they appear in the list (inactive maps being skipped). In general the order should go from most specific groups to most general groups.") (defvar *group-top-map* nil) (defvar *group-root-map* nil "Commands specific to a group context hang from this keymap. It is available as part of the @dnf{prefix map}.") (defvar *tile-group-top-map* nil) (defvar *tile-group-root-map* nil "Commands specific to a tile-group context hang from this keymap. It is available as part of the @dnf{prefix map} when the active group is a tile group.") ;; Do it this way so its easier to wipe the map and get a clean one. (defmacro fill-keymap (map &rest bindings) `(unless ,map (setf ,map (let ((m (make-sparse-keymap))) ,@(loop for i = bindings then (cddr i) while i collect `(define-key m ,(first i) ,(second i))) m)))) (fill-keymap *top-map* *escape-key* '*root-map*) (fill-keymap *root-map* (kbd "c") "exec xterm" (kbd "C-c") "exec xterm" (kbd "e") "emacs" (kbd "C-e") "emacs" (kbd "b") "banish" (kbd "C-b") "banish" (kbd "a") "time" (kbd "C-a") "time" (kbd "!") "exec" (kbd "C-g") "abort" *escape-fake-key* "send-escape" (kbd ";") "colon" (kbd ":") "eval" (kbd "v") "version" (kbd "m") "lastmsg" (kbd "C-m") "lastmsg" (kbd "G") "vgroups" (kbd "g") '*groups-map* (kbd "x") '*exchange-window-map* (kbd "F1") "gselect 1" (kbd "F2") "gselect 2" (kbd "F3") "gselect 3" (kbd "F4") "gselect 4" (kbd "F5") "gselect 5" (kbd "F6") "gselect 6" (kbd "F7") "gselect 7" (kbd "F8") "gselect 8" (kbd "F9") "gselect 9" (kbd "F10") "gselect 10" (kbd "h") '*help-map*) (fill-keymap *group-top-map* *escape-key* '*group-root-map*) (fill-keymap *group-root-map* (kbd "C-u") "next-urgent" (kbd "M-n") "next" (kbd "M-p") "prev" (kbd "o") "other" (kbd "RET") "expose" (kbd "C-RET") "expose" (kbd "w") "windows" (kbd "C-w") "windows" (kbd "DEL") "repack-window-numbers" (kbd "k") "delete" (kbd "C-k") "delete" (kbd "K") "kill" (kbd "'") "select" (kbd "\"") "windowlist" (kbd "0") "select-window-by-number 0" (kbd "1") "select-window-by-number 1" (kbd "2") "select-window-by-number 2" (kbd "3") "select-window-by-number 3" (kbd "4") "select-window-by-number 4" (kbd "5") "select-window-by-number 5" (kbd "6") "select-window-by-number 6" (kbd "7") "select-window-by-number 7" (kbd "8") "select-window-by-number 8" (kbd "9") "select-window-by-number 9" (kbd "C-N") "number" (kbd "#") "mark" (kbd "F11") "fullscreen" (kbd "A") "title" (kbd "i") "info" (kbd "I") "show-window-properties") (fill-keymap *tile-group-top-map* *escape-key* '*tile-group-root-map*) (fill-keymap *tile-group-root-map* (kbd "n") "pull-hidden-next" (kbd "C-n") "pull-hidden-next" (kbd "C-M-n") "next-in-frame" (kbd "SPC") "pull-hidden-next" (kbd "C-SPC") "pull-hidden-next" (kbd "p") "pull-hidden-previous" (kbd "C-p") "pull-hidden-previous" (kbd "C-M-p") "prev-in-frame" (kbd "P") "place-current-window" (kbd "W") "place-existing-windows" *escape-key* "pull-hidden-other" (kbd "M-t") "other-in-frame" (kbd "C-0") "pull 0" (kbd "C-1") "pull 1" (kbd "C-2") "pull 2" (kbd "C-3") "pull 3" (kbd "C-4") "pull 4" (kbd "C-5") "pull 5" (kbd "C-6") "pull 6" (kbd "C-7") "pull 7" (kbd "C-8") "pull 8" (kbd "C-9") "pull 9" (kbd "R") "remove" (kbd "s") "vsplit" (kbd "S") "hsplit" (kbd "r") "iresize" (kbd "o") "fnext" (kbd "TAB") "fnext" (kbd "M-TAB") "fother" (kbd "f") "fselect" (kbd "F") "curframe" (kbd "-") "fclear" (kbd "Q") "only" (kbd "X") "remove-split" (kbd "q") "quit-confirm" (kbd "Up") "move-focus up" (kbd "Down") "move-focus down" (kbd "Left") "move-focus left" (kbd "Right") "move-focus right" (kbd "M-Up") "move-window up" (kbd "M-Down") "move-window down" (kbd "M-Left") "move-window left" (kbd "M-Right") "move-window right" (kbd "+") "balance-frames" (kbd "l") "redisplay" (kbd "C-l") "redisplay") (fill-keymap *groups-map* (kbd "g") "groups" (kbd "c") "gnew" (kbd "n") "gnext" (kbd "C-n") "gnext" (kbd "SPC") "gnext" (kbd "C-SPC") "gnext" (kbd "N") "gnext-with-window" (kbd "p") "gprev" (kbd "C-p") "gprev" (kbd "P") "gprev-with-window" (kbd "o") "gother" (kbd "'") "gselect" (kbd "\"") "grouplist" (kbd "m") "gmove" (kbd "M") "gmove-marked" (kbd "k") "gkill" (kbd "A") "grename" (kbd "r") "grename" (kbd "1") "gselect 1" (kbd "2") "gselect 2" (kbd "3") "gselect 3" (kbd "4") "gselect 4" (kbd "5") "gselect 5" (kbd "6") "gselect 6" (kbd "7") "gselect 7" (kbd "8") "gselect 8" (kbd "9") "gselect 9" (kbd "0") "gselect 10") (fill-keymap *exchange-window-map* (kbd "Up") "exchange-direction up" (kbd "Down") "exchange-direction down" (kbd "Left") "exchange-direction left" (kbd "Right") "exchange-direction right" (kbd "p") "exchange-direction up" (kbd "n") "exchange-direction down" (kbd "b") "exchange-direction left" (kbd "f") "exchange-direction right" (kbd "k") "exchange-direction up" (kbd "j") "exchange-direction down" (kbd "h") "exchange-direction left" (kbd "l") "exchange-direction right") (fill-keymap *help-map* (kbd "v") "describe-variable" (kbd "f") "describe-function" (kbd "k") "describe-key" (kbd "c") "describe-command" (kbd "w") "where-is") (defcommand command-mode () () "Command mode allows you to type StumpWM commands without needing the @key{C-t} prefix. Keys not bound in StumpWM will still get sent to the current window. To exit command mode, type @key{C-g}." (run-hook *command-mode-start-hook*) (push-top-map *root-map*)) (defcommand set-prefix-key (key) ((:key "Key: ")) "Change the stumpwm prefix key to KEY. @example \(stumpwm:set-prefix-key (stumpwm:kbd \"C-M-H-s-z\")) @end example This will change the prefix key to @key{Control} + @key{Meta} + @key{Hyper} + @key{Super} + the @key{z} key. By most standards, a terrible prefix key but it makes a great example." (check-type key key) (copy-key-into key *escape-key*) ;; if the escape key has no modifiers then disable the fake key by ;; giving it keysym -1, an impossible value. Otherwise you have 2 ;; identical bindings and the one that appears first in the list ;; will be matched. (copy-key-into (make-key :keysym (if (key-mods-p *escape-key*) (key-keysym key) -1)) *escape-fake-key*) (sync-keys)) (defcommand-alias escape set-prefix-key) (defcommand bind (key command) ((:string "Key chord: ") (:rest "Command: ")) "Hang a key binding off the escape key." (define-key *root-map* (kbd key) command)) (defcommand unbind (key) ((:string "Key chord: ")) "Remove a key binding from the escape key." (undefine-key *root-map* (kbd key))) (defcommand send-escape () () "Send the escape key to the current window." (send-meta-key (current-screen) *escape-key*)) stumpwm-22.11/color.lisp000066400000000000000000000460251433701203600152500ustar00rootroot00000000000000;; Copyright (C) 2007-2008 Jonathan Moore Liles ;; Copyright (C) 2014 Joram Schrijver ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; A change in color, or presentation in general, is started by a ^. If that ;; ^ is followed by a single number, that's taken as the index into the color ;; map to be set as the foreground color. If the ^ is followed by two numbers, ;; the first is taken as the index of the foreground color, and the second as ;; the index of the background color. Either of those can also be *, which ;; means the value should be set to default. ;; ;; ^n resets the foreground and background color back to default. ;; ^A B turns bright colors on, and b turns them off. ;; ^R turns reverse colors on and r turns them off. ;; ^[ pushes the current settings onto the color stack. The current settings ;; remain unchanged. ;; ^] pops color settings off the stack. ;; ^> aligns the rest of the string to the right of the window. ;; ^f switches to the font at index n in the screen's font stack. ;; ^^ prints a regular caret ;; ^( &rest arguments) allows for more complicated color settings: ;; can be one of :fg, :bg, :reverse, :bright, :push, :pop, :font ;; and :>. ;; The arguments for each modifier differ: ;; - :fg and :bg take a color as an argument, which can either be a numeric ;; index into the color map or a hexadecimal color in the form of "#fff" ;; or "#ffffff". ;; - :reverse and :bright take either t or nil as an argument. A t enables ;; the setting and nil disables it. ;; - :push and :pop take no arguments. :push pushes the current settings onto ;; the color stack, leaving the current settings intact. :pop pops color ;; settings off the stack, updating the current settings. ;; - :font takes an integer that represents an index into the screen's list ;; of fonts, or, possibly, a literal font object that can immediately be ;; used. In a string you'll probably only want to specify an integer. ;; - :> takes no arguments. It triggers right-alignment for the rest of the ;; line. (in-package :stumpwm) (export '(*colors* update-color-map adjust-color update-screen-color-context lookup-color)) (defvar *colors* '("black" "red" "green" "yellow" "blue" "magenta" "cyan" "white") "Eight colors by default. You can redefine these to whatever you like and then call (update-color-map).") (defun adjust-color (color amt) (labels ((max-min (x y) (max 0 (min 1 (+ x y))))) (setf (xlib:color-red color) (max-min (xlib:color-red color) amt) (xlib:color-green color) (max-min (xlib:color-green color) amt) (xlib:color-blue color) (max-min (xlib:color-blue color) amt)) color)) (defun hex-to-xlib-color (color) (cond ((= 4 (length color)) (let ((red (/ (parse-integer (subseq color 1 2) :radix 16) 255.0)) (green (/ (parse-integer (subseq color 2 3) :radix 16) 255.0)) (blue (/ (parse-integer (subseq color 3 4) :radix 16) 255.0))) (xlib:make-color :red (+ red (* 16 red)) :green (+ green (* 16 green)) :blue (+ blue (* 16 blue))))) ((= 7 (length color)) (let ((red (/ (parse-integer (subseq color 1 3) :radix 16) 255.0)) (green (/ (parse-integer (subseq color 3 5) :radix 16) 255.0)) (blue (/ (parse-integer (subseq color 5 7) :radix 16) 255.0))) (xlib:make-color :red red :green green :blue blue))))) (defun lookup-color (screen color) (cond ((typep color 'xlib:color) color) ((and (stringp color) (or (= 7 (length color)) (= 4 (length color))) (char= #\# (elt color 0))) (hex-to-xlib-color color)) (t (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)))) (defun alloc-color (screen color) ;; We add an alpha channel to the color returned by xlib:alloc-color (logior (xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) (lookup-color screen color)) (ash #xff 24))) ;; Normal colors are dimmed and bright colors are intensified in order ;; to more closely resemble the VGA pallet. (defun update-color-map (screen) "Read *colors* and cache their pixel colors for use when rendering colored text." (labels ((map-colors (adj) (loop for c in *colors* as color = (typecase c ;; If the color element is a list, use ;; the first or second color in the ;; list appropriately (cons (lookup-color screen (case adj (:normal (first c)) (:bright (second c))))) ;; If the color element is not a list, ;; look up the color and adjust it ;; automatically (t (adjust-color (lookup-color screen c) (case adj (:normal -0.25) (:bright 0.25))))) collect (alloc-color screen color)))) (setf (screen-color-map-normal screen) (apply #'vector (map-colors :normal)) (screen-color-map-bright screen) (apply #'vector (map-colors :bright))))) (defun update-screen-color-context (screen) (let* ((cc (screen-message-cc screen)) (bright (lookup-color screen *text-color*))) (setf (ccontext-default-fg cc) (screen-fg-color screen) (ccontext-default-bg cc) (screen-bg-color screen)) (adjust-color bright 0.25) (setf (ccontext-default-bright cc) (alloc-color screen bright)))) ;;; Parser for color strings (defun parse-color (color) "Parse a possible colorcode into a list of the appropriate modifiers. If COLOR isn't a colorcode a list containing COLOR is returned." (if (and (> (length color) 1) (char= (char color 0) #\^)) (let ((foreground (char color 1)) (background (if (> (length color) 2) (char color 2) :reset))) (case foreground ;; Normalize colors (#\n '((:bg :reset) (:fg :reset) (:reverse nil))) (#\R '((:reverse t))) (#\r '((:reverse nil))) (#\B '((:bright t))) (#\b '((:bright nil))) (#\[ '((:push))) (#\] '((:pop))) (#\> '((:>))) (#\f `((:font ,(or (parse-integer (string background) :junk-allowed t) 0)))) (#\^ '("^")) (#\( (list (read-from-string (subseq color 1)))) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\*) `((:bg ,(or (parse-integer (string background) :junk-allowed t) :reset)) (:fg ,(or (parse-integer (string foreground) :junk-allowed t) :reset)) (:reverse nil))))) (list color))) ; this isn't a colorcode (defun parse-color-string (string) "Parse a color-coded string into a list of strings and color modifiers" (let ((substrings (remove-if (lambda (str) (zerop (length str))) (ppcre:split "(\\^[nrRbB>\\[\\]^]|\\^[0-9*]{1,2}|\\^f[0-9]|\\^\\(.*?\\))" string :with-registers-p t)))) (loop for substring in substrings append (parse-color substring)))) (defun uncolorify (string) "Remove any color markup in STRING" (format nil "~{~a~}" (remove-if-not 'stringp (parse-color-string string)))) ;;; Color modifiers and rendering code (defun find-color (color default cc &aux (screen (ccontext-screen cc))) (cond ((or (null color) (eq :reset color)) default) ((integerp color) (svref (if (ccontext-brightp cc) (screen-color-map-bright screen) (screen-color-map-normal screen)) color)) (t (nth-value 0 (alloc-color screen color))))) (defun find-font (cc specified-font &aux (font (or specified-font 0))) (if (integerp font) (nth font (screen-fonts (ccontext-screen cc))) font)) (defgeneric apply-color (ccontext modifier &rest arguments)) (defmethod apply-color :around ((cc ccontext) modifier &rest arguments) (declare (ignorable cc modifier arguments)) (when *draw-in-color* (call-next-method))) (defmethod apply-color ((cc ccontext) (modifier (eql :fg)) &rest args) (setf (ccontext-fg cc) (first args)) (let* ((gcontext (ccontext-gc cc)) (specified-color (first args)) (color (find-color specified-color (if (ccontext-brightp cc) (ccontext-default-bright cc) (ccontext-default-fg cc)) cc))) (if (ccontext-reversep cc) (setf (xlib:gcontext-background gcontext) color) (setf (xlib:gcontext-foreground gcontext) color)))) (defmethod apply-color ((cc ccontext) (modifier (eql :bg)) &rest args) (setf (ccontext-bg cc) (first args)) (let* ((gcontext (ccontext-gc cc)) (specified-color (first args)) (color (find-color specified-color (ccontext-default-bg cc) cc))) (if (ccontext-reversep cc) (setf (xlib:gcontext-foreground gcontext) color) (setf (xlib:gcontext-background gcontext) color)))) (defmethod apply-color ((cc ccontext) (modifier (eql :reverse)) &rest args) (setf (ccontext-reversep cc) (first args)) (let ((fg (ccontext-fg cc)) (bg (ccontext-bg cc))) (apply-color cc :fg fg) (apply-color cc :bg bg))) (defmethod apply-color ((cc ccontext) (modifier (eql :bright)) &rest args) (setf (ccontext-brightp cc) (first args)) (let ((fg (ccontext-fg cc)) (bg (ccontext-bg cc))) (apply-color cc :fg fg) (apply-color cc :bg bg))) (defmethod apply-color ((cc ccontext) (modifier (eql :push)) &rest args) (declare (ignore args)) (push (list (ccontext-fg cc) (ccontext-bg cc) (ccontext-brightp cc) (ccontext-reversep cc) (ccontext-font cc)) (ccontext-color-stack cc))) (defmethod apply-color ((cc ccontext) (modifier (eql :pop)) &rest args) (declare (ignore args)) (let ((values (pop (ccontext-color-stack cc)))) (apply-color cc :fg (first values)) (apply-color cc :bg (second values)) (apply-color cc :bright (third values)) (apply-color cc :reverse (fourth values)) (apply-color cc :font (fifth values)))) (defmethod apply-color ((cc ccontext) (modifier (eql :font)) &rest args) (let ((font (or (first args) 0))) (setf (ccontext-font cc) (find-font cc font)))) (defmethod apply-color ((cc ccontext) (modifier (eql :>)) &rest args) ;; This is a special case in RENDER-STRING and is thus only called when not ;; rendering. Since it doesn't otherwise have any effects, we just ignore it. (declare (ignore cc modifier args))) ;; Two more special cases. (defmethod apply-color ((cc ccontext) (modifier (eql :on-click)) &rest args) (declare (ignore cc modifier args))) (defmethod apply-color ((cc ccontext) (modifier (eql :on-click-end)) &rest args) (declare (ignore cc modifier args))) (defun max-font-height (parts cc) "Return the biggest font height for all of the fonts occurring in PARTS in the form of (:FONT ...) modifiers." (font-height (cons (ccontext-font cc) (loop for part in parts if (and (listp part) (eq :font (first part))) collect (find-font cc (second part)))))) (defun reset-color-context (cc) (apply-color cc :fg) (apply-color cc :bright) (apply-color cc :bg) (apply-color cc :reverse) (apply-color cc :font)) (defun rendered-string-size (string-or-parts cc &optional (resetp t)) "Return the width and height needed to render STRING-OR-PARTS, a single-line string." (let* ((parts (if (stringp string-or-parts) (parse-color-string string-or-parts) string-or-parts)) (height (max-font-height parts cc)) (width 0)) (loop for part in parts if (stringp part) do (incf width (text-line-width (ccontext-font cc) part :translate #'translate-id)) else do (apply #'apply-color cc (first part) (rest part))) (if resetp (reset-color-context cc)) (values width height))) (defun rendered-size (strings cc) "Return the width and height needed to render STRINGS" (loop for string in strings for (width line-height) = (multiple-value-list (rendered-string-size string cc nil)) maximizing width into max-width summing line-height into height finally (progn (reset-color-context cc) (return (values max-width height))))) (defun render-string (string-or-parts cc x y &key ml &aux (draw-x x)) "Renders STRING-OR-PARTS to the pixmap in CC. Returns the height and width of the rendered line as two values. The returned width is the value of X plus the rendered width." (macrolet ((register (thing) `(let ((top ,thing)) (when top (register-ml-boundaries-with-id ml (first top) draw-x y (+ y y-to-center (font-ascent (ccontext-font cc))) (second top) (third top)))))) (let* ((parts (if (stringp string-or-parts) (parse-color-string string-or-parts) string-or-parts)) (height (max-font-height parts cc)) (current-on-click nil)) (loop for (part . rest) on parts for font-height-difference = (- height (font-height (ccontext-font cc))) for y-to-center = (floor (/ font-height-difference 2)) if (stringp part) do (draw-image-glyphs (ccontext-px cc) (ccontext-gc cc) (ccontext-font cc) draw-x (+ y y-to-center (font-ascent (ccontext-font cc))) part :translate #'translate-id :size 16) (incf draw-x (text-line-width (ccontext-font cc) part :translate #'translate-id)) else do (case (first part) ((:on-click) (when ml (push (list draw-x (cadr part) (cddr part)) current-on-click))) ((:on-click-end) (when ml (register (pop current-on-click)))) ((:>) (let ((xbeg (- (xlib:drawable-width (ccontext-px cc)) x (rendered-string-size rest cc)))) ;; Terminate all clickable areas as they cannot cross the :> ;; boundary. (when ml (loop for top = (pop current-on-click) while top do (register top))) (render-string rest cc xbeg y :ml ml)) (loop-finish)) (otherwise (apply #'apply-color cc (first part) (rest part))))) (values height draw-x)))) (defun render-strings (cc padx pady strings highlights &key ml) (let* ((gc (ccontext-gc cc)) (xwin (ccontext-win cc)) (px (ccontext-px cc)) (strings (mapcar (lambda (string) (if (stringp string) (parse-color-string string) string)) strings)) (y 0)) ;; Create a new pixmap if there isn't one or if it doesn't match the ;; window (when (or (not px) (/= (xlib:drawable-width px) (xlib:drawable-width xwin)) (/= (xlib:drawable-height px) (xlib:drawable-height xwin))) (if px (xlib:free-pixmap px)) (setf px (xlib:create-pixmap :drawable xwin :width (xlib:drawable-width xwin) :height (xlib:drawable-height xwin) :depth (xlib:drawable-depth xwin)) (ccontext-px cc) px)) ;; Clear the background (xlib:with-gcontext (gc :foreground (xlib:gcontext-background gc)) (xlib:draw-rectangle px gc 0 0 (xlib:drawable-width px) (xlib:drawable-height px) t)) (loop for parts in strings for row from 0 to (length strings) for line-height = (max-font-height parts cc) if (find row highlights :test 'eql) do (xlib:draw-rectangle px gc 0 (+ pady y) (xlib:drawable-width px) line-height t) (xlib:with-gcontext (gc :foreground (xlib:gcontext-background gc) :background (xlib:gcontext-foreground gc)) ;; If we don't switch the default colors, a color operation ;; resetting either color to its default value would undo the ;; switch. (rotatef (ccontext-default-fg cc) (ccontext-default-bg cc)) (render-string parts cc (+ padx 0) (+ pady y) :ml ml) (rotatef (ccontext-default-fg cc) (ccontext-default-bg cc))) else do (render-string parts cc (+ padx 0) (+ pady y) :ml ml) end do (incf y line-height)) (xlib:copy-area px gc 0 0 (xlib:drawable-width px) (xlib:drawable-height px) xwin 0 0) (reset-color-context cc) (values))) stumpwm-22.11/command.lisp000066400000000000000000000577241433701203600155600ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; implementation of commands ;; ;; Code: (in-package #:stumpwm) (export '(argument-line-end-p argument-pop argument-pop-or-read argument-pop-rest define-stumpwm-command defcommand defcommand-alias define-stumpwm-type run-commands %interactivep%)) (defstruct command-alias from to) (defstruct command name class args) (defvar *command-hash* (make-hash-table :test 'eq) "A list of interactive stumpwm commands.") (defvar *max-command-alias-depth* 10 "The maximum number of times an command alias is expanded before an Error is raised.") (define-condition command-docstring-warning (style-warning) ;; Don't define an accessor to prevent collision with the generic command ((command :initarg :command)) (:report (lambda (condition stream) (format stream "The command ~A doesn't have a docstring" (slot-value condition 'command))))) (defmacro defcommand (name (&rest args) (&rest interactive-args) &body body) "Create a command function and store its interactive hints in *command-hash*. The local variable %interactivep% can be used to check if the command was called interactively. If it is non-NIL then it was called from a keybinding or from the colon command. The NAME argument can be a string, or a list of two symbols. If the latter, the first symbol names the command, and the second indicates the type of group under which this command will be usable. Currently, tile-group, floating-group and dynamic-group are the possible values. INTERACTIVE-ARGS is a list of the following form: ((TYPE PROMPT) (TYPE PROMPT) ...) each element in INTERACTIVE-ARGS declares the type and prompt for the command's arguments. TYPE can be one of the following: @table @var @item :y-or-n A yes or no question returning T or NIL. @item :variable A lisp variable @item :function A lisp function @item :command A stumpwm command as a string. @item :key-seq A key sequence starting from *TOP-MAP* @item :window-number An existing window number @item :number An integer number @item :string A string @item :key A single key chord @item :window-name An existing window's name @item :direction A direction symbol. One of :UP :DOWN :LEFT :RIGHT @item :gravity A gravity symbol. One of :center :top :right :bottom :left :top-right :top-left :bottom-right :bottom-left @item :group An existing group @item :frame A frame @item :shell A shell command @item :rest The rest of the input yet to be parsed. @item :module An existing stumpwm module @item :rotation A rotation symbol. One of :CL, :CLOCKWISE, :CCL, OR :COUNTERCLOCKWISE @end table Note that new argument types can be created with DEFINE-STUMPWM-TYPE. PROMPT can be string. In this case, if the corresponding argument is missing from an interactive call, stumpwm will use prompt for its value using PROMPT. If PROMPT is missing or nil, then the argument is considered an optional interactive argument and is not prompted for when missing. Alternatively, instead of specifying nil for PROMPT or leaving it out, an element can just be the argument type." (check-type name (or symbol list)) (multiple-value-bind (body decls docstring) (parse-body body :documentation t) (let ((name (if (atom name) name (first name))) (group (if (atom name) t (second name)))) (unless docstring (make-condition 'command-docstring-warning :command name)) `(progn (defun ,name ,args ,@(when docstring (list docstring)) ,@decls (let ((%interactivep% *interactivep*) (*interactivep* nil)) (declare (ignorable %interactivep%)) (run-hook-with-args *pre-command-hook* ',name) (multiple-value-prog1 (progn ,@body) (run-hook-with-args *post-command-hook* ',name)))) (export ',name) (setf (gethash ',name *command-hash*) (make-command :name ',name :class ',group :args ',interactive-args)))))) (defmacro define-stumpwm-command (name (&rest args) &body body) "Deprecated. Use `defcommand' instead." (check-type name string) (setf name (intern1 name)) `(progn (defun ,name ,(mapcar 'car args) ,@body) (setf (gethash ',name *command-hash*) (make-command :name ',name :args ',(mapcar 'rest args))))) (defmacro defcommand-alias (alias original) "Since interactive commands are functions and can conflict with package symbols. But for backwards compatibility this macro creates an alias name for the command that is only accessible interactively." `(setf (gethash ',alias *command-hash*) (make-command-alias :from ',alias :to ',original))) (defun dereference-command-symbol (command) "Given a string or symbol look it up in the command database and return whatever it finds: a command, an alias, or nil." (maphash (lambda (k v) (when (string-equal k command) (return-from dereference-command-symbol v))) *command-hash*)) (defun command-active-p (command) (declare (special *dynamic-group-blacklisted-commands*)) (let* ((group (current-group)) (active (or (typep group (command-class command)) (some (lambda (f) (funcall f group command)) *custom-command-filters*)))) (if (typep (current-group) 'dynamic-group) (unless (member command *dynamic-group-blacklisted-commands*) active) active))) (defun get-command-structure (command &optional (only-active t)) "Return the command structure for COMMAND. COMMAND can be a string, symbol, command, or command-alias. By default only search active commands." (declare (type (or string symbol command command-alias) command)) (when (or (stringp command) (symbolp command)) (setf command (dereference-command-symbol command))) (when (command-alias-p command) (setf command (loop for c = (gethash (command-alias-to command) *command-hash*) then (gethash (command-alias-to c) *command-hash*) for depth from 1 until (or (null c) (command-p c)) when (> depth *max-command-alias-depth*) do (error "Maximum command alias depth exceeded.") finally (return c)))) (when (and command (or (not only-active) (command-active-p command))) command)) (defun all-commands (&optional (only-active t)) "Return a list of all interactive commands as strings. By default only return active commands." (let (acc) (maphash (lambda (k v) ;; make sure its an active command (when (get-command-structure v only-active) (push (string-downcase k) acc))) *command-hash*) (sort acc 'string<))) ;;; command arguments (defstruct argument-line string start) (defvar *command-type-hash* (make-hash-table) "A hash table of types and functions to deal with these types.") (defun argument-line-end-p (input) "Return T if we're outta arguments from the input line." (>= (argument-line-start input) (length (argument-line-string input)))) (defun argument-pop (input) "Pop the next argument off." (unless (argument-line-end-p input) (flet ((pop-word (input start) ;; Return the first word of INPUT starting from START and ;; its end position. (let* ((p1 (position #\space input :start start :test #'char/=)) (p2 (or (and p1 (position #\Space input :start p1)) (length input)))) ;; we wanna return nil if they're the same (unless (= p1 p2) (values (subseq input p1 p2) (1+ p2))))) (pop-string (input start) ;; Return a delimited string from INPUT starting from ;; START (if there is one) and the end position of the ;; string. (let ((start (loop for i from start below (length input) for char = (char input i) do (case char (#\space) ;Skip spaces (#\" (return (1+ i))) ;Start position found (otherwise (return-from pop-string nil)))))) (let ((str (make-string-output-stream))) (loop for i from start below (length input) for char = (char input i) do (case char (#\\ ;Escape next char (incf i) (if (< i (length input)) (write-char (char input i) str) (return nil))) (#\" ;End delimiter (return (values (get-output-stream-string str) (1+ i)))) (otherwise (write-char char str)))))))) (multiple-value-bind (arg end) (nth-value-or 0 (pop-string (argument-line-string input) (argument-line-start input)) (pop-word (argument-line-string input) (argument-line-start input))) (setf (argument-line-start input) end) arg)))) (defun argument-pop-or-read (input prompt &optional completions) (or (argument-pop input) (if completions (completing-read (current-screen) prompt completions) (read-one-line (current-screen) prompt)) (throw 'error :abort))) (defun argument-pop-rest (input) "Return the remainder of the argument text." (unless (argument-line-end-p input) (prog1 (subseq (argument-line-string input) (argument-line-start input)) (setf (argument-line-start input) (length (argument-line-string input)))))) (defun argument-pop-rest-or-read (input prompt &optional completions) (or (argument-pop-rest input) (if completions (completing-read (current-screen) prompt completions) (read-one-line (current-screen) prompt)) (throw 'error :abort))) (defmacro define-stumpwm-type (type (input prompt) &body body) "Create a new type that can be used for command arguments. @var{type} can be any symbol. When @var{body} is evaluated @var{input} is bound to the argument-line. It is passed to @code{argument-pop}, @code{argument-pop-rest}, etc. @var{prompt} is the prompt that should be used when prompting the user for the argument. @example \(define-stumpwm-type :symbol (input prompt) (or (find-symbol (string-upcase (or (argument-pop input) ;; Whitespace messes up find-symbol. (string-trim \" \" (completing-read (current-screen) prompt ;; find all symbols in the ;; stumpwm package. (let (acc) (do-symbols (s (find-package \"STUMPWM\")) (push (string-downcase (symbol-name s)) acc)) acc))) (throw 'error \"Abort.\"))) \"STUMPWM\") (throw 'error \"Symbol not in STUMPWM package\"))) \(defcommand \"symbol\" (sym) ((:symbol \"Pick a symbol: \")) (message \"~a\" (with-output-to-string (s) (describe sym s)))) @end example This code creates a new type called @code{:symbol} which finds the symbol in the stumpwm package. The command @code{symbol} uses it and then describes the symbol." `(setf (gethash ,type *command-type-hash*) (lambda (,input ,prompt) ,@body))) (define-stumpwm-type :y-or-n (input prompt) (let* ((positive-responses '("y" t)) (s (or (argument-pop input) (read-one-line (current-screen) (concat prompt "(y/n): "))))) (member s positive-responses :test #'equalp))) (defun lookup-symbol (string) ;; FIXME: should we really use string-upcase? (let* ((ofs (split-string string ":")) (pkg (if (> (length ofs) 1) (find-package (string-upcase (pop ofs))) *package*)) (var (string-upcase (pop ofs))) (ret (find-symbol var pkg))) (when (plusp (length ofs)) (throw 'error "Too many :'s")) (if ret (values ret pkg var) (throw 'error (format nil "No such symbol: ~a::~a." (package-name pkg) var))))) (define-stumpwm-type :variable (input prompt) (lookup-symbol (argument-pop-or-read input prompt))) (define-stumpwm-type :function (input prompt) (multiple-value-bind (sym pkg var) (lookup-symbol (argument-pop-or-read input prompt)) (if (fboundp sym) sym (throw 'error (format nil "The symbol ~A::~A is not bound to any function." (package-name pkg) var))))) (define-stumpwm-type :command (input prompt) (or (argument-pop input) (completing-read (current-screen) prompt (all-commands)))) (define-stumpwm-type :key-seq (input prompt) (labels ((update (seq) (message "~a ~{~a ~}" prompt (mapcar 'print-key (reverse seq))))) (let ((rest (argument-pop-rest input))) (or (and rest (parse-key-seq rest)) ;; read a key sequence from the user (with-focus (screen-key-window (current-screen)) (message "~a" prompt) (nreverse (nth-value 1 (read-from-keymap (top-maps) #'update)))))))) (define-stumpwm-type :window-number (input prompt) (when-let ((n (or (argument-pop input) (completing-read (current-screen) prompt (mapcar 'window-map-number (group-windows (current-group))))))) (if-let ((win (find n (group-windows (current-group)) :test #'string= :key #'window-map-number))) (window-number win) (throw 'error "No such window.")))) (defun parse-fraction (n) "Parse two integers separated by a / and divide the first by the second. " (multiple-value-bind (num i) (parse-integer n :junk-allowed t) (cond ((= i (length n)) num) ((char-equal (char n i) #\/) (/ num (parse-integer (subseq n (+ i 1))))) (t (error 'parse-error))))) (define-stumpwm-type :number (input prompt) (when-let ((n (or (argument-pop input) (read-one-line (current-screen) prompt)))) (handler-case (parse-fraction n) (parse-error (c) (declare (ignore c)) (throw 'error "Number required."))))) (define-stumpwm-type :string (input prompt) (or (argument-pop input) (read-one-line (current-screen) prompt))) (define-stumpwm-type :password (input prompt) (or (argument-pop input) (read-one-line (current-screen) prompt :password t))) (define-stumpwm-type :key (input prompt) (when-let ((s (or (argument-pop input) (read-one-line (current-screen) prompt)))) (kbd s))) (define-stumpwm-type :window-name (input prompt) (or (argument-pop input) (completing-read (current-screen) prompt (mapcar 'window-name (group-windows (current-group)))))) (define-stumpwm-type :direction (input prompt) (let* ((values '(("up" :up) ("down" :down) ("left" :left) ("right" :right))) (string (argument-pop-or-read input prompt (mapcar 'first values))) (dir (second (assoc string values :test 'string-equal)))) (or dir (throw 'error "No matching direction.")))) (define-stumpwm-type :gravity (input prompt) "Set the current window's gravity." (let* ((values '(("center" :center) ("top" :top) ("right" :right) ("bottom" :bottom) ("left" :left) ("top-right" :top-right) ("top-left" :top-left) ("bottom-right" :bottom-right) ("bottom-left" :bottom-left))) (string (argument-pop-or-read input prompt (mapcar 'first values))) (gravity (second (assoc string values :test 'string-equal)))) (or gravity (throw 'error "No matching gravity.")))) (defun select-group (screen query) "Attempt to match string QUERY against group number or partial name." (labels ((match-num (grp) (string-equal (group-map-number grp) query)) (match-whole (grp) (string-equal (group-name grp) query)) (match-partial (grp) (let* ((end (min (length (group-name grp)) (length query)))) (string-equal (group-name grp) query :end1 end :end2 end)))) (when query (or (find-if #'match-num (screen-groups screen)) (find-if #'match-whole (screen-groups screen)) (find-if #'match-partial (screen-groups screen)))))) (define-stumpwm-type :group (input prompt) (let ((match (select-group (current-screen) (or (argument-pop input) (completing-read (current-screen) prompt (mapcar 'group-name (screen-groups (current-screen)))))))) (or match (throw 'error "No such group.")))) (define-stumpwm-type :frame (input prompt) (declare (ignore prompt)) (if-let ((arg (argument-pop input))) (or (find arg (group-frames (current-group)) :key (lambda (f) (string (get-frame-number-translation f))) :test 'string=) (throw 'error "Frame not found.")) (or (choose-frame-by-number (current-group)) (throw 'error :abort)))) (define-stumpwm-type :shell (input prompt) (declare (ignore prompt)) (let ((prompt (format nil "~A -c " *shell-program*)) (*input-history* *input-shell-history*)) (unwind-protect (or (argument-pop-rest input) (completing-read (current-screen) prompt 'complete-program)) (setf *input-shell-history* *input-history*)))) (define-stumpwm-type :rest (input prompt) (or (argument-pop-rest input) (read-one-line (current-screen) prompt))) ;;; (defun call-interactively (command &optional (input "")) "Parse the command's arguments from input given the command's argument specifications then execute it. Returns a string or nil if user aborted." (declare (type (or string symbol) command) (type (or string argument-line) input)) ;; Catch parse errors (catch 'error (let* ((arg-line (if (stringp input) (make-argument-line :string input :start 0) input)) (cmd-data (or (get-command-structure command) (throw 'error (format nil "Command '~a' not found." command)))) (arg-specs (command-args cmd-data)) (args (loop for spec in arg-specs collect (let* ((type (if (listp spec) (first spec) spec)) (prompt (when (listp spec) (second spec))) (fn (gethash type *command-type-hash*))) (unless fn (throw 'error (format nil "Bad argument type: ~s" type))) ;; If the prompt is NIL then it's ;; considered an optional argument and ;; we shouldn't prompt for it if the ;; arg line is empty. (if (and (null prompt) (argument-line-end-p arg-line)) (loop-finish) (funcall fn arg-line prompt)))))) ;; Did the whole string get parsed? (unless (or (argument-line-end-p arg-line) (position-if 'alphanumericp (argument-line-string arg-line) :start (argument-line-start arg-line))) (throw 'error (format nil "Trailing garbage: ~{~A~^ ~}" (subseq (argument-line-string arg-line) (argument-line-start arg-line))))) ;; Success (prog1 (apply (command-name cmd-data) args) (setf *last-command* command))))) (defun eval-command (cmd &optional interactivep) "exec cmd and echo the result." (labels ((parse-and-run-command (input) (let* ((arg-line (make-argument-line :string input :start 0)) (cmd (argument-pop arg-line))) (let ((*interactivep* interactivep)) (call-interactively cmd arg-line))))) (multiple-value-bind (result error-p) ;; this fancy footwork lets us grab the backtrace from where the ;; error actually happened. (restart-case (handler-bind ((error (lambda (c) (invoke-restart 'eval-command-error (format nil "^B^1*Error In Command '^b~a^B': ^n~A~a" cmd c (if *show-command-backtrace* (backtrace-string) "")))))) (parse-and-run-command cmd)) (eval-command-error (err-text) :interactive (lambda () nil) (values err-text t))) ;; interactive commands update the modeline (update-all-mode-lines) (cond ((stringp result) (if error-p (message-no-timeout "~a" result) (message "~a" result))) ((eq result :abort) (unless *suppress-abort-messages* (message "Abort."))))))) (defun run-commands (&rest commands) "Run each stumpwm command in sequence. This could be used if you're used to ratpoison's rc file and you just want to run commands or don't know lisp very well. One might put the following in one's rc file: @example \(stumpwm:run-commands \"escape C-z\" \"exec firefox\" \"split\") @end example" (loop for i in commands do (eval-command i))) (defcommand colon (&optional initial-input) (:rest) "Read a command from the user. @var{initial-text} is optional. When supplied, the text will appear in the prompt. String arguments with spaces may be passed to the command by delimiting them with double quotes. A backslash can be used to escape double quotes or backslashes inside the string. This does not apply to commands taking :REST or :SHELL type arguments." (let ((cmd (completing-read (current-screen) ": " (all-commands) :initial-input (or initial-input "")))) (unless cmd (throw 'error :abort)) (when (plusp (length cmd)) (eval-command cmd t)))) stumpwm-22.11/configure.ac000066400000000000000000000033671433701203600155310ustar00rootroot00000000000000# -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_PREREQ(2.59) AC_INIT(Stump Window Manager, esyscmd(grep :version stumpwm.asd | cut -d\" -f2 | tr -d \\n), dbjergaard@gmail.com) AC_SUBST(MODULE_DIR) AC_SUBST(LISP_PROGRAM) AC_SUBST(LISP) AC_SUBST(COMPRESSION) AC_SUBST(STUMPWM_ASDF_DIR) # Checks for programs. AC_ARG_WITH(lisp, [ --with-lisp=IMPL use the specified lisp], LISP=$withval, LISP="sbcl") AC_ARG_WITH(module-dir, [ --with-module-dir=PATH specify location of contrib modules], MODULE_DIR=$withval, MODULE_DIR="${HOME}/.stumpwm.d/modules") AC_ARG_ENABLE(compression, [ --enable-compression use SBCL's core compression feature if available], COMPRESSION="t", COMPRESSION="nil") STUMPWM_ASDF_DIR="`pwd`" if test -x "$SBCL_PATH"; then SBCL=$SBCL_PATH AC_MSG_CHECKING([for sbcl]) AC_MSG_RESULT($SBCL) else AC_PATH_PROG([SBCL], sbcl,"") fi if test "x$LISP" = "xsbcl"; then LISP_PROGRAM=$SBCL if test -z "$SBCL_HOME"; then AC_MSG_WARN(SBCL_HOME must be defined to use asdf/quicklisp (it should be where your sbcl.core resides)) fi fi if test "x$LISP_PROGRAM" = "x"; then AC_MSG_ERROR([*** No lisp is available.]) fi AC_MSG_NOTICE([Using $LISP at $LISP_PROGRAM]) # check for makeinfo AC_CHECK_PROG(MAKEINFO,makeinfo,yes,no) if test "$MAKEINFO" = "no"; then AC_MSG_WARN([You do not seem to have makeinfo, so you will not be able to build the manuals. Please install makeinfo for the manual.]) elif test "$MAKEINFO" = "yes"; then MAKEINFO=makeinfo fi AC_SUBST([MAKEINFO]) AC_OUTPUT(Makefile) AC_OUTPUT(make-image.lisp) AC_OUTPUT(load-stumpwm.lisp) stumpwm-22.11/core.lisp000066400000000000000000000120211433701203600150470ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file contains core functionality including functions on ;; windows, screens, and events. ;; ;; Code: (in-package :stumpwm) (export '(grab-pointer ungrab-pointer)) ;;; keyboard helper functions (defun key-to-keycode+state (key) (let ((code (xlib:keysym->keycodes *display* (key-keysym key)))) (cond ((eq (xlib:keycode->keysym *display* code 0) (key-keysym key)) (values code (x11-mods key))) ((eq (xlib:keycode->keysym *display* code 1) (key-keysym key)) (values code (apply 'xlib:make-state-mask (cons :shift (xlib:make-state-keys (x11-mods key)))))) (t ;; just warn them and go ahead as scheduled (warn "Don't know how to encode ~s" key) (values code (x11-mods key)))))) (defun send-fake-key (win key) "Send a fake key press event to win." (let ((xwin (window-xwin win))) (multiple-value-bind (code state) (key-to-keycode+state key) (dolist (event '(:key-press :key-release)) (xlib:send-event xwin event (xlib:make-event-mask event) :display *display* :root (screen-root (window-screen win)) ;; Apparently we need these in here, though they ;; make no sense for a key event. :x 0 :y 0 :root-x 0 :root-y 0 :window xwin :event-window xwin :code code :state state))))) (defun xlib-fake-click (root-win xwin button) "Send a fake click (button press + button release) to xlib window" (multiple-value-bind (x y) (xlib:query-pointer xwin) (multiple-value-bind (rx ry) (xlib:query-pointer root-win) (mapc (lambda (btn) (xlib:send-event xwin (first btn) (xlib:make-event-mask (first btn)) :display *display* :root root-win :window xwin :event-window xwin :code button :state (second btn) :x x :y y :root-x rx :root-y ry :same-screen-p t)) '((:button-release 0) (:button-press #x100)))))) (defun send-fake-click (win button) "Send a fake click (button press + button release) to win." (cond #+clx-ext-test ((xlib:query-extension *display* "XTEST") (xtest:fake-button-event *display* button t) (xtest:fake-button-event *display* button nil)) (t (xlib-fake-click (screen-root (window-screen win)) (window-xwin win) button)))) ;;; Pointer helper functions (defun grab-pointer (screen) "Grab the pointer and set the pointer shape." (incf *grab-pointer-count*) (let* ((cursor-font (xlib:open-font *display* *grab-pointer-font*)) (cursor (xlib:create-glyph-cursor :source-font cursor-font :source-char *grab-pointer-character* :mask-font cursor-font :mask-char *grab-pointer-character-mask* :foreground *grab-pointer-foreground* :background *grab-pointer-background*))) (xlib:grab-pointer (screen-root screen) nil :owner-p nil :cursor cursor))) (defun ungrab-pointer () "Remove the grab on the cursor and restore the cursor shape." (when (> *grab-pointer-count* 0) (decf *grab-pointer-count*)) (when (eq *grab-pointer-count* 0) (xlib:ungrab-pointer *display*) (xlib:display-finish-output *display*))) (defun grab-keyboard (xwin) (let ((ret (xlib:grab-keyboard xwin :owner-p nil :sync-keyboard-p nil :sync-pointer-p nil))) (dformat 5 "vvv Grab keyboard: ~s~%" ret) ret)) (defun ungrab-keyboard () (let ((ret (xlib:ungrab-keyboard *display*))) (dformat 5 "^^^ Ungrab keyboard: ~s~%" ret) ret)) (defun warp-pointer (screen x y) "Move the pointer to the specified location." (let ((root (screen-root screen))) (xlib:warp-pointer root x y))) (defun warp-pointer-relative (dx dy) "Move the pointer by DX and DY relative to the current location." (xlib:warp-pointer-relative *display* dx dy)) stumpwm-22.11/debug.lisp000066400000000000000000000066111433701203600152150ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;;; Commentary: ;; ;; This file contains the code for debugging stumpwm. ;; ;;; Code: (in-package #:stumpwm) (defvar *debug-level* 0 "Set this variable to a number > 0 to turn on debugging. The greater the number the more debugging output.") (defvar *debug-expose-events* nil "Set this variable for a visual indication of expose events on internal StumpWM windows.") (defvar *debug-stream* (make-synonym-stream '*error-output*) "This is the stream debugging output is sent to. It defaults to *error-output*. It may be more convenient for you to pipe debugging output directly to a file.") (defun dformat (level fmt &rest args) (when (>= *debug-level* level) (multiple-value-bind (sec m h) (get-decoded-system-time) (format *debug-stream* "~2,'0d:~2,'0d:~2,'0d ~2,' d " h m sec level)) ;; strip out non base-char chars quick-n-dirty like (write-string (map 'string (lambda (ch) (if (typep ch 'standard-char) ch #\?)) (apply 'format nil fmt args)) *debug-stream*) (force-output *debug-stream*))) (defvar *redirect-stream* nil "This variable Keeps track of the stream all output is sent to when `redirect-all-output' is called so if it changes we can close it before reopening.") (defun redirect-all-output (file) "Elect to redirect all output to the specified file. For instance, if you want everything to go to ~/.stumpwm.d/debug-output.txt you would do: @example (redirect-all-output (data-dir-file \"debug-output\" \"txt\")) @end example " (when (typep *redirect-stream* 'file-stream) (close *redirect-stream*)) (setf *redirect-stream* (open file :direction :output :if-exists :append :if-does-not-exist :create) *error-output* *redirect-stream* *standard-output* *redirect-stream* *trace-output* *redirect-stream* *debug-stream* *redirect-stream*)) (defun rotate-log () (let ((log-filename (merge-pathnames "stumpwm.log" (data-dir))) (bkp-log-filename (merge-pathnames "stumpwm.log.1" (data-dir)))) (when (probe-file log-filename) (rename-file log-filename bkp-log-filename)))) (defun open-log () (rotate-log) (let ((log-filename (merge-pathnames "stumpwm.log" (data-dir)))) (setf *debug-stream* (open log-filename :direction :output :if-exists :supersede :if-does-not-exist :create)))) (defun close-log () (when (boundp '*debug-stream*) (close *debug-stream*) (makunbound '*debug-stream*))) stumpwm-22.11/dynamic-group.lisp000066400000000000000000001670241433701203600167130ustar00rootroot00000000000000;;;; DYNAMIC TILING GROUPS ;;; Maintainer: szos at posteo dot net ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;;; Commentary: ;;; Overview ;; This file implements dynamic tiling à la DWM, where windows are organized ;; into the master window and the window stack. There exists one master window ;; per head within a group. When a new window is added to a head within the ;; group, that heads master window is pushed onto that heads stack, and the new ;; window becomes the master window. ;;; Window Placement Policy ;; When a window is added to a dynamic group it must be determined which head to ;; place the window upon. This is controlled by the class allocated slot ;; head-placement-policy. It can either be a keyword of :FIRST through :FIFTH, ;; in which case the window is placed on that head, or the keyword ;; :CURRENT-FRAME, in which case the head of the current frame is selected. ;;; Overflow Policy ;; In the event that the head a window is to be placed upon is full, a window, ;; head, and group are chosen as backups. The chosen window is then moved to the ;; chosen head or, if that head is itself full, to the chosen group. The window ;; can be chosen by one of four keywords, :NEW-WINDOW, :MASTER-WINDOW, ;; :STACK-BEG, and :STACK-END. The head can be chosen by one of the keywords ;; :FIRST through :FIFTH, or :ANY and :ORDERED. :ANY uses the first empty head ;; it can find, while :ORDERED looks for the lowest numbered head. The group can ;; be chosen by any valid string. The group will be created if it does not ;; exist. ;;; Window Layouts ;; The location of the master window can be chosen on a global or per head ;; basis. The location can be chosen by one of four keywords, :LEFT :RIGHT :TOP ;; and :BOTTOM. Likewise, the amount of space given to the master window can ;; chosen on a global or per head basis. This is given as a number (fraction) ;; between zero and one exclusive representing the amount of the screen to give ;; to the master window. In practice it must be large enough that the master ;; window is not smaller than the minimum frame width/height and small enough ;; that the window stack is not smaller than the minimum frame width/height. ;;; Code: (in-package :stumpwm) (defmacro swap (a b) "Swap the values of A and B using PSETF." `(psetf ,a ,b ,b ,a)) ;; The window definition remains unchanged, as at its core it is a tile ;; window. All we do is add a single tag. (define-swm-class dynamic-window (tile-window) ((superfluous :initform nil :accessor superfluous-window-tag))) (defmethod print-swm-object ((object dynamic-window) stream) (format stream "DYNAMIC-WINDOW ~s #x~x" (window-name object) (window-id object))) (defmethod superfluous-window-p ((window dynamic-window)) (superfluous-window-tag window)) (defmethod superfluous-window-p ((window window)) nil) ;; Class definition is greatly changed. We track more things at the class level ;; instead of at the object level, and consolidate our layout information and ;; whatnot into an alist with heads as the keys. We also expand our overflow ;; policy to live at the class level and add a head placement policy to ;; determine where new windows should be placed. (define-swm-class dynamic-group (tile-group) (;; Class allocated slots (head-placement-policy :reader dynamic-group-head-placement-policy :initform :current-frame :allocation :class :documentation "Control which head new windows are placed upon. Valid values are :current-frame :first :second :third :fourth and :fifth") (overflow-policy :reader dynamic-group-overflow-policy :initform (list :stack-end :ordered ".Overflow") :allocation :class :documentation "Control which window goes where when a head/group cannot hold more windows. The CAR is which window to remove from the group. Possible values are :new-window :master-window :stack-end and :stack-beg The CADR is which head to move the window being removed to. Possible values are :any :ordered :first :second :third :fourth and :fifth. The CADDR is what group to move the window being removed to in the event that it cannot be placed on a head in the group. Possible values are any and all strings.") (master-layout :reader dynamic-group-master-layout :initform :left :allocation :class :documentation "The default layout of the master window and window stack. Valid values are :left :right :top and :bottom") (split-ratio :reader dynamic-group-default-split-ratio :initform 2/3 :allocation :class :documentation "The default ratio for the split between the master window and the window stack. Valid values are any number between zero and one exclusive.") ;; Object allocated slots (head-info-alist :accessor dynamic-group-head-info-alist :documentation "Alist with heads as keys containing information for each head. Calling ASSOC on this alist returns a list whose FIRST element is the head, SECOND is the layout of the frames, THIRD is the master frame, FOURTH is the the master window, FIFTH is the window stack frames, SIXTH is the window stack windows, and SEVENTH is the major split ratio.")) (:documentation "A group type that implements dynamic tiling à la DWM with a single master window and a window stack.")) (defmethod print-swm-object ((object dynamic-window) stream) (format stream "DYNAMIC-WINDOW ~s #x~x" (window-name object) (window-id object))) (defun dynamic-group-p (thing) (typep thing 'dynamic-group)) ;; We need an method after initialization in order to set up our head alist with ;; the heads present when the group is created. (defmethod initialize-instance :after ((group dynamic-group) &key &allow-other-keys) "Initialize information for all present heads for dynamic groups." (let ((heads (group-heads group))) (setf (dynamic-group-head-info-alist group) (loop for head in heads collect (list head ; key for the alist (dynamic-group-master-layout group) ; frame layout (car (head-frames group head)) ; default master frame nil ; no master window yet nil ; no window stack frames yet nil ; no window stack windows yet (dynamic-group-default-split-ratio group)))))) ;; We create some basic wrappers to get the information for a specific head and ;; to add the information for a new head all in one go. (defmethod dynamic-group-head-info ((group dynamic-group) head) "Return the list of information for HEAD in GROUP. This list contains in order the layout, master frame, the master window, and the window stack." (assoc head (dynamic-group-head-info-alist group))) ;; An anaphoric macro that exposes members of the information list for a ;; specific head. Specific names can be provided through the key arguments, and ;; key arguments are themselves the default names. (defmacro with-group-head-info ((group head &key layout split-ratio master-frame master-window stack-frames stack-windows) &body body) (with-gensyms (head-info) `(let ((,head-info (dynamic-group-head-info ,group ,head))) (symbol-macrolet ((,(or layout 'layout) (cadr ,head-info)) (,(or split-ratio 'split-ratio) (caddr (cddddr ,head-info))) (,(or master-frame 'master-frame) (caddr ,head-info)) (,(or master-window 'master-window) (cadddr ,head-info)) (,(or stack-frames 'stack-frames) (car (cddddr ,head-info))) (,(or stack-windows 'stack-windows) (cadr (cddddr ,head-info)))) ,@body)))) ;; We also need a writer method for a couple of the class allocated slots. These ;; should have the same name as our slot reader and should include a keyarg to ;; update all heads, and update all groups. If updating all heads we map over ;; the head alist. If updating all group heads we map over every group and ;; update their head alist. as such providing the keyarg update-all-group-heads ;; implies update-all-heads ;; Setf methods for the layout and split ratio slots, both head local and ;; global. The global methods take an optional argument specifying which heads ;; to update to the new value. All updated heads are retiled to immediately ;; reflect the changes. (defmethod (setf dynamic-group-master-layout) (new (group dynamic-group) &optional (update-heads :unset)) ;; Possible values for update-heads are :unset, :all, or :none (if (typep new 'keyword) (let ((old (slot-value group 'master-layout))) (setf (slot-value group 'master-layout) new) (unless (eql update-heads :none) (labels ((update-group (g) (if (eql update-heads :unset) (loop for info in (slot-value g 'head-info-alist) when (eql old (cadr info)) do (setf (cadr info) new) (dynamic-group-retile-head g (car info))) (loop for info in (slot-value g 'head-info-alist) do (setf (cadr info) new) (dynamic-group-retile-head g (car info)))))) (mapc #'update-group (remove-if-not #'dynamic-group-p (screen-groups (group-screen group))))))) (error "Expected a keyword but recieved ~A" new))) (defmethod (setf dynamic-group-default-split-ratio) (new (group dynamic-group) &optional (update-heads :unset)) (if (> 1 new 0) (let ((old (dynamic-group-default-split-ratio group))) (setf (slot-value group 'split-ratio) new) (unless (eql update-heads :none) (labels ((update-group (g) (if (eql update-heads :unset) (loop for info in (slot-value g 'head-info-alist) when (= old (caddr (cddddr info))) do (setf (caddr (cddddr info)) new) (dynamic-group-retile-head g (car info))) (loop for info in (slot-value g 'head-info-alist) do (setf (caddr (cddddr info)) new) (dynamic-group-retile-head g (car info)))))) (mapc #'update-group (remove-if-not #'dynamic-group-p (screen-groups (group-screen group))))))) (error "Expected a ratio between zero and one exclusive, but got ~A" new))) (defmethod (setf dynamic-group-head-layout) (new (group dynamic-group) head) (if (typep new 'keyword) (with-group-head-info (group head) (setf layout new) (dynamic-group-retile-head group head)) (error "Expected a keyword but recieved ~A" new))) (defmethod (setf dynamic-group-head-split-ratio) (new (group dynamic-group) head) (if (> 1 new 0) (with-group-head-info (group head) (setf split-ratio new) (dynamic-group-retile-head group head)) (error "Expected a ratio between zero and one exclusive, but got ~A" new))) (defmethod (setf dynamic-group-overflow-policy) (new (group dynamic-group)) (if (and (member (car new) '(:stack-end :stack-beg :new-window :master-window)) (member (cadr new) '(:any :ordered :first :second :third :fourth :fifth)) (stringp (caddr new))) (setf (slot-value group 'overflow-policy) new) (error "The list ~A is not a valid overflow policy." new))) (defmethod (setf dynamic-group-head-placement-policy) (new (group dynamic-group)) (if (member new '(:current-frame :first :second :third :fourth :fifth)) (setf (slot-value group 'head-placement-policy) new) (error "The value ~A is not a valid head placement policy." new))) (defmethod master-window-p ((group dynamic-group) head (window dynamic-window)) (with-group-head-info (group head) (eql window master-window))) (defmethod master-window-p (g h w) (declare (ignore g h w)) nil) (defmethod stack-window-p ((group dynamic-group) head (window dynamic-window)) (with-group-head-info (group head) (member window stack-windows))) (defmethod stack-window-p (g h w) (declare (ignore g h w)) nil) ;; Create methods for adding and removing heads from a group. These are needed ;; in order to make sure our head alist tracks new/removed heads. (defmethod group-add-head ((group dynamic-group) head) (let ((new-frame-num (find-free-frame-number group))) (setf (tile-group-frame-tree group) (insert-before (tile-group-frame-tree group) (copy-frame head) (head-number head))) ;; Set up the new association (let ((frame (tile-group-frame-head group head))) (setf (frame-number frame) new-frame-num) (push (list head (dynamic-group-master-layout group) frame nil nil nil (dynamic-group-default-split-ratio group)) (dynamic-group-head-info-alist group))))) (defmethod group-remove-head ((group dynamic-group) head) (group-sync-all-heads group) (let* ((windows (head-windows group head)) (frames-to-delete (tile-group-frame-head group head)) (list-of-frames-to-delete (if (atom frames-to-delete) (list frames-to-delete) (flatten frames-to-delete))) (group-frame-tree (tile-group-frame-tree group)) (new-frame? (member (tile-group-current-frame group) list-of-frames-to-delete)) (old-frame? (member (tile-group-last-frame group) list-of-frames-to-delete))) ;; Remove the current heads frames (setf (tile-group-frame-tree group) (delete frames-to-delete group-frame-tree)) ;; When the head removed holds the current frame, update it. (when new-frame? (setf (tile-group-current-frame group) (first (group-frames group)))) ;; When the head removed holds the last frame, update it. (when old-frame? (setf (tile-group-last-frame group) nil)) ;; Loop over all heads and attempt to place orphaned windows. (do ((heads (remove head (group-heads group)) (cdr heads))) ((not (and heads windows))) ;; place windows until none are left or head is full. (loop until (or (dynamic-group-head-full-p group (car heads)) (not windows)) do (dynamic-group-place-window group (car heads) (pop windows)))) ;; If any windows remain, move them to the overflow group. (let* ((g (third (dynamic-group-overflow-policy group))) (overflow (or (find-group (group-screen group) g) (gnewbg g)))) (do ((win windows (cdr win))) ((not win)) (move-window-to-group (car win) overflow))) ;; Finally, remove the head from the groups alist entry. (let ((alist (dynamic-group-head-info-alist group))) (setf (dynamic-group-head-info-alist group) (remove (assoc head alist) alist))))) (defun dynamic-group-head-full-p (group head) "Calculate the total number of frames a head can hold, and compare that with the number of windows to see if there is space for another window. " (assert (typep head 'head)) (with-group-head-info (group head) (let ((wincount (length stack-windows ;; (head-windows group head) ))) (>= wincount ; one window will be used for the master, so not >= (case layout ; (dynamic-group-head-layout group head) ;; Calculate minimum width and heigth of frames, use that to find how ;; many frames can fit in the window stack. Err on the side of caution ((:top :bottom) (floor (/ (frame-width head) (* 2 *min-frame-width*)))) ((:right :left) (floor (/ (frame-height head) (* 2 *min-frame-height*))))))))) (defun dynamic-group-head-main-split (group head) "Return the stack tree and the master frame for GROUP and HEAD." (let* ((fh (tile-group-frame-head group head))) (if (frame-p fh) (values nil fh) (with-group-head-info (group head) (case layout ((:top :left) (values (cadr fh) (car fh))) ((:bottom :right) (values (car fh) (cadr fh)))))))) (defun dynamic-group-head-final-frame (group head) "Return the last frame in the stack tree. for GROUP and HEAD." (let ((stack-tree (dynamic-group-head-main-split group head))) (labels ((get-final-frame (tree) (when tree (or (and (frame-p tree) tree) (get-final-frame (cadr tree)))))) (get-final-frame stack-tree)))) (defun dyn-split-frame (group frame how &optional (ratio 1/2)) "Split FRAME in 2 and return the new frame number if successful. Otherwise, return NIL. RATIO is a fraction to split by." (check-type how (member :row :column)) (let ((head (frame-head group frame))) ;; don't create frames smaller than the minimum size (when (or (and (eq how :row) (>= (frame-height frame) (* *min-frame-height* 2))) (and (eq how :column) (>= (frame-width frame) (* *min-frame-width* 2)))) (multiple-value-bind (f1 f2) (funcall (if (eq how :column) 'split-frame-h 'split-frame-v) group frame ratio) (setf (tile-group-frame-head group head) (if (atom (tile-group-frame-head group head)) (list f1 f2) (funcall-on-node (tile-group-frame-head group head) (lambda (tree) (substitute (list f1 f2) frame tree)) (lambda (tree) (unless (atom tree) (find frame tree)))))) (when (eq (tile-group-current-frame group) frame) (setf (tile-group-current-frame group) f1)) (setf (tile-group-last-frame group) f2) (values (frame-number f2) f1 f2))))) (define-condition dynamic-group-too-many-windows (error) ((dgtmw-group :initform nil :initarg :group :reader dgtmw-group)) (:report (lambda (c s) (format s "To many splits made in group ~A." (group-name (dgtmw-group c)))))) (defun dyn-split-frame-in-dir-with-frame (group frame dir &optional (ratio 1/2)) "Splits FRAME by RATIO, or signals an error." (multiple-value-bind (fnum f1 f2) (dyn-split-frame group frame dir ratio) (if fnum (progn (when (frame-window frame) (update-decoration (frame-window frame))) (show-frame-indicator group) (values fnum f1 f2)) (error 'dynamic-group-too-many-windows :group group)))) (defmethod group-add-window ((group dynamic-group) window &key frame raise &allow-other-keys) (cond ((typep window 'float-window) (call-next-method)) ((eq frame :float) (dynamic-mixins:replace-class window 'float-window) (float-window-align window) (sync-minor-modes window) (when raise (group-focus-window group window))) (t ; if were not dealing with a floating window (let ((head (choose-head-from-placement-policy group))) ;; keep all calls to change-class in the same place.x (dynamic-mixins:replace-class window 'dynamic-window) ;; (change-class window 'dynamic-window) (dynamic-group-add-window group head window) (sync-minor-modes window))))) (defmethod group-delete-window ((group dynamic-group) (window dynamic-window)) "Delete a dynamic window from a dynamic group. For floating windows we fall back to the behavior defined for tile groups." (let* ((head (window-head window)) (final-frame (dynamic-group-head-final-frame group head))) (labels ((dyn-remove-split (frame) ;; Remove the split without updating windows to the new size, as ;; thats done by SYNCHRONIZE-FRAMES-AND-WINDOWS (let ((tree (tile-group-frame-head group head))) (setf (tile-group-frame-head group head) (remove-frame tree frame))))) (with-group-head-info (group head) (cond ((superfluous-window-p window) ;; window was never placed and is going straight to the overflow ;; group. (setf (superfluous-window-tag window) nil)) ((eql window master-window) (cond ((cadr stack-windows) ; two+ stack windows (setf master-window (car stack-windows) stack-windows (cdr stack-windows)) (dyn-remove-split final-frame) (balance-frames-internal group (dynamic-group-head-main-split group head) nil) (synchronize-frames-and-windows group head) (focus-frame group master-frame)) ((car stack-windows) ; one stack window (let ((final-frame (dynamic-group-head-final-frame group head))) (setf master-window (car stack-windows) stack-windows nil) (dyn-remove-split final-frame) (setf master-frame (tile-group-frame-head group head)) (synchronize-frames-and-windows group head) (focus-frame group master-frame))) (t ; No stack windows (psetf master-window nil (frame-window master-frame) nil) (synchronize-frames-and-windows group head) (focus-frame group master-frame)))) ((member window stack-windows) ;; Because theres a stack window, we are assured that we have at ;; least two frames, and FINAL-FRAME will always return the stack ;; frame. (let ((fnum (frame-number (window-frame window)))) (setf stack-windows (remove window stack-windows)) (dyn-remove-split final-frame) (when-let ((tree (dynamic-group-head-main-split group head))) ;; Only balance the stack tree if theres a stack. (balance-frames-internal group tree nil)) (synchronize-frames-and-windows group head) (labels ((find-closest-frame (number frames &optional dif closest) ;; Find the frame with the closest number to NUMBER. (if frames (if (or (not dif) (> dif (- number (frame-number (car frames))))) (find-closest-frame number (cdr frames) (- number (frame-number (car frames))) (car frames)) (find-closest-frame number (cdr frames) dif closest)) closest))) (let ((frames (head-frames group head))) ;; Try to focus the most recently focused frame, unless its ;; been removed in which case find the closest frame number. (focus-frame group (or (find fnum frames :key #'frame-number) (find-closest-frame fnum frames) master-frame)))))) (t (error "Group ~A desynchronized on removal of window ~A" group window))))))) (defmethod choose-head-from-placement-policy ((group dynamic-group)) "Return the head to place new windows into according to the head placement policy of GROUP" (case (dynamic-group-head-placement-policy group) ((:current-frame) (frame-head group (tile-group-current-frame group))) ((:first :second :third :fourth :fifth) (if-let ((head (funcall (intern (symbol-name (dynamic-group-head-placement-policy group))) (group-heads group)))) head ;; If it doesnt exist, just give the final head, cause theyve specified a ;; head position beyond the end of the list of head. (lastcar (group-heads group)))) (otherwise (error "~A is not a valid head placement policy." (dynamic-group-head-placement-policy group))))) (defun dynamic-group-add-window (group head window) ;; Add a window to a dynamic group, on a specific head. This should only be ;; called with a dynamic group and dynamic window. (if (dynamic-group-head-full-p group head) (progn (message "Head ~A in group ~A is full" head group) (handle-head-overflow group head window)) (dynamic-group-place-window group head window)) ;; The LOOP and WHEN forms here could maybe be removed...? I think the syncing ;; of the frame windows is done by synchronize-frames-and-windows ;; (specifically by the call to maximize). And the frame-window of the ;; window-frame of the window will always be set, and the window should always ;; be raised. (loop for frame in (group-frames group) do (sync-frame-windows group frame)) (when (null (frame-window (window-frame window))) (frame-raise-window (window-group window) (window-frame window) window nil))) (labels ((initialize-group-head-master-stack-split (group head) ;; Create a split, setting the master and stack frame values for the ;; group and head appropriately. return the stack and master frames. (let ((frame (tile-group-frame-head group head))) (assert (frame-p frame)) (with-group-head-info (group head :split-ratio ratio) (multiple-value-bind (fnum f1 f2) (dyn-split-frame-in-dir-with-frame group frame (case layout ((:left :right) :column) ((:top :bottom) :row)) (case layout ((:left :top) ratio) ((:right :bottom) (- 1 ratio)))) (declare (ignore fnum)) ;; Ensure that the master frame always has the lowest frame number. (when (or (eql layout :right) (eql layout :bottom)) (swap (frame-number f1) (frame-number f2))) (macrolet ((select-frame (right-and-bottom left-and-top) ;; Because f1 and f2 can both be the master frame ;; depending upon our layout, we need a way of ;; consistently selecting the master frame and stack ;; frame here. So we use this local macro. `(if (or (eql layout :right) (eql layout :bottom)) ,right-and-bottom ,left-and-top))) (psetf master-frame (select-frame f2 f1) stack-frames (list (select-frame f1 f2))) ;; Return (values stack-frame master-frame) (select-frame (values f1 f2) (values f2 f1))))))) (add-stack-frame (group head) ;; Add a frame to the stack. We always add the frame to the end of the ;; stack, which effectively turns the frame tree into a list. (labels ((get-final-frame (tree) ;; run through the tree until we get a frame. (or (and (frame-p tree) tree) (get-final-frame (cadr tree))))) (with-group-head-info (group head) (let* ((fh (tile-group-frame-head group head)) (tree (case layout ((:top :left) (cadr fh)) ; get stack tree ((:bottom :right) (car fh)))) (frame-to-split (get-final-frame tree))) (dyn-split-frame-in-dir-with-frame group frame-to-split (case layout ((:left :right) :row) ((:top :bottom) :column)) split-ratio))))) (add-window-to-stack (group head window) ;; Push WINDOW onto the stack. This assumes there already is a windows ;; stack. (with-group-head-info (group head) (push window stack-windows)))) (defun dynamic-group-place-window (group head window) ;; This function should only be called when HEAD can accept WINDOW. This ;; function DOES NOT check for or protect against head/group overflow. (with-group-head-info (group head :layout head-layout :split-ratio ratio) (let ((head-frame-tree (tile-group-frame-head group head))) (if (frame-p head-frame-tree) ;; Then theres only one frame, and we need to check the number of ;; windows to see if we are adding the initial window or moving the ;; initial window to the stack. ;; TODO: This could be rewritten to not use case, and not depend on ;; the number of windows. (case (or (and master-window (length (cons master-window stack-windows))) 0) (0 ;; Initialize master window (psetf master-frame head-frame-tree master-window window ;; set up the single window and frame (window-frame window) head-frame-tree (frame-window head-frame-tree) window (group-current-window group) window) (update-decoration window) (raise-window window) (focus-frame group master-frame)) (1 (multiple-value-bind (stack master) ;; Create the master/stack split, set up the head info ;; alist. (initialize-group-head-master-stack-split group head) (declare (ignorable stack master)) (psetf stack-windows (list master-window) master-window window (group-current-window group) window) (synchronize-frames-and-windows group head) (raise-window window) (focus-frame group master-frame))) (otherwise (error "Group ~A head ~A has desynchronized." group head))) ;; Otherwise we already have a stack, so move master to the stack and ;; make WINDOW the new master. (progn (add-stack-frame group head) (add-window-to-stack group head master-window) (setf master-window window) (synchronize-frames-and-windows group head) (raise-window window) (let* ((fh (tile-group-frame-head group head)) (tree (case head-layout ((:top :left) (cadr fh)) ; get stack tree ((:bottom :right) (car fh))))) (balance-frames-internal group tree)))))))) (labels ((only-one (group head) ;; This is just a clone of the command ONLY, but it takes a group and a ;; head to work with instead of using the current ones. (with-group-head-info (group head) (let ((win master-window) (frame (copy-frame head))) (if (only-one-frame-p) (message "There's only one frame.") (progn (mapc (lambda (w) ;; windows in other frames disappear (unless (eq (window-frame w) (tile-group-current-frame group)) (hide-window w)) (setf (window-frame w) frame)) (remove-if (lambda (w) (typep w 'float-window)) (head-windows group head))) (setf (frame-window frame) win (tile-group-frame-head group head) frame (tile-group-current-frame group) frame) (focus-frame group frame) (if (frame-window frame) (update-decoration (frame-window frame)) (show-frame-indicator group)) (sync-frame-windows group (tile-group-current-frame group)))))))) (defun dynamic-group-retile-head (group head &optional retile-floats) "Retile a specific head within a group. If RETILE-FLOATS is T then place all floating windows onto the stack." (with-group-head-info (group head) (only-one group head) (let ((windows (reverse (cons master-window (if retile-floats (append (loop for w in (head-windows group head) when (float-window-p w) collect w) stack-windows) stack-windows))))) (setf master-window nil stack-windows nil) (loop with previous-floats = nil for window in windows do (when (float-window-p window) (push window previous-floats) (dynamic-mixins:replace-class window 'dynamic-window)) (dynamic-group-place-window group head window) finally (map nil #'sync-minor-modes window)) (focus-frame group (window-frame master-window)))))) ;;; Handle overflow of both heads and groups (defun head-overflow-generate-new-head-placement-list (group head) "Return a list of heads to try to place window(s) into, excluding HEAD." (destructuring-bind (w head-to-move-to g) (dynamic-group-overflow-policy group) (declare (ignore w g)) (case head-to-move-to ((:any) (remove head (copy-list (group-heads group)))) ((:ordered) (sort (remove head (copy-list (group-heads group))) #'< :key #'frame-number)) ((:first :second :third :fourth :fifth) (let* ((fn (intern (symbol-name head-to-move-to))) (new-head (funcall fn (copy-list (group-heads group))))) ;; Return the head as a list. (and head (not (eql head new-head)) (list new-head)))) (otherwise (error "Invalid head overflow policy for heads ~A" head-to-move-to))))) (defun handle-head-overflow (group head window) ;; This function should only be called when HEAD is full. ;; It should be called with the group were working in, the head we attempted ;; to place on, and the window we attempted to place. It is important that ;; WINDOW has not been placed. (let ((potential-heads (head-overflow-generate-new-head-placement-list group head)) (unplaced t)) (destructuring-bind (window-to-move h g) (dynamic-group-overflow-policy group) (declare (ignore h g)) (if potential-heads (with-group-head-info (group head) (loop for new-head in potential-heads unless (dynamic-group-head-full-p group new-head) return (progn (setf unplaced nil) (case window-to-move ((:new-window) (dynamic-group-place-window group new-head window)) ((:master-window) (let ((m master-window)) (group-delete-window group m) (dynamic-group-place-window group new-head m))) ((:stack-end) (let ((e (lastcar stack-windows))) (group-delete-window group e) (dynamic-group-place-window group new-head e))) ((:stack-beg) (let ((b (car stack-windows))) (group-delete-window group b) (dynamic-group-place-window group new-head b))) (otherwise (error "Invalid window section of overflow policy: ~A" window-to-move))))) (when unplaced (handle-group-overflow group head window))) (handle-group-overflow group head window))))) (defun handle-group-overflow (group head window) ;; Should be called with the group were working in, the head we attempted to ;; place on, and the window we attempted to place. (destructuring-bind (who-to-move h group-to-move-to) (dynamic-group-overflow-policy group) (declare (ignore h)) (let ((to-group (or (find-group (group-screen group) group-to-move-to) (gnewbg group-to-move-to)))) (with-group-head-info (group head) (case who-to-move ((:new-window) (setf (superfluous-window-tag window) t) (move-window-to-group window to-group)) ((:master-window) (move-window-to-group master-window to-group) (dynamic-group-place-window group head window)) ((:stack-end) (move-window-to-group (lastcar stack-windows) to-group) (dynamic-group-place-window group head window)) ((:stack-beg) (move-window-to-group (car stack-windows) to-group) (dynamic-group-place-window group head window)) (otherwise (error "Invalid window section of overflow policy: ~A" who-to-move))))))) ;;; General functions for managing windows ;; We need a function to synchronize the frame and window list. This function ;; should ensure that the window in position 0 resides in the frame in position ;; zero. (defmethod synchronize-frames-and-windows ((group dynamic-group) head) "Synchronize the frames and windows within a dynamic group. " (with-group-head-info (group head) (multiple-value-bind (l-stack-tree l-master-frame) (dynamic-group-head-main-split group head) (macrolet ((pop-frame (tree) ; We want to walk the tree but immitate (with-gensyms (a) ; popping off of a list. `(let ((,a ,tree)) (if (frame-p ,a) (prog1 ,a (setf ,tree nil)) (prog1 (car ,a) (setf ,tree (cadr ,tree)))))))) (let ((stack (list l-master-frame l-stack-tree)) (windows (cons master-window stack-windows))) ;; Loop through all windows and frames (master and stack) and ;; synchronize them. (if (and (car stack) (not (car windows))) (focus-frame group (car stack)) (do ((frame (pop-frame stack) (pop-frame stack)) (window (pop windows) (pop windows))) ((not (and frame window)) (and frame window)) (setf (frame-window frame) window (window-frame window) frame) (maximize-window window) (update-decoration window)))))))) ;; We need a function to swap a stack window with the master window, regardless ;; of its location in the stack. (defun swap-window-with-master (group head window) "exchange a window with the master window for a specific group and head." (with-group-head-info (group head) (unless (eq window master-window) (let ((mf (window-frame master-window))) (psetf master-window window ; set a new master window ;; put master in the same position in the window stack list (car (member window stack-windows)) master-window) (synchronize-frames-and-windows group head) (focus-frame group mf))))) ;; We need functions to rotate the windows within a group head. These should ;; move the first/last element of the stack to be the master, and move the ;; master to the last/first element. (defvar *rotation-focus-policy* :master-or-follow "A keyword determining what frame to focus after rotating the windows in a dynamic group. Valid values are: :PRESERVE, meaning to stay on the same frame :FOLLOW, meaning to follow the current window as it rotates :MASTER, meaning to always stay to the master :MASTER-OR-FOLLOW, meaning to stay on the master, or if initiating the rotation while focused on a stack window to follow that window.") (defmethod rotate-windows-forward ((group dynamic-group) head) "Rotate all windows forward, placing the master window on top of the stack." (with-group-head-info (group head) (when stack-windows ; only when theres a stack (let* ((slw (last stack-windows 2)) (lw (cdr slw)) (curframe (tile-group-current-frame group)) (curwin (group-current-window group)) (curwin-master-p (eq curwin master-window))) (if lw (progn (push master-window stack-windows) ; put master on the stack (setf (cdr slw) nil ; trim the final window from the stack master-window (car lw))) ; make the final window the master. (psetf (car slw) master-window ; otherwise exchange master and stack master-window (car slw))) (synchronize-frames-and-windows group head) (focus-frame group (case *rotation-focus-policy* ((:preserve) curframe) ((:follow) (window-frame curwin)) ((:master) (window-frame master-window)) ((:master-or-follow) (if curwin-master-p curframe (window-frame curwin))))))))) (defmethod rotate-windows-backward ((group dynamic-group) head) "Rotate all windows backwards, placing the master window at the end of the stack." (with-group-head-info (group head) (when stack-windows ; only when theres a stack (let* ((lw (last stack-windows)) (curframe (tile-group-current-frame group)) (curwin (group-current-window group)) (curwin-master-p (eq curwin master-window))) (setf (cdr lw) (list master-window) ; put master at the end of the stack master-window (pop stack-windows)) ; make the the stack top master (synchronize-frames-and-windows group head) (focus-frame group (case *rotation-focus-policy* ((:preserve) curframe) ((:follow) (window-frame curwin)) ((:master) (window-frame master-window)) ((:master-or-follow) (if curwin-master-p curframe (window-frame curwin))))))))) (defmethod rotate-stack-forward ((group dynamic-group) head) "Rotate the stack windows, moving the top of the stack to the bottom." (with-group-head-info (group head) (when (cdr stack-windows) (let* ((slw (last stack-windows 2)) (lw (cdr slw)) (curframe (tile-group-current-frame group)) (curwin (group-current-window group)) (curwin-master-p (eq curwin master-window))) (setf (cdr slw) nil stack-windows (cons (car lw) stack-windows)) (synchronize-frames-and-windows group head) (focus-frame group (case *rotation-focus-policy* ((:preserve) curframe) ((:follow) (window-frame curwin)) ((:master) (window-frame master-window)) ((:master-or-follow) (if curwin-master-p curframe (window-frame curwin))))))))) (defmethod rotate-stack-backward ((group dynamic-group) head) "Rotate the stack windows, moving the bottom of the stack to the top." (with-group-head-info (group head) (when (cdr stack-windows) (let* ((lw (last stack-windows)) (curframe (tile-group-current-frame group)) (curwin (group-current-window group)) (curwin-master-p (eq curwin master-window))) (psetf (cdr lw) (list (car stack-windows)) stack-windows (cdr stack-windows)) (synchronize-frames-and-windows group head) (focus-frame group (case *rotation-focus-policy* ((:preserve) curframe) ((:follow) (window-frame curwin)) ((:master) (window-frame master-window)) ((:master-or-follow) (if curwin-master-p curframe (window-frame curwin))))))))) (defmethod exchange-windows ((w1 dynamic-window) (w2 dynamic-window)) "Exchange dynamic windows in their respective frames. Does not move windows between groups." (let ((g1 (window-group w1)) (g2 (window-group w2)) (h1 (window-head w1)) (h2 (window-head w2))) (when (eq g1 g2) (if (eq h1 h2) ;; This is just a simple exchange of windows within a head (with-group-head-info (g1 h1) ;; Find which of the windows is master and which is stack, if any. (let* ((master (car (member master-window (list w1 w2)))) (stack (or (and master (member (car (remove master (list w1 w2))) stack-windows)) ;; If no master, then both windows are stack. ;; Track their locations so we can swap them (cons (member w1 stack-windows) (member w2 stack-windows))))) (if master (psetf master-window (car stack) (car stack) master-window) ;; otherwise neither of the windows is master (psetf (caar stack) (cadr stack) (cadr stack) (caar stack))) (synchronize-frames-and-windows g1 h1))) ;; We need to handle moving these between heads (with-group-head-info (g1 h1 :master-window m1 :stack-windows s1) (with-group-head-info (g2 h2 :master-window m2 :stack-windows s2) (if (eq m1 w1) (if (eq m2 w2) ;; Swapping both heads master windows (progn (psetf m1 w2 m2 w1) (pull-window w1 (window-frame w2)) (pull-window w2 (window-frame w1))) ;; Swapping master of head 1 with a stack window of head 2 (let ((stack (member w2 s2))) (psetf (car stack) w1 m1 (car stack)) (pull-window w1 (window-frame w2)) (pull-window w2 (window-frame w1)))) (if (eq m2 w2) ;; Swapping master of head 2 with a stack window of head 1 (let ((stack (member w1 s1))) (psetf (car stack) w2 m2 (car stack)) (pull-window w1 (window-frame w2)) (pull-window w2 (window-frame w1))) ;; Swapping a stack window of head 1 with stack window of ;; head 2 (let ((st1 (member w1 s1)) (st2 (member w2 s2))) (psetf (car st1) w2 (car st2) w1) (pull-window w1 (window-frame w2)) (pull-window w2 (window-frame w1))))) (synchronize-frames-and-windows g1 h1) (synchronize-frames-and-windows g2 h2))))))) (defun dynamic-group-float-window (window group) "Make WINDOW into a floating window. Stop managing it as a dynamic tiling window. " (if (typep window 'float-window) (message "Window ~A is already a floating window." window) (progn (group-delete-window group window) (dynamic-mixins:replace-class window 'float-window) ;; (change-class window 'float-window) (float-window-align window) (sync-minor-modes window) (focus-all window)))) (defun dynamic-group-unfloat-window (window group) "Make WINDOW into a dynamic window. " (if (typep window 'dynamic-window) (message "Window ~A is already a dynamic window." window) (progn (let ((head (window-head window))) (dynamic-mixins:replace-class window 'dynamic-window) ;; (change-class window 'dynamic-window) (dynamic-group-add-window group head window) (sync-minor-modes window))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Dynamic Group Commands ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *dynamic-group-blacklisted-commands* nil "A blacklist of commands for dynamic groups specifically.") ;; The above needed due to the class hierarchy. dynamic groups inherit from ;; tiling groups. Because the hierarchy is group -> tile-group -> dynamic-group, ;; all commands defined for tiling groups are valid in dynamic groups, even when ;; they shouldnt be. Changing the class hierarchy is a large change that could ;; break peoples configs, so it was decided to implement a blacklist instead of ;; changing the hierarchy to group -> tile-group -> manual-tile-group ;; |> dynamic-tile-group (defun dyn-blacklist-command (cmd &aux (command (get-command-structure cmd nil))) "Add CMD to the command blacklist for dynamic groups" (unless (member command *dynamic-group-blacklisted-commands*) (push command *dynamic-group-blacklisted-commands*))) (defun dyn-unblacklist-command (cmd &aux (command (get-command-structure cmd nil))) "Remove CMD to the command blacklist for dynamic groups" (setf *dynamic-group-blacklisted-commands* (remove command *dynamic-group-blacklisted-commands*))) (flet ((bl (&rest cmds) (loop for cmd in cmds do (dyn-blacklist-command cmd)))) ;; Due to the group class hierarchy the following tile-group commands must be ;; explicitly disabled for dynamic groups. (bl "expose" "hsplit" "vsplit" "hsplit-equally" "vsplit-equally" "remove-split" "remove" "only" "pull-window-by-number" "pull" "pull-marked")) (defcommand gnew-dynamic (name) ((:rest "Group name: ")) "Create a new dynamic group named NAME." (unless name (throw 'error :abort)) (add-group (current-screen) name :type 'dynamic-group)) (defcommand gnewbg-dynamic (name) ((:rest "Group name: ")) "Create a new dynamic group named NAME in the background." (unless name (throw 'error :abort)) (add-group (current-screen) name :type 'dynamic-group :background t)) (define-stumpwm-type :rotation-direction (input prompt) (let* ((values '(("Forward" :f) ("Backward" :b))) (string (argument-pop-or-read input prompt (mapcar 'first values))) (dir (second (assoc string values :test 'string-equal)))) (or dir (throw 'error (format nil "no direction matching ~A" string))))) (defcommand (rotate-windows dynamic-group) (direction) ((:rotation-direction "Direction: ")) "Rotate all windows in the current group and head forward (clockwise) or backward (counterclockwise)" (let* ((g (current-group)) (h (current-head g))) (case direction ((:f) (rotate-windows-forward g h)) ((:b) (rotate-windows-backward g h))))) (defcommand (rotate-stack dynamic-group) (direction) ((:rotation-direction "Direction: ")) "Rotate the stack windows in current group and head forward (clockwise) or backward (counterclockwise)" (let* ((g (current-group)) (h (current-head g))) (case direction ((:f) (rotate-stack-forward g h)) ((:b) (rotate-stack-backward g h))))) (defcommand (swap-windows tile-group) () () (let* ((f1 (progn (message "Select Window One") (choose-frame-by-number (current-group)))) (f2 (progn (message "Select Window Two") (choose-frame-by-number (current-group))))) (when (and f1 f2) (let ((w1 (frame-window f1)) (w2 (frame-window f2))) (if (and w1 w2) (exchange-windows w1 w2) (throw 'error (format nil "Frame ~A has no window" (or (and w1 f2) (and w2 f1))))))))) (define-stumpwm-type :dynamic-layout (input prompt) (let* ((values '(("Top" :top) ("Left" :left) ("Right" :right) ("Bottom" :bottom))) (string (argument-pop-or-read input prompt (mapcar #'first values))) (layout (second (assoc string values :test 'string-equal)))) (or layout (throw 'error (format nil "No layout matching ~A" string))))) (defcommand (change-layout dynamic-group) (layout) ((:dynamic-layout "Layout: ")) "Change the layout of the current head and group." (setf (dynamic-group-head-layout (current-group) (current-head)) layout)) (defcommand (change-split-ratio dynamic-group) (ratio) ((:number "Ratio: ")) "Change the size of the master window of the current head and group." (setf (dynamic-group-head-split-ratio (current-group) (current-head)) ratio)) (defcommand (change-default-layout dynamic-group) (layout &optional (update-heads :unset)) ((:dynamic-layout "Layout: ")) "Change the default layout for dynamic groups." (setf (dynamic-group-master-layout (current-group) update-heads) layout)) (defcommand (change-default-split-ratio dynamic-group) (ratio &optional (update-heads :unset)) ((:number "Ratio: ")) "Change the default size of the master window for dynamic groups." (setf (dynamic-group-default-split-ratio (current-group) update-heads) ratio)) (defcommand (retile dynamic-group) (&optional (retile-floats t)) ((:y-or-n "Retile floating windows? ")) "Force a retile of all windows." (dynamic-group-retile-head (current-group) (current-head) retile-floats)) (defcommand select-floating-window (&optional (fmt *window-format*) window-list) ((:rest)) "Select a floating window from a menu." (if-let ((windows (remove-if-not #'float-window-p (or window-list (sort-windows-by-number (group-windows (current-group))))))) (if-let ((window (select-window-from-menu windows fmt))) (group-focus-window (current-group) window) (throw 'error :abort)) (message "No Managed Floating Windows"))) (defcommand (exchange-with-master dynamic-group) () () (swap-window-with-master (current-group) (current-head) (current-window))) (defcommand (hnext dynamic-group) () () "Move focus to the next head in a dynamic group" (let* ((group (current-group)) (head (current-head)) (info-alist (dynamic-group-head-info-alist group)) (head-list (member (current-head) info-alist :key #'car)) (next-head (if (cdr head-list) ; get the next head to focus on (caadr head-list) (unless (eql head (caar head-list)) (caar head-list))))) (when next-head (if (head-windows group next-head) (focus-frame group (window-frame (with-group-head-info (group next-head) master-window))) (focus-frame group next-head))))) (defcommand (hprev dynamic-group) () () (let* ((group (current-group)) (head (current-head)) (info-alist (reverse (dynamic-group-head-info-alist group))) (head-list (member (current-head) info-alist :key #'car)) (next-head (if (cdr head-list) ; get the next head to focus on (caadr head-list) (unless (eql head (caar head-list)) (caar head-list))))) (when next-head (if (head-windows group next-head) (focus-frame group (window-frame (with-group-head-info (group next-head) master-window))) (focus-frame group next-head))))) (defcommand (fnext-in-head dynamic-group) () () (let ((group (current-group))) (focus-frame-after group (head-frames group (current-head))))) (defcommand (fprev-in-head dynamic-group) () () (let ((group (current-group))) (focus-frame-after group (reverse (head-frames group (current-head)))))) ;;; Dynamic group keybindings (defvar *dynamic-group-top-map* nil) (defvar *dynamic-group-root-map* nil "Commands specific to a dynamic group context hang from this keymap. It is available as part of the @dnf{prefix map} when the active group is a dynamic group.") (fill-keymap *dynamic-group-top-map* *escape-key* '*dynamic-group-root-map*) (fill-keymap *dynamic-group-root-map* (kbd "n") "rotate-windows forward" (kbd "p") "rotate-windows backward" (kbd "N") "rotate-stack forward" (kbd "P") "rotate-stack backward" (kbd "C-n") "fnext-in-head" (kbd "C-p") "fprev-in-head" (kbd "M-n") "hnext" (kbd "M-p") "hprev" (kbd "f") "fselect" (kbd "F") "curframe" (kbd "s") "swap-windows" (kbd "RET") "exchange-with-master") (pushnew '(dynamic-group *dynamic-group-top-map*) *group-top-maps*) stumpwm-22.11/dynamic-mixins/000077500000000000000000000000001433701203600161635ustar00rootroot00000000000000stumpwm-22.11/dynamic-mixins/README.md000066400000000000000000000043771433701203600174550ustar00rootroot00000000000000# dynamic-mixins Dynamic-mixins is for simple, dynamic class combination: ```lisp (in-package :dynamic-mixins) (defclass a () ()) (defclass b () ()) (defclass c () ()) (make-instance (mix 'a 'b)) ;; => # (let ((a (make-instance 'a))) (ensure-mix a 'b 'c) ;; => # (delete-from-mix a 'a) ;; => # (delete-from-mix a 'c)) ;; => # ``` This allows objects to be mixed and updated without manually defining many permutations. ## Dictionary * `MIX &rest classes`: This produces a "mix list", which is generally only useful for passing to `MAKE-INSTANCE`. Note: Order matters! This determines class precedence. * `ENSURE-MIX object &rest name-or-class`: Ensure that classes listed in `name-or-class` are part of `object`. This will create a new class and `CHANGE-CLASS object` if necessary. Note: Order matters! This determines class precedence. * `DELETE-FROM-MIX object &rest name-or-class`: Remove classes listed in `name-or-class` from the object's class. This will create a new class and `CHANGE-CLASS object` if necessary. However, `object` must be a `MIXIN-OBJECT` created by `(MAKE-INSTANCE (MIX ...) ...)` or `ENSURE-MIX`. Otherwise, nothing will be changed. ## Notes ### Order and Precedence Order matters; you are defining a new class which has the specified classes as direct superclasses. `ENSURE-MIX` *prepends* classes in the order specified. (Originally, it appended classes.) This is simply more useful in practice: ```lisp (defclass general-object () ()) (defclass specializing-mixin () ()) (defgeneric some-operation (x)) (defmethod some-operation (x) "Handle the general case" ...) (defmethod some-operation ((x specializing-mixin)) "Handle the case for SPECIALIZING-MIXIN" ...) (let ((x (make-instance 'general-object))) (ensure-mix x 'specializing-mixin) (some-operation x)) ``` If `SPECIALIZING-MIXIN` were appended, the method which specialized on it would never be called. In practice, this defeats the point. Therefore, mixins now get precedence. ### Errors Errors regarding precendence and circularity are now handled, or rather, causing such an error will not produce a nearly-unrecoverable situation. Now you will just get an error. stumpwm-22.11/dynamic-mixins/dynamic-mixins.asd000066400000000000000000000005771433701203600216160ustar00rootroot00000000000000(defpackage :dynamic-mixins.asdf (:use #:cl #:asdf)) (in-package :dynamic-mixins.asdf) (defsystem :dynamic-mixins :description "Simple dynamic class mixing without manual permutations" :author "Ryan Pavlik" :license "BSD-2-Clause" :version "0.0" :depends-on (:alexandria) :pathname "src" :serial t :components ((:file "package") (:file "dynamic-mixins"))) stumpwm-22.11/dynamic-mixins/src/000077500000000000000000000000001433701203600167525ustar00rootroot00000000000000stumpwm-22.11/dynamic-mixins/src/dynamic-mixins.lisp000066400000000000000000000060501433701203600225750ustar00rootroot00000000000000(in-package :dynamic-mixins) (defvar *dynamic-mix-classes* (make-hash-table :test 'equal)) (defclass mixin-class (standard-class) ((classes :initform nil :initarg :classes :accessor mixin-classes))) (defmethod sb-mop:validate-superclass ((class mixin-class) (super standard-class)) t) (defmethod print-object ((o mixin-class) stream) (with-slots (classes) o (print-unreadable-object (o stream :identity t) (format stream "~S ~S" (or (class-name o) 'mixin-class) (mapcar #'class-name classes))))) (defclass mixin-object () ()) (defstruct mix-list (list nil)) (defun %find-class (name-or-class) (etypecase name-or-class (symbol (find-class name-or-class)) (class name-or-class))) (defun %mix (object-or-class &rest class-list) "Create a MIX-LIST for MAKE-INSTANCE. The first element may be an instance; further elements must be class names or classes." (let ((class0 (typecase object-or-class (symbol (list (find-class object-or-class))) (mixin-object (slot-value (class-of object-or-class) 'classes)) (t (list (class-of object-or-class)))))) (make-mix-list :list (remove-duplicates (append (mapcar #'%find-class class-list) class0))))) (defun mix (&rest classes) (make-mix-list :list (remove-duplicates (mapcar #'%find-class classes)))) (defun set-superclasses (class list) (reinitialize-instance class :direct-superclasses list)) (defun define-mixin (mix-list) (let ((new-class (make-instance 'mixin-class :classes (mix-list-list mix-list)))) (handler-case (progn (set-superclasses new-class (list* (find-class 'mixin-object) (mix-list-list mix-list)))) (error (e) (set-superclasses new-class nil) (error e))) (setf (gethash (mix-list-list mix-list) *dynamic-mix-classes*) new-class))) (defun ensure-mixin (mix-list) (if (cdr (mix-list-list mix-list)) (if-let ((class (gethash (mix-list-list mix-list) *dynamic-mix-classes*))) class (define-mixin mix-list)) (car (mix-list-list mix-list)))) (defun ensure-mix (object &rest classes) (let ((new-class (ensure-mixin (apply #'%mix object classes)))) (change-class object new-class))) (defun delete-from-mix (object &rest classes) (if (typep object 'mixin-object) (let* ((classes (mapcar #'%find-class classes)) (old-classes (slot-value (class-of object) 'classes)) (new-classes (remove-if (lambda (x) (member (%find-class x) classes)) old-classes)) (new-class (if (cdr new-classes) (ensure-mixin (apply #'mix new-classes)) (car new-classes)))) (change-class object new-class)) object)) (defmethod make-instance ((items mix-list) &rest initargs &key &allow-other-keys) (apply #'make-instance (ensure-mixin items) initargs)) stumpwm-22.11/dynamic-mixins/src/package.lisp000066400000000000000000000003251433701203600212360ustar00rootroot00000000000000(defpackage :dynamic-mixins (:use #:cl #:alexandria) (:export #:mixin-class #:mixin-object #:mixin-classes #:ensure-mix #:delete-from-mix #:mix #:replace-class #:replace-class-in-mixin)) stumpwm-22.11/dynamic-window.lisp000066400000000000000000000040041433701203600170520ustar00rootroot00000000000000(in-package :stumpwm) (defvar *expose-n-max* 26 "Maximum number of windows to display in the expose") (defvar *expose-auto-tile-fn* 'expose-tile "Function to call to tile current windows.") (defun frame-area (frames) "Calculate the area of each frame and store the result in a list." (mapcar (lambda (f) (* (frame-width f) (frame-height f))) frames)) (defun recursive-tile (n group) "Find the largest (by area) frame in the group, split it in half vertically or horizontally depending on which is dimension is larger. Repeat until there is only one window left." (unless (<= n 1) (let* ((frames (group-frames group)) (areas (frame-area frames)) (idx (position (reduce #'max areas) areas)) (frame (nth idx frames)) (w (frame-width frame)) (h (frame-height frame))) (focus-frame group frame) (if (< w h) (vsplit) (hsplit))) (recursive-tile (- n 1) group))) (defun expose-tile (win &optional (group (current-group))) "First make only one frame, then recursively split the frame until there are no more hidden windows. Tiling is done by splitting in the direction that is widest, and choosing the frame that has the largest area." (declare (ignore win)) (let* ((windows (group-windows group)) (num-win (length windows))) ;; Only try to make this the only frame if it isn't already. (unless (only-one-frame-p) (only)) (recursive-tile (min *expose-n-max* num-win) group))) (defcommand expose () () "Automagically tile all windows and let the user select one, make that window the focus. Set the variable `*expose-auto-tile-fn*' to another tiling function if a different layout is desired. Set `*expose-n-max*' to the maximum number of windows to be displayed for choosing." (funcall *expose-auto-tile-fn* nil (current-group (current-screen))) ;; have the user select a window (unless (only-one-frame-p) (run-commands "fselect")) ;; maximize that window (only)) stumpwm-22.11/events.lisp000066400000000000000000000743601433701203600154410ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Event handling. ;; ;; Code: (in-package #:stumpwm) (export '(*button-state*)) ;;; Event handler functions (defparameter *event-fn-table* (make-hash-table) "A hash of event types to functions") (defvar *current-event-time* nil) (defmacro define-stump-event-handler (event keys &body body) (let ((event-slots (gensym))) (multiple-value-bind (body declarations docstring) (parse-body body :documentation t) `(setf (gethash ,event *event-fn-table*) (lambda (&rest ,event-slots &key ,@keys &allow-other-keys) (declare (ignore ,event-slots) ,@(cdar declarations)) ,@(when docstring (list docstring)) ,@body))))) ;;; Configure request (flet ((has-x (mask) (logbitp 0 mask)) (has-y (mask) (logbitp 1 mask)) (has-w (mask) (logbitp 2 mask)) (has-h (mask) (logbitp 3 mask)) (has-bw (mask) (logbitp 4 mask)) (has-stackmode (mask) (logbitp 6 mask))) (defun configure-managed-window (win x y width height stack-mode value-mask) ;; Grant the configure request but then maximize the window after the ;; granting. (when (or (has-w value-mask) (has-h value-mask) (has-stackmode value-mask)) ;; FIXME: I don't know why we need to clear the urgency bit ;; here, but the old code would anytime a resize or raise ;; request came in, so keep doing it. -sabetts (when (window-urgent-p win) (window-clear-urgency win))) (when (or (has-x value-mask) (has-y value-mask)) (group-move-request (window-group win) win x y :root)) (when (or (has-w value-mask) (has-h value-mask)) (group-resize-request (window-group win) win width height)) (when (has-stackmode value-mask) (group-raise-request (window-group win) win stack-mode)) ;; Just to be on the safe side, hit the client with a fake ;; configure event. The ICCCM says we have to do this at ;; certain times; exactly when, I've sorta forgotten. (update-configuration win)) (defun configure-unmanaged-window (xwin x y width height border-width value-mask) "Call this function for windows that stumpwm isn't managing. Basically just give the window what it wants." (xlib:with-state (xwin) (when (has-x value-mask) (setf (xlib:drawable-x xwin) x)) (when (has-y value-mask) (setf (xlib:drawable-y xwin) y)) (when (has-h value-mask) (setf (xlib:drawable-height xwin) height)) (when (has-w value-mask) (setf (xlib:drawable-width xwin) width)) (when (has-bw value-mask) (setf (xlib:drawable-border-width xwin) border-width))))) (define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) (dformat 3 "CONFIGURE REQUEST ~@{~S ~}~%" stack-mode window x y width height border-width value-mask) (if-let ((win (find-window window))) (configure-managed-window win x y width height stack-mode value-mask) (configure-unmanaged-window window x y width height border-width value-mask))) (define-stump-event-handler :configure-notify (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) (dformat 4 "CONFIGURE NOTIFY ~@{~S ~}~%" stack-mode window x y width height border-width value-mask) (when-let ((screen (find-screen window))) (let ((old-heads (screen-heads screen)) (new-heads (make-screen-heads screen (screen-root screen)))) (cond ((equalp old-heads new-heads) (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t) (t (dformat 1 "Updating Xrandr or Xinerama configuration for ~S.~%" screen) (if new-heads (progn (head-force-refresh screen new-heads) (update-mode-lines screen)) (dformat 1 "Invalid configuration! ~S~%" new-heads))))))) (define-stump-event-handler :map-request (parent send-event-p window) (unless send-event-p ;; This assumes parent is a root window and it should be. (dformat 3 "map request: ~a ~a ~a~%" window parent (find-window window)) (let ((screen (find-screen parent)) (win (find-window window)) (wwin (find-withdrawn-window window))) ;; only absorb it if it's not already managed (it could be iconic) (cond (win (dformat 1 "map request for mapped window ~a~%" win)) ((eq (xwin-type window) :dock) (when wwin (setf screen (window-screen wwin))) (dformat 1 "window is dock-type. attempting to place in mode-line.") (place-mode-line-window screen window) ;; Some panels are broken and only set the dock type after they map and withdraw. (when wwin (setf (screen-withdrawn-windows screen) (delete wwin (screen-withdrawn-windows screen)))) t) (wwin (restore-window wwin)) ((xlib:get-property window :_KDE_NET_WM_SYSTEM_TRAY_WINDOW_FOR) ;; Do nothing if this is a systray window (the system tray ;; will handle it, if there is one, and, if there isn't the ;; user doesn't want this popping up as a managed window ;; anyway. t) (t (xlib:with-server-grabbed (*display*) (let ((window (process-mapped-window screen window))) (group-raise-request (window-group window) window :map)))))))) (define-stump-event-handler :unmap-notify (send-event-p event-window window #|configure-p|#) ;; There are two kinds of unmap notify events: the straight up ;; ones where event-window and window are the same, and ;; substructure unmap events when the event-window is the parent ;; of window. (dformat 2 "UNMAP: ~s ~s ~a~%" send-event-p (not (xlib:window-equal event-window window)) (find-window window)) (unless (and (not send-event-p) (not (xlib:window-equal event-window window))) ;; if we can't find the window then there's nothing we need to ;; do. (when-let ((window (find-window window))) (if (plusp (window-unmap-ignores window)) (progn (dformat 3 "decrement ignores! ~d~%" (window-unmap-ignores window)) (decf (window-unmap-ignores window))) (withdraw-window window))))) (define-stump-event-handler :destroy-notify (send-event-p event-window window) (unless (or send-event-p (xlib:window-equal event-window window)) ;; Ignore structure destroy notifies and only ;; use substructure destroy notifiers. This way ;; event-window is the window's parent. (if-let ((win (or (find-window window) (find-withdrawn-window window)))) (destroy-window win) (when-let ((ml (find-mode-line-by-window window))) (destroy-mode-line ml))))) (defun read-from-keymap (kmaps &optional update-fn) "Read a sequence of keys from the user, guided by the keymaps, KMAPS and return the binding or nil if the user hit an unbound sequence. The Caller is responsible for setting up the input focus." (let* ((code-state (read-key-no-modifiers)) (code (car code-state)) (state (cdr code-state))) (handle-keymap kmaps code state nil nil update-fn))) (defun handle-keymap (kmaps code state key-seq grab update-fn) "Find the command mapped to the (code state) and return it." ;; KMAPS is a list of keymaps that may match the user's key sequence. (dformat 1 "Awaiting key ~a~%" kmaps) (let* ((key (code-state->key code state)) (key-seq (cons key key-seq)) (bindings (mapcar (lambda (m) (lookup-key m key)) (dereference-kmaps kmaps))) ;; if the first non-nil thing is another keymap, then grab ;; all the keymaps and recurse on them. If the first one is a ;; command, then we're done. (match (find-if-not 'null bindings))) (dformat 1 "key-press: ~S ~S ~S~%" key state match) (run-hook-with-args *key-press-hook* key key-seq match) (when update-fn (funcall update-fn key-seq)) (cond ((kmap-or-kmap-symbol-p match) (when grab (grab-pointer (current-screen))) (let* ((code-state (read-key-no-modifiers)) (code (car code-state)) (state (cdr code-state))) (unwind-protect (handle-keymap (remove-if-not 'kmap-or-kmap-symbol-p bindings) code state key-seq nil update-fn) (when grab (ungrab-pointer))))) (match (values match key-seq)) ((and (find key *help-keys* :key #'kbd :test 'equalp)) (apply 'display-bindings-for-keymaps (reverse (cdr key-seq)) (dereference-kmaps kmaps)) (values t key-seq)) (t (values nil key-seq))))) (defun top-maps (&optional (group (current-group))) "Return all top level keymaps that are active." (flet ((funcallable-or-kmap (thing) "determine if THING is a function, or if it is bound to a kmap. Used to determine whether or not to funcall a symbol or lookup the symbol to retrieve a kmap." (or (functionp thing) (and (symbolp thing) (not (and (boundp thing) (kmap-p (symbol-value thing)))) (fboundp thing))))) (append ;; The plain jane top map is first because that's where users are ;; going to throw in their universally accessible customizations ;; which we don't want groups or minor modes shadowing them. (list '*top-map*) ;; If a minor mode map element is a function or a symbol that does not denote ;; a keymap but is fbound, then funcall it with the group. Otherwise it ;; should be a kmap object or a symbol bound to a kmap object. (loop for map in *minor-mode-maps* if (funcallable-or-kmap map) append (funcall map group) else collect map) ;; lastly, group maps. Last because minor modes should be able to ;; shadow a group's default bindings. (cond ((typep group 'dynamic-group) (loop for i in *group-top-maps* when (and (not (eql (first i) 'tile-group)) (typep group (first i))) collect (second i))) (t (loop for i in *group-top-maps* when (typep group (first i)) collect (second i))))))) (defvar *current-key-seq* nil "The sequence of keys which were used to invoke a command, available within a command definition as a dynamic var binding. Commands may dispatch further based on the value in *current-key-seq*. See the REMAP-KEYS contrib module for a working use case.") (defvar *custom-key-event-handler* nil "A custom key event handler can be set in this variable, which will take precedence over the keymap based handler defined in the default :KEY-PRESS event handler.") (define-stump-event-handler :key-press (code state #|window|#) (labels ((get-cmd (code state) (with-focus (screen-key-window (current-screen)) (handle-keymap (top-maps) code state nil t nil)))) (unwind-protect (or (and *custom-key-event-handler* (funcall *custom-key-event-handler* code state)) ;; modifiers can sneak in with a race condition. so avoid that. (unless (is-modifier code) (multiple-value-bind (cmd key-seq) (get-cmd code state) (cond ((eq cmd t)) (cmd (unmap-message-window (current-screen)) (let ((*current-key-seq* key-seq)) (eval-command cmd t)) t) (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq))))))))))) (defun bytes-to-window (bytes) "Combine a list of 4 8-bit bytes into a 32-bit number. This is because ratpoison sends the rp_command_request window in 8 byte chunks." (logior (first bytes) (ash (second bytes) 8) (ash (third bytes) 16) (ash (fourth bytes) 24))) (defun handle-rp-commands (root) "Handle a ratpoison style command request." (labels ((one-cmd () (multiple-value-bind (win type format bytes-after) (xlib:get-property root :rp_command_request :end 4 :delete-p t) (declare (ignore type format)) (setf win (xlib::lookup-window *display* (bytes-to-window win))) (when (xlib:window-p win) (let* ((data (xlib:get-property win :rp_command)) (interactive-p (car data)) (cmd (map 'string 'code-char (nbutlast (cdr data))))) (declare (ignore interactive-p)) (eval-command cmd) (xlib:change-property win :rp_command_result (map 'list 'char-code "0TODO") :string 8) (xlib:display-finish-output *display*))) bytes-after))) (loop while (> (one-cmd) 0)))) (defun handle-stumpwm-commands (root) "Handle a StumpWM style command request." (let* ((win root) (screen (find-screen root)) (data (xlib:get-property win :stumpwm_command :delete-p t :result-type '(vector (unsigned-byte 8)))) (cmd (utf8-to-string data))) (let ((msgs (screen-last-msg screen)) (hlts (screen-last-msg-highlights screen)) (*executing-stumpwm-command* t)) (setf (screen-last-msg screen) '() (screen-last-msg-highlights screen) '()) (eval-command cmd) (xlib:change-property win :stumpwm_command_result (sb-ext:string-to-octets (format nil "~{~{~a~%~}~}" (nreverse (screen-last-msg screen)))) :string 8) (setf (screen-last-msg screen) msgs (screen-last-msg-highlights screen) hlts)) (xlib:display-finish-output *display*))) (defun maybe-set-urgency (window) (when (and (window-urgent-p window) (not (find window (screen-urgent-windows (window-screen window))))) (when (register-urgent-window window) (run-hook-with-args *urgent-window-hook* window)))) (defun safe-atom-name (n) "Return the name of the atom with atom-id N or nil if there isn't one." (handler-case (xlib:atom-name *display* n) (xlib:atom-error () nil))) (defun safe-bytes-to-atoms (list) "Return a list of atoms from list. Any number that cannot be converted to an atom is removed." (loop for p in list when (typep p '(unsigned-byte 29)) collect (safe-atom-name p))) (defun update-window-properties (window atom) (case atom (:wm_name (setf (window-title window) (xwin-name (window-xwin window))) ;; Let the mode line know about the new name. (update-all-mode-lines)) (:wm_normal_hints (setf (window-normal-hints window) (get-normalized-normal-hints (window-xwin window)) (window-type window) (xwin-type (window-xwin window))) (dformat 4 "new hints: ~s~%" (window-normal-hints window)) (window-sync window :normal-hints)) (:wm_hints (maybe-set-urgency window)) (:wm_class (setf (window-class window) (xwin-class (window-xwin window)) (window-res window) (xwin-res-name (window-xwin window)))) (:wm_window_role (setf (window-role window) (xwin-role (window-xwin window)))) (:wm_transient_for (setf (window-type window) (xwin-type (window-xwin window))) (window-sync window :type)) (:_NET_WM_STATE ;; Some clients put really big numbers in the list causing ;; atom-name to fail, so filter out anything that can't be ;; converted into an atom. (dolist (p (safe-bytes-to-atoms (xlib:get-property (window-xwin window) :_NET_WM_STATE))) (case p (:_NET_WM_STATE_FULLSCREEN ;; Client is broken and sets this property itself instead of sending a ;; client request to the root window. Try to make do. ;; FIXME: what about when properties are REMOVED? (update-fullscreen window 1))))))) (define-stump-event-handler :property-notify (window atom state) (dformat 2 "property notify ~s ~s ~s~%" window atom state) (case atom (:rp_command_request ;; we will only find the screen if window is a root window, which ;; is the only place we listen for ratpoison commands. (let* ((screen (find-screen window))) (when (and (eq state :new-value) screen) (handle-rp-commands window)))) (:stumpwm_command ;; RP commands are too weird and problematic, KISS. (let* ((screen (find-screen window))) (when (and (eq state :new-value) screen) (handle-stumpwm-commands window)))) (t (when-let ((window (find-window window))) (update-window-properties window atom))))) (define-stump-event-handler :mapping-notify (request start count) ;; We could be a bit more intelligent about when to update the ;; modifier map, but I don't think it really matters. (xlib:mapping-notify *display* request start count) (update-modifier-map) (sync-keys)) (define-stump-event-handler :selection-request (requestor property selection target time) (send-selection requestor property selection target time)) (define-stump-event-handler :selection-clear (selection) (setf (getf *x-selection* selection) nil)) (define-stump-event-handler :selection-notify (window property selection) (dformat 2 "selection-notify: ~s ~s ~s~%" window property selection) (when property (let* ((selection (or selection :primary)) (sel-string (utf8-to-string (xlib:get-property window property :type :utf8_string :result-type 'vector :delete-p t)))) (when (< 0 (length sel-string)) (setf (getf *x-selection* selection) sel-string) (run-hook-with-args *selection-notify-hook* sel-string))))) (defun find-message-window-screen (win) "Return the screen, if any, that message window WIN belongs." (dolist (screen *screen-list*) (when (xlib:window-equal (screen-message-window screen) win) (return screen)))) (defun draw-cross (screen window x y width height) (xlib:draw-line window (screen-frame-outline-gc screen) x y width height t) (xlib:draw-line window (screen-frame-outline-gc screen) x (+ y height) (+ x width) y)) (define-stump-event-handler :exposure (window x y width height count) (let (screen ml) (when (zerop count) (cond ((setf screen (find-screen window)) ;; root exposed (group-root-exposure (screen-current-group screen))) ((setf screen (find-message-window-screen window)) ;; message window exposed (if (plusp (screen-ignore-msg-expose screen)) (decf (screen-ignore-msg-expose screen)) (redraw-current-message screen))) ((setf ml (find-mode-line-by-window window)) (setf screen (mode-line-screen ml)) (redraw-mode-line ml t))) ;; Show the area. (when (and *debug-expose-events* screen) (draw-cross screen window x y width height))))) (define-stump-event-handler :reparent-notify (window parent) (let ((win (find-window window))) (when (and win (not (xlib:window-equal parent (window-parent win)))) ;; reparent it back (unless (eq (xlib:window-map-state (window-xwin win)) :unmapped) (incf (window-unmap-ignores win))) (xlib:reparent-window (window-xwin win) (window-parent win) 0 0)))) ;;; Fullscreen functions (defun activate-fullscreen (window) (dformat 2 "client requests to go fullscreen~%") (add-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN) (setf (window-fullscreen window) t) (focus-window window)) (defun deactivate-fullscreen (window) (setf (window-fullscreen window) nil) (dformat 2 "client requests to leave fullscreen~%") (remove-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN) (update-decoration window) (update-mode-lines (current-screen))) (defun update-fullscreen (window action) (let ((fullscreen-p (window-fullscreen window))) (case action (0 ; _NET_WM_STATE_REMOVE (when fullscreen-p (deactivate-fullscreen window))) (1 ; _NET_WM_STATE_ADD (unless fullscreen-p (activate-fullscreen window))) (2 ; _NET_WM_STATE_TOGGLE (if fullscreen-p (deactivate-fullscreen window) (activate-fullscreen window)))))) (defun maybe-map-window (window) (if (deny-request-p window *deny-map-request*) (unless *suppress-deny-messages* (if (eq (window-group window) (current-group)) (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window))) (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window)))))) (if (typep window 'tile-window) (frame-raise-window (window-group window) (window-frame window) window (eq (window-frame window) (tile-group-current-frame (window-group window)))) (raise-window window)))) (defun maybe-raise-window (window) (if (deny-request-p window *deny-raise-request*) (unless (or *suppress-deny-messages* ;; don't mention windows that are already visible (window-visible-p window)) (if (eq (window-group window) (current-group)) (echo-string (window-screen window) (format nil "'~a' denied raise request" (window-name window))) (echo-string (window-screen window) (format nil "'~a' denied raise request in group ~a" (window-name window) (group-name (window-group window)))))) (focus-all window))) (define-stump-event-handler :client-message (window type #|format|# data) (dformat 2 "client message: ~s ~s~%" type data) (case type (:_NET_CURRENT_DESKTOP ;switch desktop (let* ((screen (find-screen window)) (n (elt data 0)) (group (and screen (< n (length (screen-groups screen))) (elt (sort-groups screen) n)))) (when group (switch-to-group group)))) (:_NET_WM_DESKTOP ;move window to desktop (let* ((our-window (find-window window)) (screen (when our-window (window-screen our-window))) (n (elt data 0)) (group (and screen (< n (length (screen-groups screen))) (elt (sort-groups screen) n)))) (when (and our-window group) (move-window-to-group our-window group)))) (:_NET_ACTIVE_WINDOW (let ((our-window (find-window window)) (source (elt data 0))) (when our-window (if (= source 2) ;request is from a pager (focus-all our-window) (maybe-raise-window our-window))))) (:_NET_CLOSE_WINDOW (when-let ((our-window (find-window window))) (delete-window our-window))) (:_NET_WM_STATE (when-let ((our-window (find-window window)) (action (elt data 0)) (p1 (elt data 1)) (p2 (elt data 2))) (dolist (p (list p1 p2)) ;; Sometimes the number cannot be converted to an atom, so skip them. (unless (or (= p 0) (not (typep p '(unsigned-byte 29)))) (case (safe-atom-name p) (:_NET_WM_STATE_DEMANDS_ATTENTION (case action (1 (add-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION)) (2 (unless (find-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION) (add-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION)))) (maybe-set-urgency our-window)) (:_NET_WM_STATE_FULLSCREEN (update-fullscreen our-window action))))))) (:_NET_MOVERESIZE_WINDOW (when-let ((our-window (find-window window)) (x (elt data 1)) (y (elt data 2))) (dformat 3 "!!! Data: ~S~%" data) (group-move-request (window-group our-window) our-window x y :root))) (t (dformat 2 "ignored message~%")))) (define-stump-event-handler :focus-out (window mode kind) (dformat 5 "~@{~s ~}~%" window mode kind)) (define-stump-event-handler :focus-in (window mode kind) (let ((win (find-window window))) (when (and win (eq mode :normal) (not (eq kind :pointer))) (let ((screen (window-screen win))) (unless (eq win (screen-focus screen)) (setf (screen-focus screen) win)))))) ;;; Mouse focus (defun focus-all (win) "Focus the window, frame, group and screen belonging to WIN. Raise the window in it's frame." (when win (unmap-message-window (window-screen win)) (switch-to-screen (window-screen win)) (let ((group (window-group win))) (switch-to-group group) (group-focus-window (window-group win) win)))) (define-stump-event-handler :enter-notify (window mode) (when (and window (eq mode :normal) (eq *mouse-focus-policy* :sloppy)) (let ((win (find-window window))) (when (and win (find win (top-windows))) (focus-all win) (update-all-mode-lines))))) (defun decode-button-code (code) "Translate the mouse button number into a more readable format" (case code (1 :left-button) (2 :middle-button) (3 :right-button) (4 :wheel-up) (5 :wheel-down) (6 :wheel-left) (7 :wheel-right) (8 :browser-back) (9 :browser-front) (t code))) (defun scroll-button-keyword-p (button) "Checks if button keyword is generated from the scroll wheel." (or (eq button :wheel-down) (eq button :wheel-up) (eq button :wheel-left) (eq button :wheel-right))) (defvar *button-state* nil "Modifier state keys for button presses.") (define-stump-event-handler :button-press (window state code x y child time) (let ((button (decode-button-code code)) (screen (find-screen window)) (mode-line (find-mode-line-by-window window)) (*button-state* (xlib:make-state-keys state)) (win)) (run-hook-with-args *click-hook* screen code x y) (cond ((setf win (find-window window)) ;; We received the event at the parent window, but it occurred in ;; the window itself. We need to adjust the coordinates to make them ;; relative to the parent window. (setf x (+ x (xlib:drawable-x window)) y (+ y (xlib:drawable-y window)))) ((setf win (find-window-by-parent window (top-windows))) ;; The click happened on the parent window, so the coordinates are ;; correct. )) (cond ((and screen (not child)) (group-button-press (screen-current-group screen) button x y :root) (run-hook-with-args *root-click-hook* screen code x y)) (mode-line (run-hook-with-args *mode-line-click-hook* mode-line code x y)) (win (group-button-press (window-group win) button x y win)))) ;; Pass click to client (xlib:allow-events *display* :replay-pointer time)) (defun make-xlib-window (drawable) "For some reason the CLX xid cache screws up returns pixmaps when they should be windows. So use this function to make a window out of DRAWABLE." (xlib::make-window :id (xlib:drawable-id drawable) :display *display*)) (defun handle-event (&rest event-slots &key display event-key &allow-other-keys) (declare (ignore display)) (dformat 1 ">>> ~S~%" event-key) (let ((eventfn (gethash event-key *event-fn-table*)) (win (getf event-slots :window)) (*current-event-time* (getf event-slots :time))) (when eventfn ;; XXX: In sbcl clx libraries, sometimes what should be a window ;; will be a pixmap instead. In this case, we need to manually ;; translate it to a window to avoid breakage in stumpwm. So far ;; the only slot that seems to be affected is the :window slot ;; for configure-request and reparent-notify events. It appears ;; as though the hash table of XIDs and clx structures gets out ;; of sync with X or perhaps X assigns a duplicate ID for a ;; pixmap and a window. (when (and win (not (xlib:window-p win))) (dformat 10 "Pixmap Workaround! ~s should be a window!~%" win) (setf (getf event-slots :window) (make-xlib-window win))) (handler-case (progn ;; This is not the stumpwm top level, but if the restart ;; is in the top level then it seems the event being ;; processed isn't popped off the stack and is immediately ;; reprocessed after restarting to the top level. So fake ;; it, and put the restart here. (with-simple-restart (top-level "Return to stumpwm's top level") (apply eventfn event-slots)) (xlib:display-finish-output *display*)) ((or xlib:window-error xlib:drawable-error) (c) ;; Asynchronous errors are handled in the error handler. ;; Synchronous errors like trying to get the window hints on ;; a deleted window are caught and ignored here. We do this ;; inside the event handler so that the event is handled. If ;; we catch it higher up the event will not be flushed from ;; the queue and we'll get ourselves into an infinite loop. (dformat 4 "ignore synchronous ~a~%" c)))) (dformat 2 "<<< ~S~%" event-key) t)) stumpwm-22.11/fdump.lisp000066400000000000000000000221571433701203600152450ustar00rootroot00000000000000;; fdump.lisp -- Layout save and restore routines. ;; Copyright (C) 2007-2008 Jonathan Liles, Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; Code: (in-package #:stumpwm) (export '(ddump ddump-current ddump-screens dump-desktop-to-file dump-group-to-file dump-screen-to-file fdump fdump-current fdump-height fdump-number fdump-width fdump-windows fdump-x fdump-y gdump gdump-current gdump-name gdump-number gdump-tree place-existing-windows restore sdump sdump-current sdump-groups sdump-number)) (defstruct fdump number x y width height windows current) ;; group dump (defstruct gdump number name tree current) ;; screen dump (defstruct sdump number groups current) ;; desktop dump (defstruct ddump screens current) (defun dump-group (group &optional (window-dump-fn 'window-id)) (labels ((dump (f) (make-fdump :windows (mapcar window-dump-fn (frame-windows group f)) :current (and (frame-window f) (funcall window-dump-fn (frame-window f))) :number (frame-number f) :x (frame-x f) :y (frame-y f) :width (frame-width f) :height (frame-height f))) (copy (tree) (cond ((null tree) tree) ((typep tree 'frame) (dump tree)) (t (mapcar #'copy tree))))) (make-gdump ;; we only use the name and number for screen and desktop restores :number (group-number group) :name (group-name group) :tree (copy (tile-group-frame-tree group)) :current (frame-number (tile-group-current-frame group))))) (defun dump-screen (screen) (make-sdump :number (screen-id screen) :current (group-number (screen-current-group screen)) :groups (mapcar 'dump-group (sort-groups screen)))) (defun dump-desktop () (make-ddump :screens (mapcar 'dump-screen *screen-list*) :current (screen-id (current-screen)))) (defun dump-pathname (name) "Convert NAME to a pathname for dump data. If NAME is an absolute path, then it will be used as is. Otherwise, defaults to writing to \"FILE.dump\" in the XDG_DATA_HOME location." (if (uiop:absolute-pathname-p name) name (merge-pathnames (ensure-directories-exist (uiop:xdg-data-home #p"stumpwm/")) (make-pathname :type "dump" :name name)))) (defun dump-to-file (foo name) (with-open-file (fp (dump-pathname name) :direction :output :if-exists :supersede :if-does-not-exist :create) (with-standard-io-syntax (let ((*package* (find-package :stumpwm)) (*print-pretty* t)) (prin1 foo fp))))) (defcommand dump-group-to-file (file) ((:rest "Dump to file: ")) "Dumps the frames of the current group of the current screen to the named file. If FILE is an absolute path, then the dump will be read written there. Otherwise, defaults to writing to \"FILE.dump\" in the XDG_DATA_HOME location." (dump-to-file (dump-group (current-group)) file) (message "Group dumped.")) (defcommand-alias dump-group dump-group-to-file) (defcommand dump-screen-to-file (file) ((:rest "Dump to file: ")) "Dumps the frames of all groups of the current screen to the named file. If FILE is an absolute path, then the dump will be read written there. Otherwise, defaults to writing to \"FILE.dump\" in the XDG_DATA_HOME location." (dump-to-file (dump-screen (current-screen)) file) (message "Screen dumped.")) (defcommand-alias dump-screen dump-screen-to-file) (defcommand dump-desktop-to-file (file) ((:rest "Dump to file: ")) "Dumps the frames of all groups of all screens to the named file. If FILE is an absolute path, then the dump will be read written there. Otherwise, defaults to writing to \"FILE.dump\" in the XDG_DATA_HOME location." (dump-to-file (dump-desktop) file) (message "Desktop dumped.")) (defcommand-alias dump-desktop dump-desktop-to-file) ;;; (defun read-dump-from-file (file) (with-open-file (fp file :direction :input) (with-standard-io-syntax (let ((*package* (find-package :stumpwm))) (read fp))))) (defun restore-group (group gdump &optional auto-populate (window-dump-fn 'window-id)) (let ((windows (group-windows group))) (labels ((give-frame-a-window (f) (unless (frame-window f) (setf (frame-window f) (find f windows :key 'window-frame)))) (restore (fd) (let ((f (make-frame :number (fdump-number fd) :x (fdump-x fd) :y (fdump-y fd) :width (fdump-width fd) :height (fdump-height fd)))) ;; import matching windows (if auto-populate (choose-new-frame-window f group) (progn (dolist (w windows) (when (equal (fdump-current fd) (funcall window-dump-fn w)) (setf (frame-window f) w)) (when (find (funcall window-dump-fn w) (fdump-windows fd) :test 'equal) (setf (window-frame w) f))))) (when (fdump-current fd) (give-frame-a-window f)) f)) (copy (tree) (cond ((null tree) tree) ((typep tree 'fdump) (restore tree)) (t (mapcar #'copy tree))))) ;; clear references to old frames (dolist (w windows) (setf (window-frame w) nil)) (setf (tile-group-frame-tree group) (copy (gdump-tree gdump)) (tile-group-current-frame group) (find (gdump-current gdump) (group-frames group) :key 'frame-number)) ;; give any windows still not in a frame a frame (dolist (w windows) (unless (window-frame w) (setf (window-frame w) (tile-group-current-frame group)))) ;; FIXME: if the current window was blank in the dump, this does not honour that. (give-frame-a-window (tile-group-current-frame group)) ;; raise the curtains (dolist (w windows) (if (eq (frame-window (window-frame w)) w) (unhide-window w) (hide-window w))) (sync-all-frame-windows group) (focus-frame group (tile-group-current-frame group))))) (defun restore-screen (screen sdump) "Restore all frames in all groups of given screen. Create groups if they don't already exist." (dolist (gdump (sdump-groups sdump)) (restore-group (or (find-group screen (gdump-name gdump)) ;; FIXME: if the group doesn't exist then ;; windows won't be migrated from existing ;; groups (add-group screen (gdump-name gdump))) gdump))) (defun restore-desktop (ddump) "Restore all frames, all groups, and all screens." (dolist (sdump (ddump-screens ddump)) (let ((screen (find (sdump-number sdump) *screen-list* :key 'screen-id :test '=))) (when screen (restore-screen screen sdump))))) (defcommand restore-from-file (file) ((:rest "Restore from file: ")) "Restores screen, groups, or frames from named file, depending on file's contents. If FILE is an absolute path, then the dump will be read from there. Otherwise, defaults to reading from \"FILE.dump\" in the XDG_DATA_HOME location." (let ((dump (read-dump-from-file (dump-pathname file)))) (typecase dump (gdump (restore-group (current-group) dump) (message "Group restored.")) (sdump (restore-screen (current-screen) dump) (message "Screen restored.")) (ddump (restore-desktop dump) (message "Desktop restored.")) (t (message "Don't know how to restore ~a." dump))))) (defcommand-alias restore restore-from-file) (defcommand place-existing-windows () () "Re-arrange existing windows according to placement rules." (sync-window-placement)) (defcommand place-current-window () () "Re-arrange current window according to placement rules." (sync-single-window-placement (current-screen) (current-window) t)) stumpwm-22.11/floating-group.lisp000066400000000000000000000465101433701203600170660ustar00rootroot00000000000000;;; implementation of a floating style window management group (in-package #:stumpwm) ;;; floating window (define-swm-class float-window (window) ((last-width :initform 0 :accessor float-window-last-width) (last-height :initform 0 :accessor float-window-last-height) (last-x :initform 0 :accessor float-window-last-x) (last-y :initform 0 :accessor float-window-last-y))) (defmethod print-swm-object ((object float-window) stream) (write-string "FLOAT-" stream) (call-next-method)) (defvar *float-window-border* 1) (defvar *float-window-title-height* 10) (defvar *float-window-modifier* :super "The keyboard modifier to use for resize and move floating windows without clicking on the top border. Valid values are :META :ALT :HYPER :SUPER, :ALTGR and :NUMLOCK.") (defun float-window-p (window) (typep window 'float-window)) (defun float-window-modifier () "Convert the *FLOAT-WINDOW-MODIFIER* to its corresponding X11." (when-let ((fn (find-symbol (concat "MODIFIERS-" (symbol-name *float-window-modifier*)) (find-package "STUMPWM")))) (funcall fn *modifiers*))) ;; some book keeping functions (defmethod (setf window-x) :before (val (window float-window)) (setf (float-window-last-x window) (window-x window))) (defmethod (setf window-y) :before (val (window float-window)) (setf (float-window-last-y window) (window-y window))) (defmethod (setf window-width) :before (val (window float-window)) (setf (float-window-last-width window) (window-width window))) (defmethod (setf window-height) :before (val (window float-window)) (setf (float-window-last-height window) (window-height window))) (defun float-window-move-resize (win &key x y width height (border *float-window-border*)) ;; x and y position the parent window while width, height resize the ;; xwin (meaning the parent will have a larger width). (with-accessors ((xwin window-xwin) (parent window-parent)) win (xlib:with-state (parent) (xlib:with-state (xwin) (when x (setf (xlib:drawable-x parent) x (window-x win) x)) (when y (setf (xlib:drawable-y parent) y (window-y win) y)) (when width (setf (xlib:drawable-width parent) (+ (xlib:drawable-x xwin) width border) (xlib:drawable-width xwin) width (window-width win) width)) (when height (setf (xlib:drawable-height parent) (+ (xlib:drawable-y xwin) height border) (xlib:drawable-height xwin) height (window-height win) height)))))) (defmethod update-decoration ((window float-window)) (let ((group (window-group window))) (setf (xlib:window-background (window-parent window)) (if (eq (group-current-window group) window) (screen-float-focus-color (window-screen window)) (screen-float-unfocus-color (window-screen window)))) (xlib:clear-area (window-parent window)))) (defmethod window-sync ((window float-window) hint) (declare (ignore hint))) (defmethod window-head ((window float-window)) (let ((left (window-x window)) (right (+ (window-x window) (window-width window))) (top (window-y window)) (bottom (+ (window-y window) (window-height window))) (heads (screen-heads (group-screen (window-group window))))) (flet ((within-frame-p (y x head) (and (>= x (frame-x head)) (< x (+ (frame-x head) (1- (frame-width head)))) (>= y (frame-y head)) (< y (+ (frame-y head) (1- (frame-height head))))))) (or (find-if (lambda (head) (or (within-frame-p top left head) (within-frame-p top right head) (within-frame-p bottom left head) (within-frame-p bottom right head))) heads) ;; Didn't find any head, so give up and return the first one ;; in the list. (first heads))))) (defmethod window-visible-p ((win float-window)) (eql (window-state win) +normal-state+)) (defmethod (setf window-fullscreen) :after (val (window float-window)) (with-accessors ((last-x float-window-last-x) (last-y float-window-last-y) (last-width float-window-last-width) (last-height float-window-last-height) (parent window-parent)) window (if val (let ((head (window-head window))) (with-accessors ((x window-x) (y window-y) (width window-width) (height window-height)) window (format t "major on: ~a ~a ~a ~a~%" x y width height)) (set-window-geometry window :x 0 :y 0) (float-window-move-resize window :x (frame-x head) :y (frame-y head) :width (frame-width head) :height (frame-height head) :border 0) (format t "loot after: ~a ~a ~a ~a~%" last-x last-y last-width last-height)) (progn (format t "fullscreenage: ~a ~a ~a ~a~%" last-x last-y last-width last-height) ;; restore the position (set-window-geometry window :x *float-window-border* :y *float-window-title-height*) (float-window-move-resize window :x last-x :y last-y :width last-width :height last-height))))) (defmethod really-raise-window ((window float-window)) (raise-window window)) ;;; floating group (define-swm-class float-group (group) ((current-window :accessor float-group-current-window))) (defmethod print-swm-object ((object float-group) stream) (write-string "FLOAT-" stream) (call-next-method)) (defmethod group-startup ((group float-group))) (flet ((add-float-window (group window raise) (dynamic-mixins:replace-class window 'float-window) ;; (change-class window 'float-window) (float-window-align window) (sync-minor-modes window) (when raise (group-focus-window group window)))) (defmethod group-add-window ((group float-group) window &key raise &allow-other-keys) (add-float-window group window raise)) (defmethod group-add-window (group (window float-window) &key raise &allow-other-keys) (add-float-window group window raise))) (defun %float-focus-next (group) (let ((windows (remove-if 'window-hidden-p (group-windows group)))) (if windows (group-focus-window group (first windows)) (no-focus group nil)))) (defmethod group-delete-window ((group float-group) (window float-window)) (declare (ignore window)) (%float-focus-next group)) (defmethod group-wake-up ((group float-group)) (%float-focus-next group)) (defmethod group-suspend ((group float-group))) (defmethod group-current-head ((group float-group)) (if-let ((current-window (group-current-window group))) (window-head current-window) (multiple-value-bind (x y) (xlib:global-pointer-position *display*) (find-head-by-position (group-screen group) x y)))) (defun float-window-align (window) (with-accessors ((parent window-parent) (screen window-screen) (width window-width) (height window-height)) window (set-window-geometry window :x *float-window-border* :y *float-window-title-height*) (xlib:with-state (parent) (setf (xlib:drawable-width parent) (+ width (* 2 *float-window-border*)) (xlib:drawable-height parent) (+ height *float-window-title-height* *float-window-border*) (xlib:window-background parent) (xlib:alloc-color (xlib:screen-default-colormap (screen-number (window-screen window))) "Orange"))) (xlib:clear-area (window-parent window)) (let ((parent-x (xlib:drawable-x parent)) (parent-y (xlib:drawable-y parent)) (parent-width (xlib:drawable-width parent)) (parent-height (xlib:drawable-height parent)) (border (xlib:drawable-border-width parent)) (screen-width (screen-width screen)) (screen-height (screen-height screen))) ;; Resize window when borders outside screen (let ((diff-width (- (+ parent-x parent-width) (- screen-width (* 2 border)))) (diff-height (- (+ parent-y parent-height) (- screen-height (* 2 border))))) (when (or (> parent-x 0) (> parent-y 0)) (float-window-move-resize window :x parent-x :y parent-y)) (when (> diff-width 0) (float-window-move-resize window :width (- width diff-width))) (when (> diff-height 0) (float-window-move-resize window :height (- height diff-height))))))) (defmethod group-resize-request ((group float-group) window width height) (float-window-move-resize window :width width :height height)) (defmethod group-move-request ((group float-group) window x y relative-to) (declare (ignore relative-to)) (float-window-move-resize window :x x :y y)) (defmethod group-raise-request ((group float-group) window type) (declare (ignore type)) (group-focus-window group window)) (defmethod group-lost-focus ((group float-group)) (%float-focus-next group)) (defmethod group-indicate-focus ((group float-group))) (defmethod group-focus-window ((group float-group) window) (focus-window window)) (defmethod group-root-exposure ((group float-group))) (defmethod group-add-head ((group float-group) head) (declare (ignore head))) (defmethod group-remove-head ((group float-group) head) (declare (ignore head))) (defmethod group-replace-head (screen (group float-group) old-head new-head) (declare (ignore screen old-head new-head))) (defmethod group-before-resize-head ((group float-group) oh nh) (declare (ignore oh nh))) (defmethod group-after-resize-head ((group float-group) head) (declare (ignore head))) (defmethod group-sync-all-heads ((group float-group))) (defmethod group-sync-head ((group float-group) head) (declare (ignore head))) (defmethod group-adopt-orphaned-windows ((group float-group) &optional (screen (current-screen))) (let ((orphaned-frames (orphaned-frames screen))) (loop for window in (list-windows screen) when (member (window-frame window) orphaned-frames) do (group-add-window group window)))) (defvar *last-click-time* 0 "Time since the last click occurred") (defun window-display-height (window) "Returns maximum displayable height of window accounting for the mode-line" (let* ((head (window-head window)) (ml (head-mode-line head)) (ml-height (if (null ml) 0 (mode-line-height ml)))) (- (head-height head) ml-height (* 2 *normal-border-width*) *float-window-border* *float-window-title-height*))) (defun maximize-float (window &key horizontal vertical) (let* ((head (window-head window)) (ml (head-mode-line head)) (hx (head-x head)) (hy (if (null ml) 0 (mode-line-height ml))) (w (- (head-width head) (* 2 *normal-border-width*) (* 2 *float-window-border*))) (h (window-display-height window))) (when horizontal (float-window-move-resize window :width w)) (when vertical (float-window-move-resize window :y hy :height h)) (when (and horizontal vertical) (float-window-move-resize window :x hx :y hy)))) (defmethod group-button-press (group button x y (window float-window)) (declare (ignore button)) (let ((screen (group-screen group)) (initial-width (xlib:drawable-width (window-parent window))) (initial-height (xlib:drawable-height (window-parent window))) (initial-x (xlib:drawable-x (window-parent window))) (initial-y (xlib:drawable-y (window-parent window))) (xwin (window-xwin window))) (when (member *mouse-focus-policy* '(:click :sloppy)) (group-focus-window group window)) ;; When in border (multiple-value-bind (relx rely same-screen-p child state-mask) (xlib:query-pointer (window-parent window)) (declare (ignore same-screen-p child)) (when (or (< x (xlib:drawable-x xwin)) (> x (+ (xlib:drawable-width xwin) (xlib:drawable-x xwin))) (< y (xlib:drawable-y xwin)) (> y (+ (xlib:drawable-height xwin) (xlib:drawable-y xwin))) (intersection (float-window-modifier) (xlib:make-state-keys state-mask))) (when (find :button-1 (xlib:make-state-keys state-mask)) (let* ((current-time (/ (get-internal-real-time) internal-time-units-per-second)) (delta-t (- current-time *last-click-time*)) (win-focused-p (eq window (screen-focus screen)))) (setf *last-click-time* current-time) (when (< delta-t 0.25) (cond ((and (not (eq (window-height window) (window-display-height window))) win-focused-p) (maximize-float window :vertical t)) (win-focused-p (maximize-float window :vertical t :horizontal t)) (t (focus-window window t)))))) (multiple-value-bind (relx rely same-screen-p child state-mask) (xlib:query-pointer (window-parent window)) (declare (ignore same-screen-p child)) (let ((left-quadrant (< relx (floor initial-width 2))) (top-quadrant (< rely (floor initial-height 2)))) (dformat 4 "corner: left: ~a top: ~a~%" left-quadrant top-quadrant) ;; When resizing warp pointer to closest corner (when (find :button-3 (xlib:make-state-keys state-mask)) (xlib:warp-pointer (window-parent window) (if left-quadrant 0 initial-width) (if top-quadrant 0 initial-height))) (labels ((move-window-event-handler (&rest event-slots &key event-key &allow-other-keys) (case event-key (:button-release :done) (:motion-notify (with-accessors ((parent window-parent)) window (xlib:with-state (parent) ;; Either move or resize the window (cond ((find :button-1 (xlib:make-state-keys state-mask)) ;; if button-1 on the sides (left, ;; right, bottom) then we resize that ;; direction ;; if button-1 on the top, then we move the window (float-window-move-resize window :x (- (getf event-slots :x) relx) :y (- (getf event-slots :y) rely))) ((find :button-3 (xlib:make-state-keys state-mask)) (let ((w (if left-quadrant (- initial-width (- (getf event-slots :x) initial-x)) (- (getf event-slots :x) (xlib:drawable-x parent)))) (h (if top-quadrant (- initial-height (- (getf event-slots :y) initial-y)) (- (getf event-slots :y) (xlib:drawable-y parent) *float-window-title-height*))) ;; also move window when in top and/or left quadrant (x (if left-quadrant (getf event-slots :x) initial-x)) (y (if top-quadrant (getf event-slots :y) initial-y))) ;; Don't let the window become too small (float-window-move-resize window :x x :y y :width (max w *min-frame-width*) :height (max h *min-frame-height*))))))) t) ;; We need to eat these events or they'll ALL ;; come blasting in later. Also things start ;; lagging hard if we don't (on clisp anyway). (:configure-notify t) (:exposure t) (t nil)))) (xlib:grab-pointer (screen-root screen) '(:button-release :pointer-motion)) (unwind-protect ;; Wait until the mouse button is released (loop for ev = (xlib:process-event *display* :handler #'move-window-event-handler :timeout nil :discard-p t) until (eq ev :done)) (ungrab-pointer)) (update-configuration window) ;; don't forget to update the cache (setf (window-x window) (xlib:drawable-x (window-parent window)) (window-y window) (xlib:drawable-y (window-parent window))))))) ;; restore the mouse to its original position (xlib:warp-pointer (window-parent window) relx rely)))) (defmethod group-button-press ((group float-group) button x y where) (declare (ignore button x y where)) (when (next-method-p) (call-next-method))) ;;; Bindings (defvar *float-group-top-map* nil) (defvar *float-group-root-map* nil "Commands specific to a floating group context hang from this keymap. It is available as part of the @dnf{prefix map} when the active group is a float group.") (fill-keymap *float-group-top-map* *escape-key* '*float-group-root-map*) (fill-keymap *float-group-root-map* (kbd "n") "next" (kbd "p") "prev") (pushnew '(float-group *float-group-top-map*) *group-top-maps*) (defcommand gnew-float (name) ((:rest "Group name: ")) "Create a floating window group with the specified name and switch to it." (add-group (current-screen) name :type 'float-group)) (defcommand gnewbg-float (name) ((:rest "Group name: ")) "Create a floating window group with the specified name, but do not switch to it." (add-group (current-screen) name :background t :type 'float-group)) stumpwm-22.11/font-rendering.lisp000066400000000000000000000036021433701203600170450ustar00rootroot00000000000000 (in-package :stumpwm) (defgeneric font-exists-p (font)) (defgeneric open-font (display font)) (defgeneric close-font (font)) (defgeneric font-ascent (font)) (defgeneric font-descent (font)) (defgeneric font-height (font)) (defgeneric text-lines-height (font string)) (defgeneric text-line-width (font text &rest keys &key start end translate)) (defgeneric draw-image-glyphs (drawable gcontext font x y sequence &rest keys &key start end translate width size)) ;;;; X11 fonts (defmethod font-exists-p ((font-name string)) ;; if we can list the font then it exists (xlib:list-font-names *display* font-name :max-fonts 1)) (defmethod open-font ((display xlib:display) (font-name string)) (xlib:open-font display (first (xlib:list-font-names display font-name :max-fonts 1)))) (defmethod close-font ((font xlib:font)) (xlib:close-font font)) (defmethod font-ascent ((font xlib:font)) (xlib:font-ascent font)) (defmethod font-descent ((font xlib:font)) (xlib:font-descent font)) (defmethod font-height ((font xlib:font)) (+ (font-ascent font) (font-descent font))) (defmethod text-line-width ((font xlib:font) text &rest keys &key (start 0) end translate) (declare (ignorable start end translate)) (apply 'xlib:text-width font text keys)) (defmethod draw-image-glyphs (drawable gcontext (font xlib:font) x y sequence &rest keys &key (start 0) end translate width size) (declare (ignorable start end translate width size)) (setf (xlib:gcontext-font gcontext) font) (apply 'xlib:draw-image-glyphs drawable gcontext x y sequence keys)) (defmethod font-height ((fonts cons)) (loop for font in fonts maximizing (font-height font))) stumpwm-22.11/group.lisp000066400000000000000000000625331433701203600152700ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; All group related code resides here ;; ;; Code: (in-package #:stumpwm) (export '(current-group group-windows move-window-to-group add-group ;; Group accessors group group-screen group-windows group-number group-name ;; Group API group-startup group-add-window group-delete-window group-wake-up group-suspend group-current-window group-current-head group-resize-request group-move-request group-raise-request group-lost-focus group-indicate-focus group-focus-window group-button-press group-root-exposure group-add-head group-remove-head group-before-resize-head group-after-resize-head group-sync-all-heads group-sync-head)) (defvar *default-group-type* 'tile-group "The type of group that should be created by default.") (defvar *always-show-windows* () "The list of windows shown in all groups") ;;; The group API (defgeneric group-startup (group) (:documentation "Called on all groups while stumpwm is starting up.")) (defgeneric group-add-window (group window &key &allow-other-keys) (:documentation "Called when a window is added to the group. All house keeping is already taken care of. Only the group's specific window managing housekeeping need be done. This function accepts keys to inform the group on how to place the window.")) (defgeneric group-delete-window (group window) (:documentation "Called when a window is removed from thegroup. All house keeping is already taken care of. Only the group's specific window managing housekeeping need be done.")) (defgeneric group-wake-up (group) (:documentation "When the group becomes the current group, this function is called. This call is expected to set the focus.")) (defgeneric group-suspend (group) (:documentation "When the group is no longer the current group, this function is called.")) (defgeneric group-current-window (group) (:documentation "The group is asked to return its focused window.")) (defgeneric group-raised-window (group) (:documentation "The group is asked to return its topmost window.")) (defgeneric group-current-head (group) (:documentation "The group is asked to return its current head.")) (defgeneric group-resize-request (group window width height) (:documentation "The window requested a width and/or height change.")) (defgeneric group-move-request (group window x y relative-to) (:documentation "The window requested a position change.")) (defgeneric group-raise-request (group window type) (:documentation "A request has been made to raise the window. TYPE is the type of raise request being made. :MAP means the window has made requested to be mapped. :above means the window has requested to to be placed above its siblings.")) (defgeneric group-lost-focus (group) (:documentation "The current window was hidden or destroyed or something happened to it. So the group is asked to do something smart about it.")) (defgeneric group-indicate-focus (group) (:documentation "The group is asked to in some way show the user where the keyboard focus is.")) (defgeneric group-focus-window (group win) (:documentation "The group is asked to focus the specified window wherever it is.")) (defgeneric group-button-press (group button x y child) (:documentation "The user clicked somewhere in the group.")) (defgeneric group-root-exposure (group) (:documentation "The root window got an exposure event. If the group needs to redraw anything on it, this is where it should do it.")) (defgeneric group-add-head (group head) (:documentation "A head is being added to this group's screen.")) (defgeneric group-remove-head (group head) (:documentation "A head is being removed from this group's screen.")) (defgeneric group-replace-head (screen group old-head new-head) (:documentation "A head is being replaced by another on this group's screen.")) (defgeneric group-before-resize-head (group oh nh) (:documentation "A head is about to be resized on this group's screen.")) (defgeneric group-after-resize-head (group head) (:documentation "A head has been resized on this group's screen.")) (defgeneric group-sync-all-heads (group) (:documentation "Called when the head configuration for the group changes.")) (defgeneric group-sync-head (group head) (:documentation "When a head or its usable area is resized, this is called. When the modeline size changes, this is called.")) (defgeneric group-repack-frame-numbers (group) (:documentation "Repack frame numbers to range from zero to the number of frames such that there are no numerical gaps.")) (defgeneric group-adopt-orphaned-windows (group &optional screen) (:documentation "Adopts window that have been orphaned (such as being in a frame that no longer belongs to any group) into the given group, defaults to searching the current screen")) (define-swm-class group () ((screen :initarg :screen :accessor group-screen) (windows :initform nil :accessor group-windows) (current-window :initform nil :accessor group-current-window) (raised-window :initform nil :accessor group-raised-window) (number :initarg :number :accessor group-number) (name :initarg :name :accessor group-name) (on-top-windows :initform nil :accessor group-on-top-windows))) (defmethod print-swm-object ((object group) stream) (format stream "GROUP ~A" (ignore-errors (group-name object)))) (defmethod group-delete-window (group window) (when (find window *always-show-windows*) (disable-always-show-window window (current-screen))) (call-next-method)) (defun current-group (&optional (screen (current-screen))) "Return the current group for the current screen, unless otherwise specified." (screen-current-group screen)) (defun move-group-to-head (screen group) "Move window to the head of the group's window list." ;(assert (member window (screen-mapped-windows screen))) (move-to-head (screen-groups screen) group)) (defun sort-groups (screen) "Return a copy of the screen's group list sorted by number." (sort1 (screen-groups screen) '< :key 'group-number)) (defun group-map-number (group) (let* ((num (group-number group)) (index (1- (abs num)))) (if (and (>= index 0) (< index (length *group-number-map*))) (format nil "~:[~;-~]~a" (minusp num) (elt *group-number-map* index)) (princ-to-string num)))) (defun fmt-group-status (group) (let ((screen (group-screen group))) (cond ((eq group (screen-current-group screen)) #\*) ((and (typep (second (screen-groups screen)) 'group) (eq group (second (screen-groups screen)))) #\+) (t #\-)))) (defun find-free-group-number (screen) "Return a free group number in SCREEN." (find-free-number (mapcar 'group-number (screen-groups screen)) 1)) (defun find-free-hidden-group-number (screen) "Return a free hidden group number for SCREEN. Hidden group numbers start at -1 and go down." (find-free-number (mapcar 'group-number (screen-groups screen)) -1 :negative)) (defun non-hidden-groups (groups) "Return only those groups that are not hidden." (remove-if (lambda (g) (< (group-number g) 1)) groups)) (defun netwm-group-id (group) "netwm specifies that desktop/group numbers are contiguous and start at 0. Return a netwm compliant group id." (let ((screen (group-screen group))) (position group (sort-groups screen)))) (defun switch-to-group (new-group) (let* ((screen (group-screen new-group)) (old-group (screen-current-group screen))) (unless (eq new-group old-group) ;; restore the visible windows (dolist (w (group-windows new-group)) (when (eq (window-state w) +normal-state+) (xwin-unhide (window-xwin w) (window-parent w)))) ;; hide the old group's windows (dolist (w (reverse (group-windows old-group))) (when (eq (window-state w) +normal-state+) (xwin-hide w))) (setf (screen-current-group screen) new-group) (move-group-to-head screen new-group) ;; restore the focus (setf (screen-focus screen) nil) (group-wake-up new-group) (xlib:change-property (screen-root screen) :_NET_CURRENT_DESKTOP (list (netwm-group-id new-group)) :cardinal 32) (mapc (lambda (w) (xwin-unhide (window-xwin w) (window-parent w))) *always-show-windows*) (update-all-mode-lines) (run-hook-with-args *focus-group-hook* new-group old-group)))) (defun copy-window-to-group (group window) (setf (window-number window) (find-free-window-number group)) (push window (group-windows group)) (group-add-window group window)) (defun always-show-window (window screen) (let ((groups-to-add-w-to (remove (current-group) (screen-groups screen)))) (mapc (lambda (group) (copy-window-to-group group window)) groups-to-add-w-to)) (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP (list #xFFFFFFFF) :cardinal 32) (push window *always-show-windows*)) (defun disable-always-show-window (window screen) (let* ((g (current-group)) (groups-to-remove-w-from (remove g (screen-groups screen)))) (mapc (lambda (group) (setf (group-windows group) (remove window (group-windows group)))) groups-to-remove-w-from) (setf (window-group window) g (window-number window) (find-free-window-number g) *always-show-windows* (remove window *always-show-windows*)) (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP (list (netwm-group-id g)) :cardinal 32))) (defcommand toggle-always-show () () "Toggle whether the current window is shown in all groups." (let ((w (current-window)) (screen (current-screen))) (when w (if (find w *always-show-windows*) (disable-always-show-window w screen) (always-show-window w screen))))) (defun move-window-to-group (window to-group) (if (equalp to-group (window-group window)) (message "That window is already in the group ~a." (group-name to-group)) (labels ((really-move-window (window to-group) (unless (eq (window-group window) to-group) (hide-window window) ;; house keeping (setf (group-windows (window-group window)) (remove window (group-windows (window-group window)))) (group-delete-window (window-group window) window) (setf (window-group window) to-group (window-number window) (find-free-window-number to-group)) (push window (group-windows to-group)) (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP (list (netwm-group-id to-group)) :cardinal 32) (group-add-window to-group window)))) ;; When a modal window is moved, all the windows it shadows must be moved ;; as well. When a shadowed window is moved, the modal shadowing it must ;; be moved. (cond ((window-modal-p window) (mapc (lambda (w) (really-move-window w to-group)) (append (list window) (shadows-of window)))) ((modals-of window) (mapc (lambda (w) (move-window-to-group w to-group)) (modals-of window))) (t (really-move-window window to-group)))))) (defun next-group (current &optional (groups (non-hidden-groups (screen-groups (group-screen current))))) "Return the group following @var{current} in @var{groups}. If none are found return @code{NIL}." (let* ((matches (member current groups)) (next-group (if (null (cdr matches)) ;; If the last one in the list is current, then ;; use the first one. (car groups) ;; Otherwise, use the next one in the list. (cadr matches)))) (unless (eq next-group current) next-group))) (defun merge-groups (from-group to-group) "Merge all windows in FROM-GROUP into TO-GROUP." (dolist (window (group-windows from-group)) (move-window-to-group window to-group))) (defun netwm-group (window &optional (screen (window-screen window))) "Get the window's desktop property and return a matching group, if there exists one." (let ((id (first (xlib:get-property (window-xwin window) :_NET_WM_DESKTOP)))) (when (and id (< id (length (screen-groups screen)))) (elt (sort-groups screen) id)))) (defun netwm-set-group (window) "Set the desktop property for the given window." (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP (list (netwm-group-id (window-group window))) :cardinal 32)) (defun netwm-set-allowed-actions (window) (xlib:change-property (window-xwin window) :_NET_WM_ALLOWED_ACTIONS (mapcar (lambda (a) (xlib:intern-atom *display* a)) +netwm-allowed-actions+) :atom 32)) (defun netwm-update-group (group index) (dolist (w (group-windows group)) (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP (list index) :cardinal 32))) (defun netwm-update-groups (screen) "Update all windows to reflect a change in the group list." ;; FIXME: This could be optimized only to update windows when there ;; is a need. (loop for i from 0 for group in (sort-groups screen) do (netwm-update-group group i))) (defun netwm-set-group-properties (screen) "Set NETWM properties regarding groups of SCREEN. Groups are known as \"virtual desktops\" in the NETWM standard." (let ((root (screen-root screen))) ;; _NET_NUMBER_OF_DESKTOPS (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS (list (length (screen-groups screen))) :cardinal 32) (unless *initializing* ;; _NET_CURRENT_DESKTOP (xlib:change-property root :_NET_CURRENT_DESKTOP (list (netwm-group-id (screen-current-group screen))) :cardinal 32)) ;; _NET_DESKTOP_NAMES (xlib:change-property root :_NET_DESKTOP_NAMES (let ((names (mapcan (lambda (group) (list (sb-ext:string-to-octets (group-name group) :external-format :utf-8) '(0))) (sort-groups screen)))) (apply #'concatenate 'list names)) :UTF8_STRING 8))) (defun kill-group (group to-group) (unless (eq group to-group) (let ((screen (group-screen group))) (merge-groups group to-group) (setf (screen-groups screen) (remove group (screen-groups screen))) (netwm-update-groups screen) (netwm-set-group-properties screen)))) (defun %ensure-group (group-name group-type screen) "If there is a group named with GROUP-NAME in SCREEN return it, otherwise create it." (or (find-group screen group-name) (let ((group (make-swm-class-instance group-type :screen screen :number (if (char= (char group-name 0) #\.) (find-free-hidden-group-number screen) (find-free-group-number screen)) :name group-name))) (setf (screen-groups screen) (append (screen-groups screen) (list group))) (netwm-set-group-properties screen) (netwm-update-groups screen) group))) (defun add-group (screen name &key background (type *default-group-type*)) "Create a new group in SCREEN with the supplied name. group names starting with a . are considered hidden groups. Hidden groups are skipped by gprev and gnext and do not show up in the group listings (unless *list-hidden-groups* is T). They also use negative numbers." (check-type screen screen) (check-type name string) (assert (not (member name '("" ".") :test #'string=)) (name) "Groups must have a name.") (let ((group (%ensure-group name type screen))) (unless background (switch-to-group group)) (mapc (lambda (window) (copy-window-to-group group window)) *always-show-windows*) group)) (defun find-group (screen name) "Return the group with the name, NAME. Or NIL if none exists." (find name (screen-groups screen) :key 'group-name :test 'string=)) ;;; Group commands ;; FIXME: groups are to screens exactly as windows are to ;; groups. There is a lot of duplicate code that could be globbed ;; together. (defun group-forward (current list) "Switch to the next non-hidden-group in the list, if one exists. Returns the new group." (if-let ((next (next-group current (non-hidden-groups list)))) (progn (switch-to-group next) next) (message "No other group."))) (defun group-forward-with-window (current list) "Switch to the next group in the list, if one exists, and moves the current window of the current group to the new one." (when-let ((next (group-forward current list)) (win (group-current-window current))) (move-window-to-group win next) (focus-all win))) (defcommand gnew (name) ((:string "Group name: ")) "Create a new group with the specified name. The new group becomes the current group. If @var{name} begins with a dot (``.'') the group new group will be created in the hidden state. Hidden groups have group numbers less than one and are invisible to from gprev, gnext, and, optionally, groups and vgroups commands." (unless name (throw 'error :abort)) (add-group (current-screen) name)) (defcommand gnewbg (name) ((:string "Group name: ")) "Create a new group but do not switch to it." (unless name (throw 'error :abort)) (add-group (current-screen) name :background t)) (defcommand gnext () () "Cycle to the next group in the group list." (group-forward (current-group) (sort-groups (current-screen)))) (defcommand gprev () () "Cycle to the previous group in the group list." (group-forward (current-group) (reverse (sort-groups (current-screen))))) (defcommand gnext-with-window () () "Cycle to the next group in the group list, taking the current window along." (group-forward-with-window (current-group) (sort-groups (current-screen)))) (defcommand gprev-with-window () () "Cycle to the previous group in the group list, taking the current window along." (group-forward-with-window (current-group) (reverse (sort-groups (current-screen))))) (defcommand gother () () "Go back to the last group." (let ((groups (screen-groups (current-screen)))) (if (> (length groups) 1) (switch-to-group (second groups)) (message "No other group.")))) (defun %grename (name group) (let ((group-name (group-name group))) (cond ((and (starts-with #\. name) ; change to hidden group (not (starts-with #\. group-name))) (setf (group-number group) (find-free-hidden-group-number (current-screen)))) ((and (not (starts-with #\. name)) ; change from hidden group (starts-with #\. group-name)) (setf (group-number group) (find-free-group-number (current-screen)))))) (setf (group-name group) name)) (defcommand grename (name) ((:string "New name for group: ")) "Rename the current group." (cond ((find-group (current-screen) name) (message "^1*^BError: Name already exists.")) ((or (zerop (length name)) (string= name ".")) (message "^1*^BError: Name cannot be empty name.")) (t (%grename name (current-group))))) (defun echo-groups (screen fmt &optional verbose (wfmt *window-format*)) "Print a list of the windows to the screen." (let* ((groups (sort-groups screen)) (names (mapcan (lambda (g) (list* (format-expand *group-formatters* fmt g) (when verbose (mapcar (lambda (w) (format-expand *window-formatters* (concatenate 'string " " wfmt) w)) (sort-windows g))))) (if *list-hidden-groups* groups (non-hidden-groups groups))))) (echo-string-list screen names))) (defcommand groups (&optional (fmt *group-format*)) (:rest) "Display the list of groups with their number and name. @var{*group-format*} controls the formatting. The optional argument @var{fmt} can be used to override the default group formatting." (echo-groups (current-screen) fmt)) (defcommand vgroups (&optional gfmt wfmt) (:string :rest) "Like @command{groups} but also display the windows in each group. The optional arguments @var{gfmt} and @var{wfmt} can be used to override the default group formatting and window formatting, respectively." (echo-groups (current-screen) (or gfmt *group-format*) t (or wfmt *window-format*))) (defcommand gselect (&optional to-group) (:rest) "Accepts numbers to select a group, otherwise grouplist selects." (if-let ((to-group (when to-group (select-group (current-screen) to-group)))) (switch-to-group to-group) (grouplist))) (defcommand grouplist (&optional (fmt *group-format*)) (:rest) "Allow the user to select a group from a list, like windowlist for groups." (when-let ((group (second (select-from-menu (current-screen) (mapcar (lambda (g) (list (format-expand *group-formatters* fmt g) g)) (screen-groups (current-screen))))))) (switch-to-group group))) (defcommand gmove (to-group) ((:group "To group: ")) "Move the current window to the specified group." (when (and to-group (current-window)) (move-window-to-group (current-window) to-group))) (defcommand gmove-and-follow (to-group) ((:group "To group: ")) "Move the current window to the specified group, and switch to it." (let ((window (current-window))) (gmove to-group) (switch-to-group to-group) (when window (really-raise-window window)))) (defcommand gmove-marked (to-group) ((:group "To group: ")) "move the marked windows to the specified group." (when to-group (let ((group (current-group))) (dolist (i (marked-windows group)) (setf (window-marked i) nil) (move-window-to-group i to-group))))) (defcommand gkill () () "Kill the current group. All windows in the current group are migrated to the next group." (let* ((dead-group (current-group)) (groups (screen-groups (current-screen))) ;; If no "visible" group is found, try with all groups (to-group (or (next-group dead-group (non-hidden-groups groups)) (next-group dead-group groups)))) (if to-group (if (or (not %interactivep%) (not (group-windows dead-group)) (y-or-n-p (format nil "You are about to kill non-empty group \"^B^3*~a^n\" The windows will be moved to group \"^B^2*~a^n\" ^B^6*Confirm?^n " (group-name dead-group) (group-name to-group)))) (let ((dead-group-name (group-name dead-group))) (switch-to-group to-group) (kill-group dead-group to-group) (message "Deleted ~a." dead-group-name)) (message "Canceled.")) (message "There's only one group left.")))) (defcommand gkill-other () () "Kill other groups. All windows in other groups are migrated to the current group." (let* ((current-group (current-group)) (groups (remove current-group (screen-groups (current-screen))))) (if (null groups) (message "No other groups.") (progn (dolist (dead-group groups) (kill-group dead-group current-group)) (message "Killed other groups."))))) (defcommand gmerge (from) ((:group "From group: ")) "Merge @var{from} into the current group. @var{from} is not deleted." (if (eq from (current-group)) (message "^B^3*Cannot merge group with itself!") (merge-groups from (current-group)))) stumpwm-22.11/head.lisp000066400000000000000000000225361433701203600150340ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Head functionality ;; ;; Code: (in-package #:stumpwm) (export '(current-head)) (defun head-by-number (screen n) (find n (screen-heads screen) :key 'head-number)) (defun screen-info-head (screen-info) "Transform SCREEN-INFO structure from CLX to a HEAD structure from StumpWM." (make-head :number (xinerama:screen-info-number screen-info) :x (xinerama:screen-info-x screen-info) :y (xinerama:screen-info-y screen-info) :width (xinerama:screen-info-width screen-info) :height (xinerama:screen-info-height screen-info) :window nil)) (defun output->head (output count) (multiple-value-bind (request-status _0 crtc _1 _2 status _3 _4 _5 _6 _7 name) (xlib:rr-get-output-info *display* output (get-universal-time)) (declare (ignore _0 _1 _2 _3 _4 _5 _6 _7)) (when (and (eq request-status :success) (eq status :connected) (plusp crtc)) (multiple-value-bind (request-status config-timestamp x y width height) (xlib:rr-get-crtc-info *display* crtc (get-universal-time)) (declare (ignore config-timestamp)) (when (eq request-status :success) (make-head :number count :x x :y y :width width :height height :window nil :name name)))))) (defun make-screen-randr-heads (root) (loop :with outputs := (nth-value 3 (xlib:rr-get-screen-resources root)) :for count :from 0 :for output :in outputs :for head := (output->head output count) :when head :collect head)) (defun make-screen-heads (screen root) (declare (ignore screen)) ;; Query for whether the server supports RANDR, if so, call the ;; randr version of make-screen-heads. (or (and (xlib:query-extension *display* "RANDR") (make-screen-randr-heads root)) (and (xlib:query-extension *display* "XINERAMA") (xinerama:xinerama-is-active *display*) (mapcar 'screen-info-head (xinerama:xinerama-query-screens *display*))) (list (make-head :number 0 :x 0 :y 0 :width (xlib:drawable-width root) :height (xlib:drawable-height root) :window nil)))) (defun copy-heads (screen) "Return a copy of screen's heads." (mapcar 'copy-frame (screen-heads screen))) (defun find-head-by-position (screen x y) (dolist (head (screen-heads screen)) (when (and (>= x (head-x head)) (>= y (head-y head)) (<= x (+ (head-x head) (head-width head))) (<= y (+ (head-y head) (head-height head)))) (return head)))) (defgeneric frame-head (group frame) (:documentation "Return the head frame is on") (:method (group frame) "As a fallback, use the frame's position on the screen to return a head in the same position. This can be out of sync with stump's state if was moved by something else, such as X11 during an external monitor change. It also doesn't work in the middle of rescaling a head." (let ((center-x (+ (frame-x frame) (ash (frame-width frame) -1))) (center-y (+ (frame-y frame) (ash (frame-height frame) -1)))) (find-head-by-position (group-screen group) center-x center-y)))) (defun group-heads (group) (screen-heads (group-screen group))) (defun resize-head (number x y width height) "Resize head number `number' to given dimension." (let* ((screen (current-screen)) (oh (find number (screen-heads screen) :key 'head-number)) (nh (make-head :number number :x x :y y :width width :height height :window nil))) (scale-head screen oh nh) (dolist (group (screen-groups screen)) (group-sync-head group oh)) (update-mode-lines screen))) (defun current-head (&optional (group (current-group))) (group-current-head group)) (defun head-windows (group head) "Returns a list of windows on HEAD of GROUP" (remove-if-not (lambda (w) (handler-case (eq head (window-head w)) (unbound-slot () nil))) (group-windows group))) (defun frame-is-head (group frame) (< (frame-number frame) (length (group-heads group)))) (defun add-head (screen head) (dformat 1 "Adding head #~D~%" (head-number head)) (setf (screen-heads screen) (sort (push head (screen-heads screen)) #'< :key 'head-number)) (dolist (group (screen-groups screen)) (group-add-head group head))) (defun remove-head (screen head) (dformat 1 "Removing head #~D~%" (head-number head)) (let ((mode-line (head-mode-line head))) (when mode-line (destroy-mode-line mode-line))) (dolist (group (screen-groups screen)) (group-remove-head group head)) ;; Remove it from SCREEN's head list. (setf (screen-heads screen) (delete head (screen-heads screen)))) (defun replace-head (screen old-head new-head) "Replaces one head with another, while preserving its frame-tree" (dformat 1 "Replacing head ~A with head ~A" old-head new-head) (when-let (mode-line (head-mode-line old-head)) (move-mode-line-to-head mode-line new-head)) (dolist (group (screen-groups screen)) (group-replace-head screen group old-head new-head)) (setf (screen-heads screen) (sort (append (list new-head) (remove old-head (screen-heads screen))) #'< :key 'head-number)) (scale-head screen new-head old-head)) ; opposite of its calling convention (defun scale-head (screen oh nh) "Scales head OH to match the dimensions of NH." (let ((nhx (head-x nh)) (nhy (head-y nh)) (nhw (head-width nh)) (nhh (head-height nh))) (unless (and (= (head-x oh) nhx) (= (head-y oh) nhy) (= (head-width oh) nhw) (= (head-height oh) nhh)) (dolist (group (screen-groups screen)) (group-before-resize-head group oh nh)) (setf (head-x oh) nhx (head-y oh) nhy (head-width oh) nhw (head-height oh) nhh) (dolist (group (screen-groups screen)) (group-after-resize-head group oh))))) (defun scale-screen (screen heads) "Scale all frames of all groups of SCREEN to match the dimensions of HEADS." (let ((old-heads (screen-heads screen))) (let* ((added-heads (set-difference heads old-heads :test '= :key 'head-number)) (removed-heads (set-difference old-heads heads :test '= :key 'head-number)) (max-change (max (length added-heads) (length removed-heads)))) (loop repeat max-change ; This is, unfortunately, the loop syntax for stopping at the max of two lists for added-head-list = added-heads then (cdr added-head-list) for added-head = (car added-head-list) for removed-head-list = removed-heads then (cdr removed-head-list) for removed-head = (car removed-head-list) do (if added-head (if removed-head (replace-head screen removed-head added-head) (add-head screen added-head)) (remove-head screen removed-head))) ;; This rescales altered, but existing screens eg a screen resolution change (dolist (head (intersection heads old-heads :test '= :key 'head-number)) (let ((new-head (find (head-number head) heads :test '= :key 'head-number)) (old-head (find (head-number head) old-heads :test '= :key 'head-number))) (scale-head screen old-head new-head)))) (when-let ((orphaned-frames (orphaned-frames screen))) (let ((group (current-group))) (dformat 1 "Orphaned frames ~A found on screen ~A! Adopting into group ~A" orphaned-frames screen group) (group-adopt-orphaned-windows group screen))))) (defun head-force-refresh (screen new-heads) (scale-screen screen new-heads) (mapc 'group-sync-all-heads (screen-groups screen)) (loop for new-head in new-heads do (run-hook-with-args *new-head-hook* new-head screen))) (defcommand refresh-heads (&optional (screen (current-screen))) () "Refresh screens in case a monitor was connected, but a ConfigureNotify event was snarfed by another program." (head-force-refresh screen (make-screen-heads screen (screen-root screen)))) (defun orphaned-frames (screen) "Returns a list of frames on a screen not associated with any group. These shouldn't exist." (let ((adopted-frames (loop for group in (screen-groups screen) append (group-frames group)))) (set-difference (screen-frames screen) adopted-frames))) stumpwm-22.11/help.lisp000066400000000000000000000451021433701203600150550ustar00rootroot00000000000000;; Copyright (C) 2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Help and introspection commands ;; ;; Code: (in-package #:stumpwm) (export '(*help-max-height* *message-max-width* *which-key-format*)) (defvar *message-max-width* 80 "The maximum width of a message before it wraps.") (defvar *help-max-height* 10 "Maximum number of lines for help to display.") (defvar *which-key-format* (concat *key-seq-color* "*~5a^n ~a") "The format string that decides how keybindings will show up in the which-key window. Two arguments will be passed to this formatter: @table @asis @item the keybind itself @item the associated command @end table") (defun columnize (list columns &key col-aligns (pad 1) (char #\Space) (align :left)) ;; only somewhat nasty (let* ((rows (ceiling (length list) columns)) (data (loop for i from 0 below (length list) by (max rows 1) collect (subseq list i (min (+ i rows) (length list))))) (max (mapcar (lambda (col) (reduce 'max col :key 'length :initial-value 0)) data)) (padstr (make-string pad :initial-element char)) (cols ;; normalize width (loop for i in data for j in max for c from 0 collect (loop for k from 0 below rows for s = (or (nth k i) "") for len = (make-string (- j (length s)) :initial-element char) collect (ecase (or (nth c col-aligns) align) (:left (format nil "~a~a~a" (if (= c 0) "" padstr) s len)) (:right (format nil "~a~a~a" (if (= c 0) "" padstr) len s))))))) (apply 'mapcar 'concat (or cols '(nil))))) (defun display-bindings-for-keymaps (key-seq &rest keymaps) (let* ((screen (current-screen)) (data (mapcan (lambda (map) (mapcar (lambda (b) (let ((bound-to (binding-command b))) (format nil *which-key-format* (print-key (binding-key b)) (cond ((or (symbolp bound-to) (stringp bound-to)) bound-to) ((kmap-p bound-to) "Anonymous Keymap") (t "Unknown"))))) (kmap-bindings map))) keymaps)) (cols (ceiling (1+ (length data)) (truncate (- (head-height (current-head)) (* 2 (screen-msg-border-width screen))) (font-height (screen-font screen)))))) (message-no-timeout "Prefix: ~a~%~{~a~^~%~}" (print-key-seq key-seq) (or (columnize data cols) '("(EMPTY MAP)"))))) (defcommand commands () () "List all available commands." (let* ((screen (current-screen)) (data (all-commands)) (cols (ceiling (length data) (truncate (- (head-height (current-head)) (* 2 (screen-msg-border-width screen))) (font-height (screen-font screen)))))) (message-no-timeout "~{~a~^~%~}" (columnize data cols)))) (defun wrap (words &optional (max-col *message-max-width*) stream) "Word wrap at the MAX-COL." ;; Format insanity edited from Gene Michael Stover's "Advanced Use of Lisp's ;; FORMAT Function (2004)" ;; Note that using format without a constant format string is not very ;; efficient. Not doing so comes at the cost of *message-max-width* being ;; available at compile time, so users would not be able to configure it at ;; runtime. (format stream (concatenate 'string "~{~<~%~1," (with-output-to-string (s) (princ max-col s) s) ":;~A~> ~}") (split-string words " "))) (defun final-key-p (keys class) "Determine if the key is a memeber of a class" (member (lastcar keys) (mapcar #'parse-key class) :test #'equalp)) (defun help-key-p (keys) "If the key is for the help command." (final-key-p keys *help-keys*)) (defun cancel-key-p (keys) "If a key is the cancelling key binding." (final-key-p keys '("C-g"))) (defcommand describe-key (keys) ((:key-seq "Describe key:")) "Either interactively type the key sequence or supply it as text. This command prints the command bound to the specified key sequence." (if-let ((cmd (loop for map in (top-maps) for cmd = (lookup-key-sequence map keys) when cmd return cmd)) (printed-key (mapcar 'print-key keys))) (let ((cmd-without-args (argument-pop (make-argument-line :string cmd :start 0)))) (message-no-timeout "~{~A~^ ~} is bound to \"~A\".~%~A" printed-key cmd (describe-command-to-stream cmd-without-args nil))) (cond ((and (help-key-p keys) (cdr printed-key)) (message "~{~A~^ ~} shows the bindings for the prefix map under ~{~A~^ ~}." printed-key (butlast printed-key))) ((cancel-key-p keys) (message "Any command ending in ~A is meant to cancel any command in progress \"ABORT\".~%" (lastcar printed-key))) (t (message "~{~A~^ ~} is not bound." printed-key))))) (defun describe-variable-to-stream (var stream) "Write the help for the variable to the stream." (format stream "variable:^5 ~a^n~%~a~%Its value is:~%~a." var (or (documentation var 'variable) "") (let* ((value (format nil "~a" (symbol-value var))) (split (split-string value (format nil "~%")))) (if (> (1+ *help-max-height*) (length split)) value (format nil "~a.." (wrap (format nil "~{~a~^~%~}" (take *help-max-height* split)))))))) (defcommand describe-variable (var) ((:variable "Describe variable: ")) "Print the online help associated with the specified variable." (message-no-timeout "~a" (with-output-to-string (s) (describe-variable-to-stream var s)))) (defun describe-function-to-stream (fn stream) "Write the help for the function to the stream." (format stream "function:^5 ~a^n~%" (string-downcase (symbol-name fn))) (when-let ((lambda-list (sb-introspect:function-lambda-list (symbol-function fn)))) (format stream "(^5~a ^B~{~a~^ ~}^b^n)~&~%" (string-downcase (symbol-name fn)) lambda-list)) (format stream "~&~a"(or (documentation fn 'function) ""))) (defcommand describe-function (fn) ((:function "Describe function: ")) "Print the online help associated with the specified function." (message-no-timeout "~a" (with-output-to-string (s) (describe-function-to-stream fn s)))) (defun find-binding-in-kmap (command keymap &key match-partial-string match-with-arguments) "Walk through KEYMAP recursively looking for bindings that match COMMAND. Return a list of keybindings where each keybinding is of the form: (command \"binding-1 binding-2 ... binding-n\" *map1* *map2* ... *mapn*) For every space-separated binding there is a corresponding keymap that it is bound in. In the above list, binding-1 is bound in *map1*, binding-2 in *map2*, and binding-n in *mapn*. COMMAND must be a string, a symbol, or a kmap structure. KEYMAP must be a symbol or a kmap structure, though it should be a symbol if readable return values are desired. MATCH-PARTIAL-STRING is a true/false value. If true, any binding structure whose command slot contains the string COMMAND is treated as a match. In the list returned, command refers to the value of (binding-command binding) where binding is the keybinding that matches COMMAND. Example: => (find-binding-in-kmap \"grename\" '*root-map*) ((\"grename\" \"g A\" *ROOT-MAP* *GROUPS-MAP*) (\"grename\" \"g r\" *ROOT-MAP* *GROUPS-MAP*)) " (labels ((key->str (key) ;; Inverse of (kbd ...) (concatenate 'string (when (key-control key) "C-") (when (key-meta key) "M-") (when (key-super key) "s-") (when (key-hyper key) "H-") (when (key-alt key) "A-") (when (key-shift key) "S-") (keysym->keysym-name (key-keysym key)))) (command-equal (cmd) (cond ((and (stringp cmd) (stringp command)) (cond (match-partial-string (cl-ppcre:scan command cmd)) (match-with-arguments (let ((els (cl-ppcre:split " " cmd))) (member command els :test #'string-equal))) (t (string-equal cmd command)))) ((or (and (symbolp cmd) (symbolp command)) (and (kmap-p cmd) (kmap-p command))) (eql cmd command)))) (walk-keymap (keymap &optional binding-acc kmap-acc) (loop for binding in (kmap-bindings (car (dereference-kmaps (list keymap)))) if (command-equal (binding-command binding)) collect (list* (binding-command binding) (format nil "~{~A~^ ~}" (reverse (cons (key->str (binding-key binding)) binding-acc))) (reverse kmap-acc)) else if (kmap-or-kmap-symbol-p (binding-command binding)) append (walk-keymap (binding-command binding) (cons (key->str (binding-key binding)) binding-acc) (cons (if (kmap-p (binding-command binding)) 'anonymous-keymap (binding-command binding)) kmap-acc))))) (let ((keys (walk-keymap keymap nil (list keymap)))) keys))) (defun find-binding (command &key match-partial-string (match-with-arguments t) (top-level-maps (cons '*top-map* (mapcar #'cadr *group-top-maps*)))) "Return a list of all keybindings matching COMMAND as specified by FIND-BINDING-IN-KMAP." (loop for map in top-level-maps append (find-binding-in-kmap command map :match-partial-string match-partial-string :match-with-arguments match-with-arguments))) (labels ((make-even-lengths (list) (let ((longest1 0) (longest2 0)) (mapc (lambda (el) (let* ((final (lastcar (cl-ppcre:split " " (cadr el)))) (l1 (length final)) (l2 (length (symbol-name (lastcar el))))) (when (> l1 longest1) (setf longest1 l1)) (when (> l2 longest2) (setf longest2 l2)))) list) (mapcar (lambda (el) (let* ((final (lastcar (cl-ppcre:split " " (cadr el)))) (l1 (length final)) (l2 (length (symbol-name (lastcar el))))) (list (format nil "~S~A" final (make-string (- longest1 l1) :initial-element #\space)) (format nil "~A~A" (lastcar el) (make-string (- longest2 l2) :initial-element #\space)) (format nil "~S" (car el))))) list)))) (defun describe-command-to-stream (com stream) "Write the help for the command to the stream." (let* ((deref (dereference-command-symbol com)) (struct (get-command-structure com nil)) (name (command-name struct)) (text (wrap (concat (unless (eq deref struct) (format nil "\"~a\" is an alias for the command \"~a\":~%" (command-alias-from deref) name)) (when-let ((message (where-is-to-stream name nil))) (format nil "~&~A~&" message)) (when-let ((lambda-list (sb-introspect:function-lambda-list (symbol-function name)))) (format nil "~%^5~a ^B~{~a~^ ~}^b^n~&~%" name lambda-list)) (format nil "~&~a" (or (documentation name 'function) ""))) *message-max-width* nil))) (let ((bindings (when (stringp com) (find-binding com :top-level-maps (top-maps))))) (if bindings (format stream "~A~%~%Bound to:~%~{~{~A~#[~; invoking ~:; in ~]~}~^~%~}" text (make-even-lengths bindings)) (format stream "~A" text)))))) (defcommand describe-command (com) ((:command "Describe command: ")) "Print the online help associated with the specified command." (if (null (get-command-structure com nil)) (message-no-timeout "Error: Command \"~a\" not found." (command-name com)) (message-no-timeout "~a" (describe-command-to-stream com nil)))) (defun where-is-to-stream (cmd stream) (labels ((keys (cmd) (loop for map in (top-maps) append (search-kmap cmd map))) (sym (comm alias-accessor) (typecase comm (command-alias (sym (funcall alias-accessor comm) alias-accessor)) (command (command-name comm)) (string (intern (string-upcase comm))) (symbol comm)))) (let ((cmd (string-downcase cmd))) (if-let ((bindings (keys cmd))) (format stream "\"~a\" is on ~{~a~^, ~}." cmd (mapcar 'print-key-seq bindings)) (format stream "Command \"~a\" is not currently bound." cmd)) (let ((reverse-hash (make-hash-table :size (hash-table-size *command-hash*) :test 'eq))) (loop for k being each hash-key of *command-hash* using (hash-value v) do (setf #1=(gethash (sym v #'command-alias-to) reverse-hash) (let ((sym (sym v #'command-alias-from))) (when (not (eql sym (sym v #'command-alias-to))) (cons sym #1#))))) (when-let ((aliases (gethash (intern (string-upcase cmd)) reverse-hash))) (format stream "~%\"~a\" is aliased to ~{\"~a\"~^, ~}." cmd (mapcar #'string-downcase aliases)) (loop for a in aliases for k = #2=(keys (string-downcase (symbol-name a))) then #2# when k do (format stream "~%\"~a\" is on ~{~a~^, ~}." (string-downcase a) (mapcar 'print-key-seq k)))))))) (defcommand where-is (cmd) ((:command "Where is command: ")) "Print the key sequences bound to the specified command." (let ((stream (make-string-output-stream))) (where-is-to-stream cmd stream) (message-no-timeout "~A" (get-output-stream-string stream)))) (defun get-kmaps-at-key (kmaps key) (dereference-kmaps (reduce (lambda (result map) (let* ((binding (handler-case (find key (kmap-bindings map) :key 'binding-key :test 'equalp) (type-error () nil))) (command (when binding (binding-command binding)))) (if command (setf result (cons command result)) result))) kmaps :initial-value ()))) (defun get-kmaps-at-key-seq (kmaps key-seq) "get a list of kmaps that are activated when pressing KEY-SEQ when KMAPS are enabled" (if (= 1 (length key-seq)) (get-kmaps-at-key kmaps (first key-seq)) (get-kmaps-at-key-seq (get-kmaps-at-key kmaps (first key-seq)) (rest key-seq)))) (defun which-key-mode-key-press-hook (key key-seq cmd) "*key-press-hook* for which-key-mode" (declare (ignore key cmd)) (when (not (eq *top-map* *resize-map*)) (let* ((oriented-key-seq (reverse key-seq)) (maps (get-kmaps-at-key-seq (dereference-kmaps (top-maps)) oriented-key-seq))) (when-let ((only-maps (remove-if-not 'kmap-p maps))) (apply 'display-bindings-for-keymaps oriented-key-seq only-maps))))) (defcommand which-key-mode () () "Toggle which-key-mode" (if (find 'which-key-mode-key-press-hook *key-press-hook*) (remove-hook *key-press-hook* 'which-key-mode-key-press-hook) (add-hook *key-press-hook* 'which-key-mode-key-press-hook))) (defcommand modifiers () () "List the modifiers stumpwm recognizes and what MOD-X it thinks they're on." (message "~@{~5@a: ~{~(~a~)~^ ~}~%~}" "Meta" (modifiers-meta *modifiers*) "Alt" (modifiers-alt *modifiers*) "Super" (modifiers-super *modifiers*) "Hyper" (modifiers-hyper *modifiers*) "AltGr" (modifiers-altgr *modifiers*))) stumpwm-22.11/input.lisp000066400000000000000000001220011433701203600152560ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file handles input stuff ;; ;; Code: (in-package :stumpwm) (export '(*input-history-ignore-duplicates* *input-candidate-selected-hook* *input-completion-style* *input-map* *numpad-map* register-altgr-as-modifier completing-read input-delete-region input-goto-char input-insert-char input-insert-string input-point input-refine-prefix input-refine-regexp input-substring input-validate-region read-one-char read-one-line)) ;;; General Utilities (defun take (n list) "Returns a list with the first n elements of the given list, and the remaining tail of the list as a second value." (loop for l on list repeat n collect (car l) into result finally (return (values result l)))) ;; This could use a much more efficient algorithm. ;; But for our purposes with small lists it's likely ok. (defun longest-common-prefix (seqs &key (test #'eql)) "Returns the length of the longest common prefix of the sequences." (flet ((longest-common-prefix-2 (seq1 seq2) (if-let ((i (mismatch seq1 seq2 :test test))) i (length seq1)))) (apply #'min (map-product #'longest-common-prefix-2 seqs seqs)))) (defstruct input-line string position history history-bk password most-recent-dead-key) ;;; completion styles (defgeneric input-completion-reset (completion-style completions) (:documentation "A completion style should implement this function and reset its state when called.")) (defgeneric input-completion-complete (completion-style input direction) (:documentation "A completion style should implement this function and complete the input by mutating it.")) (defclass input-completion-style-cyclic () ((completions :initform nil :type list) (idx :initform 0 :type fixnum))) (defmethod input-completion-reset ((cs input-completion-style-cyclic) completions) (setf (slot-value cs 'completions) completions (slot-value cs 'idx) 0)) (defmethod input-completion-complete ((cs input-completion-style-cyclic) input direction) (with-slots (completions idx) cs (let ((completion-count (length completions))) (if completions (progn (let ((elt (nth idx completions))) (input-delete-region input 0 (input-point input)) (input-insert-string input (if (listp elt) (first elt) elt)) (input-insert-char input #\Space)) ;; Prepare the next completion (setf idx (mod (+ idx (if (eq direction :forward) 1 -1)) completion-count)) :error))))) (defun make-input-completion-style-cyclic () (make-instance 'input-completion-style-cyclic)) (defclass input-completion-style-unambiguous () ((display-limit :initarg :display-limit :initform 64 :type fixnum) (completions :initform nil :type list))) (defmethod input-completion-reset ((cs input-completion-style-unambiguous) completions) (setf (slot-value cs 'completions) (take (slot-value cs 'display-limit) completions))) (defmethod input-completion-complete ((cs input-completion-style-unambiguous) input direction) (declare (ignore direction)) (with-slots (completions) cs (if (null completions) :error (let ((n (longest-common-prefix completions))) (input-delete-region input 0 (input-point input)) (input-insert-string input (subseq (first completions) 0 n)) (if (null (rest completions)) (unmap-message-window (current-screen)) (echo-string-list (current-screen) completions)))))) (defun make-input-completion-style-unambiguous (&key (display-limit 64)) (make-instance 'input-completion-style-unambiguous :display-limit display-limit)) (defun input-refine-prefix (str candidates) (remove-if-not (lambda (elt) (when (listp elt) (setf elt (car elt))) (and (<= (length str) (length elt)) (string= str elt :end1 (length str) :end2 (length str)))) candidates)) (defun input-refine-regexp (str candidates) (remove-if-not (lambda (elt) (when (listp elt) (setf elt (car elt))) (match-all-regexps str elt)) candidates)) (defvar *input-map* (let ((map (make-sparse-keymap))) (define-key map (kbd "DEL") 'input-delete-backward-char) (define-key map (kbd "M-DEL") 'input-backward-kill-word) (define-key map (kbd "C-d") 'input-delete-forward-char) (define-key map (kbd "M-d") 'input-forward-kill-word) (define-key map (kbd "Delete") 'input-delete-forward-char) (define-key map (kbd "C-f") 'input-forward-char) (define-key map (kbd "Right") 'input-forward-char) (define-key map (kbd "M-f") 'input-forward-word) (define-key map (kbd "C-b") 'input-backward-char) (define-key map (kbd "Left") 'input-backward-char) (define-key map (kbd "M-b") 'input-backward-word) (define-key map (kbd "C-a") 'input-move-beginning-of-line) (define-key map (kbd "Home") 'input-move-beginning-of-line) (define-key map (kbd "C-e") 'input-move-end-of-line) (define-key map (kbd "End") 'input-move-end-of-line) (define-key map (kbd "C-k") 'input-kill-line) (define-key map (kbd "C-u") 'input-kill-to-beginning) (define-key map (kbd "C-p") 'input-history-back) (define-key map (kbd "Up") 'input-history-back) (define-key map (kbd "C-n") 'input-history-forward) (define-key map (kbd "Down") 'input-history-forward) (define-key map (kbd "RET") 'input-submit) (define-key map (kbd "C-g") 'input-abort) (define-key map (kbd "ESC") 'input-abort) (define-key map (kbd "C-y") 'input-yank-selection) (define-key map (kbd "C-Y") 'input-yank-clipboard) (define-key map (kbd "TAB") 'input-complete-forward) (define-key map (kbd "ISO_Left_Tab") 'input-complete-backward) (define-key map t 'input-self-insert) map) "This is the keymap containing all input editing key bindings.") (defvar *input-history* nil "History for the input line.") (defvar *input-shell-history* nil "History for shell lines.") (defvar *input-last-command* nil "The last input command.") (defvar *input-completions* nil "The list of completions") (defvar *input-refine-candidates-fn* #'input-refine-prefix "A function used to filter completions based on input. The function receives two arguments: the input string and a list of completions. The function should return a list of completions, possibly filtered and/or sorted.") (defvar *input-completion-style* (make-input-completion-style-cyclic) "The completion style to use. A completion style has to implement input-completion-reset and input-completion-complete. Available completion styles include @table @asis @item make-input-completion-style-cyclic @item make-input-completion-style-unambiguous @end table") (defvar *input-completion-show-empty* nil "If t, show completion candidates even if the input is empty.") (defvar *input-history-ignore-duplicates* nil "Do not add a command to the input history if it's already the first in the list.") (defvar *numpad-map* '((87 10 . 16) (88 11 . 16) (89 12 . 16) (106 61 . 16) (83 13 . 16) (84 14 . 16) (85 15 . 16) (86 21 . 17) (79 16 . 16) (80 17 . 16) (81 18 . 16) (63 17 . 17) (82 20 . 16) (104 36 . 16) (91 60 . 16) (90 19 . 16)) "A keycode to keycode map to re-wire numpads when the numlock key is active") ;;; keysym functions (defun is-modifier (keycode) "Return t if keycode is a modifier" (or (find keycode *all-modifiers* :test 'eql) ;; Treat No Symbol keys as modifiers (and therefore ignorable) (= (xlib:keycode->keysym *display* keycode 0) 0))) (defun register-altgr-as-modifier () "Register the keysym(s) for ISO_Level3_Shift as modifiers." (setf *all-modifiers* (append (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym "ISO_Level3_Shift"))) *all-modifiers*))) (defun keycode->character (code mods) (let ((idx (if (member :shift mods) 1 0))) (xlib:keysym->character *display* (xlib:keycode->keysym *display* code idx) 0))) ;;; line and key reading functions (defun setup-input-window (screen prompt input) "Set the input window up to read input" (let* ((height (+ (font-height (screen-font screen)) (* *message-window-y-padding* 2))) (win (screen-input-window screen))) ;; Window dimensions (xlib:with-state (win) (setf (xlib:window-priority win) :above (xlib:drawable-height win) height)) (xlib:map-window win) (draw-input-bucket screen prompt input))) (defun shutdown-input-window (screen) (xlib:unmap-window (screen-input-window screen))) ;; Hack to avoid clobbering input from numpads with numlock on. (defun input-handle-key-press-event (&rest event-slots &key event-key code state &allow-other-keys) (declare (ignore event-slots)) (let ((numlock-on-p (= 2 (logand 2 (nth-value 4 (xlib:keyboard-control *display*))))) (numpad-key (assoc code *numpad-map*))) (when (and numlock-on-p numpad-key) (setf code (first (rest numpad-key)) state (rest (rest numpad-key)))) (list* event-key code state))) (defun input-handle-selection-event (&key window selection property &allow-other-keys) (declare (ignore selection)) (if property (xlib:get-property window property :type :string :result-type 'string :transform #'xlib:card8->char :delete-p t) "")) (defun input-handle-click-event (&key root-x root-y &allow-other-keys) (list :button-press root-x root-y)) (defun read-key-handle-event (&rest event-slots &key event-key &allow-other-keys) (case event-key ((or :key-release :key-press) (apply 'input-handle-key-press-event event-slots)) (t nil))) (defun read-key-or-selection-handle-event (&rest event-slots &key event-key &allow-other-keys) (case event-key ((or :key-release :key-press) (apply 'input-handle-key-press-event event-slots)) (:selection-notify (apply 'input-handle-selection-event event-slots)) (t nil))) (defun read-key-or-click-handle-event (&rest event-slots &key event-key &allow-other-keys) (case event-key ((or :key-release :key-press) (apply 'input-handle-key-press-event event-slots)) (:button-press (apply 'input-handle-click-event event-slots)) (t nil))) (defun read-key () "Return a dotted pair (code . state) key." (loop for ev = (xlib:process-event *display* :handler #'read-key-handle-event :timeout nil) do (when (and (consp ev) (eq (first ev) :key-press)) (return (rest ev))))) (defun read-key-or-click () (loop for ev = (xlib:process-event *display* :handler #'read-key-or-click-handle-event :timeout nil) do (when (consp ev) (when (eq (first ev) :key-press) (return (values nil (rest ev) nil nil))) (when (eq (first ev) :button-press) (return (values t nil (second ev) (third ev))))))) (defun read-key-no-modifiers () "Like read-key but never returns a modifier key." (loop for k = (read-key) while (is-modifier (car k)) finally (return k))) (defun read-key-no-modifiers-or-click () (loop (multiple-value-bind (has-click k x y) (read-key-or-click) (if has-click (return (values t nil x y)) (unless (is-modifier (car k)) (return (values nil k nil nil))))))) (defun read-key-or-selection () (loop for ev = (xlib:process-event *display* :handler #'read-key-or-selection-handle-event :timeout nil) do (cond ((stringp ev) (return ev)) ((and (consp ev) (eq (first ev) :key-press)) (return (rest ev)))))) (defun make-input-string (initial-input) (make-array (length initial-input) :element-type 'character :initial-contents initial-input :adjustable t :fill-pointer t)) (defun completing-read (screen prompt completions &key (initial-input "") require-match) "Read a line of input through stumpwm and return it with TAB completion. Completions can be a list, an fbound symbol, or a function. If its an fbound symbol or a function then that function is passed the substring to complete on and is expected to return a list of matches. If require-match argument is non-nil then the input must match with an element of the completions." (check-type completions (or list function symbol)) (let ((line (read-one-line screen prompt :completions completions :initial-input initial-input :require-match require-match))) (when line (string-trim " " line)))) (defvar *input-candidate-selected-hook* nil) (defun read-one-line (screen prompt &key completions (initial-input "") require-match password) "Read a line of input through stumpwm and return it. Returns nil if the user aborted." (let ((*input-last-command* nil) (*input-completions* (if (or (functionp completions) (and (symbolp completions) (fboundp completions))) (funcall completions initial-input) completions)) (input (make-input-line :string (make-input-string initial-input) :position (length initial-input) :history -1 :password password))) (labels ((match-input () (let* ((in (string-trim " " (input-line-string input))) (compls (input-find-completions in completions))) (and (consp compls) (string= in (if (consp (car compls)) (caar compls) (car compls)))))) (key-loop () (with-focus (screen-input-window screen) (loop for key = (read-key-or-selection) do (cond ((stringp key) ;; handle selection (input-insert-string input key) (draw-input-bucket screen prompt input)) ;; skip modifiers ((is-modifier (car key))) ((process-input screen prompt input (car key) (cdr key)) (if (or (not require-match) (match-input)) (return (input-line-string input)) (draw-input-bucket screen prompt input "[No match]" t)))))))) (draw-input-bucket screen prompt input) (setup-input-window screen prompt input) (catch :abort (unwind-protect (let ((input (key-loop))) (run-hook-with-args *input-candidate-selected-hook* input) input) (shutdown-input-window screen)))))) (defun read-one-char (screen) "Read a single character from the user." (with-focus (screen-key-window screen) (let ((k (read-key-no-modifiers))) (keycode->character (car k) (xlib:make-state-keys (cdr k)))))) (defun read-one-char-or-click (group) "Read a single character from the user or a click." (with-focus (screen-key-window (group-screen group)) (multiple-value-bind (has-click k x y) (read-key-no-modifiers-or-click) (if has-click (values t nil x y) (values nil (keycode->character (car k) (xlib:make-state-keys (cdr k))) nil nil))))) (defun prompt-text-y (index font y-padding) "Calculate the y position of text in a prompt." (+ y-padding (* (font-height font) index) (font-ascent font))) (defun get-completion-preview-list (input-line all-completions) (if (and (string= "" input-line) (not *input-completion-show-empty*)) '() (multiple-value-bind (completions more) (take *maximum-completions* (input-find-completions input-line all-completions)) (if more (append (butlast completions) (list (format nil "... and ~D more" (1+ (length more))))) completions)))) (defun draw-input-bucket (screen prompt input &optional (tail "") errorp) "Draw to the screen's input window the contents of input." (let* ((gcontext (screen-message-gc screen)) (win (screen-input-window screen)) (font (screen-font screen)) (prompt-lines (ppcre:split #\Newline prompt)) (prompt-lines-length (length prompt-lines)) (input-line (input-line-string input)) (completions (get-completion-preview-list input-line *input-completions*)) (completions-length (length completions)) (prompt-offset (text-line-width font (first (last prompt-lines)) :translate #'translate-id)) (line-content (input-line-string input)) (string (if (input-line-password input) (make-string (length line-content) :initial-element #\*) line-content)) (string-width (loop for char across string summing (text-line-width (screen-font screen) (string char) :translate #'translate-id))) (space-width (text-line-width (screen-font screen) " " :translate #'translate-id)) (tail-width (text-line-width (screen-font screen) tail :translate #'translate-id)) (full-string-width (+ string-width space-width)) (pos (input-line-position input)) (width (max (loop :for line :in (append prompt-lines completions) :maximize (text-line-width font line :translate #'translate-id)) (+ prompt-offset (max 100 (+ full-string-width space-width tail-width)))))) (when errorp (rotatef (xlib:gcontext-background gcontext) (xlib:gcontext-foreground gcontext))) (xlib:with-state (win) (xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext)) (xlib:draw-rectangle win gcontext 0 0 (xlib:drawable-width win) (xlib:drawable-height win) t)) (setf (xlib:drawable-width win) (+ width (* *message-window-padding* 2))) (setf (xlib:drawable-height win) (+ (* prompt-lines-length (font-height font)) (* *message-window-y-padding* 2) (* completions-length (font-height font)))) (setup-win-gravity screen win *input-window-gravity*) ;; Display the input window text. (loop for i from 0 below (+ prompt-lines-length completions-length) if (< i prompt-lines-length) do (draw-image-glyphs win gcontext font *message-window-padding* (prompt-text-y i font *message-window-y-padding*) (nth i prompt-lines) :translate #'translate-id :size 16) else do (draw-image-glyphs win gcontext font *message-window-padding* (prompt-text-y i font *message-window-y-padding*) (nth (- i prompt-lines-length) completions) :translate #'translate-id :size 16)) ;; Pad the input to the left. (loop with x = (+ *message-window-padding* prompt-offset) for char across string for i from 0 below (length string) for char-width = (text-line-width (screen-font screen) (string char) :translate #'translate-id) if (= pos i) do (xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext) :background (xlib:gcontext-foreground gcontext)) (draw-image-glyphs win gcontext (screen-font screen) x (prompt-text-y (1- prompt-lines-length) font *message-window-y-padding*) (string char) :translate #'translate-id :size 16)) else do (draw-image-glyphs win gcontext (screen-font screen) x (prompt-text-y (1- prompt-lines-length) font *message-window-y-padding*) (string char) :translate #'translate-id :size 16) end do (incf x char-width) finally (when (>= pos (length string)) (xlib:with-gcontext (gcontext :foreground (xlib:gcontext-background gcontext) :background (xlib:gcontext-foreground gcontext)) (draw-image-glyphs win gcontext (screen-font screen) x (prompt-text-y (1- prompt-lines-length) font *message-window-y-padding*) " " :translate #'translate-id :size 16)))) (draw-image-glyphs win gcontext (screen-font screen) (+ *message-window-padding* prompt-offset full-string-width space-width) (prompt-text-y (1- prompt-lines-length) font *message-window-y-padding*) tail :translate #'translate-id :size 16)) (when errorp (sleep 0.05) (rotatef (xlib:gcontext-background gcontext) (xlib:gcontext-foreground gcontext)) (draw-input-bucket screen prompt input tail)))) (defun code-state->key (code state) (let* ((mods (xlib:make-state-keys state)) (shift-p (and (find :shift mods) t)) (altgr-p (and (intersection (modifiers-altgr *modifiers*) mods) t)) (base (if altgr-p *altgr-offset* 0)) (sym (xlib:keycode->keysym *display* code base)) (upsym (xlib:keycode->keysym *display* code (+ base 1)))) ;; If a keysym has a shift modifier, then use the uppercase keysym ;; and remove remove the shift modifier. (make-key :keysym (if (and shift-p (not (eql sym upsym))) upsym sym) :control (and (find :control mods) t) :shift (and shift-p (eql sym upsym)) :meta (and (intersection mods (modifiers-meta *modifiers*)) t) :alt (and (intersection mods (modifiers-alt *modifiers*)) t) :hyper (and (intersection mods (modifiers-hyper *modifiers*)) t) :super (and (intersection mods (modifiers-super *modifiers*)) t) :altgr altgr-p))) ;;; input string utility functions (defun input-submit (input key) (declare (ignore input key)) :done) (defun input-abort (input key) (declare (ignore input key)) (throw :abort nil)) (defun input-goto-char (input point) "Move the cursor to the specified point in the string" (setf (input-line-position input) (min (max 0 point) (length (input-line-string input))))) (defun input-insert-string (input string) "Insert @var{string} into the input at the current position. @var{input} must be of type @var{input-line}. Input functions are passed this structure as their first argument." (check-type string string) (loop for c across string do (input-insert-char input c))) (defun input-point (input) "Return the position of the cursor." (check-type input input-line) (input-line-position input)) (defun input-validate-region (input start end) "Return a value pair of numbers where the first number is < the second and neither excedes the bounds of the input string." (values (max 0 (min start end)) (min (length (input-line-string input)) (max start end)))) (defun input-delete-region (input start end) "Delete the region between start and end in the input string" (check-type input input-line) (check-type start fixnum) (check-type end fixnum) (multiple-value-setq (start end) (input-validate-region input start end)) (replace (input-line-string input) (input-line-string input) :start2 end :start1 start) (decf (fill-pointer (input-line-string input)) (- end start)) (cond ((< (input-line-position input) start)) ((< (input-line-position input) end) (setf (input-line-position input) start)) (t (decf (input-line-position input) (- end start))))) (defun input-insert-char (input char) "Insert @var{char} into the input at the current position. @var{input} must be of type @var{input-line}. Input functions are passed this structure as their first argument." (vector-push-extend #\_ (input-line-string input)) (replace (input-line-string input) (input-line-string input) :start2 (input-line-position input) :start1 (1+ (input-line-position input))) (setf (char (input-line-string input) (input-line-position input)) char) (incf (input-line-position input))) (defun input-substring (input start end) "Return a the substring in INPUT bounded by START and END." (subseq (input-line-string input) start end)) ;;; "interactive" input functions (defun input-find-completions (str completions) (let ((candidates (if (or (functionp completions) (and (symbolp completions) (fboundp completions))) (funcall completions str) completions))) (remove-duplicates (funcall *input-refine-candidates-fn* str candidates) :test #'equal))) (defun input-complete (input direction) (unless (find *input-last-command* '(input-complete-forward input-complete-backward)) (input-completion-reset *input-completion-style* (input-find-completions (input-substring input 0 (input-point input)) *input-completions*))) (input-completion-complete *input-completion-style* input direction)) (defun input-complete-forward (input key) (declare (ignore key)) (input-complete input :forward)) (defun input-complete-backward (input key) (declare (ignore key)) (input-complete input :backward)) (defun input-delete-backward-char (input key) (declare (ignore key)) (let ((pos (input-line-position input))) (cond ((or (<= (length (input-line-string input)) 0) (<= pos 0)) :error) (t (replace (input-line-string input) (input-line-string input) :start2 pos :start1 (1- pos)) (decf (fill-pointer (input-line-string input))) (decf (input-line-position input)))))) (defun input-delete-forward-char (input key) (declare (ignore key)) (let ((pos (input-line-position input))) (cond ((>= pos (length (input-line-string input))) :error) (t (replace (input-line-string input) (input-line-string input) :start1 pos :start2 (1+ pos)) (decf (fill-pointer (input-line-string input))))))) (defun input-forward-kill-word (input key) (declare (ignore key)) (let* ((p1 (position-if 'alphanumericp (input-line-string input) :start (input-line-position input))) (p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :start p1)))) (input-delete-region input (input-point input) (or p2 (length (input-line-string input)))))) (defun input-backward-kill-word (input key) (declare (ignore key)) (let* ((p1 (position-if 'alphanumericp (input-line-string input) :end (input-line-position input) :from-end t)) (p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :end p1 :from-end t)))) (input-delete-region input (input-point input) (or (and p2 (1+ p2)) 0)))) (defun input-forward-word (input key) (declare (ignore key)) (let* ((p1 (position-if 'alphanumericp (input-line-string input) :start (input-line-position input))) (p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :start p1)))) (setf (input-line-position input) (or p2 (length (input-line-string input)))))) (defun input-backward-word (input key) (declare (ignore key)) (let* ((p1 (position-if 'alphanumericp (input-line-string input) :end (input-line-position input) :from-end t)) (p2 (and p1 (position-if-not 'alphanumericp (input-line-string input) :end p1 :from-end t)))) (setf (input-line-position input) (or (and p2 (1+ p2)) 0)))) (defun input-forward-char (input key) (declare (ignore key)) (incf (input-line-position input)) (when (> (input-line-position input) (length (input-line-string input))) (setf (input-line-position input) (length (input-line-string input))))) (defun input-backward-char (input key) (declare (ignore key)) (decf (input-line-position input)) (when (< (input-line-position input) 0) (setf (input-line-position input) 0))) (defun input-move-beginning-of-line (input key) (declare (ignore key)) (setf (input-line-position input) 0)) (defun input-move-end-of-line (input key) (declare (ignore key)) (setf (input-line-position input) (length (input-line-string input)))) (defun input-kill-line (input key) (declare (ignore key)) (unless (= (input-line-position input) (length (input-line-string input))) (set-x-selection (subseq (input-line-string input) (input-line-position input)))) (setf (fill-pointer (input-line-string input)) (input-line-position input))) (defun input-kill-to-beginning (input key) (declare (ignore key)) (unless (= (input-line-position input) 0) (set-x-selection (subseq (input-line-string input) 0 (input-line-position input)))) (replace (input-line-string input) (input-line-string input) :start2 (input-line-position input) :start1 0) (decf (fill-pointer (input-line-string input)) (input-line-position input)) (setf (input-line-position input) 0)) (defun input-history-back (input key) (declare (ignore key)) (when (= (input-line-history input) -1) (setf (input-line-history-bk input) (input-line-string input))) (incf (input-line-history input)) (if (>= (input-line-history input) (length *input-history*)) (progn (decf (input-line-history input)) :error) (setf (input-line-string input) (make-input-string (elt *input-history* (input-line-history input))) (input-line-position input) (length (input-line-string input))))) (defun input-history-forward (input key) (declare (ignore key)) (decf (input-line-history input)) (cond ((< (input-line-history input) -1) (incf (input-line-history input)) :error) ((= (input-line-history input) -1) (setf (input-line-string input) (input-line-history-bk input) (input-line-position input) (length (input-line-string input)))) (t (setf (input-line-string input) (make-input-string (elt *input-history* (input-line-history input))) (input-line-position input) (length (input-line-string input)))))) (defun dead-key-character (keysym) "Given a dead key keysym, return the corresponding non-dead character" (let ((symname (subseq (gethash keysym *dead-key-sym->name*) 5))) ;; Some sym names are different from their non-dead name, patch those here. (cond ((string= symname "tilde") (setf symname "asciitilde")) ((string= symname "circumflex") (setf symname "asciicircum"))) (xlib:keysym->character *display* (gethash symname *name-keysym-translations*)))) (defun dead-key-p (keysym) "Check if KEYSYM is dead" (gethash keysym *dead-key-sym->name*)) (defun make-combined-character (keysym dead-keysym) "Try to modify KEYSYM with DEAD-KEYSYM by concatenating the keysym names together, finding the keysym for it, and looking up the keysym on the X server. For example, given a keysym corresponding to 'a' and a dead keysym corresponding to 'dead_acute', 'dead_' is trimmed from the dead keysyms name, and 'a' and 'acute' are concatenated to give 'aacute', the name of the keysym for 'á'." (let ((charname (keysym->keysym-name keysym)) (deadstr (ignore-errors (subseq (gethash dead-keysym *dead-key-sym->name*) 5)))) (xlib:keysym->character *display* (keysym-name->keysym (concatenate 'string charname deadstr))))) (defun find-character-for-keysym (input key) "Find a character for the given key with support for dead keys." (cond ((dead-key-p (key-keysym key)) (if (and (input-line-most-recent-dead-key input) (= (input-line-most-recent-dead-key input) (key-keysym key))) (progn (setf (input-line-most-recent-dead-key input) nil) (dead-key-character (key-keysym key))) (setf (input-line-most-recent-dead-key input) (key-keysym key)))) (t (let ((char (make-combined-character (key-keysym key) (input-line-most-recent-dead-key input)))) (setf (input-line-most-recent-dead-key input) nil) char)))) (defun input-self-insert (input key) (let* ((%char (ignore-errors (find-character-for-keysym input key))) (char (or %char (xlib:keysym->character *display* (key-keysym key))))) (if (or (key-mods-p key) (null char) (not (characterp char))) :error (prog1 (input-insert-char input char) (setf (input-line-most-recent-dead-key input) nil))))) (defun input-yank-selection (input key) (declare (ignore key)) ;; if we own the selection then just insert it. (if (getf *x-selection* :primary) (input-insert-string input (getf *x-selection* :primary)) (xlib:convert-selection :primary :string (screen-input-window (current-screen)) :stumpwm-selection))) (defun input-yank-clipboard (input key) (declare (ignore key)) (if (getf *x-selection* :clipboard) (input-insert-string input (getf *x-selection* :clipboard)) (xlib:convert-selection :clipboard :string (screen-input-window (current-screen)) :stumpwm-selection))) ;;; Misc functions (defun process-input (screen prompt input code state) "Process the key (code and state), given the current input buffer. Returns a new modified input buffer." (labels ((process-key (code state) "Call the appropriate function based on the key pressed. Return 'done when the use has signalled the finish of his input (pressing Return), nil otherwise." (let* ((key (code-state->key code state)) (command (and key (lookup-key *input-map* key t)))) (if command (prog1 (funcall command input key) (setf *input-last-command* command) (draw-input-bucket screen prompt input)) :error)))) (case (process-key code state) (:done (unless (or (input-line-password input) (and *input-history-ignore-duplicates* (string= (input-line-string input) (first *input-history*)))) (push (input-line-string input) *input-history*)) :done) (:abort (throw :abort t)) (:error ;; FIXME draw inverted text (draw-input-bucket screen prompt input "" t) nil) (t (draw-input-bucket screen prompt input) nil)))) (defun all-modifier-codes () "Return all the keycodes that are associated with a modifier." (flatten (multiple-value-list (xlib:modifier-mapping *display*)))) (defun get-modifier-map () (labels ((find-mod (mod codes) (let* ((keysym (keysym-name->keysym mod)) (keycodes (multiple-value-list (xlib:keysym->keycodes *display* keysym)))) (intersection keycodes codes)))) (let ((modifiers (make-modifiers))) (multiple-value-bind (shift-codes lock-codes control-codes mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes) (xlib:modifier-mapping *display*) (declare (ignore shift-codes lock-codes control-codes)) (loop for mod in '(:mod-1 :mod-2 :mod-3 :mod-4 :mod-5) for codes in (list mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes) do (cond ((or (find-mod "Meta_L" codes) (find-mod "Meta_R" codes)) (push mod (modifiers-meta modifiers))) ((or (find-mod "Alt_L" codes) (find-mod "Alt_R" codes)) (push mod (modifiers-alt modifiers))) ((or (find-mod "Super_L" codes) (find-mod "Super_R" codes)) (push mod (modifiers-super modifiers))) ((or (find-mod "Hyper_L" codes) (find-mod "Hyper_R" codes)) (push mod (modifiers-hyper modifiers))) ((find-mod "Num_Lock" codes) (push mod (modifiers-numlock modifiers))) ((find-mod "ISO_Level3_Shift" codes) (push mod (modifiers-altgr modifiers))))) ;; If alt is defined but meta isn't set meta to alt and clear alt (when (and (modifiers-alt modifiers) (null (modifiers-meta modifiers))) (setf (modifiers-meta modifiers) (modifiers-alt modifiers) (modifiers-alt modifiers) nil)) modifiers)))) (defun update-modifier-map () (setf *modifiers* (get-modifier-map) *all-modifiers* (all-modifier-codes))) ;; (defun x11mod->stumpmod (screen state) ;; (let ((mod nil)) ;; (when (member state (modifiers-alt (screen-modifiers screen))) ;; (push :alt mod)) ;; (when (member state (modifiers-meta (screen-modifiers screen))) ;; (push :meta mod)) ;; (when (member state (modifiers-hyper (screen-modifiers screen))) ;; (push :hyper mod)) ;; (when (member state (modifiers-super (screen-modifiers screen))) ;; (push :super mod)) ;; (when (member state :control) ;; (push :control mod)) ;; mod)) (defun mod->string (state) "Convert a stump modifier list to a string." (let ((alist '((:alt . "A-") (:meta . "M-") (:hyper . "H-") (:super . "S-")))) (apply #'concatenate 'string (mapcar (lambda (x) (cdr (assoc x alist))) state)))) ;; (defun keycode->string (code state) ;; (concatenate 'string (mod->string state) ;; (string (keysym->character *display* ;; (xlib:keycode->keysym *display* code 0) ;; state)))) ;; (defun cook-keycode (code state) ;; (values (xlib:keycode->keysym *display* code 0) (x11mod->stumpmod state))) (defun y-or-n-p (message) "Ask a \"y or n\" question on the current screen and return T if the user presses 'y'." (message "~a(y or n) " message) (eql (read-one-char (current-screen)) #\y)) (defun yes-or-no-p (message) "ask a \"yes or no\" question on the current screen and return T if the user presses 'yes'" (loop for line = (string-trim '(#\Space) (read-one-line (current-screen) (format nil "~a(yes or no) " message) :completions '("yes" "no"))) until (find line '("yes" "no") :test 'string-equal) do (message "Please answer yes or no.") (sleep 1) finally (return (string-equal line "yes")))) stumpwm-22.11/interactive-keymap.lisp000066400000000000000000000074571433701203600177410ustar00rootroot00000000000000;; Copyright (C) 2016, 2017 Caio Oliveira ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;;; Macro for defining interactive command. Just pushes and pops new keymaps. ;; ;; Code: (in-package #:stumpwm) (export '(define-interactive-keymap)) (defun enter-interactive-keymap (kmap name) "Enter interactive mode" (message "~S started." name) (push-top-map kmap)) (defun exit-interactive-keymap (name) "Exits interactive mode" (message "~S finished." name) (pop-top-map)) (defcommand call-and-exit-kmap (command exit-command) ((:command "command to run: ") (:command "exit command: ")) "This command effectively calls two other commands in succession, via run-commands. it is designed for use in the define-interactive-keymap macro, to implement exiting the keymap on keypress. " (run-commands command exit-command)) (defmacro define-interactive-keymap (name (&key on-enter on-exit abort-if (exit-on '((kbd "RET") (kbd "ESC") (kbd "C-g")))) &body key-bindings) "Declare an interactive keymap mode. This can be used for developing interactive modes or command trees, such as @command{iresize}. The NAME argument follows the same convention as in @command{defcommand}. ON-ENTER and ON-EXIT are optional functions to run before and after the interactive keymap mode, respectively. If ABORT-IF is defined, the interactive keymap will only be activated if calling ABORT-IF returns true. KEY-BINDINGS is a list of the following form: ((KEY COMMAND) (KEY COMMAND) ...) If one appends t to the end of a binding like so: ((kbd \"n\") \"cmd\" t) then the keymap is immediately exited after running the command. Each element in KEY-BINDINGS declares a command inside the interactive keymap. Be aware that these commands won't require a prefix to run." (let* ((command (if (listp name) (car name) name)) (exit-command (format nil "EXIT-~A" command)) (keymap (gensym "m"))) (multiple-value-bind (key-bindings decls docstring) (parse-body key-bindings :documentation t) `(let ((,keymap (make-sparse-keymap))) ,@(loop for keyb in key-bindings collect `(define-key ,keymap ,(first keyb) ,(if (third keyb) (concatenate 'string "call-and-exit-kmap \"" (second keyb) "\" " exit-command) (second keyb)))) ,@(loop for keyb in exit-on collect `(define-key ,keymap ,keyb ,exit-command)) (defcommand ,name () () ,@decls ,(or docstring (format nil "Starts interactive command \"~A\"" command)) ,@(when abort-if `((when (funcall ,abort-if) (return-from ,command)))) ,@(when on-enter `((funcall ,on-enter))) (enter-interactive-keymap ,keymap (quote ,command))) (defcommand ,(intern exit-command) () () ,@(when on-exit `((funcall ,on-exit))) (exit-interactive-keymap (quote ,command))))))) stumpwm-22.11/ioloop.lisp000066400000000000000000000472521433701203600154360ustar00rootroot00000000000000;;;; Copyright (C) 2016 Fredrik Tolf ;;;; ;;;; This file is part of stumpwm. ;;;; ;;;; stumpwm is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2, or (at your option) ;;;; any later version. ;;;; stumpwm is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, see ;;;; . (in-package :stumpwm) ;;;; This file implements a generic multiplexing I/O loop for listening ;;;; to I/O events from multiple sources. The model is as follows: ;;;; ;;;; An I/O multiplexer is represented as an object, with which I/O ;;;; channels can be registered to be monitored for events when the I/O ;;;; loop runs. An I/O channel is any object for which the generic ;;;; functions IO-CHANNEL-IOPORT, IO-CHANNEL-EVENTS and ;;;; IO-CHANNEL-HANDLE are implemented. ;;;; ;;;; IO-CHANNEL-IOPORT, given an I/O multiplexer and an I/O channel, ;;;; should return the underlying system I/O facility that the channel ;;;; operates on. The actual objects used to represent an I/O facility ;;;; depends on the Lisp implementation, operating system and the ;;;; specific I/O loop implementation, but, for example, on Unix ;;;; implementations they will likely be numeric file descriptors. The ;;;; I/O loop implementation implements IO-CHANNEL-IOPORT methods for ;;;; the facilities it understands (such as FD-STREAMs on SBCL), so ;;;; user-implemented channels should simply call IO-CHANNEL-IOPORT ;;;; recursively on whatever it operates on. ;;;; ;;;; IO-CHANNEL-EVENTS, given an I/O channel, should return a list of ;;;; the events that the channel is interested in. See the ;;;; documentation for IO-CHANNEL-EVENTS for further details. ;;;; ;;;; The I/O loop guarantees that it will check what events a channel ;;;; is interested in when it is first registered, and also at any time ;;;; the channel has been notified of an event. If the channel changes ;;;; its mind at any other point in time, it should use the ;;;; IO-LOOP-UPDATE function to notify the I/O loop of such ;;;; changes. The I/O loop may very well also update spuriously at ;;;; other times, but such updates are not guaranteed. ;;;; ;;;; IO-CHANNEL-HANDLE is called by the I/O loop to notify a channel of ;;;; an event. ;;;; ;;;; An I/O multiplexer is created with a MAKE-INSTANCE call on the ;;;; class of the desired multiplexer implementation. If the code using ;;;; the multiplexer has no certain preferences on an implementation ;;;; (which should be the usual case), the variable *DEFAULT-IO-LOOP* ;;;; points to a class that should be generally optimal given the ;;;; current Lisp implementation and operating system. ;;;; ;;;; Given a multiplexer, channels can be registered with it using ;;;; IO-LOOP-ADD, unregistered with IO-LOOP-REMOVE, and updated with ;;;; IO-LOOP-UPDATE (as described above). Call IO-LOOP on the ;;;; multiplexer to actually run it. (export '(io-channel-ioport io-channel-events io-channel-handle *default-io-loop* *current-io-loop* *current-io-channel* io-loop io-loop-add io-loop-remove io-loop-update callback-channel callback-channel-stream callback-channel-events)) ;;; General interface (defgeneric io-channel-ioport (io-loop channel) (:documentation "Returns the I/O facility operated on by CHANNEL, in a representation understood by IO-LOOP. CHANNEL may be either an I/O channel or an object representing an underlying I/O facility, such as a stream object. An I/O loop implementation should implement methods for any primitive I/O facilities that it can monitor for events, and abstract channels should return whatever IO-CHANNEL-IOPORT returns for the primitive facility that it operates on. An I/O channel may also return NIL to indicate that it is only interested in purely virtual events, such as :TIMEOUT or :LOOP.")) (defgeneric io-channel-events (channel) (:documentation "Returns a list of events that CHANNEL is interested in. An event specification may be a simple symbol, or a list of a symbol and additional data for the event. Specific I/O loop implementations may implement additional events, but the following event specifications should be supported by all I/O loops: :READ -- The channel will be notified when its I/O port can be read from without blocking. :WRITE -- The channel will be notified when its I/O port can be written to without blocking. (:TIMEOUT TIME-SPEC) -- TIME-SPEC is a point in time in the same units as from (GET-INTERNAL-REAL-TIME), at which point the channel will be notified. It is permissible for TIME-SPEC to be a real number of any representation, but the system does not guarantee any particular level of accuracy. :LOOP -- The channel will be notifed for each iteration of the I/O loop, just before blocking for incoming events. This should be considered a hack to be avoided, but may be useful for certain libraries (such as XLIB). If, at any time, an empty list is returned, the channel is unregistered with the I/O loop. The I/O loop will check what events a channel is interested in when it is first registered with the loop, and whenever the channel has been notified of an event. If the channel changes its mind at any other point in time, it should use the IO-LOOP-UPDATE function to notify the I/O loop of such changes. The I/O loop may also update spuriously at any time, but such updates are not guaranteed.")) (defgeneric io-channel-handle (channel event &key &allow-other-keys) (:documentation "Called by the I/O loop to notify a channel that an event has occurred. EVENT is the symbol corresponding to the event specification from IO-CHANNEL-EVENTS (that is, :READ, :WRITE, :TIMEOUT or :LOOP). A number of keyword arguments with additional data specific to a certain event may also be passed, but no such arguments are currently defined.")) (defgeneric io-loop-add (io-loop channel) (:documentation "Add a channel to the given I/O multiplexer to be monitored.")) (defgeneric io-loop-remove (io-loop channel) (:documentation "Unregister a channel from the I/O multiplexer.")) (defgeneric io-loop-update (io-loop channel) (:documentation "Make the I/O loop update its knowledge of what events CHANNEL is interested in. See the documentation for IO-CHANNEL-EVENTS for more information.")) (defgeneric io-loop (io-loop &key &allow-other-keys) (:documentation "Run the given I/O multiplexer, watching for events on any channels registered with it. IO-LOOP will return when it has no channels left registered with it.")) (defvar *default-io-loop* 'sbcl-io-loop "The default I/O loop implementation. Should be generically optimal for the given LISP implementation and operating system.") (defvar *current-io-loop* nil "Dynamically bound to the I/O loop currently running, providing an easy way for event callbacks to register new channels.") (defvar *current-io-channel* nil "While processing an I/O channel, this variable is dynamically bound to the channel in question. This is provided primarily for error-handling code.") ;; Default methods for the above (defmethod io-channel-handle (channel event &key &allow-other-keys) (declare (ignore channel event))) ;;; SBCL implementation ;;; ;;; It would be generally nice if SBCL supported epoll/kqueue, but it ;;; doesn't. The general I/O loop interface is consistent with such ;;; implementations, however, so if support is added at any time, it ;;; could be supported fairly easily. ;;; ;;; If need should arise, it should also be quite simple to add ;;; thread-safe operation. (defclass sbcl-io-loop () ((channels :initform '())) (:documentation "Implements a select(2)-based I/O loop for SBCL. The implementation is not particularly optimal, mostly because any efficiency ambitions are mostly pointless as long as SBCL lacks support for epoll/kqueue, but should work well enough for I/O loops with relatively few channels. The implementation currently supports monitoring SB-SYS:FD-STREAM and XLIB:DISPLAY objects.")) (defmethod io-loop-add ((info sbcl-io-loop) channel) (with-slots (channels) info (when (find channel channels) (error "I/O channel is already registered")) (push channel channels))) (defmethod io-loop-remove ((info sbcl-io-loop) channel) (with-slots (channels) info (when (not (find channel channels)) (error "I/O channel is not currently registered")) (setf channels (delete channel channels)))) (defmethod io-loop-update ((info sbcl-io-loop) channel) (declare (ignore info channel))) (defmethod io-loop ((info sbcl-io-loop) &key description) (let ((*current-io-loop* info)) (with-simple-restart (:quit-ioloop "Quit I/O loop~A" (if description (format nil " (~A)" description) "")) (block io-loop (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)) (wfds (sb-alien:struct sb-unix:fd-set)) (efds (sb-alien:struct sb-unix:fd-set))) (loop :do (with-simple-restart (:restart-ioloop "Restart at I/O loop~A" (if description (format nil " (~A)" description) "")) (macrolet ((with-channel-restarts ((channel &optional remove-code) &body body) (let ((ch (gensym "CHANNEL"))) `(let* ((,ch ,channel) (*current-io-channel* ,ch)) (restart-case (progn ,@body) (:skip-channel () :report (lambda (s) (format s "Continue as if without channel ~S" ,ch)) nil) (:remove-channel () :report (lambda (s) (format s "Unregister channel ~S and continue" ,ch)) ,(or remove-code `(io-loop-remove info ,ch)) nil)))))) (let ((ch-map (make-hash-table :test 'eql)) (timeouts '()) (loop-ch '()) (maxfd 0)) ;; Since it is select(2)-based, this implementation ;; updates the entire set of interesting events once ;; every iteration. (let ((remove '())) (sb-unix:fd-zero rfds) (sb-unix:fd-zero wfds) (sb-unix:fd-zero efds) (dolist (channel (slot-value info 'channels)) (with-channel-restarts (channel (push channel remove)) (let ((fd (io-channel-ioport info channel))) (let ((events (io-channel-events channel))) (if events (dolist (event events) (multiple-value-bind (event data) (if (consp event) (values (car event) (cdr event)) (values event nil)) (case event (:read (setf maxfd (max maxfd fd)) (sb-unix:fd-set fd rfds) (push (cons :read channel) (gethash fd ch-map '()))) (:write (setf maxfd (max maxfd fd)) (sb-unix:fd-set fd wfds) (push (cons :write channel) (gethash fd ch-map '()))) (:timeout (let ((timeout (car data))) (check-type timeout real) (push (cons timeout channel) timeouts))) (:loop (push channel loop-ch))))) (push channel remove)))))) (dolist (channel remove) (io-loop-remove info channel)) (unless (slot-value info 'channels) (return-from io-loop))) ;; Call any :LOOP channels (dolist (channel loop-ch) (with-channel-restarts (channel) (io-channel-handle channel :loop))) (setf timeouts (sort timeouts '< :key 'car)) (flet ((compute-timeout () (if timeouts (let* ((internal-time-of-timeout (car (first timeouts))) (remaining-internal-time (- internal-time-of-timeout (get-internal-real-time))) (remaining-seconds (/ remaining-internal-time internal-time-units-per-second)) (s-to-ms 1000000) (remaining-ms (max (round (* remaining-seconds s-to-ms)) 0))) (floor remaining-ms 1000000)) (values nil nil)))) ;; Actually block for events (multiple-value-bind (rval errno) (multiple-value-call #'sb-unix:unix-fast-select (1+ maxfd) (sb-alien:addr rfds) (sb-alien:addr wfds) (sb-alien:addr efds) (compute-timeout)) (declare (ignore rval)) (cond ((and errno (plusp errno)) (unless (eql errno sb-unix:eintr) (dformat 1 "Unexpected ~S error: ~A~%" 'sb-unix:unix-fast-select (sb-int:strerror errno)))) (t ;; Notify channels for transpired events (maphash (lambda (fd evs) (let ((r (sb-unix:fd-isset fd rfds)) (w (sb-unix:fd-isset fd wfds)) (e (sb-unix:fd-isset fd efds))) (dolist (ev evs) (with-channel-restarts ((cdr ev)) (cond ((and (eq (car ev) :read) (or r e)) (io-channel-handle (cdr ev) :read)) ((and (eq (car ev) :write) w) (io-channel-handle (cdr ev) :write))))))) ch-map))))) ;; Check for timeouts (when timeouts (block timeouts (let ((now (get-internal-real-time))) (dolist (to timeouts) (if (<= (car to) now) (with-channel-restarts ((cdr to)) (io-channel-handle (cdr to) :timeout)) (return-from timeouts))))))))))))))) ;;; IO-CHANNEL-IOPORT methods for support facilities (defmethod io-channel-ioport (io-loop (channel sb-sys:fd-stream)) (declare (ignore io-loop)) (sb-sys:fd-stream-fd channel)) (defmethod io-channel-ioport ((io-loop sbcl-io-loop) (channel xlib:display)) (io-channel-ioport io-loop (xlib::display-input-stream channel))) ;;; Default methods for widely supported objects (defmethod io-channel-ioport (io-loop (channel synonym-stream)) (io-channel-ioport io-loop (symbol-value (synonym-stream-symbol channel)))) ;;; Callback channel implementation (defclass callback-channel () ((current :initform nil) (stream :initarg :stream :reader callback-channel-stream) (read-function :initform nil :initarg :read) (write-function :initform nil :initarg :write) (events :initform :auto :initarg :events :accessor callback-channel-events)) (:documentation "Implements a convenience I/O channel which takes an underlying I/O facility and calls the given callback functions when an event occurs on the channel. The :STREAM init-argument specifies the I/O facility to monitor, :READ specifies a function to be called back when a read event occurs, and :WRITE a corresponding function for write events. Timeouts are not supported. By default, the channel will listen for read events iff a read callback function is given and correspondingly for write events, but CALLBACK-CHANNEL-EVENTS can be SETF'd to specify events explicitly in case certain events are only interesting sporadically. To restore default behavior, set it to :AUTO.")) (defmethod io-loop-add :before (info (channel callback-channel)) (when (slot-value channel 'current) (error "Callback channel is already registered with an I/O loop"))) (defmethod io-loop-add :after (info (channel callback-channel)) (setf (slot-value channel 'current) info)) (defmethod io-loop-remove :after (info (channel callback-channel)) (setf (slot-value channel 'current) nil)) (defmethod io-channel-ioport (io-loop (channel callback-channel)) (io-channel-ioport io-loop (slot-value channel 'stream))) (defmethod io-channel-events ((channel callback-channel)) (with-slots (events) channel (if (eq events :auto) (let ((ret '())) (when (slot-value channel 'read-function) (push :read ret)) (when (slot-value channel 'write-function) (push :write ret)) ret) events))) (defmethod io-channel-handle ((channel callback-channel) (event (eql :read)) &key) (funcall (slot-value channel 'read-function) channel)) (defmethod (setf callback-channel-events) (events channel) (setf (slot-value channel 'events) events) (with-slots (current) channel (when current (io-loop-update current channel)))) stumpwm-22.11/iresize.lisp000066400000000000000000000070201433701203600155740ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;;; A resize minor mode. Something a bit better should probably be ;;; written. But it's an interesting way of doing it. ;; ;; Code: (in-package #:stumpwm) (export '(*resize-increment* iresize setup-iresize)) (defvar *resize-increment* 10 "Number of pixels to increment by when interactively resizing frames.") (defun set-resize-increment (val) (setf *resize-increment* val)) (defun single-frame-p () "Checks if there's only one frame." (let ((frame (tile-group-current-frame (current-group)))) (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))))) (defun abort-resize-p () "Resize is only available if there's more than one frame." (when (single-frame-p) (message "There's only 1 frame!") t)) (defun setup-iresize () "Start the interactive resize mode." (when *resize-hides-windows* (dolist (f (head-frames (current-group) (current-head))) (clear-frame f (current-group)))) (draw-frame-outlines (current-group) (current-head))) (defcommand resize-direction (d) ((:direction "Direction: ")) "Resize frame to direction @var{d}" (let* ((formats '((:up . "0 -~D") (:down . "0 ~D") (:left . "-~D 0") (:right . "~D 0"))) (deltas (format nil (cdr (assoc (princ d) formats)) *resize-increment*)) (to-be-run (concatenate 'string "resize " deltas))) (run-commands to-be-run))) (defun resize-unhide () (clear-frame-outlines (current-group)) (when *resize-hides-windows* (let ((group (current-group)) (head (current-head))) (dolist (f (head-frames group head)) (sync-frame-windows group f)) (dolist (w (reverse (head-windows group head))) (setf (frame-window (window-frame w)) w) (raise-window w)) (when (current-window) (focus-window (current-window)))))) (define-interactive-keymap (iresize tile-group) (:on-enter #'setup-iresize :on-exit #'resize-unhide :abort-if #'abort-resize-p) ((kbd "Up") "resize-direction up") ((kbd "C-p") "resize-direction up") ((kbd "p") "resize-direction up") ((kbd "k") "resize-direction up") ((kbd "Down") "resize-direction down") ((kbd "C-n") "resize-direction down") ((kbd "n") "resize-direction down") ((kbd "j") "resize-direction down") ((kbd "Left") "resize-direction left") ((kbd "C-b") "resize-direction left") ((kbd "b") "resize-direction left") ((kbd "h") "resize-direction left") ((kbd "Right") "resize-direction right") ((kbd "C-f") "resize-direction right") ((kbd "f") "resize-direction right") ((kbd "l") "resize-direction right")) stumpwm-22.11/keysyms.lisp000066400000000000000000003703101433701203600156330ustar00rootroot00000000000000;; Copyright (C) 2006-2008 Matthew Kennedy ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Mapping a keysym to a name is a client side activity in X11. Some ;; of the code here was taken from the CMUCL Hemlocks code base. The ;; actual mappings were taken from Xorg's keysymdefs.h. ;; ;; Code: (in-package #:stumpwm) (defvar *keysym-name-translations* (make-hash-table)) (defvar *name-keysym-translations* (make-hash-table :test #'equal)) (defvar *dead-key-name->sym* (make-hash-table :test #'equal)) (defvar *dead-key-sym->name* (make-hash-table)) (defun define-keysym (keysym name) "Define a mapping from a keysym name to a keysym." (setf (gethash keysym *keysym-name-translations*) name (gethash name *name-keysym-translations*) keysym)) (defun define-dead-keysym (keysym name) "Define a dead key keysym" (define-keysym keysym name) (setf (gethash name *dead-key-name->sym*) keysym (gethash keysym *dead-key-sym->name*) name)) (defun keysym-name->keysym (name) "Return the keysym corresponding to NAME." (multiple-value-bind (value present-p) (gethash name *name-keysym-translations*) (declare (ignore present-p)) value)) (defun keysym->keysym-name (keysym) "Return the name corresponding to KEYSYM." (multiple-value-bind (value present-p) (gethash keysym *keysym-name-translations*) (declare (ignore present-p)) value)) (define-keysym #xffffff "VoidSymbol") ;Void symbol (define-keysym #xff08 "BackSpace") ;Back space, back char (define-keysym #xff09 "Tab") (define-keysym #xff0a "Linefeed") ;Linefeed, LF (define-keysym #xff0b "Clear") (define-keysym #xff0d "Return") ;Return, enter (define-keysym #xff13 "Pause") ;Pause, hold (define-keysym #xff14 "Scroll_Lock") (define-keysym #xff15 "Sys_Req") (define-keysym #xff1b "Escape") (define-keysym #xffff "Delete") ;Delete, rubout (define-keysym #xff20 "Multi_key") ;Multi-key character compose (define-keysym #xff37 "Codeinput") (define-keysym #xff3c "SingleCandidate") (define-keysym #xff3d "MultipleCandidate") (define-keysym #xff3e "PreviousCandidate") (define-keysym #xff21 "Kanji") ;Kanji, Kanji convert (define-keysym #xff22 "Muhenkan") ;Cancel Conversion (define-keysym #xff23 "Henkan_Mode") ;Start/Stop Conversion (define-keysym #xff23 "Henkan") ;Alias for Henkan_Mode (define-keysym #xff24 "Romaji") ;to Romaji (define-keysym #xff25 "Hiragana") ;to Hiragana (define-keysym #xff26 "Katakana") ;to Katakana (define-keysym #xff27 "Hiragana_Katakana") ;Hiragana/Katakana toggle (define-keysym #xff28 "Zenkaku") ;to Zenkaku (define-keysym #xff29 "Hankaku") ;to Hankaku (define-keysym #xff2a "Zenkaku_Hankaku") ;Zenkaku/Hankaku toggle (define-keysym #xff2b "Touroku") ;Add to Dictionary (define-keysym #xff2c "Massyo") ;Delete from Dictionary (define-keysym #xff2d "Kana_Lock") ;Kana Lock (define-keysym #xff2e "Kana_Shift") ;Kana Shift (define-keysym #xff2f "Eisu_Shift") ;Alphanumeric Shift (define-keysym #xff30 "Eisu_toggle") ;Alphanumeric toggle (define-keysym #xff37 "Kanji_Bangou") ;Codeinput (define-keysym #xff3d "Zen_Koho") ;Multiple/All Candidate(s) (define-keysym #xff3e "Mae_Koho") ;Previous Candidate (define-keysym #xff50 "Home") (define-keysym #xff51 "Left") ;Move left, left arrow (define-keysym #xff52 "Up") ;Move up, up arrow (define-keysym #xff53 "Right") ;Move right, right arrow (define-keysym #xff54 "Down") ;Move down, down arrow (define-keysym #xff55 "Prior") ;Prior, previous (define-keysym #xff55 "Page_Up") (define-keysym #xff56 "Next") ;Next (define-keysym #xff56 "Page_Down") (define-keysym #xff57 "End") ;EOL (define-keysym #xff58 "Begin") ;BOL (define-keysym #xff60 "Select") ;Select, mark (define-keysym #xff61 "Print") (define-keysym #xff62 "Execute") ;Execute, run, do (define-keysym #xff63 "Insert") ;Insert, insert here (define-keysym #xff65 "Undo") (define-keysym #xff66 "Redo") ;Redo, again (define-keysym #xff67 "Menu") (define-keysym #xff68 "Find") ;Find, search (define-keysym #xff69 "Cancel") ;Cancel, stop, abort, exit (define-keysym #xff6a "Help") ;Help (define-keysym #xff6b "Break") (define-keysym #xff7e "Mode_switch") ;Character set switch (define-keysym #xff7e "script_switch") ;Alias for mode_switch (define-keysym #xff7f "Num_Lock") (define-keysym #xff80 "KP_Space") ;Space (define-keysym #xff89 "KP_Tab") (define-keysym #xff8d "KP_Enter") ;Enter (define-keysym #xff91 "KP_F1") ;PF1, KP_A, ... (define-keysym #xff92 "KP_F2") (define-keysym #xff93 "KP_F3") (define-keysym #xff94 "KP_F4") (define-keysym #xff95 "KP_Home") (define-keysym #xff96 "KP_Left") (define-keysym #xff97 "KP_Up") (define-keysym #xff98 "KP_Right") (define-keysym #xff99 "KP_Down") (define-keysym #xff9a "KP_Prior") (define-keysym #xff9a "KP_Page_Up") (define-keysym #xff9b "KP_Next") (define-keysym #xff9b "KP_Page_Down") (define-keysym #xff9c "KP_End") (define-keysym #xff9d "KP_Begin") (define-keysym #xff9e "KP_Insert") (define-keysym #xff9f "KP_Delete") (define-keysym #xffbd "KP_Equal") ;Equals (define-keysym #xffaa "KP_Multiply") (define-keysym #xffab "KP_Add") (define-keysym #xffac "KP_Separator") ;Separator, often comma (define-keysym #xffad "KP_Subtract") (define-keysym #xffae "KP_Decimal") (define-keysym #xffaf "KP_Divide") (define-keysym #xffb0 "KP_0") (define-keysym #xffb1 "KP_1") (define-keysym #xffb2 "KP_2") (define-keysym #xffb3 "KP_3") (define-keysym #xffb4 "KP_4") (define-keysym #xffb5 "KP_5") (define-keysym #xffb6 "KP_6") (define-keysym #xffb7 "KP_7") (define-keysym #xffb8 "KP_8") (define-keysym #xffb9 "KP_9") (define-keysym #xffbe "F1") (define-keysym #xffbf "F2") (define-keysym #xffc0 "F3") (define-keysym #xffc1 "F4") (define-keysym #xffc2 "F5") (define-keysym #xffc3 "F6") (define-keysym #xffc4 "F7") (define-keysym #xffc5 "F8") (define-keysym #xffc6 "F9") (define-keysym #xffc7 "F10") (define-keysym #xffc8 "F11") (define-keysym #xffc9 "F12") (define-keysym #xffca "F13") (define-keysym #xffcb "F14") (define-keysym #xffcc "F15") (define-keysym #xffcd "F16") (define-keysym #xffce "F17") (define-keysym #xffcf "F18") (define-keysym #xffd0 "F19") (define-keysym #xffd1 "F20") (define-keysym #xffd2 "F21") (define-keysym #xffd3 "F22") (define-keysym #xffd4 "F23") (define-keysym #xffd5 "F24") (define-keysym #xffd6 "F25") (define-keysym #xffd7 "F26") (define-keysym #xffd8 "F27") (define-keysym #xffd9 "F28") (define-keysym #xffda "F29") (define-keysym #xffdb "F30") (define-keysym #xffdc "F31") (define-keysym #xffdd "F32") (define-keysym #xffde "F33") (define-keysym #xffdf "F34") (define-keysym #xffe0 "F35") (define-keysym #xffe1 "Shift_L") ;Left shift (define-keysym #xffe2 "Shift_R") ;Right shift (define-keysym #xffe3 "Control_L") ;Left control (define-keysym #xffe4 "Control_R") ;Right control (define-keysym #xffe5 "Caps_Lock") ;Caps lock (define-keysym #xffe6 "Shift_Lock") ;Shift lock (define-keysym #xffe7 "Meta_L") ;Left meta (define-keysym #xffe8 "Meta_R") ;Right meta (define-keysym #xffe9 "Alt_L") ;Left alt (define-keysym #xffea "Alt_R") ;Right alt (define-keysym #xffeb "Super_L") ;Left super (define-keysym #xffec "Super_R") ;Right super (define-keysym #xffed "Hyper_L") ;Left hyper (define-keysym #xffee "Hyper_R") ;Right hyper (define-keysym #xfe01 "ISO_Lock") (define-keysym #xfe02 "ISO_Level2_Latch") (define-keysym #xfe03 "ISO_Level3_Shift") (define-keysym #xfe04 "ISO_Level3_Latch") (define-keysym #xfe05 "ISO_Level3_Lock") (define-keysym #xff7e "ISO_Group_Shift") ;Alias for mode_switch (define-keysym #xfe06 "ISO_Group_Latch") (define-keysym #xfe07 "ISO_Group_Lock") (define-keysym #xfe08 "ISO_Next_Group") (define-keysym #xfe09 "ISO_Next_Group_Lock") (define-keysym #xfe0a "ISO_Prev_Group") (define-keysym #xfe0b "ISO_Prev_Group_Lock") (define-keysym #xfe0c "ISO_First_Group") (define-keysym #xfe0d "ISO_First_Group_Lock") (define-keysym #xfe0e "ISO_Last_Group") (define-keysym #xfe0f "ISO_Last_Group_Lock") (define-keysym #xfe20 "ISO_Left_Tab") (define-keysym #xfe21 "ISO_Move_Line_Up") (define-keysym #xfe22 "ISO_Move_Line_Down") (define-keysym #xfe23 "ISO_Partial_Line_Up") (define-keysym #xfe24 "ISO_Partial_Line_Down") (define-keysym #xfe25 "ISO_Partial_Space_Left") (define-keysym #xfe26 "ISO_Partial_Space_Right") (define-keysym #xfe27 "ISO_Set_Margin_Left") (define-keysym #xfe28 "ISO_Set_Margin_Right") (define-keysym #xfe29 "ISO_Release_Margin_Left") (define-keysym #xfe2a "ISO_Release_Margin_Right") (define-keysym #xfe2b "ISO_Release_Both_Margins") (define-keysym #xfe2c "ISO_Fast_Cursor_Left") (define-keysym #xfe2d "ISO_Fast_Cursor_Right") (define-keysym #xfe2e "ISO_Fast_Cursor_Up") (define-keysym #xfe2f "ISO_Fast_Cursor_Down") (define-keysym #xfe30 "ISO_Continuous_Underline") (define-keysym #xfe31 "ISO_Discontinuous_Underline") (define-keysym #xfe32 "ISO_Emphasize") (define-keysym #xfe33 "ISO_Center_Object") (define-keysym #xfe34 "ISO_Enter") (define-dead-keysym #xfe50 "dead_grave") (define-dead-keysym #xfe51 "dead_acute") (define-dead-keysym #xfe52 "dead_circumflex") (define-dead-keysym #xfe53 "dead_tilde") (define-dead-keysym #xfe54 "dead_macron") (define-dead-keysym #xfe55 "dead_breve") (define-dead-keysym #xfe56 "dead_abovedot") (define-dead-keysym #xfe57 "dead_diaeresis") (define-dead-keysym #xfe58 "dead_abovering") (define-dead-keysym #xfe59 "dead_doubleacute") (define-dead-keysym #xfe5a "dead_caron") (define-dead-keysym #xfe5b "dead_cedilla") (define-dead-keysym #xfe5c "dead_ogonek") (define-dead-keysym #xfe5d "dead_iota") (define-dead-keysym #xfe5e "dead_voiced_sound") (define-dead-keysym #xfe5f "dead_semivoiced_sound") (define-dead-keysym #xfe60 "dead_belowdot") (define-dead-keysym #xfe61 "dead_hook") (define-dead-keysym #xfe62 "dead_horn") (define-keysym #xfed0 "First_Virtual_Screen") (define-keysym #xfed1 "Prev_Virtual_Screen") (define-keysym #xfed2 "Next_Virtual_Screen") (define-keysym #xfed4 "Last_Virtual_Screen") (define-keysym #xfed5 "Terminate_Server") (define-keysym #xfe70 "AccessX_Enable") (define-keysym #xfe71 "AccessX_Feedback_Enable") (define-keysym #xfe72 "RepeatKeys_Enable") (define-keysym #xfe73 "SlowKeys_Enable") (define-keysym #xfe74 "BounceKeys_Enable") (define-keysym #xfe75 "StickyKeys_Enable") (define-keysym #xfe76 "MouseKeys_Enable") (define-keysym #xfe77 "MouseKeys_Accel_Enable") (define-keysym #xfe78 "Overlay1_Enable") (define-keysym #xfe79 "Overlay2_Enable") (define-keysym #xfe7a "AudibleBell_Enable") (define-keysym #xfee0 "Pointer_Left") (define-keysym #xfee1 "Pointer_Right") (define-keysym #xfee2 "Pointer_Up") (define-keysym #xfee3 "Pointer_Down") (define-keysym #xfee4 "Pointer_UpLeft") (define-keysym #xfee5 "Pointer_UpRight") (define-keysym #xfee6 "Pointer_DownLeft") (define-keysym #xfee7 "Pointer_DownRight") (define-keysym #xfee8 "Pointer_Button_Dflt") (define-keysym #xfee9 "Pointer_Button1") (define-keysym #xfeea "Pointer_Button2") (define-keysym #xfeeb "Pointer_Button3") (define-keysym #xfeec "Pointer_Button4") (define-keysym #xfeed "Pointer_Button5") (define-keysym #xfeee "Pointer_DblClick_Dflt") (define-keysym #xfeef "Pointer_DblClick1") (define-keysym #xfef0 "Pointer_DblClick2") (define-keysym #xfef1 "Pointer_DblClick3") (define-keysym #xfef2 "Pointer_DblClick4") (define-keysym #xfef3 "Pointer_DblClick5") (define-keysym #xfef4 "Pointer_Drag_Dflt") (define-keysym #xfef5 "Pointer_Drag1") (define-keysym #xfef6 "Pointer_Drag2") (define-keysym #xfef7 "Pointer_Drag3") (define-keysym #xfef8 "Pointer_Drag4") (define-keysym #xfefd "Pointer_Drag5") (define-keysym #xfef9 "Pointer_EnableKeys") (define-keysym #xfefa "Pointer_Accelerate") (define-keysym #xfefb "Pointer_DfltBtnNext") (define-keysym #xfefc "Pointer_DfltBtnPrev") (define-keysym #xfd01 "3270_Duplicate") (define-keysym #xfd02 "3270_FieldMark") (define-keysym #xfd03 "3270_Right2") (define-keysym #xfd04 "3270_Left2") (define-keysym #xfd05 "3270_BackTab") (define-keysym #xfd06 "3270_EraseEOF") (define-keysym #xfd07 "3270_EraseInput") (define-keysym #xfd08 "3270_Reset") (define-keysym #xfd09 "3270_Quit") (define-keysym #xfd0a "3270_PA1") (define-keysym #xfd0b "3270_PA2") (define-keysym #xfd0c "3270_PA3") (define-keysym #xfd0d "3270_Test") (define-keysym #xfd0e "3270_Attn") (define-keysym #xfd0f "3270_CursorBlink") (define-keysym #xfd10 "3270_AltCursor") (define-keysym #xfd11 "3270_KeyClick") (define-keysym #xfd12 "3270_Jump") (define-keysym #xfd13 "3270_Ident") (define-keysym #xfd14 "3270_Rule") (define-keysym #xfd15 "3270_Copy") (define-keysym #xfd16 "3270_Play") (define-keysym #xfd17 "3270_Setup") (define-keysym #xfd18 "3270_Record") (define-keysym #xfd19 "3270_ChangeScreen") (define-keysym #xfd1a "3270_DeleteWord") (define-keysym #xfd1b "3270_ExSelect") (define-keysym #xfd1c "3270_CursorSelect") (define-keysym #xfd1d "3270_PrintScreen") (define-keysym #xfd1e "3270_Enter") (define-keysym #x0020 "space") ;U+0020 SPACE (define-keysym #x0021 "exclam") ;U+0021 EXCLAMATION MARK (define-keysym #x0022 "quotedbl") ;U+0022 QUOTATION MARK (define-keysym #x0023 "numbersign") ;U+0023 NUMBER SIGN (define-keysym #x0024 "dollar") ;U+0024 DOLLAR SIGN (define-keysym #x0025 "percent") ;U+0025 PERCENT SIGN (define-keysym #x0026 "ampersand") ;U+0026 AMPERSAND (define-keysym #x0027 "apostrophe") ;U+0027 APOSTROPHE (define-keysym #x0027 "quoteright") ;deprecated (define-keysym #x0028 "parenleft") ;U+0028 LEFT PARENTHESIS (define-keysym #x0029 "parenright") ;U+0029 RIGHT PARENTHESIS (define-keysym #x002a "asterisk") ;U+002A ASTERISK (define-keysym #x002b "plus") ;U+002B PLUS SIGN (define-keysym #x002c "comma") ;U+002C COMMA (define-keysym #x002d "minus") ;U+002D HYPHEN-MINUS (define-keysym #x002e "period") ;U+002E FULL STOP (define-keysym #x002f "slash") ;U+002F SOLIDUS (define-keysym #x0030 "0") ;U+0030 DIGIT ZERO (define-keysym #x0031 "1") ;U+0031 DIGIT ONE (define-keysym #x0032 "2") ;U+0032 DIGIT TWO (define-keysym #x0033 "3") ;U+0033 DIGIT THREE (define-keysym #x0034 "4") ;U+0034 DIGIT FOUR (define-keysym #x0035 "5") ;U+0035 DIGIT FIVE (define-keysym #x0036 "6") ;U+0036 DIGIT SIX (define-keysym #x0037 "7") ;U+0037 DIGIT SEVEN (define-keysym #x0038 "8") ;U+0038 DIGIT EIGHT (define-keysym #x0039 "9") ;U+0039 DIGIT NINE (define-keysym #x003a "colon") ;U+003A COLON (define-keysym #x003b "semicolon") ;U+003B SEMICOLON (define-keysym #x003c "less") ;U+003C LESS-THAN SIGN (define-keysym #x003d "equal") ;U+003D EQUALS SIGN (define-keysym #x003e "greater") ;U+003E GREATER-THAN SIGN (define-keysym #x003f "question") ;U+003F QUESTION MARK (define-keysym #x0040 "at") ;U+0040 COMMERCIAL AT (define-keysym #x0041 "A") ;U+0041 LATIN CAPITAL LETTER A (define-keysym #x0042 "B") ;U+0042 LATIN CAPITAL LETTER B (define-keysym #x0043 "C") ;U+0043 LATIN CAPITAL LETTER C (define-keysym #x0044 "D") ;U+0044 LATIN CAPITAL LETTER D (define-keysym #x0045 "E") ;U+0045 LATIN CAPITAL LETTER E (define-keysym #x0046 "F") ;U+0046 LATIN CAPITAL LETTER F (define-keysym #x0047 "G") ;U+0047 LATIN CAPITAL LETTER G (define-keysym #x0048 "H") ;U+0048 LATIN CAPITAL LETTER H (define-keysym #x0049 "I") ;U+0049 LATIN CAPITAL LETTER I (define-keysym #x004a "J") ;U+004A LATIN CAPITAL LETTER J (define-keysym #x004b "K") ;U+004B LATIN CAPITAL LETTER K (define-keysym #x004c "L") ;U+004C LATIN CAPITAL LETTER L (define-keysym #x004d "M") ;U+004D LATIN CAPITAL LETTER M (define-keysym #x004e "N") ;U+004E LATIN CAPITAL LETTER N (define-keysym #x004f "O") ;U+004F LATIN CAPITAL LETTER O (define-keysym #x0050 "P") ;U+0050 LATIN CAPITAL LETTER P (define-keysym #x0051 "Q") ;U+0051 LATIN CAPITAL LETTER Q (define-keysym #x0052 "R") ;U+0052 LATIN CAPITAL LETTER R (define-keysym #x0053 "S") ;U+0053 LATIN CAPITAL LETTER S (define-keysym #x0054 "T") ;U+0054 LATIN CAPITAL LETTER T (define-keysym #x0055 "U") ;U+0055 LATIN CAPITAL LETTER U (define-keysym #x0056 "V") ;U+0056 LATIN CAPITAL LETTER V (define-keysym #x0057 "W") ;U+0057 LATIN CAPITAL LETTER W (define-keysym #x0058 "X") ;U+0058 LATIN CAPITAL LETTER X (define-keysym #x0059 "Y") ;U+0059 LATIN CAPITAL LETTER Y (define-keysym #x005a "Z") ;U+005A LATIN CAPITAL LETTER Z (define-keysym #x005b "bracketleft") ;U+005B LEFT SQUARE BRACKET (define-keysym #x005c "backslash") ;U+005C REVERSE SOLIDUS (define-keysym #x005d "bracketright") ;U+005D RIGHT SQUARE BRACKET (define-keysym #x005e "asciicircum") ;U+005E CIRCUMFLEX ACCENT (define-keysym #x005f "underscore") ;U+005F LOW LINE (define-keysym #x0060 "grave") ;U+0060 GRAVE ACCENT (define-keysym #x0060 "quoteleft") ;deprecated (define-keysym #x0061 "a") ;U+0061 LATIN SMALL LETTER A (define-keysym #x0062 "b") ;U+0062 LATIN SMALL LETTER B (define-keysym #x0063 "c") ;U+0063 LATIN SMALL LETTER C (define-keysym #x0064 "d") ;U+0064 LATIN SMALL LETTER D (define-keysym #x0065 "e") ;U+0065 LATIN SMALL LETTER E (define-keysym #x0066 "f") ;U+0066 LATIN SMALL LETTER F (define-keysym #x0067 "g") ;U+0067 LATIN SMALL LETTER G (define-keysym #x0068 "h") ;U+0068 LATIN SMALL LETTER H (define-keysym #x0069 "i") ;U+0069 LATIN SMALL LETTER I (define-keysym #x006a "j") ;U+006A LATIN SMALL LETTER J (define-keysym #x006b "k") ;U+006B LATIN SMALL LETTER K (define-keysym #x006c "l") ;U+006C LATIN SMALL LETTER L (define-keysym #x006d "m") ;U+006D LATIN SMALL LETTER M (define-keysym #x006e "n") ;U+006E LATIN SMALL LETTER N (define-keysym #x006f "o") ;U+006F LATIN SMALL LETTER O (define-keysym #x0070 "p") ;U+0070 LATIN SMALL LETTER P (define-keysym #x0071 "q") ;U+0071 LATIN SMALL LETTER Q (define-keysym #x0072 "r") ;U+0072 LATIN SMALL LETTER R (define-keysym #x0073 "s") ;U+0073 LATIN SMALL LETTER S (define-keysym #x0074 "t") ;U+0074 LATIN SMALL LETTER T (define-keysym #x0075 "u") ;U+0075 LATIN SMALL LETTER U (define-keysym #x0076 "v") ;U+0076 LATIN SMALL LETTER V (define-keysym #x0077 "w") ;U+0077 LATIN SMALL LETTER W (define-keysym #x0078 "x") ;U+0078 LATIN SMALL LETTER X (define-keysym #x0079 "y") ;U+0079 LATIN SMALL LETTER Y (define-keysym #x007a "z") ;U+007A LATIN SMALL LETTER Z (define-keysym #x007b "braceleft") ;U+007B LEFT CURLY BRACKET (define-keysym #x007c "bar") ;U+007C VERTICAL LINE (define-keysym #x007d "braceright") ;U+007D RIGHT CURLY BRACKET (define-keysym #x007e "asciitilde") ;U+007E TILDE (define-keysym #x00a0 "nobreakspace") ;U+00A0 NO-BREAK SPACE (define-keysym #x00a1 "exclamdown") ;U+00A1 INVERTED EXCLAMATION MARK (define-keysym #x00a2 "cent") ;U+00A2 CENT SIGN (define-keysym #x00a3 "sterling") ;U+00A3 POUND SIGN (define-keysym #x00a4 "currency") ;U+00A4 CURRENCY SIGN (define-keysym #x00a5 "yen") ;U+00A5 YEN SIGN (define-keysym #x00a6 "brokenbar") ;U+00A6 BROKEN BAR (define-keysym #x00a7 "section") ;U+00A7 SECTION SIGN (define-keysym #x00a8 "diaeresis") ;U+00A8 DIAERESIS (define-keysym #x00a9 "copyright") ;U+00A9 COPYRIGHT SIGN (define-keysym #x00aa "ordfeminine") ;U+00AA FEMININE ORDINAL INDICATOR (define-keysym #x00ab "guillemotleft") ;U+00AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK (define-keysym #x00ac "notsign") ;U+00AC NOT SIGN (define-keysym #x00ad "hyphen") ;U+00AD SOFT HYPHEN (define-keysym #x00ae "registered") ;U+00AE REGISTERED SIGN (define-keysym #x00af "macron") ;U+00AF MACRON (define-keysym #x00b0 "degree") ;U+00B0 DEGREE SIGN (define-keysym #x00b1 "plusminus") ;U+00B1 PLUS-MINUS SIGN (define-keysym #x00b2 "twosuperior") ;U+00B2 SUPERSCRIPT TWO (define-keysym #x00b3 "threesuperior") ;U+00B3 SUPERSCRIPT THREE (define-keysym #x00b4 "acute") ;U+00B4 ACUTE ACCENT (define-keysym #x00b5 "mu") ;U+00B5 MICRO SIGN (define-keysym #x00b6 "paragraph") ;U+00B6 PILCROW SIGN (define-keysym #x00b7 "periodcentered") ;U+00B7 MIDDLE DOT (define-keysym #x00b8 "cedilla") ;U+00B8 CEDILLA (define-keysym #x00b9 "onesuperior") ;U+00B9 SUPERSCRIPT ONE (define-keysym #x00ba "masculine") ;U+00BA MASCULINE ORDINAL INDICATOR (define-keysym #x00bb "guillemotright") ;U+00BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK (define-keysym #x00bc "onequarter") ;U+00BC VULGAR FRACTION ONE QUARTER (define-keysym #x00bd "onehalf") ;U+00BD VULGAR FRACTION ONE HALF (define-keysym #x00be "threequarters") ;U+00BE VULGAR FRACTION THREE QUARTERS (define-keysym #x00bf "questiondown") ;U+00BF INVERTED QUESTION MARK (define-keysym #x00c0 "Agrave") ;U+00C0 LATIN CAPITAL LETTER A WITH GRAVE (define-keysym #x00c1 "Aacute") ;U+00C1 LATIN CAPITAL LETTER A WITH ACUTE (define-keysym #x00c2 "Acircumflex") ;U+00C2 LATIN CAPITAL LETTER A WITH CIRCUMFLEX (define-keysym #x00c3 "Atilde") ;U+00C3 LATIN CAPITAL LETTER A WITH TILDE (define-keysym #x00c4 "Adiaeresis") ;U+00C4 LATIN CAPITAL LETTER A WITH DIAERESIS (define-keysym #x00c5 "Aring") ;U+00C5 LATIN CAPITAL LETTER A WITH RING ABOVE (define-keysym #x00c6 "AE") ;U+00C6 LATIN CAPITAL LETTER AE (define-keysym #x00c7 "Ccedilla") ;U+00C7 LATIN CAPITAL LETTER C WITH CEDILLA (define-keysym #x00c8 "Egrave") ;U+00C8 LATIN CAPITAL LETTER E WITH GRAVE (define-keysym #x00c9 "Eacute") ;U+00C9 LATIN CAPITAL LETTER E WITH ACUTE (define-keysym #x00ca "Ecircumflex") ;U+00CA LATIN CAPITAL LETTER E WITH CIRCUMFLEX (define-keysym #x00cb "Ediaeresis") ;U+00CB LATIN CAPITAL LETTER E WITH DIAERESIS (define-keysym #x00cc "Igrave") ;U+00CC LATIN CAPITAL LETTER I WITH GRAVE (define-keysym #x00cd "Iacute") ;U+00CD LATIN CAPITAL LETTER I WITH ACUTE (define-keysym #x00ce "Icircumflex") ;U+00CE LATIN CAPITAL LETTER I WITH CIRCUMFLEX (define-keysym #x00cf "Idiaeresis") ;U+00CF LATIN CAPITAL LETTER I WITH DIAERESIS (define-keysym #x00d0 "ETH") ;U+00D0 LATIN CAPITAL LETTER ETH (define-keysym #x00d0 "Eth") ;deprecated (define-keysym #x00d1 "Ntilde") ;U+00D1 LATIN CAPITAL LETTER N WITH TILDE (define-keysym #x00d2 "Ograve") ;U+00D2 LATIN CAPITAL LETTER O WITH GRAVE (define-keysym #x00d3 "Oacute") ;U+00D3 LATIN CAPITAL LETTER O WITH ACUTE (define-keysym #x00d4 "Ocircumflex") ;U+00D4 LATIN CAPITAL LETTER O WITH CIRCUMFLEX (define-keysym #x00d5 "Otilde") ;U+00D5 LATIN CAPITAL LETTER O WITH TILDE (define-keysym #x00d6 "Odiaeresis") ;U+00D6 LATIN CAPITAL LETTER O WITH DIAERESIS (define-keysym #x00d7 "multiply") ;U+00D7 MULTIPLICATION SIGN (define-keysym #x00d8 "Oslash") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE (define-keysym #x00d8 "Ooblique") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE (define-keysym #x00d9 "Ugrave") ;U+00D9 LATIN CAPITAL LETTER U WITH GRAVE (define-keysym #x00da "Uacute") ;U+00DA LATIN CAPITAL LETTER U WITH ACUTE (define-keysym #x00db "Ucircumflex") ;U+00DB LATIN CAPITAL LETTER U WITH CIRCUMFLEX (define-keysym #x00dc "Udiaeresis") ;U+00DC LATIN CAPITAL LETTER U WITH DIAERESIS (define-keysym #x00dd "Yacute") ;U+00DD LATIN CAPITAL LETTER Y WITH ACUTE (define-keysym #x00de "THORN") ;U+00DE LATIN CAPITAL LETTER THORN (define-keysym #x00de "Thorn") ;deprecated (define-keysym #x00df "ssharp") ;U+00DF LATIN SMALL LETTER SHARP S (define-keysym #x00e0 "agrave") ;U+00E0 LATIN SMALL LETTER A WITH GRAVE (define-keysym #x00e1 "aacute") ;U+00E1 LATIN SMALL LETTER A WITH ACUTE (define-keysym #x00e2 "acircumflex") ;U+00E2 LATIN SMALL LETTER A WITH CIRCUMFLEX (define-keysym #x00e3 "atilde") ;U+00E3 LATIN SMALL LETTER A WITH TILDE (define-keysym #x00e4 "adiaeresis") ;U+00E4 LATIN SMALL LETTER A WITH DIAERESIS (define-keysym #x00e5 "aring") ;U+00E5 LATIN SMALL LETTER A WITH RING ABOVE (define-keysym #x00e6 "ae") ;U+00E6 LATIN SMALL LETTER AE (define-keysym #x00e7 "ccedilla") ;U+00E7 LATIN SMALL LETTER C WITH CEDILLA (define-keysym #x00e8 "egrave") ;U+00E8 LATIN SMALL LETTER E WITH GRAVE (define-keysym #x00e9 "eacute") ;U+00E9 LATIN SMALL LETTER E WITH ACUTE (define-keysym #x00ea "ecircumflex") ;U+00EA LATIN SMALL LETTER E WITH CIRCUMFLEX (define-keysym #x00eb "ediaeresis") ;U+00EB LATIN SMALL LETTER E WITH DIAERESIS (define-keysym #x00ec "igrave") ;U+00EC LATIN SMALL LETTER I WITH GRAVE (define-keysym #x00ed "iacute") ;U+00ED LATIN SMALL LETTER I WITH ACUTE (define-keysym #x00ee "icircumflex") ;U+00EE LATIN SMALL LETTER I WITH CIRCUMFLEX (define-keysym #x00ef "idiaeresis") ;U+00EF LATIN SMALL LETTER I WITH DIAERESIS (define-keysym #x00f0 "eth") ;U+00F0 LATIN SMALL LETTER ETH (define-keysym #x00f1 "ntilde") ;U+00F1 LATIN SMALL LETTER N WITH TILDE (define-keysym #x00f2 "ograve") ;U+00F2 LATIN SMALL LETTER O WITH GRAVE (define-keysym #x00f3 "oacute") ;U+00F3 LATIN SMALL LETTER O WITH ACUTE (define-keysym #x00f4 "ocircumflex") ;U+00F4 LATIN SMALL LETTER O WITH CIRCUMFLEX (define-keysym #x00f5 "otilde") ;U+00F5 LATIN SMALL LETTER O WITH TILDE (define-keysym #x00f6 "odiaeresis") ;U+00F6 LATIN SMALL LETTER O WITH DIAERESIS (define-keysym #x00f7 "division") ;U+00F7 DIVISION SIGN (define-keysym #x00f8 "oslash") ;U+00F8 LATIN SMALL LETTER O WITH STROKE (define-keysym #x00f8 "ooblique") ;U+00F8 LATIN SMALL LETTER O WITH STROKE (define-keysym #x00f9 "ugrave") ;U+00F9 LATIN SMALL LETTER U WITH GRAVE (define-keysym #x00fa "uacute") ;U+00FA LATIN SMALL LETTER U WITH ACUTE (define-keysym #x00fb "ucircumflex") ;U+00FB LATIN SMALL LETTER U WITH CIRCUMFLEX (define-keysym #x00fc "udiaeresis") ;U+00FC LATIN SMALL LETTER U WITH DIAERESIS (define-keysym #x00fd "yacute") ;U+00FD LATIN SMALL LETTER Y WITH ACUTE (define-keysym #x00fe "thorn") ;U+00FE LATIN SMALL LETTER THORN (define-keysym #x00ff "ydiaeresis") ;U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (define-keysym #x01a1 "Aogonek") ;U+0104 LATIN CAPITAL LETTER A WITH OGONEK (define-keysym #x01a2 "breve") ;U+02D8 BREVE (define-keysym #x01a3 "Lstroke") ;U+0141 LATIN CAPITAL LETTER L WITH STROKE (define-keysym #x01a5 "Lcaron") ;U+013D LATIN CAPITAL LETTER L WITH CARON (define-keysym #x01a6 "Sacute") ;U+015A LATIN CAPITAL LETTER S WITH ACUTE (define-keysym #x01a9 "Scaron") ;U+0160 LATIN CAPITAL LETTER S WITH CARON (define-keysym #x01aa "Scedilla") ;U+015E LATIN CAPITAL LETTER S WITH CEDILLA (define-keysym #x01ab "Tcaron") ;U+0164 LATIN CAPITAL LETTER T WITH CARON (define-keysym #x01ac "Zacute") ;U+0179 LATIN CAPITAL LETTER Z WITH ACUTE (define-keysym #x01ae "Zcaron") ;U+017D LATIN CAPITAL LETTER Z WITH CARON (define-keysym #x01af "Zabovedot") ;U+017B LATIN CAPITAL LETTER Z WITH DOT ABOVE (define-keysym #x01b1 "aogonek") ;U+0105 LATIN SMALL LETTER A WITH OGONEK (define-keysym #x01b2 "ogonek") ;U+02DB OGONEK (define-keysym #x01b3 "lstroke") ;U+0142 LATIN SMALL LETTER L WITH STROKE (define-keysym #x01b5 "lcaron") ;U+013E LATIN SMALL LETTER L WITH CARON (define-keysym #x01b6 "sacute") ;U+015B LATIN SMALL LETTER S WITH ACUTE (define-keysym #x01b7 "caron") ;U+02C7 CARON (define-keysym #x01b9 "scaron") ;U+0161 LATIN SMALL LETTER S WITH CARON (define-keysym #x01ba "scedilla") ;U+015F LATIN SMALL LETTER S WITH CEDILLA (define-keysym #x01bb "tcaron") ;U+0165 LATIN SMALL LETTER T WITH CARON (define-keysym #x01bc "zacute") ;U+017A LATIN SMALL LETTER Z WITH ACUTE (define-keysym #x01bd "doubleacute") ;U+02DD DOUBLE ACUTE ACCENT (define-keysym #x01be "zcaron") ;U+017E LATIN SMALL LETTER Z WITH CARON (define-keysym #x01bf "zabovedot") ;U+017C LATIN SMALL LETTER Z WITH DOT ABOVE (define-keysym #x01c0 "Racute") ;U+0154 LATIN CAPITAL LETTER R WITH ACUTE (define-keysym #x01c3 "Abreve") ;U+0102 LATIN CAPITAL LETTER A WITH BREVE (define-keysym #x01c5 "Lacute") ;U+0139 LATIN CAPITAL LETTER L WITH ACUTE (define-keysym #x01c6 "Cacute") ;U+0106 LATIN CAPITAL LETTER C WITH ACUTE (define-keysym #x01c8 "Ccaron") ;U+010C LATIN CAPITAL LETTER C WITH CARON (define-keysym #x01ca "Eogonek") ;U+0118 LATIN CAPITAL LETTER E WITH OGONEK (define-keysym #x01cc "Ecaron") ;U+011A LATIN CAPITAL LETTER E WITH CARON (define-keysym #x01cf "Dcaron") ;U+010E LATIN CAPITAL LETTER D WITH CARON (define-keysym #x01d0 "Dstroke") ;U+0110 LATIN CAPITAL LETTER D WITH STROKE (define-keysym #x01d1 "Nacute") ;U+0143 LATIN CAPITAL LETTER N WITH ACUTE (define-keysym #x01d2 "Ncaron") ;U+0147 LATIN CAPITAL LETTER N WITH CARON (define-keysym #x01d5 "Odoubleacute") ;U+0150 LATIN CAPITAL LETTER O WITH DOUBLE ACUTE (define-keysym #x01d8 "Rcaron") ;U+0158 LATIN CAPITAL LETTER R WITH CARON (define-keysym #x01d9 "Uring") ;U+016E LATIN CAPITAL LETTER U WITH RING ABOVE (define-keysym #x01db "Udoubleacute") ;U+0170 LATIN CAPITAL LETTER U WITH DOUBLE ACUTE (define-keysym #x01de "Tcedilla") ;U+0162 LATIN CAPITAL LETTER T WITH CEDILLA (define-keysym #x01e0 "racute") ;U+0155 LATIN SMALL LETTER R WITH ACUTE (define-keysym #x01e3 "abreve") ;U+0103 LATIN SMALL LETTER A WITH BREVE (define-keysym #x01e5 "lacute") ;U+013A LATIN SMALL LETTER L WITH ACUTE (define-keysym #x01e6 "cacute") ;U+0107 LATIN SMALL LETTER C WITH ACUTE (define-keysym #x01e8 "ccaron") ;U+010D LATIN SMALL LETTER C WITH CARON (define-keysym #x01ea "eogonek") ;U+0119 LATIN SMALL LETTER E WITH OGONEK (define-keysym #x01ec "ecaron") ;U+011B LATIN SMALL LETTER E WITH CARON (define-keysym #x01ef "dcaron") ;U+010F LATIN SMALL LETTER D WITH CARON (define-keysym #x01f0 "dstroke") ;U+0111 LATIN SMALL LETTER D WITH STROKE (define-keysym #x01f1 "nacute") ;U+0144 LATIN SMALL LETTER N WITH ACUTE (define-keysym #x01f2 "ncaron") ;U+0148 LATIN SMALL LETTER N WITH CARON (define-keysym #x01f5 "odoubleacute") ;U+0151 LATIN SMALL LETTER O WITH DOUBLE ACUTE (define-keysym #x01fb "udoubleacute") ;U+0171 LATIN SMALL LETTER U WITH DOUBLE ACUTE (define-keysym #x01f8 "rcaron") ;U+0159 LATIN SMALL LETTER R WITH CARON (define-keysym #x01f9 "uring") ;U+016F LATIN SMALL LETTER U WITH RING ABOVE (define-keysym #x01fe "tcedilla") ;U+0163 LATIN SMALL LETTER T WITH CEDILLA (define-keysym #x01ff "abovedot") ;U+02D9 DOT ABOVE (define-keysym #x02a1 "Hstroke") ;U+0126 LATIN CAPITAL LETTER H WITH STROKE (define-keysym #x02a6 "Hcircumflex") ;U+0124 LATIN CAPITAL LETTER H WITH CIRCUMFLEX (define-keysym #x02a9 "Iabovedot") ;U+0130 LATIN CAPITAL LETTER I WITH DOT ABOVE (define-keysym #x02ab "Gbreve") ;U+011E LATIN CAPITAL LETTER G WITH BREVE (define-keysym #x02ac "Jcircumflex") ;U+0134 LATIN CAPITAL LETTER J WITH CIRCUMFLEX (define-keysym #x02b1 "hstroke") ;U+0127 LATIN SMALL LETTER H WITH STROKE (define-keysym #x02b6 "hcircumflex") ;U+0125 LATIN SMALL LETTER H WITH CIRCUMFLEX (define-keysym #x02b9 "idotless") ;U+0131 LATIN SMALL LETTER DOTLESS I (define-keysym #x02bb "gbreve") ;U+011F LATIN SMALL LETTER G WITH BREVE (define-keysym #x02bc "jcircumflex") ;U+0135 LATIN SMALL LETTER J WITH CIRCUMFLEX (define-keysym #x02c5 "Cabovedot") ;U+010A LATIN CAPITAL LETTER C WITH DOT ABOVE (define-keysym #x02c6 "Ccircumflex") ;U+0108 LATIN CAPITAL LETTER C WITH CIRCUMFLEX (define-keysym #x02d5 "Gabovedot") ;U+0120 LATIN CAPITAL LETTER G WITH DOT ABOVE (define-keysym #x02d8 "Gcircumflex") ;U+011C LATIN CAPITAL LETTER G WITH CIRCUMFLEX (define-keysym #x02dd "Ubreve") ;U+016C LATIN CAPITAL LETTER U WITH BREVE (define-keysym #x02de "Scircumflex") ;U+015C LATIN CAPITAL LETTER S WITH CIRCUMFLEX (define-keysym #x02e5 "cabovedot") ;U+010B LATIN SMALL LETTER C WITH DOT ABOVE (define-keysym #x02e6 "ccircumflex") ;U+0109 LATIN SMALL LETTER C WITH CIRCUMFLEX (define-keysym #x02f5 "gabovedot") ;U+0121 LATIN SMALL LETTER G WITH DOT ABOVE (define-keysym #x02f8 "gcircumflex") ;U+011D LATIN SMALL LETTER G WITH CIRCUMFLEX (define-keysym #x02fd "ubreve") ;U+016D LATIN SMALL LETTER U WITH BREVE (define-keysym #x02fe "scircumflex") ;U+015D LATIN SMALL LETTER S WITH CIRCUMFLEX (define-keysym #x03a2 "kra") ;U+0138 LATIN SMALL LETTER KRA (define-keysym #x03a2 "kappa") ;deprecated (define-keysym #x03a3 "Rcedilla") ;U+0156 LATIN CAPITAL LETTER R WITH CEDILLA (define-keysym #x03a5 "Itilde") ;U+0128 LATIN CAPITAL LETTER I WITH TILDE (define-keysym #x03a6 "Lcedilla") ;U+013B LATIN CAPITAL LETTER L WITH CEDILLA (define-keysym #x03aa "Emacron") ;U+0112 LATIN CAPITAL LETTER E WITH MACRON (define-keysym #x03ab "Gcedilla") ;U+0122 LATIN CAPITAL LETTER G WITH CEDILLA (define-keysym #x03ac "Tslash") ;U+0166 LATIN CAPITAL LETTER T WITH STROKE (define-keysym #x03b3 "rcedilla") ;U+0157 LATIN SMALL LETTER R WITH CEDILLA (define-keysym #x03b5 "itilde") ;U+0129 LATIN SMALL LETTER I WITH TILDE (define-keysym #x03b6 "lcedilla") ;U+013C LATIN SMALL LETTER L WITH CEDILLA (define-keysym #x03ba "emacron") ;U+0113 LATIN SMALL LETTER E WITH MACRON (define-keysym #x03bb "gcedilla") ;U+0123 LATIN SMALL LETTER G WITH CEDILLA (define-keysym #x03bc "tslash") ;U+0167 LATIN SMALL LETTER T WITH STROKE (define-keysym #x03bd "ENG") ;U+014A LATIN CAPITAL LETTER ENG (define-keysym #x03bf "eng") ;U+014B LATIN SMALL LETTER ENG (define-keysym #x03c0 "Amacron") ;U+0100 LATIN CAPITAL LETTER A WITH MACRON (define-keysym #x03c7 "Iogonek") ;U+012E LATIN CAPITAL LETTER I WITH OGONEK (define-keysym #x03cc "Eabovedot") ;U+0116 LATIN CAPITAL LETTER E WITH DOT ABOVE (define-keysym #x03cf "Imacron") ;U+012A LATIN CAPITAL LETTER I WITH MACRON (define-keysym #x03d1 "Ncedilla") ;U+0145 LATIN CAPITAL LETTER N WITH CEDILLA (define-keysym #x03d2 "Omacron") ;U+014C LATIN CAPITAL LETTER O WITH MACRON (define-keysym #x03d3 "Kcedilla") ;U+0136 LATIN CAPITAL LETTER K WITH CEDILLA (define-keysym #x03d9 "Uogonek") ;U+0172 LATIN CAPITAL LETTER U WITH OGONEK (define-keysym #x03dd "Utilde") ;U+0168 LATIN CAPITAL LETTER U WITH TILDE (define-keysym #x03de "Umacron") ;U+016A LATIN CAPITAL LETTER U WITH MACRON (define-keysym #x03e0 "amacron") ;U+0101 LATIN SMALL LETTER A WITH MACRON (define-keysym #x03e7 "iogonek") ;U+012F LATIN SMALL LETTER I WITH OGONEK (define-keysym #x03ec "eabovedot") ;U+0117 LATIN SMALL LETTER E WITH DOT ABOVE (define-keysym #x03ef "imacron") ;U+012B LATIN SMALL LETTER I WITH MACRON (define-keysym #x03f1 "ncedilla") ;U+0146 LATIN SMALL LETTER N WITH CEDILLA (define-keysym #x03f2 "omacron") ;U+014D LATIN SMALL LETTER O WITH MACRON (define-keysym #x03f3 "kcedilla") ;U+0137 LATIN SMALL LETTER K WITH CEDILLA (define-keysym #x03f9 "uogonek") ;U+0173 LATIN SMALL LETTER U WITH OGONEK (define-keysym #x03fd "utilde") ;U+0169 LATIN SMALL LETTER U WITH TILDE (define-keysym #x03fe "umacron") ;U+016B LATIN SMALL LETTER U WITH MACRON (define-keysym #x1001e02 "Babovedot") ;U+1E02 LATIN CAPITAL LETTER B WITH DOT ABOVE (define-keysym #x1001e03 "babovedot") ;U+1E03 LATIN SMALL LETTER B WITH DOT ABOVE (define-keysym #x1001e0a "Dabovedot") ;U+1E0A LATIN CAPITAL LETTER D WITH DOT ABOVE (define-keysym #x1001e80 "Wgrave") ;U+1E80 LATIN CAPITAL LETTER W WITH GRAVE (define-keysym #x1001e82 "Wacute") ;U+1E82 LATIN CAPITAL LETTER W WITH ACUTE (define-keysym #x1001e0b "dabovedot") ;U+1E0B LATIN SMALL LETTER D WITH DOT ABOVE (define-keysym #x1001ef2 "Ygrave") ;U+1EF2 LATIN CAPITAL LETTER Y WITH GRAVE (define-keysym #x1001e1e "Fabovedot") ;U+1E1E LATIN CAPITAL LETTER F WITH DOT ABOVE (define-keysym #x1001e1f "fabovedot") ;U+1E1F LATIN SMALL LETTER F WITH DOT ABOVE (define-keysym #x1001e40 "Mabovedot") ;U+1E40 LATIN CAPITAL LETTER M WITH DOT ABOVE (define-keysym #x1001e41 "mabovedot") ;U+1E41 LATIN SMALL LETTER M WITH DOT ABOVE (define-keysym #x1001e56 "Pabovedot") ;U+1E56 LATIN CAPITAL LETTER P WITH DOT ABOVE (define-keysym #x1001e81 "wgrave") ;U+1E81 LATIN SMALL LETTER W WITH GRAVE (define-keysym #x1001e57 "pabovedot") ;U+1E57 LATIN SMALL LETTER P WITH DOT ABOVE (define-keysym #x1001e83 "wacute") ;U+1E83 LATIN SMALL LETTER W WITH ACUTE (define-keysym #x1001e60 "Sabovedot") ;U+1E60 LATIN CAPITAL LETTER S WITH DOT ABOVE (define-keysym #x1001ef3 "ygrave") ;U+1EF3 LATIN SMALL LETTER Y WITH GRAVE (define-keysym #x1001e84 "Wdiaeresis") ;U+1E84 LATIN CAPITAL LETTER W WITH DIAERESIS (define-keysym #x1001e85 "wdiaeresis") ;U+1E85 LATIN SMALL LETTER W WITH DIAERESIS (define-keysym #x1001e61 "sabovedot") ;U+1E61 LATIN SMALL LETTER S WITH DOT ABOVE (define-keysym #x1000174 "Wcircumflex") ;U+0174 LATIN CAPITAL LETTER W WITH CIRCUMFLEX (define-keysym #x1001e6a "Tabovedot") ;U+1E6A LATIN CAPITAL LETTER T WITH DOT ABOVE (define-keysym #x1000176 "Ycircumflex") ;U+0176 LATIN CAPITAL LETTER Y WITH CIRCUMFLEX (define-keysym #x1000175 "wcircumflex") ;U+0175 LATIN SMALL LETTER W WITH CIRCUMFLEX (define-keysym #x1001e6b "tabovedot") ;U+1E6B LATIN SMALL LETTER T WITH DOT ABOVE (define-keysym #x1000177 "ycircumflex") ;U+0177 LATIN SMALL LETTER Y WITH CIRCUMFLEX (define-keysym #x13bc "OE") ;U+0152 LATIN CAPITAL LIGATURE OE (define-keysym #x13bd "oe") ;U+0153 LATIN SMALL LIGATURE OE (define-keysym #x13be "Ydiaeresis") ;U+0178 LATIN CAPITAL LETTER Y WITH DIAERESIS (define-keysym #x047e "overline") ;U+203E OVERLINE (define-keysym #x04a1 "kana_fullstop") ;U+3002 IDEOGRAPHIC FULL STOP (define-keysym #x04a2 "kana_openingbracket") ;U+300C LEFT CORNER BRACKET (define-keysym #x04a3 "kana_closingbracket") ;U+300D RIGHT CORNER BRACKET (define-keysym #x04a4 "kana_comma") ;U+3001 IDEOGRAPHIC COMMA (define-keysym #x04a5 "kana_conjunctive") ;U+30FB KATAKANA MIDDLE DOT (define-keysym #x04a5 "kana_middledot") ;deprecated (define-keysym #x04a6 "kana_WO") ;U+30F2 KATAKANA LETTER WO (define-keysym #x04a7 "kana_a") ;U+30A1 KATAKANA LETTER SMALL A (define-keysym #x04a8 "kana_i") ;U+30A3 KATAKANA LETTER SMALL I (define-keysym #x04a9 "kana_u") ;U+30A5 KATAKANA LETTER SMALL U (define-keysym #x04aa "kana_e") ;U+30A7 KATAKANA LETTER SMALL E (define-keysym #x04ab "kana_o") ;U+30A9 KATAKANA LETTER SMALL O (define-keysym #x04ac "kana_ya") ;U+30E3 KATAKANA LETTER SMALL YA (define-keysym #x04ad "kana_yu") ;U+30E5 KATAKANA LETTER SMALL YU (define-keysym #x04ae "kana_yo") ;U+30E7 KATAKANA LETTER SMALL YO (define-keysym #x04af "kana_tsu") ;U+30C3 KATAKANA LETTER SMALL TU (define-keysym #x04af "kana_tu") ;deprecated (define-keysym #x04b0 "prolongedsound") ;U+30FC KATAKANA-HIRAGANA PROLONGED SOUND MARK (define-keysym #x04b1 "kana_A") ;U+30A2 KATAKANA LETTER A (define-keysym #x04b2 "kana_I") ;U+30A4 KATAKANA LETTER I (define-keysym #x04b3 "kana_U") ;U+30A6 KATAKANA LETTER U (define-keysym #x04b4 "kana_E") ;U+30A8 KATAKANA LETTER E (define-keysym #x04b5 "kana_O") ;U+30AA KATAKANA LETTER O (define-keysym #x04b6 "kana_KA") ;U+30AB KATAKANA LETTER KA (define-keysym #x04b7 "kana_KI") ;U+30AD KATAKANA LETTER KI (define-keysym #x04b8 "kana_KU") ;U+30AF KATAKANA LETTER KU (define-keysym #x04b9 "kana_KE") ;U+30B1 KATAKANA LETTER KE (define-keysym #x04ba "kana_KO") ;U+30B3 KATAKANA LETTER KO (define-keysym #x04bb "kana_SA") ;U+30B5 KATAKANA LETTER SA (define-keysym #x04bc "kana_SHI") ;U+30B7 KATAKANA LETTER SI (define-keysym #x04bd "kana_SU") ;U+30B9 KATAKANA LETTER SU (define-keysym #x04be "kana_SE") ;U+30BB KATAKANA LETTER SE (define-keysym #x04bf "kana_SO") ;U+30BD KATAKANA LETTER SO (define-keysym #x04c0 "kana_TA") ;U+30BF KATAKANA LETTER TA (define-keysym #x04c1 "kana_CHI") ;U+30C1 KATAKANA LETTER TI (define-keysym #x04c1 "kana_TI") ;deprecated (define-keysym #x04c2 "kana_TSU") ;U+30C4 KATAKANA LETTER TU (define-keysym #x04c2 "kana_TU") ;deprecated (define-keysym #x04c3 "kana_TE") ;U+30C6 KATAKANA LETTER TE (define-keysym #x04c4 "kana_TO") ;U+30C8 KATAKANA LETTER TO (define-keysym #x04c5 "kana_NA") ;U+30CA KATAKANA LETTER NA (define-keysym #x04c6 "kana_NI") ;U+30CB KATAKANA LETTER NI (define-keysym #x04c7 "kana_NU") ;U+30CC KATAKANA LETTER NU (define-keysym #x04c8 "kana_NE") ;U+30CD KATAKANA LETTER NE (define-keysym #x04c9 "kana_NO") ;U+30CE KATAKANA LETTER NO (define-keysym #x04ca "kana_HA") ;U+30CF KATAKANA LETTER HA (define-keysym #x04cb "kana_HI") ;U+30D2 KATAKANA LETTER HI (define-keysym #x04cc "kana_FU") ;U+30D5 KATAKANA LETTER HU (define-keysym #x04cc "kana_HU") ;deprecated (define-keysym #x04cd "kana_HE") ;U+30D8 KATAKANA LETTER HE (define-keysym #x04ce "kana_HO") ;U+30DB KATAKANA LETTER HO (define-keysym #x04cf "kana_MA") ;U+30DE KATAKANA LETTER MA (define-keysym #x04d0 "kana_MI") ;U+30DF KATAKANA LETTER MI (define-keysym #x04d1 "kana_MU") ;U+30E0 KATAKANA LETTER MU (define-keysym #x04d2 "kana_ME") ;U+30E1 KATAKANA LETTER ME (define-keysym #x04d3 "kana_MO") ;U+30E2 KATAKANA LETTER MO (define-keysym #x04d4 "kana_YA") ;U+30E4 KATAKANA LETTER YA (define-keysym #x04d5 "kana_YU") ;U+30E6 KATAKANA LETTER YU (define-keysym #x04d6 "kana_YO") ;U+30E8 KATAKANA LETTER YO (define-keysym #x04d7 "kana_RA") ;U+30E9 KATAKANA LETTER RA (define-keysym #x04d8 "kana_RI") ;U+30EA KATAKANA LETTER RI (define-keysym #x04d9 "kana_RU") ;U+30EB KATAKANA LETTER RU (define-keysym #x04da "kana_RE") ;U+30EC KATAKANA LETTER RE (define-keysym #x04db "kana_RO") ;U+30ED KATAKANA LETTER RO (define-keysym #x04dc "kana_WA") ;U+30EF KATAKANA LETTER WA (define-keysym #x04dd "kana_N") ;U+30F3 KATAKANA LETTER N (define-keysym #x04de "voicedsound") ;U+309B KATAKANA-HIRAGANA VOICED SOUND MARK (define-keysym #x04df "semivoicedsound") ;U+309C KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK (define-keysym #xff7e "kana_switch") ;Alias for mode_switch (define-keysym #x10006f0 "Farsi_0") ;U+06F0 EXTENDED ARABIC-INDIC DIGIT ZERO (define-keysym #x10006f1 "Farsi_1") ;U+06F1 EXTENDED ARABIC-INDIC DIGIT ONE (define-keysym #x10006f2 "Farsi_2") ;U+06F2 EXTENDED ARABIC-INDIC DIGIT TWO (define-keysym #x10006f3 "Farsi_3") ;U+06F3 EXTENDED ARABIC-INDIC DIGIT THREE (define-keysym #x10006f4 "Farsi_4") ;U+06F4 EXTENDED ARABIC-INDIC DIGIT FOUR (define-keysym #x10006f5 "Farsi_5") ;U+06F5 EXTENDED ARABIC-INDIC DIGIT FIVE (define-keysym #x10006f6 "Farsi_6") ;U+06F6 EXTENDED ARABIC-INDIC DIGIT SIX (define-keysym #x10006f7 "Farsi_7") ;U+06F7 EXTENDED ARABIC-INDIC DIGIT SEVEN (define-keysym #x10006f8 "Farsi_8") ;U+06F8 EXTENDED ARABIC-INDIC DIGIT EIGHT (define-keysym #x10006f9 "Farsi_9") ;U+06F9 EXTENDED ARABIC-INDIC DIGIT NINE (define-keysym #x100066a "Arabic_percent") ;U+066A ARABIC PERCENT SIGN (define-keysym #x1000670 "Arabic_superscript_alef") ;U+0670 ARABIC LETTER SUPERSCRIPT ALEF (define-keysym #x1000679 "Arabic_tteh") ;U+0679 ARABIC LETTER TTEH (define-keysym #x100067e "Arabic_peh") ;U+067E ARABIC LETTER PEH (define-keysym #x1000686 "Arabic_tcheh") ;U+0686 ARABIC LETTER TCHEH (define-keysym #x1000688 "Arabic_ddal") ;U+0688 ARABIC LETTER DDAL (define-keysym #x1000691 "Arabic_rreh") ;U+0691 ARABIC LETTER RREH (define-keysym #x05ac "Arabic_comma") ;U+060C ARABIC COMMA (define-keysym #x10006d4 "Arabic_fullstop") ;U+06D4 ARABIC FULL STOP (define-keysym #x1000660 "Arabic_0") ;U+0660 ARABIC-INDIC DIGIT ZERO (define-keysym #x1000661 "Arabic_1") ;U+0661 ARABIC-INDIC DIGIT ONE (define-keysym #x1000662 "Arabic_2") ;U+0662 ARABIC-INDIC DIGIT TWO (define-keysym #x1000663 "Arabic_3") ;U+0663 ARABIC-INDIC DIGIT THREE (define-keysym #x1000664 "Arabic_4") ;U+0664 ARABIC-INDIC DIGIT FOUR (define-keysym #x1000665 "Arabic_5") ;U+0665 ARABIC-INDIC DIGIT FIVE (define-keysym #x1000666 "Arabic_6") ;U+0666 ARABIC-INDIC DIGIT SIX (define-keysym #x1000667 "Arabic_7") ;U+0667 ARABIC-INDIC DIGIT SEVEN (define-keysym #x1000668 "Arabic_8") ;U+0668 ARABIC-INDIC DIGIT EIGHT (define-keysym #x1000669 "Arabic_9") ;U+0669 ARABIC-INDIC DIGIT NINE (define-keysym #x05bb "Arabic_semicolon") ;U+061B ARABIC SEMICOLON (define-keysym #x05bf "Arabic_question_mark") ;U+061F ARABIC QUESTION MARK (define-keysym #x05c1 "Arabic_hamza") ;U+0621 ARABIC LETTER HAMZA (define-keysym #x05c2 "Arabic_maddaonalef") ;U+0622 ARABIC LETTER ALEF WITH MADDA ABOVE (define-keysym #x05c3 "Arabic_hamzaonalef") ;U+0623 ARABIC LETTER ALEF WITH HAMZA ABOVE (define-keysym #x05c4 "Arabic_hamzaonwaw") ;U+0624 ARABIC LETTER WAW WITH HAMZA ABOVE (define-keysym #x05c5 "Arabic_hamzaunderalef") ;U+0625 ARABIC LETTER ALEF WITH HAMZA BELOW (define-keysym #x05c6 "Arabic_hamzaonyeh") ;U+0626 ARABIC LETTER YEH WITH HAMZA ABOVE (define-keysym #x05c7 "Arabic_alef") ;U+0627 ARABIC LETTER ALEF (define-keysym #x05c8 "Arabic_beh") ;U+0628 ARABIC LETTER BEH (define-keysym #x05c9 "Arabic_tehmarbuta") ;U+0629 ARABIC LETTER TEH MARBUTA (define-keysym #x05ca "Arabic_teh") ;U+062A ARABIC LETTER TEH (define-keysym #x05cb "Arabic_theh") ;U+062B ARABIC LETTER THEH (define-keysym #x05cc "Arabic_jeem") ;U+062C ARABIC LETTER JEEM (define-keysym #x05cd "Arabic_hah") ;U+062D ARABIC LETTER HAH (define-keysym #x05ce "Arabic_khah") ;U+062E ARABIC LETTER KHAH (define-keysym #x05cf "Arabic_dal") ;U+062F ARABIC LETTER DAL (define-keysym #x05d0 "Arabic_thal") ;U+0630 ARABIC LETTER THAL (define-keysym #x05d1 "Arabic_ra") ;U+0631 ARABIC LETTER REH (define-keysym #x05d2 "Arabic_zain") ;U+0632 ARABIC LETTER ZAIN (define-keysym #x05d3 "Arabic_seen") ;U+0633 ARABIC LETTER SEEN (define-keysym #x05d4 "Arabic_sheen") ;U+0634 ARABIC LETTER SHEEN (define-keysym #x05d5 "Arabic_sad") ;U+0635 ARABIC LETTER SAD (define-keysym #x05d6 "Arabic_dad") ;U+0636 ARABIC LETTER DAD (define-keysym #x05d7 "Arabic_tah") ;U+0637 ARABIC LETTER TAH (define-keysym #x05d8 "Arabic_zah") ;U+0638 ARABIC LETTER ZAH (define-keysym #x05d9 "Arabic_ain") ;U+0639 ARABIC LETTER AIN (define-keysym #x05da "Arabic_ghain") ;U+063A ARABIC LETTER GHAIN (define-keysym #x05e0 "Arabic_tatweel") ;U+0640 ARABIC TATWEEL (define-keysym #x05e1 "Arabic_feh") ;U+0641 ARABIC LETTER FEH (define-keysym #x05e2 "Arabic_qaf") ;U+0642 ARABIC LETTER QAF (define-keysym #x05e3 "Arabic_kaf") ;U+0643 ARABIC LETTER KAF (define-keysym #x05e4 "Arabic_lam") ;U+0644 ARABIC LETTER LAM (define-keysym #x05e5 "Arabic_meem") ;U+0645 ARABIC LETTER MEEM (define-keysym #x05e6 "Arabic_noon") ;U+0646 ARABIC LETTER NOON (define-keysym #x05e7 "Arabic_ha") ;U+0647 ARABIC LETTER HEH (define-keysym #x05e7 "Arabic_heh") ;deprecated (define-keysym #x05e8 "Arabic_waw") ;U+0648 ARABIC LETTER WAW (define-keysym #x05e9 "Arabic_alefmaksura") ;U+0649 ARABIC LETTER ALEF MAKSURA (define-keysym #x05ea "Arabic_yeh") ;U+064A ARABIC LETTER YEH (define-keysym #x05eb "Arabic_fathatan") ;U+064B ARABIC FATHATAN (define-keysym #x05ec "Arabic_dammatan") ;U+064C ARABIC DAMMATAN (define-keysym #x05ed "Arabic_kasratan") ;U+064D ARABIC KASRATAN (define-keysym #x05ee "Arabic_fatha") ;U+064E ARABIC FATHA (define-keysym #x05ef "Arabic_damma") ;U+064F ARABIC DAMMA (define-keysym #x05f0 "Arabic_kasra") ;U+0650 ARABIC KASRA (define-keysym #x05f1 "Arabic_shadda") ;U+0651 ARABIC SHADDA (define-keysym #x05f2 "Arabic_sukun") ;U+0652 ARABIC SUKUN (define-keysym #x1000653 "Arabic_madda_above") ;U+0653 ARABIC MADDAH ABOVE (define-keysym #x1000654 "Arabic_hamza_above") ;U+0654 ARABIC HAMZA ABOVE (define-keysym #x1000655 "Arabic_hamza_below") ;U+0655 ARABIC HAMZA BELOW (define-keysym #x1000698 "Arabic_jeh") ;U+0698 ARABIC LETTER JEH (define-keysym #x10006a4 "Arabic_veh") ;U+06A4 ARABIC LETTER VEH (define-keysym #x10006a9 "Arabic_keheh") ;U+06A9 ARABIC LETTER KEHEH (define-keysym #x10006af "Arabic_gaf") ;U+06AF ARABIC LETTER GAF (define-keysym #x10006ba "Arabic_noon_ghunna") ;U+06BA ARABIC LETTER NOON GHUNNA (define-keysym #x10006be "Arabic_heh_doachashmee") ;U+06BE ARABIC LETTER HEH DOACHASHMEE (define-keysym #x10006cc "Farsi_yeh") ;U+06CC ARABIC LETTER FARSI YEH (define-keysym #x10006cc "Arabic_farsi_yeh") ;U+06CC ARABIC LETTER FARSI YEH (define-keysym #x10006d2 "Arabic_yeh_baree") ;U+06D2 ARABIC LETTER YEH BARREE (define-keysym #x10006c1 "Arabic_heh_goal") ;U+06C1 ARABIC LETTER HEH GOAL (define-keysym #xff7e "Arabic_switch") ;Alias for mode_switch (define-keysym #x1000492 "Cyrillic_GHE_bar") ;U+0492 CYRILLIC CAPITAL LETTER GHE WITH STROKE (define-keysym #x1000493 "Cyrillic_ghe_bar") ;U+0493 CYRILLIC SMALL LETTER GHE WITH STROKE (define-keysym #x1000496 "Cyrillic_ZHE_descender") ;U+0496 CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER (define-keysym #x1000497 "Cyrillic_zhe_descender") ;U+0497 CYRILLIC SMALL LETTER ZHE WITH DESCENDER (define-keysym #x100049a "Cyrillic_KA_descender") ;U+049A CYRILLIC CAPITAL LETTER KA WITH DESCENDER (define-keysym #x100049b "Cyrillic_ka_descender") ;U+049B CYRILLIC SMALL LETTER KA WITH DESCENDER (define-keysym #x100049c "Cyrillic_KA_vertstroke") ;U+049C CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE (define-keysym #x100049d "Cyrillic_ka_vertstroke") ;U+049D CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE (define-keysym #x10004a2 "Cyrillic_EN_descender") ;U+04A2 CYRILLIC CAPITAL LETTER EN WITH DESCENDER (define-keysym #x10004a3 "Cyrillic_en_descender") ;U+04A3 CYRILLIC SMALL LETTER EN WITH DESCENDER (define-keysym #x10004ae "Cyrillic_U_straight") ;U+04AE CYRILLIC CAPITAL LETTER STRAIGHT U (define-keysym #x10004af "Cyrillic_u_straight") ;U+04AF CYRILLIC SMALL LETTER STRAIGHT U (define-keysym #x10004b0 "Cyrillic_U_straight_bar") ;U+04B0 CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE (define-keysym #x10004b1 "Cyrillic_u_straight_bar") ;U+04B1 CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE (define-keysym #x10004b2 "Cyrillic_HA_descender") ;U+04B2 CYRILLIC CAPITAL LETTER HA WITH DESCENDER (define-keysym #x10004b3 "Cyrillic_ha_descender") ;U+04B3 CYRILLIC SMALL LETTER HA WITH DESCENDER (define-keysym #x10004b6 "Cyrillic_CHE_descender") ;U+04B6 CYRILLIC CAPITAL LETTER CHE WITH DESCENDER (define-keysym #x10004b7 "Cyrillic_che_descender") ;U+04B7 CYRILLIC SMALL LETTER CHE WITH DESCENDER (define-keysym #x10004b8 "Cyrillic_CHE_vertstroke") ;U+04B8 CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE (define-keysym #x10004b9 "Cyrillic_che_vertstroke") ;U+04B9 CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE (define-keysym #x10004ba "Cyrillic_SHHA") ;U+04BA CYRILLIC CAPITAL LETTER SHHA (define-keysym #x10004bb "Cyrillic_shha") ;U+04BB CYRILLIC SMALL LETTER SHHA (define-keysym #x10004d8 "Cyrillic_SCHWA") ;U+04D8 CYRILLIC CAPITAL LETTER SCHWA (define-keysym #x10004d9 "Cyrillic_schwa") ;U+04D9 CYRILLIC SMALL LETTER SCHWA (define-keysym #x10004e2 "Cyrillic_I_macron") ;U+04E2 CYRILLIC CAPITAL LETTER I WITH MACRON (define-keysym #x10004e3 "Cyrillic_i_macron") ;U+04E3 CYRILLIC SMALL LETTER I WITH MACRON (define-keysym #x10004e8 "Cyrillic_O_bar") ;U+04E8 CYRILLIC CAPITAL LETTER BARRED O (define-keysym #x10004e9 "Cyrillic_o_bar") ;U+04E9 CYRILLIC SMALL LETTER BARRED O (define-keysym #x10004ee "Cyrillic_U_macron") ;U+04EE CYRILLIC CAPITAL LETTER U WITH MACRON (define-keysym #x10004ef "Cyrillic_u_macron") ;U+04EF CYRILLIC SMALL LETTER U WITH MACRON (define-keysym #x06a1 "Serbian_dje") ;U+0452 CYRILLIC SMALL LETTER DJE (define-keysym #x06a2 "Macedonia_gje") ;U+0453 CYRILLIC SMALL LETTER GJE (define-keysym #x06a3 "Cyrillic_io") ;U+0451 CYRILLIC SMALL LETTER IO (define-keysym #x06a4 "Ukrainian_ie") ;U+0454 CYRILLIC SMALL LETTER UKRAINIAN IE (define-keysym #x06a4 "Ukranian_je") ;deprecated (define-keysym #x06a5 "Macedonia_dse") ;U+0455 CYRILLIC SMALL LETTER DZE (define-keysym #x06a6 "Ukrainian_i") ;U+0456 CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I (define-keysym #x06a6 "Ukranian_i") ;deprecated (define-keysym #x06a7 "Ukrainian_yi") ;U+0457 CYRILLIC SMALL LETTER YI (define-keysym #x06a7 "Ukranian_yi") ;deprecated (define-keysym #x06a8 "Cyrillic_je") ;U+0458 CYRILLIC SMALL LETTER JE (define-keysym #x06a8 "Serbian_je") ;deprecated (define-keysym #x06a9 "Cyrillic_lje") ;U+0459 CYRILLIC SMALL LETTER LJE (define-keysym #x06a9 "Serbian_lje") ;deprecated (define-keysym #x06aa "Cyrillic_nje") ;U+045A CYRILLIC SMALL LETTER NJE (define-keysym #x06aa "Serbian_nje") ;deprecated (define-keysym #x06ab "Serbian_tshe") ;U+045B CYRILLIC SMALL LETTER TSHE (define-keysym #x06ac "Macedonia_kje") ;U+045C CYRILLIC SMALL LETTER KJE (define-keysym #x06ad "Ukrainian_ghe_with_upturn") ;U+0491 CYRILLIC SMALL LETTER GHE WITH UPTURN (define-keysym #x06ae "Byelorussian_shortu") ;U+045E CYRILLIC SMALL LETTER SHORT U (define-keysym #x06af "Cyrillic_dzhe") ;U+045F CYRILLIC SMALL LETTER DZHE (define-keysym #x06af "Serbian_dze") ;deprecated (define-keysym #x06b0 "numerosign") ;U+2116 NUMERO SIGN (define-keysym #x06b1 "Serbian_DJE") ;U+0402 CYRILLIC CAPITAL LETTER DJE (define-keysym #x06b2 "Macedonia_GJE") ;U+0403 CYRILLIC CAPITAL LETTER GJE (define-keysym #x06b3 "Cyrillic_IO") ;U+0401 CYRILLIC CAPITAL LETTER IO (define-keysym #x06b4 "Ukrainian_IE") ;U+0404 CYRILLIC CAPITAL LETTER UKRAINIAN IE (define-keysym #x06b4 "Ukranian_JE") ;deprecated (define-keysym #x06b5 "Macedonia_DSE") ;U+0405 CYRILLIC CAPITAL LETTER DZE (define-keysym #x06b6 "Ukrainian_I") ;U+0406 CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I (define-keysym #x06b6 "Ukranian_I") ;deprecated (define-keysym #x06b7 "Ukrainian_YI") ;U+0407 CYRILLIC CAPITAL LETTER YI (define-keysym #x06b7 "Ukranian_YI") ;deprecated (define-keysym #x06b8 "Cyrillic_JE") ;U+0408 CYRILLIC CAPITAL LETTER JE (define-keysym #x06b8 "Serbian_JE") ;deprecated (define-keysym #x06b9 "Cyrillic_LJE") ;U+0409 CYRILLIC CAPITAL LETTER LJE (define-keysym #x06b9 "Serbian_LJE") ;deprecated (define-keysym #x06ba "Cyrillic_NJE") ;U+040A CYRILLIC CAPITAL LETTER NJE (define-keysym #x06ba "Serbian_NJE") ;deprecated (define-keysym #x06bb "Serbian_TSHE") ;U+040B CYRILLIC CAPITAL LETTER TSHE (define-keysym #x06bc "Macedonia_KJE") ;U+040C CYRILLIC CAPITAL LETTER KJE (define-keysym #x06bd "Ukrainian_GHE_WITH_UPTURN") ;U+0490 CYRILLIC CAPITAL LETTER GHE WITH UPTURN (define-keysym #x06be "Byelorussian_SHORTU") ;U+040E CYRILLIC CAPITAL LETTER SHORT U (define-keysym #x06bf "Cyrillic_DZHE") ;U+040F CYRILLIC CAPITAL LETTER DZHE (define-keysym #x06bf "Serbian_DZE") ;deprecated (define-keysym #x06c0 "Cyrillic_yu") ;U+044E CYRILLIC SMALL LETTER YU (define-keysym #x06c1 "Cyrillic_a") ;U+0430 CYRILLIC SMALL LETTER A (define-keysym #x06c2 "Cyrillic_be") ;U+0431 CYRILLIC SMALL LETTER BE (define-keysym #x06c3 "Cyrillic_tse") ;U+0446 CYRILLIC SMALL LETTER TSE (define-keysym #x06c4 "Cyrillic_de") ;U+0434 CYRILLIC SMALL LETTER DE (define-keysym #x06c5 "Cyrillic_ie") ;U+0435 CYRILLIC SMALL LETTER IE (define-keysym #x06c6 "Cyrillic_ef") ;U+0444 CYRILLIC SMALL LETTER EF (define-keysym #x06c7 "Cyrillic_ghe") ;U+0433 CYRILLIC SMALL LETTER GHE (define-keysym #x06c8 "Cyrillic_ha") ;U+0445 CYRILLIC SMALL LETTER HA (define-keysym #x06c9 "Cyrillic_i") ;U+0438 CYRILLIC SMALL LETTER I (define-keysym #x06ca "Cyrillic_shorti") ;U+0439 CYRILLIC SMALL LETTER SHORT I (define-keysym #x06cb "Cyrillic_ka") ;U+043A CYRILLIC SMALL LETTER KA (define-keysym #x06cc "Cyrillic_el") ;U+043B CYRILLIC SMALL LETTER EL (define-keysym #x06cd "Cyrillic_em") ;U+043C CYRILLIC SMALL LETTER EM (define-keysym #x06ce "Cyrillic_en") ;U+043D CYRILLIC SMALL LETTER EN (define-keysym #x06cf "Cyrillic_o") ;U+043E CYRILLIC SMALL LETTER O (define-keysym #x06d0 "Cyrillic_pe") ;U+043F CYRILLIC SMALL LETTER PE (define-keysym #x06d1 "Cyrillic_ya") ;U+044F CYRILLIC SMALL LETTER YA (define-keysym #x06d2 "Cyrillic_er") ;U+0440 CYRILLIC SMALL LETTER ER (define-keysym #x06d3 "Cyrillic_es") ;U+0441 CYRILLIC SMALL LETTER ES (define-keysym #x06d4 "Cyrillic_te") ;U+0442 CYRILLIC SMALL LETTER TE (define-keysym #x06d5 "Cyrillic_u") ;U+0443 CYRILLIC SMALL LETTER U (define-keysym #x06d6 "Cyrillic_zhe") ;U+0436 CYRILLIC SMALL LETTER ZHE (define-keysym #x06d7 "Cyrillic_ve") ;U+0432 CYRILLIC SMALL LETTER VE (define-keysym #x06d8 "Cyrillic_softsign") ;U+044C CYRILLIC SMALL LETTER SOFT SIGN (define-keysym #x06d9 "Cyrillic_yeru") ;U+044B CYRILLIC SMALL LETTER YERU (define-keysym #x06da "Cyrillic_ze") ;U+0437 CYRILLIC SMALL LETTER ZE (define-keysym #x06db "Cyrillic_sha") ;U+0448 CYRILLIC SMALL LETTER SHA (define-keysym #x06dc "Cyrillic_e") ;U+044D CYRILLIC SMALL LETTER E (define-keysym #x06dd "Cyrillic_shcha") ;U+0449 CYRILLIC SMALL LETTER SHCHA (define-keysym #x06de "Cyrillic_che") ;U+0447 CYRILLIC SMALL LETTER CHE (define-keysym #x06df "Cyrillic_hardsign") ;U+044A CYRILLIC SMALL LETTER HARD SIGN (define-keysym #x06e0 "Cyrillic_YU") ;U+042E CYRILLIC CAPITAL LETTER YU (define-keysym #x06e1 "Cyrillic_A") ;U+0410 CYRILLIC CAPITAL LETTER A (define-keysym #x06e2 "Cyrillic_BE") ;U+0411 CYRILLIC CAPITAL LETTER BE (define-keysym #x06e3 "Cyrillic_TSE") ;U+0426 CYRILLIC CAPITAL LETTER TSE (define-keysym #x06e4 "Cyrillic_DE") ;U+0414 CYRILLIC CAPITAL LETTER DE (define-keysym #x06e5 "Cyrillic_IE") ;U+0415 CYRILLIC CAPITAL LETTER IE (define-keysym #x06e6 "Cyrillic_EF") ;U+0424 CYRILLIC CAPITAL LETTER EF (define-keysym #x06e7 "Cyrillic_GHE") ;U+0413 CYRILLIC CAPITAL LETTER GHE (define-keysym #x06e8 "Cyrillic_HA") ;U+0425 CYRILLIC CAPITAL LETTER HA (define-keysym #x06e9 "Cyrillic_I") ;U+0418 CYRILLIC CAPITAL LETTER I (define-keysym #x06ea "Cyrillic_SHORTI") ;U+0419 CYRILLIC CAPITAL LETTER SHORT I (define-keysym #x06eb "Cyrillic_KA") ;U+041A CYRILLIC CAPITAL LETTER KA (define-keysym #x06ec "Cyrillic_EL") ;U+041B CYRILLIC CAPITAL LETTER EL (define-keysym #x06ed "Cyrillic_EM") ;U+041C CYRILLIC CAPITAL LETTER EM (define-keysym #x06ee "Cyrillic_EN") ;U+041D CYRILLIC CAPITAL LETTER EN (define-keysym #x06ef "Cyrillic_O") ;U+041E CYRILLIC CAPITAL LETTER O (define-keysym #x06f0 "Cyrillic_PE") ;U+041F CYRILLIC CAPITAL LETTER PE (define-keysym #x06f1 "Cyrillic_YA") ;U+042F CYRILLIC CAPITAL LETTER YA (define-keysym #x06f2 "Cyrillic_ER") ;U+0420 CYRILLIC CAPITAL LETTER ER (define-keysym #x06f3 "Cyrillic_ES") ;U+0421 CYRILLIC CAPITAL LETTER ES (define-keysym #x06f4 "Cyrillic_TE") ;U+0422 CYRILLIC CAPITAL LETTER TE (define-keysym #x06f5 "Cyrillic_U") ;U+0423 CYRILLIC CAPITAL LETTER U (define-keysym #x06f6 "Cyrillic_ZHE") ;U+0416 CYRILLIC CAPITAL LETTER ZHE (define-keysym #x06f7 "Cyrillic_VE") ;U+0412 CYRILLIC CAPITAL LETTER VE (define-keysym #x06f8 "Cyrillic_SOFTSIGN") ;U+042C CYRILLIC CAPITAL LETTER SOFT SIGN (define-keysym #x06f9 "Cyrillic_YERU") ;U+042B CYRILLIC CAPITAL LETTER YERU (define-keysym #x06fa "Cyrillic_ZE") ;U+0417 CYRILLIC CAPITAL LETTER ZE (define-keysym #x06fb "Cyrillic_SHA") ;U+0428 CYRILLIC CAPITAL LETTER SHA (define-keysym #x06fc "Cyrillic_E") ;U+042D CYRILLIC CAPITAL LETTER E (define-keysym #x06fd "Cyrillic_SHCHA") ;U+0429 CYRILLIC CAPITAL LETTER SHCHA (define-keysym #x06fe "Cyrillic_CHE") ;U+0427 CYRILLIC CAPITAL LETTER CHE (define-keysym #x06ff "Cyrillic_HARDSIGN") ;U+042A CYRILLIC CAPITAL LETTER HARD SIGN (define-keysym #x07a1 "Greek_ALPHAaccent") ;U+0386 GREEK CAPITAL LETTER ALPHA WITH TONOS (define-keysym #x07a2 "Greek_EPSILONaccent") ;U+0388 GREEK CAPITAL LETTER EPSILON WITH TONOS (define-keysym #x07a3 "Greek_ETAaccent") ;U+0389 GREEK CAPITAL LETTER ETA WITH TONOS (define-keysym #x07a4 "Greek_IOTAaccent") ;U+038A GREEK CAPITAL LETTER IOTA WITH TONOS (define-keysym #x07a5 "Greek_IOTAdieresis") ;U+03AA GREEK CAPITAL LETTER IOTA WITH DIALYTIKA (define-keysym #x07a5 "Greek_IOTAdiaeresis") ;old typo (define-keysym #x07a7 "Greek_OMICRONaccent") ;U+038C GREEK CAPITAL LETTER OMICRON WITH TONOS (define-keysym #x07a8 "Greek_UPSILONaccent") ;U+038E GREEK CAPITAL LETTER UPSILON WITH TONOS (define-keysym #x07a9 "Greek_UPSILONdieresis") ;U+03AB GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA (define-keysym #x07ab "Greek_OMEGAaccent") ;U+038F GREEK CAPITAL LETTER OMEGA WITH TONOS (define-keysym #x07ae "Greek_accentdieresis") ;U+0385 GREEK DIALYTIKA TONOS (define-keysym #x07af "Greek_horizbar") ;U+2015 HORIZONTAL BAR (define-keysym #x07b1 "Greek_alphaaccent") ;U+03AC GREEK SMALL LETTER ALPHA WITH TONOS (define-keysym #x07b2 "Greek_epsilonaccent") ;U+03AD GREEK SMALL LETTER EPSILON WITH TONOS (define-keysym #x07b3 "Greek_etaaccent") ;U+03AE GREEK SMALL LETTER ETA WITH TONOS (define-keysym #x07b4 "Greek_iotaaccent") ;U+03AF GREEK SMALL LETTER IOTA WITH TONOS (define-keysym #x07b5 "Greek_iotadieresis") ;U+03CA GREEK SMALL LETTER IOTA WITH DIALYTIKA (define-keysym #x07b6 "Greek_iotaaccentdieresis") ;U+0390 GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS (define-keysym #x07b7 "Greek_omicronaccent") ;U+03CC GREEK SMALL LETTER OMICRON WITH TONOS (define-keysym #x07b8 "Greek_upsilonaccent") ;U+03CD GREEK SMALL LETTER UPSILON WITH TONOS (define-keysym #x07b9 "Greek_upsilondieresis") ;U+03CB GREEK SMALL LETTER UPSILON WITH DIALYTIKA (define-keysym #x07ba "Greek_upsilonaccentdieresis") ;U+03B0 GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS (define-keysym #x07bb "Greek_omegaaccent") ;U+03CE GREEK SMALL LETTER OMEGA WITH TONOS (define-keysym #x07c1 "Greek_ALPHA") ;U+0391 GREEK CAPITAL LETTER ALPHA (define-keysym #x07c2 "Greek_BETA") ;U+0392 GREEK CAPITAL LETTER BETA (define-keysym #x07c3 "Greek_GAMMA") ;U+0393 GREEK CAPITAL LETTER GAMMA (define-keysym #x07c4 "Greek_DELTA") ;U+0394 GREEK CAPITAL LETTER DELTA (define-keysym #x07c5 "Greek_EPSILON") ;U+0395 GREEK CAPITAL LETTER EPSILON (define-keysym #x07c6 "Greek_ZETA") ;U+0396 GREEK CAPITAL LETTER ZETA (define-keysym #x07c7 "Greek_ETA") ;U+0397 GREEK CAPITAL LETTER ETA (define-keysym #x07c8 "Greek_THETA") ;U+0398 GREEK CAPITAL LETTER THETA (define-keysym #x07c9 "Greek_IOTA") ;U+0399 GREEK CAPITAL LETTER IOTA (define-keysym #x07ca "Greek_KAPPA") ;U+039A GREEK CAPITAL LETTER KAPPA (define-keysym #x07cb "Greek_LAMDA") ;U+039B GREEK CAPITAL LETTER LAMDA (define-keysym #x07cb "Greek_LAMBDA") ;U+039B GREEK CAPITAL LETTER LAMDA (define-keysym #x07cc "Greek_MU") ;U+039C GREEK CAPITAL LETTER MU (define-keysym #x07cd "Greek_NU") ;U+039D GREEK CAPITAL LETTER NU (define-keysym #x07ce "Greek_XI") ;U+039E GREEK CAPITAL LETTER XI (define-keysym #x07cf "Greek_OMICRON") ;U+039F GREEK CAPITAL LETTER OMICRON (define-keysym #x07d0 "Greek_PI") ;U+03A0 GREEK CAPITAL LETTER PI (define-keysym #x07d1 "Greek_RHO") ;U+03A1 GREEK CAPITAL LETTER RHO (define-keysym #x07d2 "Greek_SIGMA") ;U+03A3 GREEK CAPITAL LETTER SIGMA (define-keysym #x07d4 "Greek_TAU") ;U+03A4 GREEK CAPITAL LETTER TAU (define-keysym #x07d5 "Greek_UPSILON") ;U+03A5 GREEK CAPITAL LETTER UPSILON (define-keysym #x07d6 "Greek_PHI") ;U+03A6 GREEK CAPITAL LETTER PHI (define-keysym #x07d7 "Greek_CHI") ;U+03A7 GREEK CAPITAL LETTER CHI (define-keysym #x07d8 "Greek_PSI") ;U+03A8 GREEK CAPITAL LETTER PSI (define-keysym #x07d9 "Greek_OMEGA") ;U+03A9 GREEK CAPITAL LETTER OMEGA (define-keysym #x07e1 "Greek_alpha") ;U+03B1 GREEK SMALL LETTER ALPHA (define-keysym #x07e2 "Greek_beta") ;U+03B2 GREEK SMALL LETTER BETA (define-keysym #x07e3 "Greek_gamma") ;U+03B3 GREEK SMALL LETTER GAMMA (define-keysym #x07e4 "Greek_delta") ;U+03B4 GREEK SMALL LETTER DELTA (define-keysym #x07e5 "Greek_epsilon") ;U+03B5 GREEK SMALL LETTER EPSILON (define-keysym #x07e6 "Greek_zeta") ;U+03B6 GREEK SMALL LETTER ZETA (define-keysym #x07e7 "Greek_eta") ;U+03B7 GREEK SMALL LETTER ETA (define-keysym #x07e8 "Greek_theta") ;U+03B8 GREEK SMALL LETTER THETA (define-keysym #x07e9 "Greek_iota") ;U+03B9 GREEK SMALL LETTER IOTA (define-keysym #x07ea "Greek_kappa") ;U+03BA GREEK SMALL LETTER KAPPA (define-keysym #x07eb "Greek_lamda") ;U+03BB GREEK SMALL LETTER LAMDA (define-keysym #x07eb "Greek_lambda") ;U+03BB GREEK SMALL LETTER LAMDA (define-keysym #x07ec "Greek_mu") ;U+03BC GREEK SMALL LETTER MU (define-keysym #x07ed "Greek_nu") ;U+03BD GREEK SMALL LETTER NU (define-keysym #x07ee "Greek_xi") ;U+03BE GREEK SMALL LETTER XI (define-keysym #x07ef "Greek_omicron") ;U+03BF GREEK SMALL LETTER OMICRON (define-keysym #x07f0 "Greek_pi") ;U+03C0 GREEK SMALL LETTER PI (define-keysym #x07f1 "Greek_rho") ;U+03C1 GREEK SMALL LETTER RHO (define-keysym #x07f2 "Greek_sigma") ;U+03C3 GREEK SMALL LETTER SIGMA (define-keysym #x07f3 "Greek_finalsmallsigma") ;U+03C2 GREEK SMALL LETTER FINAL SIGMA (define-keysym #x07f4 "Greek_tau") ;U+03C4 GREEK SMALL LETTER TAU (define-keysym #x07f5 "Greek_upsilon") ;U+03C5 GREEK SMALL LETTER UPSILON (define-keysym #x07f6 "Greek_phi") ;U+03C6 GREEK SMALL LETTER PHI (define-keysym #x07f7 "Greek_chi") ;U+03C7 GREEK SMALL LETTER CHI (define-keysym #x07f8 "Greek_psi") ;U+03C8 GREEK SMALL LETTER PSI (define-keysym #x07f9 "Greek_omega") ;U+03C9 GREEK SMALL LETTER OMEGA (define-keysym #xff7e "Greek_switch") ;Alias for mode_switch (define-keysym #x08a1 "leftradical") ;U+23B7 RADICAL SYMBOL BOTTOM (define-keysym #x08a2 "topleftradical") ;(U+250C BOX DRAWINGS LIGHT DOWN AND RIGHT) (define-keysym #x08a3 "horizconnector") ;(U+2500 BOX DRAWINGS LIGHT HORIZONTAL) (define-keysym #x08a4 "topintegral") ;U+2320 TOP HALF INTEGRAL (define-keysym #x08a5 "botintegral") ;U+2321 BOTTOM HALF INTEGRAL (define-keysym #x08a6 "vertconnector") ;(U+2502 BOX DRAWINGS LIGHT VERTICAL) (define-keysym #x08a7 "topleftsqbracket") ;U+23A1 LEFT SQUARE BRACKET UPPER CORNER (define-keysym #x08a8 "botleftsqbracket") ;U+23A3 LEFT SQUARE BRACKET LOWER CORNER (define-keysym #x08a9 "toprightsqbracket") ;U+23A4 RIGHT SQUARE BRACKET UPPER CORNER (define-keysym #x08aa "botrightsqbracket") ;U+23A6 RIGHT SQUARE BRACKET LOWER CORNER (define-keysym #x08ab "topleftparens") ;U+239B LEFT PARENTHESIS UPPER HOOK (define-keysym #x08ac "botleftparens") ;U+239D LEFT PARENTHESIS LOWER HOOK (define-keysym #x08ad "toprightparens") ;U+239E RIGHT PARENTHESIS UPPER HOOK (define-keysym #x08ae "botrightparens") ;U+23A0 RIGHT PARENTHESIS LOWER HOOK (define-keysym #x08af "leftmiddlecurlybrace") ;U+23A8 LEFT CURLY BRACKET MIDDLE PIECE (define-keysym #x08b0 "rightmiddlecurlybrace") ;U+23AC RIGHT CURLY BRACKET MIDDLE PIECE (define-keysym #x08b1 "topleftsummation") (define-keysym #x08b2 "botleftsummation") (define-keysym #x08b3 "topvertsummationconnector") (define-keysym #x08b4 "botvertsummationconnector") (define-keysym #x08b5 "toprightsummation") (define-keysym #x08b6 "botrightsummation") (define-keysym #x08b7 "rightmiddlesummation") (define-keysym #x08bc "lessthanequal") ;U+2264 LESS-THAN OR EQUAL TO (define-keysym #x08bd "notequal") ;U+2260 NOT EQUAL TO (define-keysym #x08be "greaterthanequal") ;U+2265 GREATER-THAN OR EQUAL TO (define-keysym #x08bf "integral") ;U+222B INTEGRAL (define-keysym #x08c0 "therefore") ;U+2234 THEREFORE (define-keysym #x08c1 "variation") ;U+221D PROPORTIONAL TO (define-keysym #x08c2 "infinity") ;U+221E INFINITY (define-keysym #x08c5 "nabla") ;U+2207 NABLA (define-keysym #x08c8 "approximate") ;U+223C TILDE OPERATOR (define-keysym #x08c9 "similarequal") ;U+2243 ASYMPTOTICALLY EQUAL TO (define-keysym #x08cd "ifonlyif") ;U+21D4 LEFT RIGHT DOUBLE ARROW (define-keysym #x08ce "implies") ;U+21D2 RIGHTWARDS DOUBLE ARROW (define-keysym #x08cf "identical") ;U+2261 IDENTICAL TO (define-keysym #x08d6 "radical") ;U+221A SQUARE ROOT (define-keysym #x08da "includedin") ;U+2282 SUBSET OF (define-keysym #x08db "includes") ;U+2283 SUPERSET OF (define-keysym #x08dc "intersection") ;U+2229 INTERSECTION (define-keysym #x08dd "union") ;U+222A UNION (define-keysym #x08de "logicaland") ;U+2227 LOGICAL AND (define-keysym #x08df "logicalor") ;U+2228 LOGICAL OR (define-keysym #x08ef "partialderivative") ;U+2202 PARTIAL DIFFERENTIAL (define-keysym #x08f6 "function") ;U+0192 LATIN SMALL LETTER F WITH HOOK (define-keysym #x08fb "leftarrow") ;U+2190 LEFTWARDS ARROW (define-keysym #x08fc "uparrow") ;U+2191 UPWARDS ARROW (define-keysym #x08fd "rightarrow") ;U+2192 RIGHTWARDS ARROW (define-keysym #x08fe "downarrow") ;U+2193 DOWNWARDS ARROW (define-keysym #x09df "blank") (define-keysym #x09e0 "soliddiamond") ;U+25C6 BLACK DIAMOND (define-keysym #x09e1 "checkerboard") ;U+2592 MEDIUM SHADE (define-keysym #x09e2 "ht") ;U+2409 SYMBOL FOR HORIZONTAL TABULATION (define-keysym #x09e3 "ff") ;U+240C SYMBOL FOR FORM FEED (define-keysym #x09e4 "cr") ;U+240D SYMBOL FOR CARRIAGE RETURN (define-keysym #x09e5 "lf") ;U+240A SYMBOL FOR LINE FEED (define-keysym #x09e8 "nl") ;U+2424 SYMBOL FOR NEWLINE (define-keysym #x09e9 "vt") ;U+240B SYMBOL FOR VERTICAL TABULATION (define-keysym #x09ea "lowrightcorner") ;U+2518 BOX DRAWINGS LIGHT UP AND LEFT (define-keysym #x09eb "uprightcorner") ;U+2510 BOX DRAWINGS LIGHT DOWN AND LEFT (define-keysym #x09ec "upleftcorner") ;U+250C BOX DRAWINGS LIGHT DOWN AND RIGHT (define-keysym #x09ed "lowleftcorner") ;U+2514 BOX DRAWINGS LIGHT UP AND RIGHT (define-keysym #x09ee "crossinglines") ;U+253C BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL (define-keysym #x09ef "horizlinescan1") ;U+23BA HORIZONTAL SCAN LINE-1 (define-keysym #x09f0 "horizlinescan3") ;U+23BB HORIZONTAL SCAN LINE-3 (define-keysym #x09f1 "horizlinescan5") ;U+2500 BOX DRAWINGS LIGHT HORIZONTAL (define-keysym #x09f2 "horizlinescan7") ;U+23BC HORIZONTAL SCAN LINE-7 (define-keysym #x09f3 "horizlinescan9") ;U+23BD HORIZONTAL SCAN LINE-9 (define-keysym #x09f4 "leftt") ;U+251C BOX DRAWINGS LIGHT VERTICAL AND RIGHT (define-keysym #x09f5 "rightt") ;U+2524 BOX DRAWINGS LIGHT VERTICAL AND LEFT (define-keysym #x09f6 "bott") ;U+2534 BOX DRAWINGS LIGHT UP AND HORIZONTAL (define-keysym #x09f7 "topt") ;U+252C BOX DRAWINGS LIGHT DOWN AND HORIZONTAL (define-keysym #x09f8 "vertbar") ;U+2502 BOX DRAWINGS LIGHT VERTICAL (define-keysym #x0aa1 "emspace") ;U+2003 EM SPACE (define-keysym #x0aa2 "enspace") ;U+2002 EN SPACE (define-keysym #x0aa3 "em3space") ;U+2004 THREE-PER-EM SPACE (define-keysym #x0aa4 "em4space") ;U+2005 FOUR-PER-EM SPACE (define-keysym #x0aa5 "digitspace") ;U+2007 FIGURE SPACE (define-keysym #x0aa6 "punctspace") ;U+2008 PUNCTUATION SPACE (define-keysym #x0aa7 "thinspace") ;U+2009 THIN SPACE (define-keysym #x0aa8 "hairspace") ;U+200A HAIR SPACE (define-keysym #x0aa9 "emdash") ;U+2014 EM DASH (define-keysym #x0aaa "endash") ;U+2013 EN DASH (define-keysym #x0aac "signifblank") ;(U+2423 OPEN BOX) (define-keysym #x0aae "ellipsis") ;U+2026 HORIZONTAL ELLIPSIS (define-keysym #x0aaf "doubbaselinedot") ;U+2025 TWO DOT LEADER (define-keysym #x0ab0 "onethird") ;U+2153 VULGAR FRACTION ONE THIRD (define-keysym #x0ab1 "twothirds") ;U+2154 VULGAR FRACTION TWO THIRDS (define-keysym #x0ab2 "onefifth") ;U+2155 VULGAR FRACTION ONE FIFTH (define-keysym #x0ab3 "twofifths") ;U+2156 VULGAR FRACTION TWO FIFTHS (define-keysym #x0ab4 "threefifths") ;U+2157 VULGAR FRACTION THREE FIFTHS (define-keysym #x0ab5 "fourfifths") ;U+2158 VULGAR FRACTION FOUR FIFTHS (define-keysym #x0ab6 "onesixth") ;U+2159 VULGAR FRACTION ONE SIXTH (define-keysym #x0ab7 "fivesixths") ;U+215A VULGAR FRACTION FIVE SIXTHS (define-keysym #x0ab8 "careof") ;U+2105 CARE OF (define-keysym #x0abb "figdash") ;U+2012 FIGURE DASH (define-keysym #x0abc "leftanglebracket") ;(U+27E8 MATHEMATICAL LEFT ANGLE BRACKET) (define-keysym #x0abd "decimalpoint") ;(U+002E FULL STOP) (define-keysym #x0abe "rightanglebracket") ;(U+27E9 MATHEMATICAL RIGHT ANGLE BRACKET) (define-keysym #x0abf "marker") (define-keysym #x0ac3 "oneeighth") ;U+215B VULGAR FRACTION ONE EIGHTH (define-keysym #x0ac4 "threeeighths") ;U+215C VULGAR FRACTION THREE EIGHTHS (define-keysym #x0ac5 "fiveeighths") ;U+215D VULGAR FRACTION FIVE EIGHTHS (define-keysym #x0ac6 "seveneighths") ;U+215E VULGAR FRACTION SEVEN EIGHTHS (define-keysym #x0ac9 "trademark") ;U+2122 TRADE MARK SIGN (define-keysym #x0aca "signaturemark") ;(U+2613 SALTIRE) (define-keysym #x0acb "trademarkincircle") (define-keysym #x0acc "leftopentriangle") ;(U+25C1 WHITE LEFT-POINTING TRIANGLE) (define-keysym #x0acd "rightopentriangle") ;(U+25B7 WHITE RIGHT-POINTING TRIANGLE) (define-keysym #x0ace "emopencircle") ;(U+25CB WHITE CIRCLE) (define-keysym #x0acf "emopenrectangle") ;(U+25AF WHITE VERTICAL RECTANGLE) (define-keysym #x0ad0 "leftsinglequotemark") ;U+2018 LEFT SINGLE QUOTATION MARK (define-keysym #x0ad1 "rightsinglequotemark") ;U+2019 RIGHT SINGLE QUOTATION MARK (define-keysym #x0ad2 "leftdoublequotemark") ;U+201C LEFT DOUBLE QUOTATION MARK (define-keysym #x0ad3 "rightdoublequotemark") ;U+201D RIGHT DOUBLE QUOTATION MARK (define-keysym #x0ad4 "prescription") ;U+211E PRESCRIPTION TAKE (define-keysym #x0ad6 "minutes") ;U+2032 PRIME (define-keysym #x0ad7 "seconds") ;U+2033 DOUBLE PRIME (define-keysym #x0ad9 "latincross") ;U+271D LATIN CROSS (define-keysym #x0ada "hexagram") (define-keysym #x0adb "filledrectbullet") ;(U+25AC BLACK RECTANGLE) (define-keysym #x0adc "filledlefttribullet") ;(U+25C0 BLACK LEFT-POINTING TRIANGLE) (define-keysym #x0add "filledrighttribullet") ;(U+25B6 BLACK RIGHT-POINTING TRIANGLE) (define-keysym #x0ade "emfilledcircle") ;(U+25CF BLACK CIRCLE) (define-keysym #x0adf "emfilledrect") ;(U+25AE BLACK VERTICAL RECTANGLE) (define-keysym #x0ae0 "enopencircbullet") ;(U+25E6 WHITE BULLET) (define-keysym #x0ae1 "enopensquarebullet") ;(U+25AB WHITE SMALL SQUARE) (define-keysym #x0ae2 "openrectbullet") ;(U+25AD WHITE RECTANGLE) (define-keysym #x0ae3 "opentribulletup") ;(U+25B3 WHITE UP-POINTING TRIANGLE) (define-keysym #x0ae4 "opentribulletdown") ;(U+25BD WHITE DOWN-POINTING TRIANGLE) (define-keysym #x0ae5 "openstar") ;(U+2606 WHITE STAR) (define-keysym #x0ae6 "enfilledcircbullet") ;(U+2022 BULLET) (define-keysym #x0ae7 "enfilledsqbullet") ;(U+25AA BLACK SMALL SQUARE) (define-keysym #x0ae8 "filledtribulletup") ;(U+25B2 BLACK UP-POINTING TRIANGLE) (define-keysym #x0ae9 "filledtribulletdown") ;(U+25BC BLACK DOWN-POINTING TRIANGLE) (define-keysym #x0aea "leftpointer") ;(U+261C WHITE LEFT POINTING INDEX) (define-keysym #x0aeb "rightpointer") ;(U+261E WHITE RIGHT POINTING INDEX) (define-keysym #x0aec "club") ;U+2663 BLACK CLUB SUIT (define-keysym #x0aed "diamond") ;U+2666 BLACK DIAMOND SUIT (define-keysym #x0aee "heart") ;U+2665 BLACK HEART SUIT (define-keysym #x0af0 "maltesecross") ;U+2720 MALTESE CROSS (define-keysym #x0af1 "dagger") ;U+2020 DAGGER (define-keysym #x0af2 "doubledagger") ;U+2021 DOUBLE DAGGER (define-keysym #x0af3 "checkmark") ;U+2713 CHECK MARK (define-keysym #x0af4 "ballotcross") ;U+2717 BALLOT X (define-keysym #x0af5 "musicalsharp") ;U+266F MUSIC SHARP SIGN (define-keysym #x0af6 "musicalflat") ;U+266D MUSIC FLAT SIGN (define-keysym #x0af7 "malesymbol") ;U+2642 MALE SIGN (define-keysym #x0af8 "femalesymbol") ;U+2640 FEMALE SIGN (define-keysym #x0af9 "telephone") ;U+260E BLACK TELEPHONE (define-keysym #x0afa "telephonerecorder") ;U+2315 TELEPHONE RECORDER (define-keysym #x0afb "phonographcopyright") ;U+2117 SOUND RECORDING COPYRIGHT (define-keysym #x0afc "caret") ;U+2038 CARET (define-keysym #x0afd "singlelowquotemark") ;U+201A SINGLE LOW-9 QUOTATION MARK (define-keysym #x0afe "doublelowquotemark") ;U+201E DOUBLE LOW-9 QUOTATION MARK (define-keysym #x0aff "cursor") (define-keysym #x0ba3 "leftcaret") ;(U+003C LESS-THAN SIGN) (define-keysym #x0ba6 "rightcaret") ;(U+003E GREATER-THAN SIGN) (define-keysym #x0ba8 "downcaret") ;(U+2228 LOGICAL OR) (define-keysym #x0ba9 "upcaret") ;(U+2227 LOGICAL AND) (define-keysym #x0bc0 "overbar") ;(U+00AF MACRON) (define-keysym #x0bc2 "downtack") ;U+22A5 UP TACK (define-keysym #x0bc3 "upshoe") ;(U+2229 INTERSECTION) (define-keysym #x0bc4 "downstile") ;U+230A LEFT FLOOR (define-keysym #x0bc6 "underbar") ;(U+005F LOW LINE) (define-keysym #x0bca "jot") ;U+2218 RING OPERATOR (define-keysym #x0bcc "quad") ;U+2395 APL FUNCTIONAL SYMBOL QUAD (define-keysym #x0bce "uptack") ;U+22A4 DOWN TACK (define-keysym #x0bcf "circle") ;U+25CB WHITE CIRCLE (define-keysym #x0bd3 "upstile") ;U+2308 LEFT CEILING (define-keysym #x0bd6 "downshoe") ;(U+222A UNION) (define-keysym #x0bd8 "rightshoe") ;(U+2283 SUPERSET OF) (define-keysym #x0bda "leftshoe") ;(U+2282 SUBSET OF) (define-keysym #x0bdc "lefttack") ;U+22A2 RIGHT TACK (define-keysym #x0bfc "righttack") ;U+22A3 LEFT TACK (define-keysym #x0cdf "hebrew_doublelowline") ;U+2017 DOUBLE LOW LINE (define-keysym #x0ce0 "hebrew_aleph") ;U+05D0 HEBREW LETTER ALEF (define-keysym #x0ce1 "hebrew_bet") ;U+05D1 HEBREW LETTER BET (define-keysym #x0ce1 "hebrew_beth") ;deprecated (define-keysym #x0ce2 "hebrew_gimel") ;U+05D2 HEBREW LETTER GIMEL (define-keysym #x0ce2 "hebrew_gimmel") ;deprecated (define-keysym #x0ce3 "hebrew_dalet") ;U+05D3 HEBREW LETTER DALET (define-keysym #x0ce3 "hebrew_daleth") ;deprecated (define-keysym #x0ce4 "hebrew_he") ;U+05D4 HEBREW LETTER HE (define-keysym #x0ce5 "hebrew_waw") ;U+05D5 HEBREW LETTER VAV (define-keysym #x0ce6 "hebrew_zain") ;U+05D6 HEBREW LETTER ZAYIN (define-keysym #x0ce6 "hebrew_zayin") ;deprecated (define-keysym #x0ce7 "hebrew_chet") ;U+05D7 HEBREW LETTER HET (define-keysym #x0ce7 "hebrew_het") ;deprecated (define-keysym #x0ce8 "hebrew_tet") ;U+05D8 HEBREW LETTER TET (define-keysym #x0ce8 "hebrew_teth") ;deprecated (define-keysym #x0ce9 "hebrew_yod") ;U+05D9 HEBREW LETTER YOD (define-keysym #x0cea "hebrew_finalkaph") ;U+05DA HEBREW LETTER FINAL KAF (define-keysym #x0ceb "hebrew_kaph") ;U+05DB HEBREW LETTER KAF (define-keysym #x0cec "hebrew_lamed") ;U+05DC HEBREW LETTER LAMED (define-keysym #x0ced "hebrew_finalmem") ;U+05DD HEBREW LETTER FINAL MEM (define-keysym #x0cee "hebrew_mem") ;U+05DE HEBREW LETTER MEM (define-keysym #x0cef "hebrew_finalnun") ;U+05DF HEBREW LETTER FINAL NUN (define-keysym #x0cf0 "hebrew_nun") ;U+05E0 HEBREW LETTER NUN (define-keysym #x0cf1 "hebrew_samech") ;U+05E1 HEBREW LETTER SAMEKH (define-keysym #x0cf1 "hebrew_samekh") ;deprecated (define-keysym #x0cf2 "hebrew_ayin") ;U+05E2 HEBREW LETTER AYIN (define-keysym #x0cf3 "hebrew_finalpe") ;U+05E3 HEBREW LETTER FINAL PE (define-keysym #x0cf4 "hebrew_pe") ;U+05E4 HEBREW LETTER PE (define-keysym #x0cf5 "hebrew_finalzade") ;U+05E5 HEBREW LETTER FINAL TSADI (define-keysym #x0cf5 "hebrew_finalzadi") ;deprecated (define-keysym #x0cf6 "hebrew_zade") ;U+05E6 HEBREW LETTER TSADI (define-keysym #x0cf6 "hebrew_zadi") ;deprecated (define-keysym #x0cf7 "hebrew_qoph") ;U+05E7 HEBREW LETTER QOF (define-keysym #x0cf7 "hebrew_kuf") ;deprecated (define-keysym #x0cf8 "hebrew_resh") ;U+05E8 HEBREW LETTER RESH (define-keysym #x0cf9 "hebrew_shin") ;U+05E9 HEBREW LETTER SHIN (define-keysym #x0cfa "hebrew_taw") ;U+05EA HEBREW LETTER TAV (define-keysym #x0cfa "hebrew_taf") ;deprecated (define-keysym #xff7e "Hebrew_switch") ;Alias for mode_switch (define-keysym #x0da1 "Thai_kokai") ;U+0E01 THAI CHARACTER KO KAI (define-keysym #x0da2 "Thai_khokhai") ;U+0E02 THAI CHARACTER KHO KHAI (define-keysym #x0da3 "Thai_khokhuat") ;U+0E03 THAI CHARACTER KHO KHUAT (define-keysym #x0da4 "Thai_khokhwai") ;U+0E04 THAI CHARACTER KHO KHWAI (define-keysym #x0da5 "Thai_khokhon") ;U+0E05 THAI CHARACTER KHO KHON (define-keysym #x0da6 "Thai_khorakhang") ;U+0E06 THAI CHARACTER KHO RAKHANG (define-keysym #x0da7 "Thai_ngongu") ;U+0E07 THAI CHARACTER NGO NGU (define-keysym #x0da8 "Thai_chochan") ;U+0E08 THAI CHARACTER CHO CHAN (define-keysym #x0da9 "Thai_choching") ;U+0E09 THAI CHARACTER CHO CHING (define-keysym #x0daa "Thai_chochang") ;U+0E0A THAI CHARACTER CHO CHANG (define-keysym #x0dab "Thai_soso") ;U+0E0B THAI CHARACTER SO SO (define-keysym #x0dac "Thai_chochoe") ;U+0E0C THAI CHARACTER CHO CHOE (define-keysym #x0dad "Thai_yoying") ;U+0E0D THAI CHARACTER YO YING (define-keysym #x0dae "Thai_dochada") ;U+0E0E THAI CHARACTER DO CHADA (define-keysym #x0daf "Thai_topatak") ;U+0E0F THAI CHARACTER TO PATAK (define-keysym #x0db0 "Thai_thothan") ;U+0E10 THAI CHARACTER THO THAN (define-keysym #x0db1 "Thai_thonangmontho") ;U+0E11 THAI CHARACTER THO NANGMONTHO (define-keysym #x0db2 "Thai_thophuthao") ;U+0E12 THAI CHARACTER THO PHUTHAO (define-keysym #x0db3 "Thai_nonen") ;U+0E13 THAI CHARACTER NO NEN (define-keysym #x0db4 "Thai_dodek") ;U+0E14 THAI CHARACTER DO DEK (define-keysym #x0db5 "Thai_totao") ;U+0E15 THAI CHARACTER TO TAO (define-keysym #x0db6 "Thai_thothung") ;U+0E16 THAI CHARACTER THO THUNG (define-keysym #x0db7 "Thai_thothahan") ;U+0E17 THAI CHARACTER THO THAHAN (define-keysym #x0db8 "Thai_thothong") ;U+0E18 THAI CHARACTER THO THONG (define-keysym #x0db9 "Thai_nonu") ;U+0E19 THAI CHARACTER NO NU (define-keysym #x0dba "Thai_bobaimai") ;U+0E1A THAI CHARACTER BO BAIMAI (define-keysym #x0dbb "Thai_popla") ;U+0E1B THAI CHARACTER PO PLA (define-keysym #x0dbc "Thai_phophung") ;U+0E1C THAI CHARACTER PHO PHUNG (define-keysym #x0dbd "Thai_fofa") ;U+0E1D THAI CHARACTER FO FA (define-keysym #x0dbe "Thai_phophan") ;U+0E1E THAI CHARACTER PHO PHAN (define-keysym #x0dbf "Thai_fofan") ;U+0E1F THAI CHARACTER FO FAN (define-keysym #x0dc0 "Thai_phosamphao") ;U+0E20 THAI CHARACTER PHO SAMPHAO (define-keysym #x0dc1 "Thai_moma") ;U+0E21 THAI CHARACTER MO MA (define-keysym #x0dc2 "Thai_yoyak") ;U+0E22 THAI CHARACTER YO YAK (define-keysym #x0dc3 "Thai_rorua") ;U+0E23 THAI CHARACTER RO RUA (define-keysym #x0dc4 "Thai_ru") ;U+0E24 THAI CHARACTER RU (define-keysym #x0dc5 "Thai_loling") ;U+0E25 THAI CHARACTER LO LING (define-keysym #x0dc6 "Thai_lu") ;U+0E26 THAI CHARACTER LU (define-keysym #x0dc7 "Thai_wowaen") ;U+0E27 THAI CHARACTER WO WAEN (define-keysym #x0dc8 "Thai_sosala") ;U+0E28 THAI CHARACTER SO SALA (define-keysym #x0dc9 "Thai_sorusi") ;U+0E29 THAI CHARACTER SO RUSI (define-keysym #x0dca "Thai_sosua") ;U+0E2A THAI CHARACTER SO SUA (define-keysym #x0dcb "Thai_hohip") ;U+0E2B THAI CHARACTER HO HIP (define-keysym #x0dcc "Thai_lochula") ;U+0E2C THAI CHARACTER LO CHULA (define-keysym #x0dcd "Thai_oang") ;U+0E2D THAI CHARACTER O ANG (define-keysym #x0dce "Thai_honokhuk") ;U+0E2E THAI CHARACTER HO NOKHUK (define-keysym #x0dcf "Thai_paiyannoi") ;U+0E2F THAI CHARACTER PAIYANNOI (define-keysym #x0dd0 "Thai_saraa") ;U+0E30 THAI CHARACTER SARA A (define-keysym #x0dd1 "Thai_maihanakat") ;U+0E31 THAI CHARACTER MAI HAN-AKAT (define-keysym #x0dd2 "Thai_saraaa") ;U+0E32 THAI CHARACTER SARA AA (define-keysym #x0dd3 "Thai_saraam") ;U+0E33 THAI CHARACTER SARA AM (define-keysym #x0dd4 "Thai_sarai") ;U+0E34 THAI CHARACTER SARA I (define-keysym #x0dd5 "Thai_saraii") ;U+0E35 THAI CHARACTER SARA II (define-keysym #x0dd6 "Thai_saraue") ;U+0E36 THAI CHARACTER SARA UE (define-keysym #x0dd7 "Thai_sarauee") ;U+0E37 THAI CHARACTER SARA UEE (define-keysym #x0dd8 "Thai_sarau") ;U+0E38 THAI CHARACTER SARA U (define-keysym #x0dd9 "Thai_sarauu") ;U+0E39 THAI CHARACTER SARA UU (define-keysym #x0dda "Thai_phinthu") ;U+0E3A THAI CHARACTER PHINTHU (define-keysym #x0dde "Thai_maihanakat_maitho") (define-keysym #x0ddf "Thai_baht") ;U+0E3F THAI CURRENCY SYMBOL BAHT (define-keysym #x0de0 "Thai_sarae") ;U+0E40 THAI CHARACTER SARA E (define-keysym #x0de1 "Thai_saraae") ;U+0E41 THAI CHARACTER SARA AE (define-keysym #x0de2 "Thai_sarao") ;U+0E42 THAI CHARACTER SARA O (define-keysym #x0de3 "Thai_saraaimaimuan") ;U+0E43 THAI CHARACTER SARA AI MAIMUAN (define-keysym #x0de4 "Thai_saraaimaimalai") ;U+0E44 THAI CHARACTER SARA AI MAIMALAI (define-keysym #x0de5 "Thai_lakkhangyao") ;U+0E45 THAI CHARACTER LAKKHANGYAO (define-keysym #x0de6 "Thai_maiyamok") ;U+0E46 THAI CHARACTER MAIYAMOK (define-keysym #x0de7 "Thai_maitaikhu") ;U+0E47 THAI CHARACTER MAITAIKHU (define-keysym #x0de8 "Thai_maiek") ;U+0E48 THAI CHARACTER MAI EK (define-keysym #x0de9 "Thai_maitho") ;U+0E49 THAI CHARACTER MAI THO (define-keysym #x0dea "Thai_maitri") ;U+0E4A THAI CHARACTER MAI TRI (define-keysym #x0deb "Thai_maichattawa") ;U+0E4B THAI CHARACTER MAI CHATTAWA (define-keysym #x0dec "Thai_thanthakhat") ;U+0E4C THAI CHARACTER THANTHAKHAT (define-keysym #x0ded "Thai_nikhahit") ;U+0E4D THAI CHARACTER NIKHAHIT (define-keysym #x0df0 "Thai_leksun") ;U+0E50 THAI DIGIT ZERO (define-keysym #x0df1 "Thai_leknung") ;U+0E51 THAI DIGIT ONE (define-keysym #x0df2 "Thai_leksong") ;U+0E52 THAI DIGIT TWO (define-keysym #x0df3 "Thai_leksam") ;U+0E53 THAI DIGIT THREE (define-keysym #x0df4 "Thai_leksi") ;U+0E54 THAI DIGIT FOUR (define-keysym #x0df5 "Thai_lekha") ;U+0E55 THAI DIGIT FIVE (define-keysym #x0df6 "Thai_lekhok") ;U+0E56 THAI DIGIT SIX (define-keysym #x0df7 "Thai_lekchet") ;U+0E57 THAI DIGIT SEVEN (define-keysym #x0df8 "Thai_lekpaet") ;U+0E58 THAI DIGIT EIGHT (define-keysym #x0df9 "Thai_lekkao") ;U+0E59 THAI DIGIT NINE (define-keysym #xff31 "Hangul") ;Hangul start/stop(toggle) (define-keysym #xff32 "Hangul_Start") ;Hangul start (define-keysym #xff33 "Hangul_End") ;Hangul end, English start (define-keysym #xff34 "Hangul_Hanja") ;Start Hangul->Hanja Conversion (define-keysym #xff35 "Hangul_Jamo") ;Hangul Jamo mode (define-keysym #xff36 "Hangul_Romaja") ;Hangul Romaja mode (define-keysym #xff37 "Hangul_Codeinput") ;Hangul code input mode (define-keysym #xff38 "Hangul_Jeonja") ;Jeonja mode (define-keysym #xff39 "Hangul_Banja") ;Banja mode (define-keysym #xff3a "Hangul_PreHanja") ;Pre Hanja conversion (define-keysym #xff3b "Hangul_PostHanja") ;Post Hanja conversion (define-keysym #xff3c "Hangul_SingleCandidate") ;Single candidate (define-keysym #xff3d "Hangul_MultipleCandidate") ;Multiple candidate (define-keysym #xff3e "Hangul_PreviousCandidate") ;Previous candidate (define-keysym #xff3f "Hangul_Special") ;Special symbols (define-keysym #xff7e "Hangul_switch") ;Alias for mode_switch (define-keysym #x0ea1 "Hangul_Kiyeog") (define-keysym #x0ea2 "Hangul_SsangKiyeog") (define-keysym #x0ea3 "Hangul_KiyeogSios") (define-keysym #x0ea4 "Hangul_Nieun") (define-keysym #x0ea5 "Hangul_NieunJieuj") (define-keysym #x0ea6 "Hangul_NieunHieuh") (define-keysym #x0ea7 "Hangul_Dikeud") (define-keysym #x0ea8 "Hangul_SsangDikeud") (define-keysym #x0ea9 "Hangul_Rieul") (define-keysym #x0eaa "Hangul_RieulKiyeog") (define-keysym #x0eab "Hangul_RieulMieum") (define-keysym #x0eac "Hangul_RieulPieub") (define-keysym #x0ead "Hangul_RieulSios") (define-keysym #x0eae "Hangul_RieulTieut") (define-keysym #x0eaf "Hangul_RieulPhieuf") (define-keysym #x0eb0 "Hangul_RieulHieuh") (define-keysym #x0eb1 "Hangul_Mieum") (define-keysym #x0eb2 "Hangul_Pieub") (define-keysym #x0eb3 "Hangul_SsangPieub") (define-keysym #x0eb4 "Hangul_PieubSios") (define-keysym #x0eb5 "Hangul_Sios") (define-keysym #x0eb6 "Hangul_SsangSios") (define-keysym #x0eb7 "Hangul_Ieung") (define-keysym #x0eb8 "Hangul_Jieuj") (define-keysym #x0eb9 "Hangul_SsangJieuj") (define-keysym #x0eba "Hangul_Cieuc") (define-keysym #x0ebb "Hangul_Khieuq") (define-keysym #x0ebc "Hangul_Tieut") (define-keysym #x0ebd "Hangul_Phieuf") (define-keysym #x0ebe "Hangul_Hieuh") (define-keysym #x0ebf "Hangul_A") (define-keysym #x0ec0 "Hangul_AE") (define-keysym #x0ec1 "Hangul_YA") (define-keysym #x0ec2 "Hangul_YAE") (define-keysym #x0ec3 "Hangul_EO") (define-keysym #x0ec4 "Hangul_E") (define-keysym #x0ec5 "Hangul_YEO") (define-keysym #x0ec6 "Hangul_YE") (define-keysym #x0ec7 "Hangul_O") (define-keysym #x0ec8 "Hangul_WA") (define-keysym #x0ec9 "Hangul_WAE") (define-keysym #x0eca "Hangul_OE") (define-keysym #x0ecb "Hangul_YO") (define-keysym #x0ecc "Hangul_U") (define-keysym #x0ecd "Hangul_WEO") (define-keysym #x0ece "Hangul_WE") (define-keysym #x0ecf "Hangul_WI") (define-keysym #x0ed0 "Hangul_YU") (define-keysym #x0ed1 "Hangul_EU") (define-keysym #x0ed2 "Hangul_YI") (define-keysym #x0ed3 "Hangul_I") (define-keysym #x0ed4 "Hangul_J_Kiyeog") (define-keysym #x0ed5 "Hangul_J_SsangKiyeog") (define-keysym #x0ed6 "Hangul_J_KiyeogSios") (define-keysym #x0ed7 "Hangul_J_Nieun") (define-keysym #x0ed8 "Hangul_J_NieunJieuj") (define-keysym #x0ed9 "Hangul_J_NieunHieuh") (define-keysym #x0eda "Hangul_J_Dikeud") (define-keysym #x0edb "Hangul_J_Rieul") (define-keysym #x0edc "Hangul_J_RieulKiyeog") (define-keysym #x0edd "Hangul_J_RieulMieum") (define-keysym #x0ede "Hangul_J_RieulPieub") (define-keysym #x0edf "Hangul_J_RieulSios") (define-keysym #x0ee0 "Hangul_J_RieulTieut") (define-keysym #x0ee1 "Hangul_J_RieulPhieuf") (define-keysym #x0ee2 "Hangul_J_RieulHieuh") (define-keysym #x0ee3 "Hangul_J_Mieum") (define-keysym #x0ee4 "Hangul_J_Pieub") (define-keysym #x0ee5 "Hangul_J_PieubSios") (define-keysym #x0ee6 "Hangul_J_Sios") (define-keysym #x0ee7 "Hangul_J_SsangSios") (define-keysym #x0ee8 "Hangul_J_Ieung") (define-keysym #x0ee9 "Hangul_J_Jieuj") (define-keysym #x0eea "Hangul_J_Cieuc") (define-keysym #x0eeb "Hangul_J_Khieuq") (define-keysym #x0eec "Hangul_J_Tieut") (define-keysym #x0eed "Hangul_J_Phieuf") (define-keysym #x0eee "Hangul_J_Hieuh") (define-keysym #x0eef "Hangul_RieulYeorinHieuh") (define-keysym #x0ef0 "Hangul_SunkyeongeumMieum") (define-keysym #x0ef1 "Hangul_SunkyeongeumPieub") (define-keysym #x0ef2 "Hangul_PanSios") (define-keysym #x0ef3 "Hangul_KkogjiDalrinIeung") (define-keysym #x0ef4 "Hangul_SunkyeongeumPhieuf") (define-keysym #x0ef5 "Hangul_YeorinHieuh") (define-keysym #x0ef6 "Hangul_AraeA") (define-keysym #x0ef7 "Hangul_AraeAE") (define-keysym #x0ef8 "Hangul_J_PanSios") (define-keysym #x0ef9 "Hangul_J_KkogjiDalrinIeung") (define-keysym #x0efa "Hangul_J_YeorinHieuh") (define-keysym #x0eff "Korean_Won") ;(U+20A9 WON SIGN) (define-keysym #x1000587 "Armenian_ligature_ew") ;U+0587 ARMENIAN SMALL LIGATURE ECH YIWN (define-keysym #x1000589 "Armenian_full_stop") ;U+0589 ARMENIAN FULL STOP (define-keysym #x1000589 "Armenian_verjaket") ;U+0589 ARMENIAN FULL STOP (define-keysym #x100055d "Armenian_separation_mark") ;U+055D ARMENIAN COMMA (define-keysym #x100055d "Armenian_but") ;U+055D ARMENIAN COMMA (define-keysym #x100058a "Armenian_hyphen") ;U+058A ARMENIAN HYPHEN (define-keysym #x100058a "Armenian_yentamna") ;U+058A ARMENIAN HYPHEN (define-keysym #x100055c "Armenian_exclam") ;U+055C ARMENIAN EXCLAMATION MARK (define-keysym #x100055c "Armenian_amanak") ;U+055C ARMENIAN EXCLAMATION MARK (define-keysym #x100055b "Armenian_accent") ;U+055B ARMENIAN EMPHASIS MARK (define-keysym #x100055b "Armenian_shesht") ;U+055B ARMENIAN EMPHASIS MARK (define-keysym #x100055e "Armenian_question") ;U+055E ARMENIAN QUESTION MARK (define-keysym #x100055e "Armenian_paruyk") ;U+055E ARMENIAN QUESTION MARK (define-keysym #x1000531 "Armenian_AYB") ;U+0531 ARMENIAN CAPITAL LETTER AYB (define-keysym #x1000561 "Armenian_ayb") ;U+0561 ARMENIAN SMALL LETTER AYB (define-keysym #x1000532 "Armenian_BEN") ;U+0532 ARMENIAN CAPITAL LETTER BEN (define-keysym #x1000562 "Armenian_ben") ;U+0562 ARMENIAN SMALL LETTER BEN (define-keysym #x1000533 "Armenian_GIM") ;U+0533 ARMENIAN CAPITAL LETTER GIM (define-keysym #x1000563 "Armenian_gim") ;U+0563 ARMENIAN SMALL LETTER GIM (define-keysym #x1000534 "Armenian_DA") ;U+0534 ARMENIAN CAPITAL LETTER DA (define-keysym #x1000564 "Armenian_da") ;U+0564 ARMENIAN SMALL LETTER DA (define-keysym #x1000535 "Armenian_YECH") ;U+0535 ARMENIAN CAPITAL LETTER ECH (define-keysym #x1000565 "Armenian_yech") ;U+0565 ARMENIAN SMALL LETTER ECH (define-keysym #x1000536 "Armenian_ZA") ;U+0536 ARMENIAN CAPITAL LETTER ZA (define-keysym #x1000566 "Armenian_za") ;U+0566 ARMENIAN SMALL LETTER ZA (define-keysym #x1000537 "Armenian_E") ;U+0537 ARMENIAN CAPITAL LETTER EH (define-keysym #x1000567 "Armenian_e") ;U+0567 ARMENIAN SMALL LETTER EH (define-keysym #x1000538 "Armenian_AT") ;U+0538 ARMENIAN CAPITAL LETTER ET (define-keysym #x1000568 "Armenian_at") ;U+0568 ARMENIAN SMALL LETTER ET (define-keysym #x1000539 "Armenian_TO") ;U+0539 ARMENIAN CAPITAL LETTER TO (define-keysym #x1000569 "Armenian_to") ;U+0569 ARMENIAN SMALL LETTER TO (define-keysym #x100053a "Armenian_ZHE") ;U+053A ARMENIAN CAPITAL LETTER ZHE (define-keysym #x100056a "Armenian_zhe") ;U+056A ARMENIAN SMALL LETTER ZHE (define-keysym #x100053b "Armenian_INI") ;U+053B ARMENIAN CAPITAL LETTER INI (define-keysym #x100056b "Armenian_ini") ;U+056B ARMENIAN SMALL LETTER INI (define-keysym #x100053c "Armenian_LYUN") ;U+053C ARMENIAN CAPITAL LETTER LIWN (define-keysym #x100056c "Armenian_lyun") ;U+056C ARMENIAN SMALL LETTER LIWN (define-keysym #x100053d "Armenian_KHE") ;U+053D ARMENIAN CAPITAL LETTER XEH (define-keysym #x100056d "Armenian_khe") ;U+056D ARMENIAN SMALL LETTER XEH (define-keysym #x100053e "Armenian_TSA") ;U+053E ARMENIAN CAPITAL LETTER CA (define-keysym #x100056e "Armenian_tsa") ;U+056E ARMENIAN SMALL LETTER CA (define-keysym #x100053f "Armenian_KEN") ;U+053F ARMENIAN CAPITAL LETTER KEN (define-keysym #x100056f "Armenian_ken") ;U+056F ARMENIAN SMALL LETTER KEN (define-keysym #x1000540 "Armenian_HO") ;U+0540 ARMENIAN CAPITAL LETTER HO (define-keysym #x1000570 "Armenian_ho") ;U+0570 ARMENIAN SMALL LETTER HO (define-keysym #x1000541 "Armenian_DZA") ;U+0541 ARMENIAN CAPITAL LETTER JA (define-keysym #x1000571 "Armenian_dza") ;U+0571 ARMENIAN SMALL LETTER JA (define-keysym #x1000542 "Armenian_GHAT") ;U+0542 ARMENIAN CAPITAL LETTER GHAD (define-keysym #x1000572 "Armenian_ghat") ;U+0572 ARMENIAN SMALL LETTER GHAD (define-keysym #x1000543 "Armenian_TCHE") ;U+0543 ARMENIAN CAPITAL LETTER CHEH (define-keysym #x1000573 "Armenian_tche") ;U+0573 ARMENIAN SMALL LETTER CHEH (define-keysym #x1000544 "Armenian_MEN") ;U+0544 ARMENIAN CAPITAL LETTER MEN (define-keysym #x1000574 "Armenian_men") ;U+0574 ARMENIAN SMALL LETTER MEN (define-keysym #x1000545 "Armenian_HI") ;U+0545 ARMENIAN CAPITAL LETTER YI (define-keysym #x1000575 "Armenian_hi") ;U+0575 ARMENIAN SMALL LETTER YI (define-keysym #x1000546 "Armenian_NU") ;U+0546 ARMENIAN CAPITAL LETTER NOW (define-keysym #x1000576 "Armenian_nu") ;U+0576 ARMENIAN SMALL LETTER NOW (define-keysym #x1000547 "Armenian_SHA") ;U+0547 ARMENIAN CAPITAL LETTER SHA (define-keysym #x1000577 "Armenian_sha") ;U+0577 ARMENIAN SMALL LETTER SHA (define-keysym #x1000548 "Armenian_VO") ;U+0548 ARMENIAN CAPITAL LETTER VO (define-keysym #x1000578 "Armenian_vo") ;U+0578 ARMENIAN SMALL LETTER VO (define-keysym #x1000549 "Armenian_CHA") ;U+0549 ARMENIAN CAPITAL LETTER CHA (define-keysym #x1000579 "Armenian_cha") ;U+0579 ARMENIAN SMALL LETTER CHA (define-keysym #x100054a "Armenian_PE") ;U+054A ARMENIAN CAPITAL LETTER PEH (define-keysym #x100057a "Armenian_pe") ;U+057A ARMENIAN SMALL LETTER PEH (define-keysym #x100054b "Armenian_JE") ;U+054B ARMENIAN CAPITAL LETTER JHEH (define-keysym #x100057b "Armenian_je") ;U+057B ARMENIAN SMALL LETTER JHEH (define-keysym #x100054c "Armenian_RA") ;U+054C ARMENIAN CAPITAL LETTER RA (define-keysym #x100057c "Armenian_ra") ;U+057C ARMENIAN SMALL LETTER RA (define-keysym #x100054d "Armenian_SE") ;U+054D ARMENIAN CAPITAL LETTER SEH (define-keysym #x100057d "Armenian_se") ;U+057D ARMENIAN SMALL LETTER SEH (define-keysym #x100054e "Armenian_VEV") ;U+054E ARMENIAN CAPITAL LETTER VEW (define-keysym #x100057e "Armenian_vev") ;U+057E ARMENIAN SMALL LETTER VEW (define-keysym #x100054f "Armenian_TYUN") ;U+054F ARMENIAN CAPITAL LETTER TIWN (define-keysym #x100057f "Armenian_tyun") ;U+057F ARMENIAN SMALL LETTER TIWN (define-keysym #x1000550 "Armenian_RE") ;U+0550 ARMENIAN CAPITAL LETTER REH (define-keysym #x1000580 "Armenian_re") ;U+0580 ARMENIAN SMALL LETTER REH (define-keysym #x1000551 "Armenian_TSO") ;U+0551 ARMENIAN CAPITAL LETTER CO (define-keysym #x1000581 "Armenian_tso") ;U+0581 ARMENIAN SMALL LETTER CO (define-keysym #x1000552 "Armenian_VYUN") ;U+0552 ARMENIAN CAPITAL LETTER YIWN (define-keysym #x1000582 "Armenian_vyun") ;U+0582 ARMENIAN SMALL LETTER YIWN (define-keysym #x1000553 "Armenian_PYUR") ;U+0553 ARMENIAN CAPITAL LETTER PIWR (define-keysym #x1000583 "Armenian_pyur") ;U+0583 ARMENIAN SMALL LETTER PIWR (define-keysym #x1000554 "Armenian_KE") ;U+0554 ARMENIAN CAPITAL LETTER KEH (define-keysym #x1000584 "Armenian_ke") ;U+0584 ARMENIAN SMALL LETTER KEH (define-keysym #x1000555 "Armenian_O") ;U+0555 ARMENIAN CAPITAL LETTER OH (define-keysym #x1000585 "Armenian_o") ;U+0585 ARMENIAN SMALL LETTER OH (define-keysym #x1000556 "Armenian_FE") ;U+0556 ARMENIAN CAPITAL LETTER FEH (define-keysym #x1000586 "Armenian_fe") ;U+0586 ARMENIAN SMALL LETTER FEH (define-keysym #x100055a "Armenian_apostrophe") ;U+055A ARMENIAN APOSTROPHE (define-keysym #x10010d0 "Georgian_an") ;U+10D0 GEORGIAN LETTER AN (define-keysym #x10010d1 "Georgian_ban") ;U+10D1 GEORGIAN LETTER BAN (define-keysym #x10010d2 "Georgian_gan") ;U+10D2 GEORGIAN LETTER GAN (define-keysym #x10010d3 "Georgian_don") ;U+10D3 GEORGIAN LETTER DON (define-keysym #x10010d4 "Georgian_en") ;U+10D4 GEORGIAN LETTER EN (define-keysym #x10010d5 "Georgian_vin") ;U+10D5 GEORGIAN LETTER VIN (define-keysym #x10010d6 "Georgian_zen") ;U+10D6 GEORGIAN LETTER ZEN (define-keysym #x10010d7 "Georgian_tan") ;U+10D7 GEORGIAN LETTER TAN (define-keysym #x10010d8 "Georgian_in") ;U+10D8 GEORGIAN LETTER IN (define-keysym #x10010d9 "Georgian_kan") ;U+10D9 GEORGIAN LETTER KAN (define-keysym #x10010da "Georgian_las") ;U+10DA GEORGIAN LETTER LAS (define-keysym #x10010db "Georgian_man") ;U+10DB GEORGIAN LETTER MAN (define-keysym #x10010dc "Georgian_nar") ;U+10DC GEORGIAN LETTER NAR (define-keysym #x10010dd "Georgian_on") ;U+10DD GEORGIAN LETTER ON (define-keysym #x10010de "Georgian_par") ;U+10DE GEORGIAN LETTER PAR (define-keysym #x10010df "Georgian_zhar") ;U+10DF GEORGIAN LETTER ZHAR (define-keysym #x10010e0 "Georgian_rae") ;U+10E0 GEORGIAN LETTER RAE (define-keysym #x10010e1 "Georgian_san") ;U+10E1 GEORGIAN LETTER SAN (define-keysym #x10010e2 "Georgian_tar") ;U+10E2 GEORGIAN LETTER TAR (define-keysym #x10010e3 "Georgian_un") ;U+10E3 GEORGIAN LETTER UN (define-keysym #x10010e4 "Georgian_phar") ;U+10E4 GEORGIAN LETTER PHAR (define-keysym #x10010e5 "Georgian_khar") ;U+10E5 GEORGIAN LETTER KHAR (define-keysym #x10010e6 "Georgian_ghan") ;U+10E6 GEORGIAN LETTER GHAN (define-keysym #x10010e7 "Georgian_qar") ;U+10E7 GEORGIAN LETTER QAR (define-keysym #x10010e8 "Georgian_shin") ;U+10E8 GEORGIAN LETTER SHIN (define-keysym #x10010e9 "Georgian_chin") ;U+10E9 GEORGIAN LETTER CHIN (define-keysym #x10010ea "Georgian_can") ;U+10EA GEORGIAN LETTER CAN (define-keysym #x10010eb "Georgian_jil") ;U+10EB GEORGIAN LETTER JIL (define-keysym #x10010ec "Georgian_cil") ;U+10EC GEORGIAN LETTER CIL (define-keysym #x10010ed "Georgian_char") ;U+10ED GEORGIAN LETTER CHAR (define-keysym #x10010ee "Georgian_xan") ;U+10EE GEORGIAN LETTER XAN (define-keysym #x10010ef "Georgian_jhan") ;U+10EF GEORGIAN LETTER JHAN (define-keysym #x10010f0 "Georgian_hae") ;U+10F0 GEORGIAN LETTER HAE (define-keysym #x10010f1 "Georgian_he") ;U+10F1 GEORGIAN LETTER HE (define-keysym #x10010f2 "Georgian_hie") ;U+10F2 GEORGIAN LETTER HIE (define-keysym #x10010f3 "Georgian_we") ;U+10F3 GEORGIAN LETTER WE (define-keysym #x10010f4 "Georgian_har") ;U+10F4 GEORGIAN LETTER HAR (define-keysym #x10010f5 "Georgian_hoe") ;U+10F5 GEORGIAN LETTER HOE (define-keysym #x10010f6 "Georgian_fi") ;U+10F6 GEORGIAN LETTER FI (define-keysym #x1001e8a "Xabovedot") ;U+1E8A LATIN CAPITAL LETTER X WITH DOT ABOVE (define-keysym #x100012c "Ibreve") ;U+012C LATIN CAPITAL LETTER I WITH BREVE (define-keysym #x10001b5 "Zstroke") ;U+01B5 LATIN CAPITAL LETTER Z WITH STROKE (define-keysym #x10001e6 "Gcaron") ;U+01E6 LATIN CAPITAL LETTER G WITH CARON (define-keysym #x10001d1 "Ocaron") ;U+01D2 LATIN CAPITAL LETTER O WITH CARON (define-keysym #x100019f "Obarred") ;U+019F LATIN CAPITAL LETTER O WITH MIDDLE TILDE (define-keysym #x1001e8b "xabovedot") ;U+1E8B LATIN SMALL LETTER X WITH DOT ABOVE (define-keysym #x100012d "ibreve") ;U+012D LATIN SMALL LETTER I WITH BREVE (define-keysym #x10001b6 "zstroke") ;U+01B6 LATIN SMALL LETTER Z WITH STROKE (define-keysym #x10001e7 "gcaron") ;U+01E7 LATIN SMALL LETTER G WITH CARON (define-keysym #x10001d2 "ocaron") ;U+01D2 LATIN SMALL LETTER O WITH CARON (define-keysym #x1000275 "obarred") ;U+0275 LATIN SMALL LETTER BARRED O (define-keysym #x100018f "SCHWA") ;U+018F LATIN CAPITAL LETTER SCHWA (define-keysym #x1000259 "schwa") ;U+0259 LATIN SMALL LETTER SCHWA (define-keysym #x1001e36 "Lbelowdot") ;U+1E36 LATIN CAPITAL LETTER L WITH DOT BELOW (define-keysym #x1001e37 "lbelowdot") ;U+1E37 LATIN SMALL LETTER L WITH DOT BELOW (define-keysym #x1001ea0 "Abelowdot") ;U+1EA0 LATIN CAPITAL LETTER A WITH DOT BELOW (define-keysym #x1001ea1 "abelowdot") ;U+1EA1 LATIN SMALL LETTER A WITH DOT BELOW (define-keysym #x1001ea2 "Ahook") ;U+1EA2 LATIN CAPITAL LETTER A WITH HOOK ABOVE (define-keysym #x1001ea3 "ahook") ;U+1EA3 LATIN SMALL LETTER A WITH HOOK ABOVE (define-keysym #x1001ea4 "Acircumflexacute") ;U+1EA4 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ea5 "acircumflexacute") ;U+1EA5 LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ea6 "Acircumflexgrave") ;U+1EA6 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ea7 "acircumflexgrave") ;U+1EA7 LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ea8 "Acircumflexhook") ;U+1EA8 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001ea9 "acircumflexhook") ;U+1EA9 LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001eaa "Acircumflextilde") ;U+1EAA LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE (define-keysym #x1001eab "acircumflextilde") ;U+1EAB LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE (define-keysym #x1001eac "Acircumflexbelowdot") ;U+1EAC LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001ead "acircumflexbelowdot") ;U+1EAD LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001eae "Abreveacute") ;U+1EAE LATIN CAPITAL LETTER A WITH BREVE AND ACUTE (define-keysym #x1001eaf "abreveacute") ;U+1EAF LATIN SMALL LETTER A WITH BREVE AND ACUTE (define-keysym #x1001eb0 "Abrevegrave") ;U+1EB0 LATIN CAPITAL LETTER A WITH BREVE AND GRAVE (define-keysym #x1001eb1 "abrevegrave") ;U+1EB1 LATIN SMALL LETTER A WITH BREVE AND GRAVE (define-keysym #x1001eb2 "Abrevehook") ;U+1EB2 LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE (define-keysym #x1001eb3 "abrevehook") ;U+1EB3 LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE (define-keysym #x1001eb4 "Abrevetilde") ;U+1EB4 LATIN CAPITAL LETTER A WITH BREVE AND TILDE (define-keysym #x1001eb5 "abrevetilde") ;U+1EB5 LATIN SMALL LETTER A WITH BREVE AND TILDE (define-keysym #x1001eb6 "Abrevebelowdot") ;U+1EB6 LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW (define-keysym #x1001eb7 "abrevebelowdot") ;U+1EB7 LATIN SMALL LETTER A WITH BREVE AND DOT BELOW (define-keysym #x1001eb8 "Ebelowdot") ;U+1EB8 LATIN CAPITAL LETTER E WITH DOT BELOW (define-keysym #x1001eb9 "ebelowdot") ;U+1EB9 LATIN SMALL LETTER E WITH DOT BELOW (define-keysym #x1001eba "Ehook") ;U+1EBA LATIN CAPITAL LETTER E WITH HOOK ABOVE (define-keysym #x1001ebb "ehook") ;U+1EBB LATIN SMALL LETTER E WITH HOOK ABOVE (define-keysym #x1001ebc "Etilde") ;U+1EBC LATIN CAPITAL LETTER E WITH TILDE (define-keysym #x1001ebd "etilde") ;U+1EBD LATIN SMALL LETTER E WITH TILDE (define-keysym #x1001ebe "Ecircumflexacute") ;U+1EBE LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ebf "ecircumflexacute") ;U+1EBF LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ec0 "Ecircumflexgrave") ;U+1EC0 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ec1 "ecircumflexgrave") ;U+1EC1 LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ec2 "Ecircumflexhook") ;U+1EC2 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001ec3 "ecircumflexhook") ;U+1EC3 LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001ec4 "Ecircumflextilde") ;U+1EC4 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE (define-keysym #x1001ec5 "ecircumflextilde") ;U+1EC5 LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE (define-keysym #x1001ec6 "Ecircumflexbelowdot") ;U+1EC6 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001ec7 "ecircumflexbelowdot") ;U+1EC7 LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001ec8 "Ihook") ;U+1EC8 LATIN CAPITAL LETTER I WITH HOOK ABOVE (define-keysym #x1001ec9 "ihook") ;U+1EC9 LATIN SMALL LETTER I WITH HOOK ABOVE (define-keysym #x1001eca "Ibelowdot") ;U+1ECA LATIN CAPITAL LETTER I WITH DOT BELOW (define-keysym #x1001ecb "ibelowdot") ;U+1ECB LATIN SMALL LETTER I WITH DOT BELOW (define-keysym #x1001ecc "Obelowdot") ;U+1ECC LATIN CAPITAL LETTER O WITH DOT BELOW (define-keysym #x1001ecd "obelowdot") ;U+1ECD LATIN SMALL LETTER O WITH DOT BELOW (define-keysym #x1001ece "Ohook") ;U+1ECE LATIN CAPITAL LETTER O WITH HOOK ABOVE (define-keysym #x1001ecf "ohook") ;U+1ECF LATIN SMALL LETTER O WITH HOOK ABOVE (define-keysym #x1001ed0 "Ocircumflexacute") ;U+1ED0 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ed1 "ocircumflexacute") ;U+1ED1 LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE (define-keysym #x1001ed2 "Ocircumflexgrave") ;U+1ED2 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ed3 "ocircumflexgrave") ;U+1ED3 LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE (define-keysym #x1001ed4 "Ocircumflexhook") ;U+1ED4 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001ed5 "ocircumflexhook") ;U+1ED5 LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE (define-keysym #x1001ed6 "Ocircumflextilde") ;U+1ED6 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE (define-keysym #x1001ed7 "ocircumflextilde") ;U+1ED7 LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE (define-keysym #x1001ed8 "Ocircumflexbelowdot") ;U+1ED8 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001ed9 "ocircumflexbelowdot") ;U+1ED9 LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW (define-keysym #x1001eda "Ohornacute") ;U+1EDA LATIN CAPITAL LETTER O WITH HORN AND ACUTE (define-keysym #x1001edb "ohornacute") ;U+1EDB LATIN SMALL LETTER O WITH HORN AND ACUTE (define-keysym #x1001edc "Ohorngrave") ;U+1EDC LATIN CAPITAL LETTER O WITH HORN AND GRAVE (define-keysym #x1001edd "ohorngrave") ;U+1EDD LATIN SMALL LETTER O WITH HORN AND GRAVE (define-keysym #x1001ede "Ohornhook") ;U+1EDE LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE (define-keysym #x1001edf "ohornhook") ;U+1EDF LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE (define-keysym #x1001ee0 "Ohorntilde") ;U+1EE0 LATIN CAPITAL LETTER O WITH HORN AND TILDE (define-keysym #x1001ee1 "ohorntilde") ;U+1EE1 LATIN SMALL LETTER O WITH HORN AND TILDE (define-keysym #x1001ee2 "Ohornbelowdot") ;U+1EE2 LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW (define-keysym #x1001ee3 "ohornbelowdot") ;U+1EE3 LATIN SMALL LETTER O WITH HORN AND DOT BELOW (define-keysym #x1001ee4 "Ubelowdot") ;U+1EE4 LATIN CAPITAL LETTER U WITH DOT BELOW (define-keysym #x1001ee5 "ubelowdot") ;U+1EE5 LATIN SMALL LETTER U WITH DOT BELOW (define-keysym #x1001ee6 "Uhook") ;U+1EE6 LATIN CAPITAL LETTER U WITH HOOK ABOVE (define-keysym #x1001ee7 "uhook") ;U+1EE7 LATIN SMALL LETTER U WITH HOOK ABOVE (define-keysym #x1001ee8 "Uhornacute") ;U+1EE8 LATIN CAPITAL LETTER U WITH HORN AND ACUTE (define-keysym #x1001ee9 "uhornacute") ;U+1EE9 LATIN SMALL LETTER U WITH HORN AND ACUTE (define-keysym #x1001eea "Uhorngrave") ;U+1EEA LATIN CAPITAL LETTER U WITH HORN AND GRAVE (define-keysym #x1001eeb "uhorngrave") ;U+1EEB LATIN SMALL LETTER U WITH HORN AND GRAVE (define-keysym #x1001eec "Uhornhook") ;U+1EEC LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE (define-keysym #x1001eed "uhornhook") ;U+1EED LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE (define-keysym #x1001eee "Uhorntilde") ;U+1EEE LATIN CAPITAL LETTER U WITH HORN AND TILDE (define-keysym #x1001eef "uhorntilde") ;U+1EEF LATIN SMALL LETTER U WITH HORN AND TILDE (define-keysym #x1001ef0 "Uhornbelowdot") ;U+1EF0 LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW (define-keysym #x1001ef1 "uhornbelowdot") ;U+1EF1 LATIN SMALL LETTER U WITH HORN AND DOT BELOW (define-keysym #x1001ef4 "Ybelowdot") ;U+1EF4 LATIN CAPITAL LETTER Y WITH DOT BELOW (define-keysym #x1001ef5 "ybelowdot") ;U+1EF5 LATIN SMALL LETTER Y WITH DOT BELOW (define-keysym #x1001ef6 "Yhook") ;U+1EF6 LATIN CAPITAL LETTER Y WITH HOOK ABOVE (define-keysym #x1001ef7 "yhook") ;U+1EF7 LATIN SMALL LETTER Y WITH HOOK ABOVE (define-keysym #x1001ef8 "Ytilde") ;U+1EF8 LATIN CAPITAL LETTER Y WITH TILDE (define-keysym #x1001ef9 "ytilde") ;U+1EF9 LATIN SMALL LETTER Y WITH TILDE (define-keysym #x10001a0 "Ohorn") ;U+01A0 LATIN CAPITAL LETTER O WITH HORN (define-keysym #x10001a1 "ohorn") ;U+01A1 LATIN SMALL LETTER O WITH HORN (define-keysym #x10001af "Uhorn") ;U+01AF LATIN CAPITAL LETTER U WITH HORN (define-keysym #x10001b0 "uhorn") ;U+01B0 LATIN SMALL LETTER U WITH HORN (define-keysym #x10020a0 "EcuSign") ;U+20A0 EURO-CURRENCY SIGN (define-keysym #x10020a1 "ColonSign") ;U+20A1 COLON SIGN (define-keysym #x10020a2 "CruzeiroSign") ;U+20A2 CRUZEIRO SIGN (define-keysym #x10020a3 "FFrancSign") ;U+20A3 FRENCH FRANC SIGN (define-keysym #x10020a4 "LiraSign") ;U+20A4 LIRA SIGN (define-keysym #x10020a5 "MillSign") ;U+20A5 MILL SIGN (define-keysym #x10020a6 "NairaSign") ;U+20A6 NAIRA SIGN (define-keysym #x10020a7 "PesetaSign") ;U+20A7 PESETA SIGN (define-keysym #x10020a8 "RupeeSign") ;U+20A8 RUPEE SIGN (define-keysym #x10020a9 "WonSign") ;U+20A9 WON SIGN (define-keysym #x10020aa "NewSheqelSign") ;U+20AA NEW SHEQEL SIGN (define-keysym #x10020ab "DongSign") ;U+20AB DONG SIGN (define-keysym #x20ac "EuroSign") ;U+20AC EURO SIGN (define-keysym #x1002070 "zerosuperior") ;U+2070 SUPERSCRIPT ZERO (define-keysym #x1002074 "foursuperior") ;U+2074 SUPERSCRIPT FOUR (define-keysym #x1002075 "fivesuperior") ;U+2075 SUPERSCRIPT FIVE (define-keysym #x1002076 "sixsuperior") ;U+2076 SUPERSCRIPT SIX (define-keysym #x1002077 "sevensuperior") ;U+2077 SUPERSCRIPT SEVEN (define-keysym #x1002078 "eightsuperior") ;U+2078 SUPERSCRIPT EIGHT (define-keysym #x1002079 "ninesuperior") ;U+2079 SUPERSCRIPT NINE (define-keysym #x1002080 "zerosubscript") ;U+2080 SUBSCRIPT ZERO (define-keysym #x1002081 "onesubscript") ;U+2081 SUBSCRIPT ONE (define-keysym #x1002082 "twosubscript") ;U+2082 SUBSCRIPT TWO (define-keysym #x1002083 "threesubscript") ;U+2083 SUBSCRIPT THREE (define-keysym #x1002084 "foursubscript") ;U+2084 SUBSCRIPT FOUR (define-keysym #x1002085 "fivesubscript") ;U+2085 SUBSCRIPT FIVE (define-keysym #x1002086 "sixsubscript") ;U+2086 SUBSCRIPT SIX (define-keysym #x1002087 "sevensubscript") ;U+2087 SUBSCRIPT SEVEN (define-keysym #x1002088 "eightsubscript") ;U+2088 SUBSCRIPT EIGHT (define-keysym #x1002089 "ninesubscript") ;U+2089 SUBSCRIPT NINE (define-keysym #x1002202 "partdifferential") ;U+2202 PARTIAL DIFFERENTIAL (define-keysym #x1002205 "emptyset") ;U+2205 NULL SET (define-keysym #x1002208 "elementof") ;U+2208 ELEMENT OF (define-keysym #x1002209 "notelementof") ;U+2209 NOT AN ELEMENT OF (define-keysym #x100220B "containsas") ;U+220B CONTAINS AS MEMBER (define-keysym #x100221A "squareroot") ;U+221A SQUARE ROOT (define-keysym #x100221B "cuberoot") ;U+221B CUBE ROOT (define-keysym #x100221C "fourthroot") ;U+221C FOURTH ROOT (define-keysym #x100222C "dintegral") ;U+222C DOUBLE INTEGRAL (define-keysym #x100222D "tintegral") ;U+222D TRIPLE INTEGRAL (define-keysym #x1002235 "because") ;U+2235 BECAUSE (define-keysym #x1002248 "approxeq") ;U+2245 ALMOST EQUAL TO (define-keysym #x1002247 "notapproxeq") ;U+2247 NOT ALMOST EQUAL TO (define-keysym #x1002262 "notidentical") ;U+2262 NOT IDENTICAL TO (define-keysym #x1002263 "stricteq") ;U+2263 STRICTLY EQUIVALENT TO ;; A bunch of extended keysyms (define-keysym #x100000A8 "hpmute_acute") (define-keysym #x100000A9 "hpmute_grave") (define-keysym #x100000AA "hpmute_asciicircum") (define-keysym #x100000AB "hpmute_diaeresis") (define-keysym #x100000AC "hpmute_asciitilde") (define-keysym #x100000AF "hplira") (define-keysym #x100000BE "hpguilder") (define-keysym #x100000EE "hpYdiaeresis") (define-keysym #x100000EE "hpIO") (define-keysym #x100000F6 "hplongminus") (define-keysym #x100000FC "hpblock") (define-keysym #x1000FF00 "apLineDel") (define-keysym #x1000FF01 "apCharDel") (define-keysym #x1000FF02 "apCopy") (define-keysym #x1000FF03 "apCut") (define-keysym #x1000FF04 "apPaste") (define-keysym #x1000FF05 "apMove") (define-keysym #x1000FF06 "apGrow") (define-keysym #x1000FF07 "apCmd") (define-keysym #x1000FF08 "apShell") (define-keysym #x1000FF09 "apLeftBar") (define-keysym #x1000FF0A "apRightBar") (define-keysym #x1000FF0B "apLeftBox") (define-keysym #x1000FF0C "apRightBox") (define-keysym #x1000FF0D "apUpBox") (define-keysym #x1000FF0E "apDownBox") (define-keysym #x1000FF0F "apPop") (define-keysym #x1000FF10 "apRead") (define-keysym #x1000FF11 "apEdit") (define-keysym #x1000FF12 "apSave") (define-keysym #x1000FF13 "apExit") (define-keysym #x1000FF14 "apRepeat") (define-keysym #x1000FF48 "hpModelock1") (define-keysym #x1000FF49 "hpModelock2") (define-keysym #x1000FF6C "hpReset") (define-keysym #x1000FF6D "hpSystem") (define-keysym #x1000FF6E "hpUser") (define-keysym #x1000FF6F "hpClearLine") (define-keysym #x1000FF70 "hpInsertLine") (define-keysym #x1000FF71 "hpDeleteLine") (define-keysym #x1000FF72 "hpInsertChar") (define-keysym #x1000FF73 "hpDeleteChar") (define-keysym #x1000FF74 "hpBackTab") (define-keysym #x1000FF75 "hpKP_BackTab") (define-keysym #x1000FFA8 "apKP_parenleft") (define-keysym #x1000FFA9 "apKP_parenright") (define-keysym #x10004001 "I2ND_FUNC_L") (define-keysym #x10004002 "I2ND_FUNC_R") (define-keysym #x10004003 "IREMOVE") (define-keysym #x10004004 "IREPEAT") (define-keysym #x10004101 "IA1") (define-keysym #x10004102 "IA2") (define-keysym #x10004103 "IA3") (define-keysym #x10004104 "IA4") (define-keysym #x10004105 "IA5") (define-keysym #x10004106 "IA6") (define-keysym #x10004107 "IA7") (define-keysym #x10004108 "IA8") (define-keysym #x10004109 "IA9") (define-keysym #x1000410A "IA10") (define-keysym #x1000410B "IA11") (define-keysym #x1000410C "IA12") (define-keysym #x1000410D "IA13") (define-keysym #x1000410E "IA14") (define-keysym #x1000410F "IA15") (define-keysym #x10004201 "IB1") (define-keysym #x10004202 "IB2") (define-keysym #x10004203 "IB3") (define-keysym #x10004204 "IB4") (define-keysym #x10004205 "IB5") (define-keysym #x10004206 "IB6") (define-keysym #x10004207 "IB7") (define-keysym #x10004208 "IB8") (define-keysym #x10004209 "IB9") (define-keysym #x1000420A "IB10") (define-keysym #x1000420B "IB11") (define-keysym #x1000420C "IB12") (define-keysym #x1000420D "IB13") (define-keysym #x1000420E "IB14") (define-keysym #x1000420F "IB15") (define-keysym #x10004210 "IB16") (define-keysym #x1000FF00 "DRemove") (define-keysym #x1000FEB0 "Dring_accent") (define-keysym #x1000FE5E "Dcircumflex_accent") (define-keysym #x1000FE2C "Dcedilla_accent") (define-keysym #x1000FE27 "Dacute_accent") (define-keysym #x1000FE60 "Dgrave_accent") (define-keysym #x1000FE7E "Dtilde") (define-keysym #x1000FE22 "Ddiaeresis") (define-keysym #x1004FF02 "osfCopy") (define-keysym #x1004FF03 "osfCut") (define-keysym #x1004FF04 "osfPaste") (define-keysym #x1004FF07 "osfBackTab") (define-keysym #x1004FF08 "osfBackSpace") (define-keysym #x1004FF0B "osfClear") (define-keysym #x1004FF1B "osfEscape") (define-keysym #x1004FF31 "osfAddMode") (define-keysym #x1004FF32 "osfPrimaryPaste") (define-keysym #x1004FF33 "osfQuickPaste") (define-keysym #x1004FF40 "osfPageLeft") (define-keysym #x1004FF41 "osfPageUp") (define-keysym #x1004FF42 "osfPageDown") (define-keysym #x1004FF43 "osfPageRight") (define-keysym #x1004FF44 "osfActivate") (define-keysym #x1004FF45 "osfMenuBar") (define-keysym #x1004FF51 "osfLeft") (define-keysym #x1004FF52 "osfUp") (define-keysym #x1004FF53 "osfRight") (define-keysym #x1004FF54 "osfDown") (define-keysym #x1004FF55 "osfPrior") (define-keysym #x1004FF56 "osfNext") (define-keysym #x1004FF57 "osfEndLine") (define-keysym #x1004FF58 "osfBeginLine") (define-keysym #x1004FF59 "osfEndData") (define-keysym #x1004FF5A "osfBeginData") (define-keysym #x1004FF5B "osfPrevMenu") (define-keysym #x1004FF5C "osfNextMenu") (define-keysym #x1004FF5D "osfPrevField") (define-keysym #x1004FF5E "osfNextField") (define-keysym #x1004FF60 "osfSelect") (define-keysym #x1004FF63 "osfInsert") (define-keysym #x1004FF65 "osfUndo") (define-keysym #x1004FF67 "osfMenu") (define-keysym #x1004FF69 "osfCancel") (define-keysym #x1004FF6A "osfHelp") (define-keysym #x1004FF71 "osfSelectAll") (define-keysym #x1004FF72 "osfDeselectAll") (define-keysym #x1004FF73 "osfReselect") (define-keysym #x1004FF74 "osfExtend") (define-keysym #x1004FF78 "osfRestore") (define-keysym #x1004FF7E "osfSwitchDirection") (define-keysym #x1004FFF5 "osfPriorMinor") (define-keysym #x1004FFF6 "osfNextMinor") (define-keysym #x1004FFF7 "osfRightLine") (define-keysym #x1004FFF8 "osfLeftLine") (define-keysym #x1004FFFF "osfDelete") (define-keysym #x1005FF00 "SunFA_Grave") (define-keysym #x1005FF01 "SunFA_Circum") (define-keysym #x1005FF02 "SunFA_Tilde") (define-keysym #x1005FF03 "SunFA_Acute") (define-keysym #x1005FF04 "SunFA_Diaeresis") (define-keysym #x1005FF05 "SunFA_Cedilla") (define-keysym #x1005FF10 "SunF36") (define-keysym #x1005FF11 "SunF37") (define-keysym #x1005FF60 "SunSys_Req") (define-keysym #x1005FF70 "SunProps") (define-keysym #x1005FF71 "SunFront") (define-keysym #x1005FF72 "SunCopy") (define-keysym #x1005FF73 "SunOpen") (define-keysym #x1005FF74 "SunPaste") (define-keysym #x1005FF75 "SunCut") (define-keysym #x1005FF76 "SunPowerSwitch") (define-keysym #x1005FF77 "SunAudioLowerVolume") (define-keysym #x1005FF78 "SunAudioMute") (define-keysym #x1005FF79 "SunAudioRaiseVolume") (define-keysym #x1005FF7A "SunVideoDegauss") (define-keysym #x1005FF7B "SunVideoLowerBrightness") (define-keysym #x1005FF7C "SunVideoRaiseBrightness") (define-keysym #x1005FF7D "SunPowerSwitchShift") (define-keysym #xFF20 "SunCompose") (define-keysym #xFF55 "SunPageUp") (define-keysym #xFF56 "SunPageDown") (define-keysym #xFF61 "SunPrint_Screen") (define-keysym #xFF65 "SunUndo") (define-keysym #xFF66 "SunAgain") (define-keysym #xFF68 "SunFind") (define-keysym #xFF69 "SunStop") (define-keysym #xFF7E "SunAltGraph") (define-keysym #x1006FF00 "WYSetup") (define-keysym #x1006FF00 "ncdSetup") (define-keysym #x10070001 "XeroxPointerButton1") (define-keysym #x10070002 "XeroxPointerButton2") (define-keysym #x10070003 "XeroxPointerButton3") (define-keysym #x10070004 "XeroxPointerButton4") (define-keysym #x10070005 "XeroxPointerButton5") (define-keysym #x1008FF01 "XF86ModeLock") (define-keysym #x1008FF02 "XF86MonBrightnessUp") (define-keysym #x1008FF03 "XF86MonBrightnessDown") (define-keysym #x1008FF04 "XF86KbdLightOnOff") (define-keysym #x1008FF05 "XF86KbdBrightnessUp") (define-keysym #x1008FF06 "XF86KbdBrightnessDown") (define-keysym #x1008FF10 "XF86Standby") (define-keysym #x1008FF11 "XF86AudioLowerVolume") (define-keysym #x1008FF12 "XF86AudioMute") (define-keysym #x1008FF13 "XF86AudioRaiseVolume") (define-keysym #x1008FF14 "XF86AudioPlay") (define-keysym #x1008FF15 "XF86AudioStop") (define-keysym #x1008FF16 "XF86AudioPrev") (define-keysym #x1008FF17 "XF86AudioNext") (define-keysym #x1008FF18 "XF86HomePage") (define-keysym #x1008FF19 "XF86Mail") (define-keysym #x1008FF1A "XF86Start") (define-keysym #x1008FF1B "XF86Search") (define-keysym #x1008FF1C "XF86AudioRecord") (define-keysym #x1008FF1D "XF86Calculator") (define-keysym #x1008FF1E "XF86Memo") (define-keysym #x1008FF1F "XF86ToDoList") (define-keysym #x1008FF20 "XF86Calendar") (define-keysym #x1008FF21 "XF86PowerDown") (define-keysym #x1008FF22 "XF86ContrastAdjust") (define-keysym #x1008FF23 "XF86RockerUp") (define-keysym #x1008FF24 "XF86RockerDown") (define-keysym #x1008FF25 "XF86RockerEnter") (define-keysym #x1008FF26 "XF86Back") (define-keysym #x1008FF27 "XF86Forward") (define-keysym #x1008FF28 "XF86Stop") (define-keysym #x1008FF29 "XF86Refresh") (define-keysym #x1008FF2A "XF86PowerOff") (define-keysym #x1008FF2B "XF86WakeUp") (define-keysym #x1008FF2C "XF86Eject") (define-keysym #x1008FF2D "XF86ScreenSaver") (define-keysym #x1008FF2E "XF86WWW") (define-keysym #x1008FF2F "XF86Sleep") (define-keysym #x1008FF30 "XF86Favorites") (define-keysym #x1008FF31 "XF86AudioPause") (define-keysym #x1008FF32 "XF86AudioMedia") (define-keysym #x1008FF33 "XF86MyComputer") (define-keysym #x1008FF34 "XF86VendorHome") (define-keysym #x1008FF35 "XF86LightBulb") (define-keysym #x1008FF36 "XF86Shop") (define-keysym #x1008FF37 "XF86History") (define-keysym #x1008FF38 "XF86OpenURL") (define-keysym #x1008FF39 "XF86AddFavorite") (define-keysym #x1008FF3A "XF86HotLinks") (define-keysym #x1008FF3B "XF86BrightnessAdjust") (define-keysym #x1008FF3C "XF86Finance") (define-keysym #x1008FF3D "XF86Community") (define-keysym #x1008FF3E "XF86AudioRewind") (define-keysym #x1008FF3F "XF86BackForward") (define-keysym #x1008FF40 "XF86Launch0") (define-keysym #x1008FF41 "XF86Launch1") (define-keysym #x1008FF42 "XF86Launch2") (define-keysym #x1008FF43 "XF86Launch3") (define-keysym #x1008FF44 "XF86Launch4") (define-keysym #x1008FF45 "XF86Launch5") (define-keysym #x1008FF46 "XF86Launch6") (define-keysym #x1008FF47 "XF86Launch7") (define-keysym #x1008FF48 "XF86Launch8") (define-keysym #x1008FF49 "XF86Launch9") (define-keysym #x1008FF4A "XF86LaunchA") (define-keysym #x1008FF4B "XF86LaunchB") (define-keysym #x1008FF4C "XF86LaunchC") (define-keysym #x1008FF4D "XF86LaunchD") (define-keysym #x1008FF4E "XF86LaunchE") (define-keysym #x1008FF4F "XF86LaunchF") (define-keysym #x1008FF50 "XF86ApplicationLeft") (define-keysym #x1008FF51 "XF86ApplicationRight") (define-keysym #x1008FF52 "XF86Book") (define-keysym #x1008FF53 "XF86CD") (define-keysym #x1008FF54 "XF86Calculater") (define-keysym #x1008FF55 "XF86Clear") (define-keysym #x1008FF56 "XF86Close") (define-keysym #x1008FF57 "XF86Copy") (define-keysym #x1008FF58 "XF86Cut") (define-keysym #x1008FF59 "XF86Display") (define-keysym #x1008FF5A "XF86DOS") (define-keysym #x1008FF5B "XF86Documents") (define-keysym #x1008FF5C "XF86Excel") (define-keysym #x1008FF5D "XF86Explorer") (define-keysym #x1008FF5E "XF86Game") (define-keysym #x1008FF5F "XF86Go") (define-keysym #x1008FF60 "XF86iTouch") (define-keysym #x1008FF61 "XF86LogOff") (define-keysym #x1008FF62 "XF86Market") (define-keysym #x1008FF63 "XF86Meeting") (define-keysym #x1008FF65 "XF86MenuKB") (define-keysym #x1008FF66 "XF86MenuPB") (define-keysym #x1008FF67 "XF86MySites") (define-keysym #x1008FF68 "XF86New") (define-keysym #x1008FF69 "XF86News") (define-keysym #x1008FF6A "XF86OfficeHome") (define-keysym #x1008FF6B "XF86Open") (define-keysym #x1008FF6C "XF86Option") (define-keysym #x1008FF6D "XF86Paste") (define-keysym #x1008FF6E "XF86Phone") (define-keysym #x1008FF70 "XF86Q") (define-keysym #x1008FF72 "XF86Reply") (define-keysym #x1008FF73 "XF86Reload") (define-keysym #x1008FF74 "XF86RotateWindows") (define-keysym #x1008FF75 "XF86RotationPB") (define-keysym #x1008FF76 "XF86RotationKB") (define-keysym #x1008FF77 "XF86Save") (define-keysym #x1008FF78 "XF86ScrollUp") (define-keysym #x1008FF79 "XF86ScrollDown") (define-keysym #x1008FF7A "XF86ScrollClick") (define-keysym #x1008FF7B "XF86Send") (define-keysym #x1008FF7C "XF86Spell") (define-keysym #x1008FF7D "XF86SplitScreen") (define-keysym #x1008FF7E "XF86Support") (define-keysym #x1008FF7F "XF86TaskPane") (define-keysym #x1008FF80 "XF86Terminal") (define-keysym #x1008FF81 "XF86Tools") (define-keysym #x1008FF82 "XF86Travel") (define-keysym #x1008FF84 "XF86UserPB") (define-keysym #x1008FF85 "XF86User1KB") (define-keysym #x1008FF86 "XF86User2KB") (define-keysym #x1008FF87 "XF86Video") (define-keysym #x1008FF88 "XF86WheelButton") (define-keysym #x1008FF89 "XF86Word") (define-keysym #x1008FF8A "XF86Xfer") (define-keysym #x1008FF8B "XF86ZoomIn") (define-keysym #x1008FF8C "XF86ZoomOut") (define-keysym #x1008FF8D "XF86Away") (define-keysym #x1008FF8E "XF86Messenger") (define-keysym #x1008FF8F "XF86WebCam") (define-keysym #x1008FF90 "XF86MailForward") (define-keysym #x1008FF91 "XF86Pictures") (define-keysym #x1008FF92 "XF86Music") (define-keysym #x1008FF93 "XF86Battery") (define-keysym #x1008FF94 "XF86Bluetooth") (define-keysym #x1008FF95 "XF86WLAN") (define-keysym #x1008FF96 "XF86UWB") (define-keysym #x1008FF97 "XF86AudioForward") (define-keysym #x1008FF98 "XF86AudioRepeat") (define-keysym #x1008FF99 "XF86AudioRandomPlay") (define-keysym #x1008FF9A "XF86Subtitle") (define-keysym #x1008FF9B "XF86AudioCycleTrack") (define-keysym #x1008FF9C "XF86CycleAngle") (define-keysym #x1008FF9D "XF86FrameBack") (define-keysym #x1008FF9E "XF86FrameForward") (define-keysym #x1008FF9F "XF86Time") (define-keysym #x1008FFA0 "XF86Select") (define-keysym #x1008FFA1 "XF86View") (define-keysym #x1008FFA2 "XF86TopMenu") (define-keysym #x1008FFA3 "XF86Red") (define-keysym #x1008FFA4 "XF86Green") (define-keysym #x1008FFA5 "XF86Yellow") (define-keysym #x1008FFA6 "XF86Blue") (define-keysym #x1008FFA7 "XF86Suspend") (define-keysym #x1008FFA8 "XF86Hibernate") (define-keysym #x1008FFA9 "XF86TouchpadToggle") (define-keysym #x1008FFB0 "XF86TouchpadOn") (define-keysym #x1008FFB1 "XF86TouchpadOff") (define-keysym #x1008FFB2 "XF86AudioMicMute") (define-keysym #x1008FFB5 "XF86RFKill") (define-keysym #x1008FE01 "XF86_Switch_VT_1") (define-keysym #x1008FE02 "XF86_Switch_VT_2") (define-keysym #x1008FE03 "XF86_Switch_VT_3") (define-keysym #x1008FE04 "XF86_Switch_VT_4") (define-keysym #x1008FE05 "XF86_Switch_VT_5") (define-keysym #x1008FE06 "XF86_Switch_VT_6") (define-keysym #x1008FE07 "XF86_Switch_VT_7") (define-keysym #x1008FE08 "XF86_Switch_VT_8") (define-keysym #x1008FE09 "XF86_Switch_VT_9") (define-keysym #x1008FE0A "XF86_Switch_VT_10") (define-keysym #x1008FE0B "XF86_Switch_VT_11") (define-keysym #x1008FE0C "XF86_Switch_VT_12") (define-keysym #x1008FE20 "XF86_Ungrab") (define-keysym #x1008FE21 "XF86_ClearGrab") (define-keysym #x1008FE22 "XF86_Next_VMode") (define-keysym #x1008FE23 "XF86_Prev_VMode") (define-keysym #x100000A8 "usldead_acute") (define-keysym #x100000A9 "usldead_grave") (define-keysym #x100000AB "usldead_diaeresis") (define-keysym #x100000AA "usldead_asciicircum") (define-keysym #x100000AC "usldead_asciitilde") (define-keysym #x1000FE2C "usldead_cedilla") (define-keysym #x1000FEB0 "usldead_ring") stumpwm-22.11/keytrans.lisp000066400000000000000000000103431433701203600157640ustar00rootroot00000000000000;; Copyright (C) 2006-2008 Matthew Kennedy ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Translate between stumpwm key names and keysym names. ;; ;; Code: (in-package #:stumpwm) (defvar *stumpwm-name->keysym-name-translations* (make-hash-table :test #'equal) "Hashtable mapping from stumpwm key names to keysym names.") (defun define-keysym-name (stumpwm-name keysym-name) "Define a mapping from a STUMPWM-NAME to KEYSYM-NAME. This function is used to translate Emacs-like names to keysym names." (setf (gethash stumpwm-name *stumpwm-name->keysym-name-translations*) keysym-name)) (defun stumpwm-name->keysym-name (stumpwm-name) (multiple-value-bind (value present-p) (gethash stumpwm-name *stumpwm-name->keysym-name-translations*) (declare (ignore present-p)) value)) (defun keysym-name->stumpwm-name (keysym-name) (maphash (lambda (k v) (when (equal v keysym-name) (return-from keysym-name->stumpwm-name k))) *stumpwm-name->keysym-name-translations*)) (defun stumpwm-name->keysym (stumpwm-name) "Return the keysym corresponding to STUMPWM-NAME. If no mapping for STUMPWM-NAME exists, then fallback by calling KEYSYM-NAME->KEYSYM." (let ((keysym-name (stumpwm-name->keysym-name stumpwm-name))) (keysym-name->keysym (or keysym-name stumpwm-name)))) (defun keysym->stumpwm-name (keysym) "Return the stumpwm key name corresponding to KEYSYM. If no mapping for the stumpwm key name exists, then fall back by calling KEYSYM->KEYSYM-NAME." (let ((keysym-name (keysym->keysym-name keysym))) (or (keysym-name->stumpwm-name keysym-name) keysym-name))) (define-keysym-name "RET" "Return") (define-keysym-name "ESC" "Escape") (define-keysym-name "TAB" "Tab") (define-keysym-name "DEL" "BackSpace") (define-keysym-name "SPC" "space") (define-keysym-name "!" "exclam") (define-keysym-name "\"" "quotedbl") (define-keysym-name "$" "dollar") (define-keysym-name "£" "sterling") (define-keysym-name "%" "percent") (define-keysym-name "&" "ampersand") (define-keysym-name "'" "quoteright") ;deprecated (define-keysym-name "'" "apostrophe") (define-keysym-name "`" "quoteleft") ;deprecated (define-keysym-name "`" "grave") (define-keysym-name "&" "ampersand") (define-keysym-name "(" "parenleft") (define-keysym-name ")" "parenright") (define-keysym-name "*" "asterisk") (define-keysym-name "+" "plus") (define-keysym-name "," "comma") (define-keysym-name "-" "minus") (define-keysym-name "." "period") (define-keysym-name "/" "slash") (define-keysym-name ":" "colon") (define-keysym-name ";" "semicolon") (define-keysym-name "<" "less") (define-keysym-name "=" "equal") (define-keysym-name ">" "greater") (define-keysym-name "?" "question") (define-keysym-name "@" "at") (define-keysym-name "[" "bracketleft") (define-keysym-name "\\" "backslash") (define-keysym-name "]" "bracketright") (define-keysym-name "^" "asciicircum") (define-keysym-name "_" "underscore") (define-keysym-name "#" "numbersign") (define-keysym-name "{" "braceleft") (define-keysym-name "|" "bar") (define-keysym-name "}" "braceright") (define-keysym-name "~" "asciitilde") (define-keysym-name "<" "quoteleft") (define-keysym-name ">" "quoteright") (define-keysym-name "«" "guillemotleft") (define-keysym-name "»" "guillemotright") (define-keysym-name "À" "Agrave") (define-keysym-name "à" "agrave") (define-keysym-name "Ç" "Ccedilla") (define-keysym-name "ç" "ccedilla") (define-keysym-name "É" "Eacute") (define-keysym-name "é" "eacute") (define-keysym-name "È" "Egrave") (define-keysym-name "è" "egrave") (define-keysym-name "Ê" "Ecircumflex") (define-keysym-name "ê" "ecircumflex") stumpwm-22.11/kmap.lisp000066400000000000000000000247631433701203600150670ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file handles keymaps ;; ;; Code: (in-package stumpwm) (export '(*top-map* *root-map* *key-seq-color* *altgr-offset* define-key kbd lookup-command lookup-key make-sparse-keymap undefine-key)) (defvar *top-map* nil "The top level key map. This is where you'll find the binding for the @dfn{prefix map}.") (defvar *root-map* nil "This is the keymap by default bound to @kbd{C-t} (along with *group-root-map* and either *tile-group-root-map*, *float-group-root-map*, or *dynamic-group-map*). It is known as the @dfn{prefix map}.") (defvar *key-seq-color* "^5" "Color of a keybinding when displayed in windows such as the prefix keybinding in the which-key window.") (defstruct key keysym shift control meta alt hyper super altgr) (defstruct kmap bindings) (defstruct binding key command) (defun make-sparse-keymap () "Create an empty keymap. If you want to create a new list of bindings in the key binding tree, this is where you start. To hang frame related bindings off @kbd{C-t C-f} one might use the following code: @example \(defvar *my-frame-bindings* (let ((m (stumpwm:make-sparse-keymap))) (stumpwm:define-key m (stumpwm:kbd \"f\") \"curframe\") (stumpwm:define-key m (stumpwm:kbd \"M-b\") \"move-focus left\") m ; NOTE: this is important )) \(stumpwm:define-key stumpwm:*root-map* (stumpwm:kbd \"C-f\") '*my-frame-bindings*) @end example" (make-kmap)) (defun lookup-command (keymap command) "Return a list of keys that are bound to command" (loop for i in (kmap-bindings keymap) when (equal command (binding-command i)) collect (binding-key i))) (defun lookup-key (keymap key &optional accept-default) (labels ((retcmd (key) (when key (binding-command key)))) (or (retcmd (find key (kmap-bindings keymap) :key 'binding-key :test 'equalp)) (and accept-default (retcmd (find t (kmap-bindings keymap) :key 'binding-key)))))) (defun key-mods-p (key) (or (key-shift key) (key-control key) (key-meta key) (key-alt key) (key-hyper key) (key-super key))) (defun x11-mods (key &optional with-numlock with-capslock) "Return the modifiers for key in a format that clx understands. if WITH-NUMLOCK is non-nil then include the numlock modifier. if WITH-CAPSLOCK is non-nil then include the capslock modifier. Most of the time these just gets in the way." (let (mods) (when (key-shift key) (push :shift mods)) (when (key-control key) (push :control mods)) (when (key-meta key) (setf mods (append (modifiers-meta *modifiers*) mods))) (when (key-alt key) (setf mods (append (modifiers-alt *modifiers*) mods))) (when (key-hyper key) (setf mods (append (modifiers-hyper *modifiers*) mods))) (when (key-super key) (setf mods (append (modifiers-super *modifiers*) mods))) (when with-numlock (setf mods (append (modifiers-numlock *modifiers*) mods))) (when with-capslock (push :lock mods)) (apply 'xlib:make-state-mask mods))) (defun report-kbd-parse-error (c stream) (format stream "Failed to parse key string: ~s" (slot-value c 'string)) (when-let ((reason (kbd-parse-error-reason c))) (format stream "~%Reason: ~A" reason))) (define-condition kbd-parse-error (stumpwm-error) ((string :initarg :string) (reason :initarg :reason :reader kbd-parse-error-reason :initform nil)) (:report report-kbd-parse-error) (:documentation "Raised when a kbd string failed to parse.")) (defun parse-mods (mods end) "MODS is a sequence of #\- pairs. Return a list suitable for passing as the last argument to (apply #'make-key ...)" (unless (evenp end) (error 'kbd-parse-error :string mods :reason "Did you forget to separate modifier characters with '-'?")) (loop for i from 0 below end by 2 when (char/= (char mods (1+ i)) #\-) do (error 'kbd-parse-error :string mods) nconc (case (char mods i) (#\M (list :meta t)) (#\A (list :alt t)) (#\C (list :control t)) (#\H (list :hyper t)) (#\s (list :super t)) (#\S (list :shift t)) (t (error 'kbd-parse-error :string mods :reason (format nil "Unknown modifer character ~A" (char mods i))))))) (defvar *altgr-offset* 2 "The offset of altgr keysyms. Often 2 or 4, but always an even number.") (defun keysym-requires-altgr (keysym) (when *display* (unless (and (xlib:keysym->keycodes *display* keysym) t) (let* ((min (xlib:display-min-keycode *display*)) (max (xlib:display-max-keycode *display*)) (map (xlib::display-keyboard-mapping *display*)) (size (array-dimension map 1))) (when (> *altgr-offset* size) (error "AltGr offset is larger than the available offsets")) (do ((i min (1+ i))) ((> i max) nil) (when (or (= keysym (aref map i *altgr-offset*)) (= keysym (aref map i (1+ *altgr-offset*)))) (return-from keysym-requires-altgr t))))))) (defun parse-key (string) "Parse STRING and return a key structure. Raise an error of type kbd-parse if the key failed to parse." (let* ((p (when (> (length string) 2) (position #\- string :from-end t :end (- (length string) 1)))) (%mods (parse-mods string (if p (1+ p) 0))) (keysym (stumpwm-name->keysym (subseq string (if p (1+ p) 0)))) (mods (if (keysym-requires-altgr keysym) (append '(:altgr t) %mods) %mods))) (if keysym (apply 'make-key :keysym keysym mods) (error 'kbd-parse-error :string string)))) (defun parse-key-seq (keys) "KEYS is a key sequence. Parse it and return the list of keys." (mapcar 'parse-key (split-string keys))) (defun kbd (keys) "This compiles a key string into a key structure used by `define-key', `undefine-key', `set-prefix-key' and others." ;; XXX: define-key needs to be fixed to handle a list of keys (first (parse-key-seq keys))) (defun copy-key-into (from to) "copy the contents of TO into FROM." (setf (key-keysym to) (key-keysym from) (key-shift to) (key-shift from) (key-control to) (key-control from) (key-meta to) (key-meta from) (key-alt to) (key-alt from) (key-hyper to) (key-hyper from) (key-super to) (key-super from))) (defun print-mods (key) (concatenate 'string (when (key-control key) "C-") (when (key-meta key) "M-") (when (key-alt key) "A-") (when (key-shift key) "S-") (when (key-super key) "s-") (when (key-hyper key) "H-"))) (defun print-key (key) (format nil "~a~a" (print-mods key) (keysym->stumpwm-name (key-keysym key)))) (defun print-key-seq (seq) (format nil (concat *key-seq-color* "*~{~a~^ ~}^n") (mapcar 'print-key seq))) (defun define-key (map key command) "Add a keybinding mapping for the key, @var{key}, to the command, @var{command}, in the specified keymap. If @var{command} is nil, remove an existing binding. For example, @example \(stumpwm:define-key stumpwm:*root-map* (stumpwm:kbd \"C-z\") \"echo Zzzzz...\") @end example Now when you type C-t C-z, you'll see the text ``Zzzzz...'' pop up." (declare (type kmap map) (type (or key (eql t)) key)) (let ((binding (find key (kmap-bindings map) :key 'binding-key :test 'equalp))) (if command (setf (kmap-bindings map) (append (if binding (delete binding (kmap-bindings map)) (kmap-bindings map)) (list (make-binding :key key :command command)))) (setf (kmap-bindings map) (delete binding (kmap-bindings map)))) ;; We need to tell the X server when changing the top-map bindings. (when (eq map *top-map*) (sync-keys)))) ;; Not really needed. Keep it for backward compatibility. (defun undefine-key (map key) "Clear the key binding in the specified keybinding." (define-key map key nil)) (defun lookup-key-sequence (kmap key-seq) "Return the command bound to the key sequenc, KEY-SEQ, in keymap KMAP." (when (kmap-symbol-p kmap) (setf kmap (symbol-value kmap))) (check-type kmap kmap) (let* ((key (car key-seq)) (cmd (lookup-key kmap key))) (cond ((null (cdr key-seq)) cmd) (cmd (if (kmap-or-kmap-symbol-p cmd) (lookup-key-sequence cmd (cdr key-seq)) cmd)) (t nil)))) (defun kmap-symbol-p (x) (and (symbolp x) (boundp x) (kmap-p (symbol-value x)))) (defun kmap-or-kmap-symbol-p (x) (or (kmap-p x) (kmap-symbol-p x))) (defun dereference-kmaps (kmaps) (mapcar (lambda (m) (if (kmap-symbol-p m) (symbol-value m) m)) kmaps)) (defun search-kmap (command keymap &key (test 'equal)) "Search the keymap for the specified binding. Return the key sequences that run binding." (labels ((search-it (cmd kmap key-seq) (when (kmap-symbol-p kmap) (setf kmap (symbol-value kmap))) (check-type kmap kmap) (loop for i in (kmap-bindings kmap) if (funcall test (binding-command i) cmd) collect (cons (binding-key i) key-seq) else if (kmap-or-kmap-symbol-p (binding-command i)) append (search-it cmd (binding-command i) (cons (binding-key i) key-seq))))) (mapcar 'reverse (search-it command keymap nil)))) ;;; The Top Map (defvar *top-map-list* nil) (defun push-top-map (new-top) (push *top-map* *top-map-list*) (setf *top-map* new-top) (sync-keys)) (defun pop-top-map () (when *top-map-list* (setf *top-map* (pop *top-map-list*)) (sync-keys) t)) stumpwm-22.11/load-stumpwm.lisp.in000066400000000000000000000003771433701203600171700ustar00rootroot00000000000000(in-package #:cl-user) #-sbcl (error "This lisp implementation is not supported.") (require 'asdf) (asdf:initialize-source-registry '(:source-registry (:directory "@STUMPWM_ASDF_DIR@") :inherit-configuration)) (asdf:oos 'asdf:load-op 'stumpwm) stumpwm-22.11/main.lisp000066400000000000000000000020101433701203600150400ustar00rootroot00000000000000;; Copyright (C) 2020 Javier Olaechea ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;;; Commentary: ;; ;; This file contains the entry-point for the StumpWM executable. ;; ;;; Code: (in-package #:stumpwm) (export '(main)) (defun main () (let ((argv (uiop:command-line-arguments))) (if (find "--generate-manual" argv :test #'string-equal) (generate-manual) (stumpwm)))) stumpwm-22.11/make-image.lisp.in000066400000000000000000000023471433701203600165330ustar00rootroot00000000000000(in-package #:cl-user) (load "load-stumpwm.lisp") (stumpwm:set-module-dir "@MODULE_DIR@") (when (uiop:version<= "3.1.5" (asdf:asdf-version)) ;; We register StumpWM and its dependencies as immutable, to stop ASDF from ;; looking for their source code when loading modules. (uiop:symbol-call '#:asdf '#:register-immutable-system :stumpwm) (dolist (system-name (uiop:symbol-call '#:asdf '#:system-depends-on (asdf:find-system :stumpwm))) (uiop:symbol-call '#:asdf '#:register-immutable-system system-name))) (sb-ext:save-lisp-and-die "stumpwm" :toplevel (lambda () ;; asdf requires sbcl_home to be set, so set it to the value when the image was built (alexandria:when-let ((home #.(sb-ext:posix-getenv "SBCL_HOME"))) (sb-posix:putenv (format nil "SBCL_HOME=~A" home))) (stumpwm:stumpwm) 0) :executable t :purify t :compression (if (member :sb-core-compression *features*) @COMPRESSION@ nil)) stumpwm-22.11/manual.lisp000066400000000000000000000130211433701203600153750ustar00rootroot00000000000000;; Copyright (C) 2007-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Generate the texinfo manual from docstrings in the source. ;; ;; Code: (in-package #:stumpwm) (require :sb-introspect) (defun generate-function-doc (s line) (ppcre:register-groups-bind (name) ("^@@@ (.*)" line) (let ((fn-name (with-standard-io-syntax (let ((*package* (find-package :stumpwm))) (read-from-string name))))) (if (fboundp fn-name) (let ((fn (fdefinition fn-name)) (*print-pretty* nil)) (format s "@defun {~A} ~{~A~^ ~}~%~A~&@end defun~%~%" name (sb-introspect:function-lambda-list fn) (documentation fn 'function)) t) (warn "Function ~A not found." fn-name))))) (defun generate-macro-doc (s line) (ppcre:register-groups-bind (name) ("^%%% (.*)" line) (let* ((symbol (find-symbol (string-upcase name) :stumpwm)) (*print-pretty* nil)) (format s "@defmac {~a} ~{~a~^ ~}~%~a~&@end defmac~%~%" name (sb-introspect:function-lambda-list (macro-function symbol)) (documentation symbol 'function)) t))) (defun generate-variable-doc (s line) (ppcre:register-groups-bind (name) ("^### (.*)" line) (let ((sym (find-symbol (string-upcase name) :stumpwm))) (format s "@defvar ~a~%~a~&@end defvar~%~%" name (documentation sym 'variable)) t))) (defun generate-hook-doc (s line) (ppcre:register-groups-bind (name) ("^\\$\\$\\$ (.*)" line) (let ((sym (find-symbol (string-upcase name) :stumpwm))) (format s "@defvr {Hook} ~a~%~a~&@end defvr~%~%" name (documentation sym 'variable)) t))) (defun generate-command-doc (s line) (ppcre:register-groups-bind (name) ("^!!! (.*)" line) (if-let (symbol (find-symbol (string-upcase name) :stumpwm)) (let ((cmd (symbol-function symbol)) (*print-pretty* nil)) (format s "@deffn {Command} ~a ~{~a~^ ~}~%~a~&@end deffn~%~%" name (sb-introspect:function-lambda-list cmd) (documentation cmd 'function)) t) (warn "Symbol ~A not found in package STUMPWM" name)))) (defun generate-class-doc (s line) (ppcre:register-groups-bind (name) ("^€€€ (.*)" line) (let ((sym (find-symbol (string-upcase name) :stumpwm))) (if sym (let ((class (find-class sym))) (if class (progn (format s "@deftp {Class} ~A ~{~A~^ ~}~%~ADirect Superclasses: ~{~A~^, ~}@*~&Direct Subclasses: ~{~A~^, ~}@*~&Direct Slots: @*@ @ ~{~{~A~^@ -@ ~}~^@*@ @ ~}@*~&@end deftp~%~%" sym (mapcar #'sb-mop:slot-definition-name (sb-mop:class-direct-slots class)) (let ((doc (documentation class t))) (if doc (concatenate 'string doc "@*") "")) (mapcar #'sb-mop:class-name (sb-mop:class-direct-superclasses class)) (mapcar #'sb-mop:class-name (sb-mop:class-direct-subclasses class)) (mapcar (lambda (slot) (let ((name (sb-mop:slot-definition-name slot)) (docs (documentation slot t))) (if docs (list name docs) (list name)))) (sb-mop:class-direct-slots class))) t) (warn "Symbol ~A does not denote a class" sym))) (warn "Symbol ~A not found in package STUMPWM" sym))))) (defun generate-manual (&key (in #p"stumpwm.texi.in") (out #p"stumpwm.texi")) (let ((*print-case* :downcase)) (with-open-file (os out :direction :output :if-exists :supersede) (with-open-file (is in :direction :input) (loop for line = (read-line is nil is) until (eq line is) do (or (generate-function-doc os line) (generate-macro-doc os line) (generate-hook-doc os line) (generate-variable-doc os line) (generate-command-doc os line) (generate-class-doc os line) (write-line line os))))))) stumpwm-22.11/menu-declarations.lisp000066400000000000000000000154051433701203600175420ustar00rootroot00000000000000;; Copyright (C) 2018 Stuart Dilts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Interface declarations/implementations for interactive menus. See ;; menu-definitions.lisp for implementations of the generic methods ;; declared here. ;; ;; Code: ;;; interactive menu (in-package #:stumpwm) ;; export all of the commands/variables that someone may want to change ;; the key bindings of, and those needed for constructing menus (export '(*menu-map* *single-menu-map* *batch-menu-map* menu-entry menu-entry-display menu-entry-apply menu menu-abort menu-up menu-down menu-scroll-down menu-scroll-up menu-page-down menu-page-up menu-finish menu-backspace)) (defvar *menu-map* nil "The keymap used by the interactive menu.") (defvar *single-menu-map* nil "The keymap used by single selection menus in addition to *menu-map*") (defvar *batch-menu-map* nil "The keymap used by batch-menu menus in addition to *menu-map*") (defvar *menu-maximum-height* 50 "The default maximum amount of entries displayed in a menu.") (defclass menu-entry () ((label :initarg :label :reader menu-entry-label) (icon :initarg :icon :initform #\Space :reader menu-entry-icon :documentation "An additional decorator for the entry") (data :initarg :data :reader menu-entry-data :documentation "Any additional object that is associated with the menu-entry")) (:documentation "Defines a menu entry")) (defgeneric menu-entry-display (menu-entry) (:documentation "Generates a string suitable for displaying in a menu")) (defgeneric menu-entry-apply (menu-entry function) (:documentation "Apply FUNCTION to the data portion of the menu entry.")) (defclass menu () ((table :initarg :table :accessor menu-table :documentation "The list that is displayed in the menu") (selected :initarg :selected :initform 0 :accessor menu-selected :documentation "The index of the selected item") (prompt :initarg :prompt :initform "Search?" :reader menu-prompt) (view-start :initarg :view-start :accessor menu-view-start :initform 0) (view-end :initarg :view-end :accessor menu-view-end :initform 0) (keymap :accessor menu-keymap :initform nil :documentation "Keymap used for navigating the menu." )) (:documentation "Base class for holding the state of a menu")) (defmethod initialize-instance :after ((m menu) &key additional-keymap) (with-accessors ((keymap menu-keymap)) m (setf keymap (if additional-keymap (list additional-keymap *menu-map*) (list *menu-map*))))) (defclass single-menu (menu) ((unfiltered-table :initarg :filtered-table :initform nil :accessor single-menu-unfiltered-table :documentation "Holds the values that have been filtered based on current-input and filter-pred") (filter-pred :initarg :filter-pred :initform (error "You must specify a filter predicate") :accessor single-menu-filter-pred) (current-input :initarg current-input :initform (make-array 10 :element-type 'character :adjustable t :fill-pointer 0) :accessor single-menu-current-input :documentation "The input field for the menu.")) (:documentation "Class used when selecting a single item in a menu. Allows searching through the list.")) (defmethod initialize-instance :after ((menu single-menu) &key initargs) (declare (ignore initargs)) (with-accessors ((unfiltered-table single-menu-unfiltered-table) (table menu-table) (keymap menu-keymap)) menu (unless unfiltered-table (setf unfiltered-table table)) (push *single-menu-map* keymap))) (defclass batch-menu (menu) ((allowed-markers :initarg :allowed-markers :reader batch-menu-allowed-markers :initform nil :documentation "The characters that a user is allowed to mark entries with. If nil, then all chars are allowed")) (:documentation "Class used for marking items in a menu")) (defmethod initialize-instance :after ((m batch-menu) &key initargs) (declare (ignore initargs)) (with-accessors ((table menu-table) (keymap menu-keymap)) m ;; process the table to hold selection values: ;; tables is a list of pairs, with the first val the mark, the second the entry (labels ((process-entry (entry) (cons nil entry))) (setf table (mapcar #'process-entry table))) (push *batch-menu-map* keymap))) (defgeneric menu-up (menu) (:documentation "Move menu cursor up")) (defgeneric menu-down (menu) (:documentation "Move menu cursor down")) (defgeneric menu-scroll-up (menu) (:documentation "Scroll the menu up")) (defgeneric menu-scroll-down (menu) (:documentation "Scroll the menu down")) (defgeneric menu-page-up (menu) (:documentation "Move a whole page down in the menu")) (defgeneric menu-page-down (menu) (:documentation "Move a whole page up in the menu")) (defgeneric menu-finish (menu) (:documentation "What to do when exiting the menu with results. Must signal :menu-quit with the result.")) (defgeneric menu-abort (menu) (:documentation "What to do when exiting the menu without results. Must signal :menu-quit with the result.")) ;; here for single-menu (defgeneric menu-backspace (menu) (:documentation "What occurs when backspace is pressed in a menu")) (defgeneric menu-prompt-line (menu) (:documentation "Returns the prompt-line that should be displayed. If no line is to be displayed, then return nil")) (defgeneric typing-action (menu key-seq) (:documentation "Performs an action based on key-seq when key-seq is not in the appropriate menu-map.")) (defgeneric get-menu-items (menu) (:documentation "Returns the items in the menu that should be displayed.")) stumpwm-22.11/menu-definitions.lisp000066400000000000000000000462361433701203600174130ustar00rootroot00000000000000;; Copyright (C) 2018 Stuart Dilts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Implementation of an interactive menu. This file contains the definitions of the menu ;; class as defined in menu-declarations.lisp. ;; ;; Code: ;;; interactive menu (in-package #:stumpwm) (export '(entries-from-nested-list select-from-menu select-from-batch-menu command-menu)) (defun entries-from-nested-list (lst) (mapcar (lambda (x) (make-instance 'menu-entry :label (car x) :data (cadr x))) lst)) (defmethod menu-entry-display ((entry menu-entry)) (concat (string (menu-entry-icon entry)) " " (menu-entry-label entry))) (defmethod menu-entry-apply ((entry menu-entry) function) (if (slot-boundp entry 'data) (values (apply function (menu-entry-data entry)) t) (values nil nil))) (defmethod print-object ((obj menu-entry) out) (print-unreadable-object (obj out :type t) (format out ":LABEL ~s :ICON ~s :DATA ~a" (menu-entry-label obj) (menu-entry-icon obj) (when (slot-boundp obj 'data) (menu-entry-data obj))))) (defun menu-scrolling-required (menu) (and *menu-maximum-height* (> (length (menu-table menu)) *menu-maximum-height*))) (defun menu-height (menu) (let ((len (length (menu-table menu)))) (min (or *menu-maximum-height* len) len))) (defun bound-check-menu (menu) "Adjust the menu view and selected item based on current view and new selection." (let ((len (length (menu-table menu)))) ;; Wrap around (setf (menu-selected menu) (cond ((< (menu-selected menu) 0) (1- len)) ((>= (menu-selected menu) len) 0) (t (menu-selected menu)))) (setf (values (menu-view-start menu) (menu-view-end menu)) (if (zerop len) (values 0 0) (let* ((menu-height (menu-height menu)) (sel (menu-selected menu)) (start (- sel 1)) (end (+ sel menu-height -1))) (multiple-value-bind (start end) (cond ((< start 0) (values 0 menu-height)) ((> end len) (values (- len menu-height) len)) (t (values start end))) (assert (<= 0 start (- len menu-height)) (start)) (assert (<= menu-height end len) (end)) (values start end))))))) (defmethod menu-up ((menu menu)) (decf (menu-selected menu)) (bound-check-menu menu)) ;; before or after? probably doesn't matter (defmethod menu-up :before ((menu single-menu)) "clear the search string if the cursor is moved" (setf (fill-pointer (single-menu-current-input menu)) 0)) (defmethod menu-down ((menu menu)) (incf (menu-selected menu)) (bound-check-menu menu)) (defmethod menu-down :before ((menu single-menu)) "clear the search string if the cursor is moved" (setf (fill-pointer (single-menu-current-input menu)) 0)) (defmethod menu-scroll-up ((menu menu)) (decf (menu-selected menu) *menu-scrolling-step*) (bound-check-menu menu)) (defmethod menu-scroll-up :before ((menu single-menu)) "clear the search string if the cursor is moved" (setf (fill-pointer (single-menu-current-input menu)) 0)) (defmethod menu-scroll-down ((menu menu)) (incf (menu-selected menu) *menu-scrolling-step*) (bound-check-menu menu)) (defmethod menu-scroll-down :before ((menu single-menu)) "clear the search string if the cursor is moved" (setf (fill-pointer (single-menu-current-input menu)) 0)) (defmethod menu-page-up ((menu menu)) (when *menu-maximum-height* ;;No scrolling = no page up/down (decf (menu-selected menu) *menu-maximum-height*) (let ((*menu-scrolling-step* *menu-maximum-height*)) (bound-check-menu menu)))) (defmethod menu-page-up :before ((menu single-menu)) (when *menu-maximum-height* ;;No scrolling = no page up/down (setf (fill-pointer (single-menu-current-input menu)) 0))) (defmethod menu-page-down ((menu menu)) (when *menu-maximum-height* (incf (menu-selected menu) *menu-maximum-height*) (let ((*menu-scrolling-step* *menu-maximum-height*)) (bound-check-menu menu)))) (defmethod menu-page-down :before ((menu single-menu)) (when *menu-maximum-height* (setf (fill-pointer (single-menu-current-input menu)) 0))) (defmethod menu-finish ((menu menu)) (throw :menu-quit (nth (menu-selected menu) (menu-table menu)))) (defmethod menu-finish ((menu batch-menu)) "Value returned with the signal is an alist, where the cdr of the value returned by assoc is a list items that were marked with that character. Example when entry1 and entry2 are marked with 'a', and entry3 is not marked: ((a entry1 entry2) (NIL entry3))" (with-slots (allowed-markers table) menu (let ((alist (list))) (dolist (entry table) (let ((mark (car entry)) (value (cdr entry))) (if-let ((cell (assoc mark alist))) (push value (cdr cell)) (setf alist (acons mark (list value) alist))))) (throw :menu-quit alist)))) (defmethod menu-abort (menu) (declare (ignore menu)) (throw :menu-quit nil)) (defun get-input-char (key) "If @var{key} is a character suitable for menu completion (e.g. not backspace or F9), return it otherwise return nil" (let ((char (xlib:keysym->character *display* (key-keysym key)))) (if (or (key-mods-p key) (null char) (not (characterp char))) nil char))) ;; menu-backspace might be in someone's custom *menu-map*: ;; leave this here just to be safe: (defmethod menu-backspace ((menu menu)) (declare (ignore menu)) "By default, do nothing") (defun batch-menu-unmark-selected (menu) (with-accessors ((table menu-table) (selected menu-selected)) menu (setf (car (nth selected table)) nil))) (defmethod menu-backspace ((menu batch-menu)) "If the cursor is not at the top, move cursor up. Regardless, unmark the entry at the selected point." (when (> (menu-selected menu) 0) (menu-up menu)) (batch-menu-unmark-selected menu)) (defmethod menu-backspace ((menu single-menu)) (when (> (fill-pointer (single-menu-current-input menu)) 0) (vector-pop (single-menu-current-input menu)) (typing-action menu nil))) (defmethod menu-prompt-line ((menu menu)) "If there is a prompt, show it:" (menu-prompt menu)) (defun menu-prompt-visible (menu) (or (menu-prompt menu) (> (length (single-menu-current-input menu)) 0))) (defmethod menu-prompt-line ((menu single-menu)) "When a prompt is shown, also show the search string." (when (menu-prompt-visible menu) (format nil "~@[~A ~]~A" (menu-prompt menu) (single-menu-current-input menu)))) (defmethod typing-action ((menu menu) key-seq) "Default action is to do nothing" (declare (ignore key-seq))) (defmethod typing-action ((menu single-menu) key-seq) "If the user entered a key not mapped in @var{*menu-map}, check it. If he's trying to type an entry's name, either complete or not based on COMPLETE-PARTIAL. Match is case insensitive. If @var{key-seq} is nil, some other function has manipulated the current-input and is requesting a re-computation of the match." (let ((input-char (and key-seq (get-input-char key-seq)))) (when input-char (vector-push-extend input-char (single-menu-current-input menu))) (handler-case (when (or input-char (not key-seq)) (labels ((match-p (table-item) (funcall (single-menu-filter-pred menu) (car table-item) (second table-item) (single-menu-current-input menu)))) (setf (menu-table menu) (remove-if-not #'match-p (single-menu-unfiltered-table menu)) (menu-selected menu) 0) (bound-check-menu menu))) (cl-ppcre:ppcre-syntax-error ())))) (defmethod typing-action ((menu batch-menu) key-seq) "Mark the selected item with the character that was typed. If the character is not allowed, as specified by allowed-markers, item is not marked" (let ((input-char (and key-seq (get-input-char key-seq)))) (with-slots (selected table allowed-markers) menu (when (and input-char (or (not allowed-markers) (member input-char allowed-markers))) (setf (car (nth selected table)) input-char) (menu-down menu))))) (defun menu-element-name (element) "Used for the default menus: they don't use menu-entry." (if (listp element) (first element) element)) (defmethod get-menu-items ((menu menu)) (mapcar #'menu-element-name (subseq (menu-table menu) (menu-view-start menu) (menu-view-end menu)))) (defmethod get-menu-items ((menu batch-menu)) (with-slots (table view-start view-end) menu (mapcar (lambda (entry) (if (car entry) ;; if there is a mark, show it, else show a space (concat (string (car entry)) (menu-entry-display (cdr entry))) (concat " " (menu-entry-display (cdr entry))))) (subseq table view-start view-end)))) (defun menu-item-matches-regexp (item-string item-object user-input) "The default filter predicate for SELECT-FROM-MENU. When using this predicate, an item is visible when it matches all of the regular expressions in USER-INPUT (multiple regexps are separated by one or more spaces; ARGUMENT-POP is used to split the string)." (declare (ignore item-object)) (match-all-regexps user-input item-string)) (defun run-menu (screen menu) "Runs the menu. Implement all of the methods in the menu, then pass an instance to this function" (declare (type menu menu)) ;; align the menu, make the pages (bound-check-menu menu) (catch :menu-quit (unwind-protect (with-focus (screen-key-window screen) (let ((*suppress-echo-timeout* t) (displaying-help-bindings nil)) (loop (let* ((sel (menu-selected menu)) (start (menu-view-start menu)) (end (menu-view-end menu)) (len (length (menu-table menu))) (prompt-line (menu-prompt-line menu)) (strings (get-menu-items menu)) (highlight (- sel start))) (unless displaying-help-bindings (unless (zerop start) (setf strings (cons "..." strings)) (incf highlight)) (unless (= len end) (setf strings (nconc strings '("...")))) (when prompt-line (push prompt-line strings) (incf highlight)) (run-hook-with-args *menu-selection-hook* menu) (echo-string-list screen strings highlight))) (multiple-value-bind (action key-seq) (read-from-keymap (menu-keymap menu)) (cond ((and action (not (or (fboundp action) (functionp action))) (help-key-p key-seq)) (setf displaying-help-bindings t)) ((and displaying-help-bindings (eql action 'menu-abort)) (setf displaying-help-bindings nil)) (t (when displaying-help-bindings (setf displaying-help-bindings nil)) (if (fboundp action) (progn (funcall action menu) (bound-check-menu menu)) (typing-action menu (first key-seq))))))))) (unmap-all-message-windows)))) (defun select-from-menu (screen table &optional (prompt "Search:") (initial-selection 0) extra-keymap (filter-pred #'menu-item-matches-regexp)) "Prompt the user to select from a menu on SCREEN. TABLE can be a list of values or a nested list. If it's a nested list, the first element in the sublist is displayed in the menu. What is displayed as menu items must be strings. EXTRA-KEYMAP can be a keymap whose bindings will take precedence over the default bindings. FILTER-PRED should be a a function returning T when a certain menu item should be visible to the user. It should accept arguments ITEM-STRING (the string shown to the user), ITEM-OBJECT (the object corresponding to the menu item), and USER-INPUT (the current user input). The default is MENU-ITEM-MATCHES-REGEXP. Returns the selected element in TABLE or nil if aborted. " (check-type screen screen) (check-type table (or (cons string) (cons cons))) (check-type prompt (or null string)) (check-type initial-selection integer) (when table (let ((menu (make-instance 'single-menu :table (if (every #'listp table) table (mapcar #'list table)) :selected initial-selection :prompt prompt :view-start 0 :view-end 0 :additional-keymap extra-keymap :FILTER-PRED filter-pred))) (run-menu screen menu)))) (defun select-from-batch-menu (screen table &key (prompt "Select:") allowed-markers (initial-selection 0) extra-keymap) "Prompt the user with a menu that allows them to mark each item with a character. They can exit the menu by pressing enter, or whatever key is mapped to 'menu-finish' in *menu-map*. Value returned is an alist, where the cdr of each entry is a list of items that were marked with that character. Note that the lisp printer cannot distinguish between '(a . (b c d)) and '(a b c d). Example when \"foo\" and \"bar\" are marked with '#\d', and \"baz\" is not marked: ((#\d \"foo\" \"bar\") (NIL \"baz\")) ALLOWED-MARKERS is a list of characters. If this parameter is specified, no other markers are allowed. EXTRA-KEYMAP can be a keymap whose bindings will take precedence over the default bindings." (check-type screen screen) (check-type table list) (check-type prompt (or null string)) (check-type allowed-markers list) (when table (let ((menu (make-instance 'batch-menu :table table :prompt prompt :allowed-markers allowed-markers :selected initial-selection :additional-keymap extra-keymap))) (run-menu screen menu)))) (defun command-menu (screen items command-list &key (prompt "Select:") (initial-selection 0) extra-keymap) "Use batch-menu to make selections and run commands specified in command-list. SCREEN: The screen to display the menu on. ITEMS: The items to be shown in the list. This is expected to be a list of @code{menu-item}s. COMMAND-LIST: A list of entries defining the commands associated with each mark. Only marks that are defined are allowed in the menu. The format for these entries is (mark-character function calling-options). Available calling-options: :single (Default) Each value is passed separately to the supplied function. :all all values selected with this mark are passed to the function in a list. Example: '((#\d 'delete-window) (#\m 'move-multiple-windows :all))" (let ((results (select-from-batch-menu screen items :prompt prompt ;; use the first value of every entry ;; except when it is nill: :allowed-markers (mapcan (lambda (x) (if (first x) (list (first x)))) command-list) :initial-selection initial-selection :extra-keymap extra-keymap))) (dolist (command-entry command-list) (let ((selections (assoc (first command-entry) results)) (func (second command-entry)) ;; change this to cddr if we ever have more than one option? (options (caddr command-entry))) (when selections (cond ((eql :all options) (funcall func (mapcar 'menu-entry-data (cdr selections)))) ;; default option: check if it is nil: ((or (eql options :all) (eql options nil)) (dolist (data (cdr selections)) (funcall func (menu-entry-data data)))) (t (error (format nil "keyword ~s not a valid command option for selection-menu." options))))))))) (when (null *menu-map*) (setf *menu-map* (let ((m (make-sparse-keymap))) (define-key m (kbd "C-p") 'menu-up) (define-key m (kbd "Up") 'menu-up) (define-key m (kbd "S-Up") 'menu-scroll-up) (define-key m (kbd "SunPageUp") 'menu-page-up) (define-key m (kbd "C-n") 'menu-down) (define-key m (kbd "Down") 'menu-down) (define-key m (kbd "S-Down") 'menu-scroll-down) (define-key m (kbd "SunPageDown") 'menu-page-down) (define-key m (kbd "C-g") 'menu-abort) (define-key m (kbd "ESC") 'menu-abort) (define-key m (kbd "RET") 'menu-finish) m))) (when (null *single-menu-map*) (setf *single-menu-map* (let ((m (make-sparse-keymap))) (define-key m (kbd "DEL") 'menu-backspace) m))) (when (null *batch-menu-map*) (setf *batch-menu-map* (let ((m (make-sparse-keymap))) (define-key m (kbd "DEL") 'menu-backspace) (define-key m (kbd "n") 'menu-down) (define-key m (kbd "p") 'menu-up) (define-key m (kbd "space") 'menu-down) (define-key m (kbd "u") (lambda (menu) (batch-menu-unmark-selected menu) (menu-down menu))) (define-key m (kbd "x") 'menu-finish) m))) stumpwm-22.11/message-window.lisp000066400000000000000000000370031433701203600170570ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; message printing functions ;; ;; Code: (in-package #:stumpwm) (export '(echo-string err message gravity-coords with-message-queuing *queue-messages-p*)) (defgeneric gravity-coords (gravity width height minx miny maxx maxy) (:documentation "Get the X and Y coordinates to place something of width WIDTH and height HEIGHT within an area defined by MINX MINY MAXX and MAXY, guided by GRAVITY.")) (defmacro define-simple-gravity (name x y) "Define a simple gravity calculation of name NAME, where X and Y are one of :MIN, :MAX or :CENTER." `(defmethod gravity-coords ((gravity (eql ,name)) (width number) (height number) (minx number) (miny number) (maxx number) (maxy number)) (declare (ignorable gravity width height minx miny maxx maxy)) (values ,(ecase x (:min 'minx) (:max '(- maxx width)) (:center '(+ minx (truncate (- maxx minx width) 2)))) ,(ecase y (:min 'miny) (:max '(- maxy height)) (:center '(+ miny (truncate (- maxy miny height) 2))))))) (define-simple-gravity :top-right :max :min) (define-simple-gravity :top-left :min :min) (define-simple-gravity :bottom-right :max :max) (define-simple-gravity :bottom-left :min :max) (define-simple-gravity :right :max :center) (define-simple-gravity :left :min :center) (define-simple-gravity :top :center :min) (define-simple-gravity :bottom :center :max) (define-simple-gravity :center :center :center) (defun message-window-real-gravity (screen) "Returns the gravity that should be used when displaying the message window, taking into account *message-window-gravity* and *message-window-input-gravity*." (if (eq (xlib:window-map-state (screen-input-window screen)) :unmapped) *message-window-gravity* *message-window-input-gravity*)) (defun setup-win-gravity (screen win gravity) "Position the x, y of the window according to its gravity. This function expects to be wrapped in a with-state for win." (xlib:with-state ((screen-root screen)) (let* ((w (+ (xlib:drawable-width win) (* (xlib:drawable-border-width win) 2))) (h (+ (xlib:drawable-height win) (* (xlib:drawable-border-width win) 2))) (head-x (head-x (current-head))) (head-y (head-y (current-head))) (head-maxx (+ head-x (head-width (current-head)))) (head-maxy (+ head-y (head-height (current-head))))) (multiple-value-bind (x y) (gravity-coords gravity w h head-x head-y head-maxx head-maxy) (setf (xlib:drawable-y win) (max head-y y) (xlib:drawable-x win) (max head-x x)))))) (defun setup-message-window (screen width height) (let ((win (screen-message-window screen))) ;; Now that we know the dimensions, raise and resize it. (xlib:with-state (win) (setf (xlib:drawable-height win) (+ height (* *message-window-y-padding* 2)) (xlib:drawable-width win) (+ width (* *message-window-padding* 2)) (xlib:window-priority win) :above) (setup-win-gravity screen win (message-window-real-gravity screen))) (xlib:map-window win) (incf (screen-ignore-msg-expose screen)) ;; Have to flush this or the window might get cleared ;; after we've already started drawing it. (xlib:display-finish-output *display*))) (defun unmap-message-window (screen) "Unmap the screen's message window, if it is mapped." (unless (eq (xlib:window-map-state (screen-message-window screen)) :unmapped) (xlib:unmap-window (screen-message-window screen)))) (defun unmap-all-message-windows () (mapc #'unmap-message-window *screen-list*) (when (timer-p *message-window-timer*) (cancel-timer *message-window-timer*) (setf *message-window-timer* nil))) (defun unmap-frame-indicator-window (screen) "Unmap the screen's message window, if it is mapped." ;; (unless (eq (xlib:window-map-state (screen-frame-window screen)) :unmapped) (xlib:unmap-window (screen-frame-window screen))) (defun unmap-all-frame-indicator-windows () (mapc #'unmap-frame-indicator-window *screen-list*) (when (timer-p *frame-indicator-timer*) (cancel-timer *frame-indicator-timer*) (setf *frame-indicator-timer* nil))) (defun reset-message-window-timer (timeout-wait) "Set the message window timer to timeout in timeout-wait seconds." (unless *ignore-echo-timeout* (when (timer-p *message-window-timer*) (cancel-timer *message-window-timer*)) (setf *message-window-timer* (run-with-timer timeout-wait nil 'unmap-all-message-windows)))) (defun reset-frame-indicator-timer () "Set the message window timer to timeout in *timeout-frame-indicator-wait* seconds." (when (timer-p *frame-indicator-timer*) (cancel-timer *frame-indicator-timer*)) (setf *frame-indicator-timer* (run-with-timer *timeout-frame-indicator-wait* nil 'unmap-all-frame-indicator-windows))) (defun show-frame-outline (group &optional (clear t)) ;; Don't draw if this isn't a current group! (when (find group (mapcar 'screen-current-group *screen-list*)) (dformat 5 "show-frame-outline!~%") ;; *resize-hides-windows* uses the frame outlines for display, ;; so try not to interfere. (unless (eq *top-map* *resize-map*) (when clear (clear-frame-outlines group)) (let ((frame (tile-group-current-frame group))) (unless (and (= 1 (length (tile-group-frame-tree group))) (atom (first (tile-group-frame-tree group)))) ;; draw the outline (unless (frame-window frame) (draw-frame-outline group frame t t))))))) (defun redraw-frame-outline (group) (show-frame-outline group t)) (defun show-frame-indicator (group &optional force) (show-frame-outline group) ;; FIXME: Arg, these tests are already done in show-frame-outline (when (find group (mapcar 'screen-current-group *screen-list*)) (when (or force (and (or (> (length (tile-group-frame-tree group)) 1) (not (atom (first (tile-group-frame-tree group))))) (not *suppress-frame-indicator*))) (let ((frame (tile-group-current-frame group)) (w (screen-frame-window (current-screen))) (string (if (stringp *frame-indicator-text*) *frame-indicator-text* (prin1-to-string *frame-indicator-text*))) (font (screen-font (current-screen)))) ;; If it's already mapped it'll appear briefly in the wrong ;; place, so unmap it first. (xlib:unmap-window w) (xlib:with-state (w) (setf (xlib:drawable-x w) (+ (frame-display-x group frame) (truncate (- (frame-width frame) (text-line-width font string)) 2)) (xlib:drawable-y w) (+ (frame-display-y group frame) (truncate (- (frame-height frame) (font-height font)) 2)) (xlib:window-priority w) :above)) (xlib:map-window w) (echo-in-window w font (screen-fg-color (current-screen)) (screen-bg-color (current-screen)) string) (reset-frame-indicator-timer))))) (defun redraw-frame-indicator (group) (when (and (timer-p *frame-indicator-timer*) (find group (mapcar 'screen-current-group *screen-list*))) (let ((frame (tile-group-current-frame group)) (w (screen-frame-window (current-screen))) (string (if (stringp *frame-indicator-text*) *frame-indicator-text* (prin1-to-string *frame-indicator-text*))) (font (screen-font (current-screen)))) (xlib:with-state (w) (setf (xlib:drawable-x w) (+ (frame-display-x group frame) (truncate (- (frame-width frame) (text-line-width font string)) 2)) (xlib:drawable-y w) (+ (frame-display-y group frame) (truncate (- (frame-height frame) (font-height font)) 2)) (xlib:window-priority w) :above)) (xlib:map-window w) (echo-in-window w font (screen-fg-color (current-screen)) (screen-bg-color (current-screen)) string)))) (defun echo-in-window (win font fg bg string) (let* ((height (font-height font)) (gcontext (xlib:create-gcontext :drawable win :font (when (typep font 'xlib:font) font) :foreground fg :background bg)) (width (text-line-width font string))) (xlib:with-state (win) (setf (xlib:drawable-height win) height (xlib:drawable-width win) width)) (xlib:clear-area win) (xlib:display-finish-output *display*) (draw-image-glyphs win gcontext font 0 (font-ascent font) string :translate #'translate-id :size 16))) (defun push-last-message (screen strings highlights) ;; only push unique messages (unless *record-last-msg-override* (push strings (screen-last-msg screen)) (push highlights (screen-last-msg-highlights screen)) ;; crop for size (when (>= (length (screen-last-msg screen)) *max-last-message-size*) (setf (screen-last-msg screen) (butlast (screen-last-msg screen))) (setf (screen-last-msg-highlights screen) (butlast (screen-last-msg-highlights screen)))))) (defun redraw-current-message (screen) (let ((*record-last-msg-override* t) (*ignore-echo-timeout* t)) (dformat 5 "Redrawing message window!~%") (apply 'echo-string-list screen (screen-current-msg screen) (screen-current-msg-highlights screen)))) (defun echo-nth-last-message (screen n) (let ((*record-last-msg-override* t)) (apply 'echo-string-list screen (nth n (screen-last-msg screen)) (nth n (screen-last-msg-highlights screen))))) (defvar *queue-messages-p* nil "When non-nil, ECHO-STRING-LIST will retain old messages in addition to new ones. When the value is :new-on-bottom, new messages are added to the bottom as in a log file. See also WITH-MESSAGE-QUEUING.") (defmacro with-message-queuing (new-on-bottom-p &body body) "Queue all messages sent by (MESSAGE ...), (ECHO-STRING ...), (ECHO-STRING-LIST ...) forms within BODY without clobbering earlier messages. When NEW-ON-BOTTOM-P is non-nil, new messages are queued at the bottom." `(progn ;; clear current messages if not already queueing (unless *queue-messages-p* (setf (screen-current-msg (current-screen)) nil (screen-current-msg-highlights (current-screen)) nil)) (let ((*queue-messages-p* ,(if new-on-bottom-p :new-on-bottom t))) ,@body))) (defun combine-new-old-messages (new new-highlights old old-highlights &key new-on-bottom-p) "combine NEW and OLD messages and their highlights according to NEW-ON-TOP-P" (let (top top-highlights bot bot-highlights) (if new-on-bottom-p ;; new messages added to the bottom, like a log file (setf top old top-highlights old-highlights bot new bot-highlights new-highlights) ;; new messages at the top (setf bot old bot-highlights old-highlights top new top-highlights new-highlights)) (values (append top bot) (append top-highlights (loop for idx in bot-highlights with offset = (length top) collect (+ idx offset)))))) (defun echo-string-list (screen strings &rest highlights) "Draw each string in l in the screen's message window. HIGHLIGHT is the nth entry to highlight." (when strings (when *queue-messages-p* (multiple-value-bind (combined-strings combined-highlights) (combine-new-old-messages strings highlights (screen-current-msg screen) (screen-current-msg-highlights screen) :new-on-bottom-p (eq *queue-messages-p* :new-on-bottom)) (setf strings combined-strings highlights combined-highlights))) (unless *executing-stumpwm-command* (multiple-value-bind (width height) (rendered-size strings (screen-message-cc screen)) (setup-message-window screen width height) (render-strings (screen-message-cc screen) *message-window-padding* *message-window-y-padding* strings highlights)) (setf (screen-current-msg screen) strings (screen-current-msg-highlights screen) highlights) ;; Set a timer to hide the message after a number of seconds (if *suppress-echo-timeout* ;; any left over timers need to be canceled. (when (timer-p *message-window-timer*) (cancel-timer *message-window-timer*) (setf *message-window-timer* nil)) (reset-message-window-timer (if (> (length strings) 1) (or *timeout-wait-multiline* *timeout-wait*) *timeout-wait*)))) (push-last-message screen strings highlights) (xlib:display-finish-output *display*) (dformat 5 "Outputting a message:~%~{ ~a~%~}" strings) (apply 'run-hook-with-args *message-hook* strings))) (defun echo-string (screen msg) "Display @var{string} in the message bar on @var{screen}. You almost always want to use @command{message}." (echo-string-list screen (split-string msg (string #\Newline)))) (defun message (fmt &rest args) "run FMT and ARGS through `format' and echo the result to the current screen." (echo-string (current-screen) (apply 'format nil fmt args))) (defun err (fmt &rest args) "run FMT and ARGS through format and echo the result to the current screen along with a backtrace. For careful study, the message does not time out." (let ((*suppress-echo-timeout* t)) (echo-string (current-screen) (concat (apply 'format nil fmt args) (backtrace-string))))) (defun message-no-timeout (fmt &rest args) "Like message, but the window doesn't disappear after a few seconds." (let ((*suppress-echo-timeout* t)) (apply 'message fmt args))) ;;; Commands (defvar *lastmsg-nth* nil) (defcommand lastmsg () () "Display the last message. If the previous command was lastmsg, then continue cycling back through the message history." (if (string= *last-command* "lastmsg") (progn (incf *lastmsg-nth*) (if (>= *lastmsg-nth* (length (screen-last-msg (current-screen)))) (setf *lastmsg-nth* 0))) (setf *lastmsg-nth* 0)) (if (screen-last-msg (current-screen)) (echo-nth-last-message (current-screen) *lastmsg-nth*) (message "No last message."))) stumpwm-22.11/minor-modes.lisp000066400000000000000000001372311433701203600163630ustar00rootroot00000000000000;;;; MINOR MODES ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;;; Commentary: ;; This file implements minor modes for StumpWM. Minor modes are implemented as ;; mixins which get added to a scope object to allow overriding methods which ;; are called upon that object. Minor modes are defined with the macro ;; DEFINE-MINOR-MODE, and new scopes can be defined by ;; DEFINE-MINOR-MODE-SCOPE. All scope objects must be instances of classes, as ;; the MOP is used to implement minor modes and add them to scope objects. ;;; Code: (in-package :stumpwm) (export '(minor-mode define-minor-mode add-minor-mode-scope define-minor-mode-scope define-descended-minor-mode-scope sync-all-minor-modes validate-superscope validate-scope *minor-mode* *minor-mode-enable-hook* *minor-mode-disable-hook* *unscoped-minor-modes* minor-mode-scope minor-mode-global-p enable-minor-mode disable-minor-mode autoenable-minor-mode autodisable-minor-mode minor-mode-keymap minor-mode-lighter list-modes list-minor-modes list-current-mode-objects list-mode-objects enabled-minor-modes current-minor-modes minor-mode-enabled-p find-minor-mode generate-keymap)) (defvar *minor-mode*) (setf (documentation '*minor-mode* 'variable) "A dynamic variable bound to the minor mode object when executing a minor mode command.") ;;; General Hooks (defvar *minor-mode-enable-hook* () "A hook run whenever a minor mode is enabled. Functions are called with the minor mode symbol and the object they have been added to. This is run when a minor mode is explicitly enabled via enable-minor-mode.") (defvar *minor-mode-disable-hook* () "A hook run whenever a minor mode is disabled. Functions are called with the minor mode symbol and the scope object. This is run when a minor mode is explicitly disabled via disable-minor-mode. This is run AFTER the minor mode has been disabled, and is called with the minor mode and the first object it was disabled in.") ;;; Classes and Global Modes (defclass unscoped-modes () ()) (defclass minor-mode () () (:documentation "The root minor mode class. All minor modes are subclasses of this class.")) (defvar *unscoped-minor-modes* (make-instance 'unscoped-modes) "A dynamic variable holding all unscoped minor modes as mixed into the same object.") (defvar *active-global-minor-modes* () "A list of all currently active global minor modes.") ;;; Sync Keys (defun minor-mode-sync-keys-hook-function (&rest rest) (declare (ignore rest)) (sync-keys)) (add-hook *focus-frame-hook* 'minor-mode-sync-keys-hook-function) (add-hook *focus-window-hook* 'minor-mode-sync-keys-hook-function) (add-hook *focus-group-hook* 'minor-mode-sync-keys-hook-function) ;;; Conditions (define-condition minor-mode-error (error) ()) (define-condition minor-mode-hook-error (minor-mode-error) ((mode :initarg :mode :reader minor-mode-hook-error-mode) (hook :initarg :hook :reader minor-mode-hook-error-hook)) (:report (lambda (c s) (format s "There is no hook of type ~A for minor mode ~A" (minor-mode-hook-error-hook c) (minor-mode-hook-error-mode c))))) (define-condition minor-mode-e/d-error (minor-mode-error) ((mode :initarg :mode :reader minor-mode-e/d-error-mode) (object :initarg :object :reader minor-mode-e/d-error-object) (reason :initarg :reason :reader minor-mode-e/d-error-reason)) (:report (lambda (c s) (format s "Error encountered when enabling or disabling minor mode ~A in object ~A.~%Reason: ~A" (minor-mode-e/d-error-mode c) (minor-mode-e/d-error-object c) (minor-mode-e/d-error-reason c))))) (define-condition minor-mode-autoenable-error (minor-mode-e/d-error) () (:report (lambda (c s) (format s "Unable to enable minor mode ~A in object ~A.~%Reason: ~A" (minor-mode-e/d-error-mode c) (minor-mode-e/d-error-object c) (minor-mode-e/d-error-reason c))))) (define-condition minor-mode-enable-error (minor-mode-autoenable-error) ()) (define-condition minor-mode-autodisable-error (minor-mode-e/d-error) () (:report (lambda (c s) (format s "Unable to disable minor mode ~A in object ~A.~%Reason: ~A" (minor-mode-e/d-error-mode c) (minor-mode-e/d-error-object c) (minor-mode-e/d-error-reason c))))) (define-condition minor-mode-disable-error (minor-mode-autodisable-error) ()) ;;; Minor Mode Protocol (defgeneric minor-mode-global-p (minor-mode-symbol) (:documentation "Return T when MINOR-MODE-SYMBOL denotes a global minor mode") (:method (mode) (declare (ignore mode)) nil)) (defgeneric minor-mode-scope (minor-mode-symbol) (:documentation "Return as a keyword the scope of the minor mode")) (defgeneric minor-mode-keymap (minor-mode) (:method (minor-mode) nil) (:documentation "Return the top map for the minor mode")) (defgeneric minor-mode-lighter (mode) (:method (minor-mode) nil) (:documentation "Return a string of minor mode lighters.")) (defgeneric lighter-on-click (minor-mode-symbol) (:method (minor-mode) nil) (:documentation "Return the on-click function defined for MINOR-MODE-SYMBOL")) (defgeneric minor-mode-enable-hook (minor-mode-symbol) (:documentation "Returns the minor mode enable hook for a given minor mode symbol. This hook is run whenever the minor mode is enabled via autoenable.")) (defgeneric minor-mode-disable-hook (minor-mode-symbol) (:documentation "Returns the minor mode disable hook for a given minor mode symbol. This hook is run whenever the minor mode is disabled via autodisable.")) (defgeneric minor-mode-hook (minor-mode-symbol) (:documentation "Returns the minor mode hook for a given minor mode symbol. This hook is run whenever the minor mode is explicitly enabled.")) (defgeneric minor-mode-destroy-hook (minor-mode-symbol) (:documentation "Returns the minor mode hook for a given minor mode symbol. This hook is run whenever the minor mode is explicitly disabled.")) (macrolet ((def-hook-error (function) `(defmethod no-applicable-method ((f (eql #',function)) &rest rest) (declare (ignore f)) (restart-case (error 'minor-mode-hook-error :mode (car rest) :hook ',function) (use-hook (hook) :report "Provide a hook to run" :interactive (lambda () (list (eval (read *query-io*)))) hook) (continue () :report "Run no hooks and continue" nil))))) (def-hook-error minor-mode-enable-hook) (def-hook-error minor-mode-disable-hook) (def-hook-error minor-mode-hook) (def-hook-error minor-mode-destroy-hook)) (defun run-hook-for-minor-mode (hook minor-mode object &optional invert-order) "Run a specific minor mode hook for the minor mode and all of its superclasses which have such a hook defined. HOOK must be a function which takes a symbol and returns a list of functions. MINOR-MODE is a symbol to be passed to HOOK. OBJECT is the minor mode object to pass to the hook functions. When INVERT-ORDER is T the superclass hooks are run first." (labels ((run (mode) (let ((name (class-name mode)) (supers (sb-mop:class-direct-superclasses mode))) (when invert-order (run-hook-with-args (funcall hook name) name object)) (when supers (mapc #'run supers)) (unless invert-order (run-hook-with-args (funcall hook name) name object))))) (run (find-class minor-mode)))) (defgeneric autoenable-minor-mode (mode object) (:documentation "The core of enabling minor modes within an object. Mixes the minor mode in to the object")) (defmethod no-applicable-method ((f (eql #'autoenable-minor-mode)) &rest rest) (declare (ignore f)) (restart-case (signal 'minor-mode-autoenable-error :mode (car rest) :object (cadr rest) :reason 'no-applicable-method) (continue () nil))) (defgeneric autodisable-minor-mode (mode object) (:documentation "The core of disabling minor modes within an object. Calls the minor modes on-disable function.")) (defmethod no-applicable-method ((f (eql #'autodisable-minor-mode)) &rest rest) (declare (ignore f)) (restart-case (signal 'minor-mode-autodisable-error :mode (car rest) :object (cadr rest) :reason 'no-applicable-method) (continue () nil))) (defgeneric enable-when (mode object) (:documentation "Define methods for this generic function to control when the minor mode should be enabled.") (:method (mode object) (declare (ignore mode object)) nil)) (defun relevant-objects-for-minor-mode (mode &optional default) "Find the relevant objects for MODE. If MODE is not global and DEFAULT is non-nil, then DEFAULT is used in place of the current object." (let ((scope (minor-mode-scope mode))) (cond ((minor-mode-global-p mode) (let ((objs (funcall (scope-all-objects-function scope)))) (if (or (null default) (member default objs)) objs (cons default objs)))) (t (list (or default (funcall (scope-current-object-function scope)))))))) (defun disable-minor-mode (minor-mode &optional scope-object) "Disable MINOR-MODE in the relevant objects." (when (minor-mode-global-p minor-mode) (setf *active-global-minor-modes* (remove minor-mode *active-global-minor-modes*))) (handler-bind ((minor-mode-hook-error (lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (let ((run-destroy-hook nil)) (flet ((disable (object) (when (typep object minor-mode) (unless run-destroy-hook (setf run-destroy-hook object) (run-hook-for-minor-mode #'minor-mode-destroy-hook minor-mode object t)) (autodisable-minor-mode minor-mode object)))) (map nil #'disable (relevant-objects-for-minor-mode minor-mode scope-object))) (run-hook-with-args *minor-mode-disable-hook* minor-mode run-destroy-hook))) (minor-mode-sync-keys-hook-function)) (defun enable-minor-mode (minor-mode &optional scope-object) "Enable MINOR-MODE. If MINOR-MODE is global, then enable it in all relevant objects. Otherwise enable it in the current object. If SCOPE-OBJECT is provided, use SCOPE-OBJECT instead of the current object, or include it in the list of current objects if MINOR-MODE is global" (when (minor-mode-global-p minor-mode) (pushnew minor-mode *active-global-minor-modes*)) (handler-bind ((minor-mode-hook-error (lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (let ((run-hook nil)) (flet ((enable (object) (cond ((typep object minor-mode) (restart-case (error 'minor-mode-enable-error :mode minor-mode :object object :reason 'already-enabled) (continue () nil))) ((autoenable-minor-mode minor-mode object) (unless run-hook (setf run-hook object)))))) (map nil #'enable (relevant-objects-for-minor-mode minor-mode scope-object)) (when run-hook (run-hook-for-minor-mode #'minor-mode-hook minor-mode run-hook) (run-hook-with-args *minor-mode-enable-hook* minor-mode run-hook))))) (minor-mode-sync-keys-hook-function)) ;;; Find Minor Modes (defun sync-minor-modes (object) "Sync the globally active minor modes in the object" (loop for class in *active-global-minor-modes* when (and (not (typep object class)) ; Dont autoenable if already enabled (typep object (scope-type (minor-mode-scope class)))) do (autoenable-minor-mode class object))) (defun sync-all-minor-modes () "Loop through all recently created objects and ensure that the appropriate minor modes are enabled in them, then nullify the list of objects." ;; This functions is needed because calling autoenable-minor-mode from within ;; a method that accesses slots is implied to be undefined behavior, so we ;; cant do this from within initialize-instance. (let ((objects (prog1 (swm-class-new-objects (current-screen)) (setf (swm-class-new-objects (current-screen)) nil)))) (when (and objects *active-global-minor-modes*) (map nil #'sync-minor-modes objects)))) (defun replace-class-and-sync (object new-class &rest initargs) "Replaces the main class in OBJECT with the new class, and then syncs all minor modes." (apply #'dynamic-mixins:replace-class object new-class initargs) (sync-minor-modes object)) (defun list-modes (object) "List all minor modes followed by the major mode for OBJECT." (sync-all-minor-modes) (when (typep object 'dynamic-mixins:mixin-object) (mapcar #'class-name (dynamic-mixins:mixin-classes (class-of object))))) (defun list-minor-modes (object) "List all minor modes active in OBJECT" (butlast (list-modes object))) (defun list-mode-objects (&optional (sync t)) (when sync (sync-all-minor-modes)) (let* ((screens (sort-screens)) (groups (loop for screen in screens append (screen-groups screen))) (heads (loop for screen in screens append (screen-heads screen))) (frames (loop for group in groups when (typep group 'tile-group) append (flatten (tile-group-frame-tree group)))) (windows (loop for group in groups append (group-windows group)))) (append windows frames heads groups screens (list *unscoped-minor-modes*)))) (defun list-current-mode-objects (&key (screen (current-screen))) (sync-all-minor-modes) (let* ((group (current-group screen)) (head (current-head group)) (frame (when (typep group 'tile-group) (tile-group-current-frame group))) (window (group-current-window group))) (if frame (list window frame head group screen *unscoped-minor-modes*) (list window head group screen *unscoped-minor-modes*)))) (defcommand current-minor-modes (&optional (screen (current-screen))) () "Return all currently active minor modes." (let ((modes (mapcan #'list-minor-modes (list-current-mode-objects :screen screen)))) (prog1 modes (when %interactivep% (message "~{~A~^~%~}" (or modes '("No active minor modes"))))))) (defcommand enabled-minor-modes () () "Return all enabled minor modes, with duplicates removed." (let ((modes (remove-duplicates (mapcan #'list-minor-modes (list-mode-objects))))) (prog1 modes (when %interactivep% (message "~{~A~^~%~}" (or modes '("No active minor modes"))))))) (defun minor-mode-enabled-p (minor-mode &optional (screen (current-screen))) "Return T if MINOR-MODE is active" (check-type minor-mode symbol) (if (minor-mode-global-p minor-mode) (member minor-mode *active-global-minor-modes*) (member minor-mode (append (current-minor-modes screen))))) (defun find-minor-mode (minor-mode &optional (screen (current-screen))) "Return the minor mode object associated with MINOR-MODE." (check-type minor-mode symbol) (flet ((ct (o) (and (typep o minor-mode) o))) (let ((group (current-group screen))) (or (ct *unscoped-minor-modes*) (ct screen) (ct group) (ct (current-head group)) (ct (when (typep group 'tile-group) (tile-group-current-frame group))) (ct (group-current-window group)))))) ;;; Activep and Top Maps (defun minor-mode-command-active-p (group command) (find-minor-mode (command-class command) (group-screen group))) (push #'minor-mode-command-active-p *custom-command-filters*) (defun minor-mode-top-maps (group) "Return a list of all minor mode top maps." (apply #'append (mapcar #'minor-mode-keymap (list-current-mode-objects :screen (group-screen group))))) ;;; Lighter on click (flet ((ml-on-click-minor-mode (code minor-mode &rest rest) (declare (ignore rest)) (let ((fn (lighter-on-click minor-mode))) (if fn (funcall fn code) (let ((svar (read-one-line (current-screen) (format nil "Disable minor mode ~A? [Yes/no] " minor-mode)))) (when (string-equal "yes" svar) (disable-minor-mode minor-mode))))))) (register-ml-on-click-id :ml-on-click-minor-mode #'ml-on-click-minor-mode)) ;;; Helper Functions (defun generate-keymap (keymap-spec &optional (top-map (stumpwm:make-sparse-keymap)) (filter-bindings #'identity)) "Generate a (potentially nested) keymap based on KEYMAP. KEYMAP is a list of keymap specs, where each spec is a cons cell containing an input sequence and something to bind it to. The input sequence is a string representing an arbitrary sequence of keys, eg \"C-x C-s\". The thing to bind it to is an arbitrary thing which will be passed to FILTER-BINDINGS, which defaults to #'identity. TOP-MAP is the keymap to bind everything in, and defaults to an empty keymap." (let* ((topmap top-map) (curmap topmap) (keymap keymap-spec)) (flet ((create-keymap-binding (keys) (let ((in-seq (car keys)) (bind-to (cdr keys))) (labels ((bind-it (key &optional to) (cond (to (stumpwm:define-key curmap (stumpwm:kbd key) to)) (t (stumpwm:define-key curmap (stumpwm:kbd key) (funcall filter-bindings bind-to))))) (attempt-binding (key rest bind seq) (cond ((and bind (stumpwm::kmap-p bind)) (if (null rest) (restart-case (error "~A in ~A is already bound to a keymap" (stumpwm::print-key (stumpwm:kbd key)) seq) (keep-binding () :report "Keep the current binding" nil) (replace-binding () :report (lambda (s) (format s "Replace with binding ~A" bind-to)) (bind-it key))) (setf curmap bind))) (bind (restart-case (error "~S in ~S is already bound to ~A" (stumpwm::print-key (stumpwm:kbd key)) seq bind) (replace-binding () :report (lambda (s) (format s "Replace with binding ~A" (if (null rest) bind-to (format nil "the keymap ~{~A~^ ~}" rest)))) (bind-it key)))) ((null rest) (bind-it key)) (t (let ((m (stumpwm:make-sparse-keymap))) (bind-it key m) (setf curmap m))))) (traverse-and-bind (seq) (loop for (key . rest) on (cl-ppcre:split " " seq) do (let ((bind (stumpwm:lookup-key curmap (stumpwm:kbd key)))) (attempt-binding key rest bind seq))))) (if (not (or (symbolp bind-to) (stringp bind-to) (functionp bind-to))) (restart-case (error "Invalid binding ~A" bind-to) (bind-anyway () :report "Bind the key binding regardless" (traverse-and-bind in-seq)) (skip-binding () :report "skip this binding" nil)) (traverse-and-bind in-seq)))))) (cond ((null keymap) topmap) ((or (symbolp keymap) (stumpwm::kmap-p keymap)) keymap) ((listp keymap) (restart-case (mapc (lambda (keys) (create-keymap-binding keys) (setf curmap topmap)) keymap) (abort-bindings () :report "Return the keymap without binding further keys" topmap) (abort-bindings* () :report "Return an empty keymap" (stumpwm:make-sparse-keymap))) topmap) (t (restart-case (error "Function MAKE-MINOR-MODE-KEYMAP cant understand ~A" keymap) (use-empty-keymap () :report "Use an empty keymap" (stumpwm:make-sparse-keymap)))))))) (defun make-minor-mode-keymap (spec) (generate-keymap spec)) (defun make-minor-mode-top-map (top-map-spec root-map-spec) "Create a top map for a minor mode based upon its TOP-MAP-SPEC and ROOT-MAP-SPEC." (let ((top-map nil) (root-map (if root-map-spec (make-minor-mode-keymap root-map-spec) (make-sparse-keymap)))) (fill-keymap top-map *escape-key* root-map) (generate-keymap top-map-spec top-map))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-special-variable-name (mode name) (intern (format nil "*~A-~A*" mode name))) (defun parse-minor-mode-options (options) (let ((valid-options '((:interactive . 1) (:scope . 1) (:global . 1) (:lighter-make-clickable . 1) (:lighter . 1) (:lighter-on-click . 1) (:expose-keymaps . 1) (:rebind . 1) (:root-map . 1) (:top-map . 1) (:enable-when . t) (:make-hooks . 1) (:default-initargs . t) (:define-command-definer . 1))) (all-vals '()) (other-opts '())) (flet ((collect-values (option) (destructuring-bind (optname . option-arguments) option (alexandria:if-let (argcount (cdr (assoc optname valid-options))) (progn (if (and (numberp argcount) (= argcount 1)) (push (car option-arguments) all-vals) (push option-arguments all-vals)) (push optname all-vals)) (push option other-opts))))) (mapc #'collect-values options) (values all-vals other-opts)))) (defun define-command-macro (mode) `(defmacro ,(intern (format nil "~:@(define-~A-command~)" mode)) (name (&rest args) (&rest interactive-args) &body body) (multiple-value-bind (body decls docstring) (parse-body body :documentation t) `(defcommand (,name ,',mode) ,args ,interactive-args ,@(when docstring (list docstring)) ,@decls (let ((*minor-mode* (find-minor-mode ',',mode (current-screen)))) ,@body))))) (defun define-enable-methods (mode scope) (let ((optarg (get-scope scope))) `((defmethod autoenable-minor-mode ((mode (eql ',mode)) (obj ,mode)) (with-simple-restart (continue "Ignore enable error for ~A" ',mode) (signal 'minor-mode-enable-error :mode ',mode :object obj :reason 'already-enabled))) (defmethod autoenable-minor-mode ((mode (eql ',mode)) (obj ,(car optarg))) (when (and ,@(unless (eql (third optarg) (first optarg)) ;; Check if the filter type is the same as the class ;; type, and if not then explicitly check if the object ;; conforms to that type. `((typep obj ',(third optarg)))) (enable-when mode obj)) (prog1 (dynamic-mixins:ensure-mix obj ',mode) (handler-bind ((minor-mode-hook-error (lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (run-hook-for-minor-mode #'minor-mode-enable-hook ',mode obj))))) (defmethod autodisable-minor-mode ((mode (eql ',mode)) (obj ,mode)) (handler-bind ((minor-mode-hook-error (lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (run-hook-for-minor-mode #'minor-mode-disable-hook ',mode obj t)) (dynamic-mixins:delete-from-mix obj ',mode))))) (defun genlighter (mode lighter) (cond ((null lighter) (flet ((nullgen (s l) (mapcar (lambda (e) (if (or (string-equal e "mode") (< (length e) l)) e (subseq e 0 l))) s))) `(lambda (mode) (declare (ignore mode)) ,(let ((split (remove-if (lambda (s) (string= s "")) (cl-ppcre:split "-" (symbol-name mode))))) (format nil "~{~A~^-~}" (case (length split) ((1) split) ((2) (nullgen split 3)) ((3) (nullgen split 2)) (otherwise (nullgen split 1)))))))) ((stringp lighter) `(lambda (mode) (declare (ignore mode)) ,lighter)) (t (when (or (symbolp lighter) (and (listp lighter) (not (or (eql (car lighter) 'lambda) (eql (car lighter) 'function))))) (warn "Assuming ~A is funcallable" lighter)) lighter))) (defun define-hooks (mode) `((defvar ,(make-special-variable-name mode 'enable-hook) nil ,(format nil "A hook run when enabling ~A, called with the mode symbol and the scope object." mode)) (defvar ,(make-special-variable-name mode 'disable-hook) nil ,(format nil "A hook run when disabling ~A, called with the mode symbol and the scope object. This hook is run when ~A is disabled in an object, however if an object goes out of scope before a minor mode is disabled then this hook will not be run for that object." mode mode)) (defvar ,(make-special-variable-name mode 'hook) nil ,(format nil "A hook run when explicitly enabling ~A, called with the mode symbol and the scope object." mode)) (defvar ,(make-special-variable-name mode 'destroy-hook) nil ,(format nil "A hook run when explicitly disabling ~A, called with the mode symbol and the scope object." mode)) (defmethod minor-mode-enable-hook ((mode (eql ',mode))) (declare (ignore mode)) ,(make-special-variable-name mode 'enable-hook)) (defmethod (setf minor-mode-enable-hook) (new (mode (eql ',mode))) (declare (ignore mode)) (setf ,(make-special-variable-name mode 'enable-hook) new)) (defmethod minor-mode-disable-hook ((mode (eql ',mode))) (declare (ignore mode)) ,(make-special-variable-name mode 'disable-hook)) (defmethod (setf minor-mode-disable-hook) (new (mode (eql ',mode))) (declare (ignore mode)) (setf ,(make-special-variable-name mode 'disable-hook) new)) (defmethod minor-mode-hook ((mode (eql ',mode))) (declare (ignore mode)) ,(make-special-variable-name mode 'hook)) (defmethod (setf minor-mode-hook) (new (mode (eql ',mode))) (declare (ignore mode)) (setf ,(make-special-variable-name mode 'hook) new)) (defmethod minor-mode-destroy-hook ((mode (eql ',mode))) (declare (ignore mode)) ,(make-special-variable-name mode 'destroy-hook)) (defmethod (setf minor-mode-destroy-hook) (new (mode (eql ',mode))) (declare (ignore mode)) (setf ,(make-special-variable-name mode 'destroy-hook) new))))) ;;; Minor Mode Scopes (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *minor-mode-scopes* (make-hash-table) "Store the scope supertypes and object retrieval functions for a scope") (defun add-minor-mode-scope (designator type current-object-thunk &optional filter-type) "Add a list of the TYPE, CURRENT-OBJECT-THUNK, and ALL-OBJECTS-THUNK, under DESIGNATOR in the minor mode scope hash table." (setf (gethash designator *minor-mode-scopes*) (list type current-object-thunk (or filter-type type)))) (defun get-scope (designator) (multiple-value-bind (value foundp) (gethash designator *minor-mode-scopes*) (if foundp value (error "Invalid scope designator ~A" designator)))) (defun scope-type (designator) (first (get-scope designator))) (defun scope-filter-type (designator) (third (get-scope designator))) (defun scope-current-object-function (designator) (cadr (get-scope designator))) (defun scope-all-objects-function (designator) (let ((type (first (get-scope designator)))) (lambda () (loop for object in (list-mode-objects nil) when (typep object type) collect object)))) (defun find-active-global-minor-modes-for-scope (scope) (loop for mode in *active-global-minor-modes* when (eql scope (minor-mode-scope mode)) collect mode))) (defgeneric validate-superscope (scope superscope) (:documentation "A generic function for explicitly allowing a scope to descend from an otherwise invalid superscope.")) (defmethod no-applicable-method ((f (eql #'validate-superscope)) &rest r) (declare (ignore f r)) (values nil nil)) (defun superclassp (class superclass) (check-type class symbol) (check-type superclass symbol) (let ((s (find-class superclass)) (superclasses (sb-mop:class-direct-superclasses (find-class class)))) (loop for super in superclasses when (or (eq super s) (superclassp (class-name super) superclass)) do (return-from superclassp t)))) (defun validate-scope (scope superclasses &key (errorp t)) "Validate a scope for a set of superclasses. SCOPE must be a designator as defined with define-minor-mode-scope, and superclasses should be the list of superclasses for a minor mode being defined with a scope of SCOPE. When ERRORP is T then an error is signalled when an invalid superscope is encountered. If it is NIL the NIL is returned instead. Upon success a list of conses is returned where the car is the scope designator and the cdr is the class with that scope." (flet ((doerror (scope superscope type) (if errorp (error "~S is not a valid subscope of ~S from class ~A" scope superscope type) (return-from validate-scope nil)))) (let ((scopetype (scope-type scope)) (superscopes (mapcar (lambda (el) (cons (ignore-errors (minor-mode-scope el)) el)) superclasses))) (mapc (lambda (superscope) (when (car superscope) (multiple-value-bind (valid invalid) (validate-superscope scope (car superscope)) (or (and invalid (doerror scope (car superscope) (cdr superscope))) valid (eql scopetype (scope-type (car superscope))) (superclassp scopetype (scope-type (car superscope))) (doerror scope (car superscope) (cdr superscope)))))) superscopes)))) (defun validate-minor-mode-superclasses (superclasses) (flet ((validate (class) (when (or (eq class 'swm-class) (superclassp class 'swm-class)) (error "The class ~A is not a valid superclass for minor modes~%as it descends from SWM-CLASS" class)))) (mapc #'validate superclasses))) (defmacro define-minor-mode-scope ((designator class &optional filter-type) &body retrieve-current-object) "Define a minor mode scope for use with DEFINE-MINOR-MODE. This generates a call to ADD-MINOR-MODE-SCOPE which is evaluated when compiled, loaded, or executed. DESIGNATOR should be a keyword and TYPE should denote a class, while FILTER-TYPE should denote a general type. RETRIEVE-CURRENT-OBJECT should be a thunk body which returns the current object for this scope." `(eval-when (:compile-toplevel :load-toplevel :execute) (add-minor-mode-scope ,designator ',class (lambda () ,@retrieve-current-object) ,@(when filter-type `(',filter-type))))) (defmacro define-descended-minor-mode-scope (designator parent &key class filter-type retrieve-current-object) "Define a descended scope which inherits the parents type and functions unless provided." `(eval-when (:compile-toplevel :load-toplevel :execute) (add-minor-mode-scope ,designator ,@(if class `(',class) `((scope-type ,parent))) ,(if retrieve-current-object `(lambda () ,retrieve-current-object) `(scope-current-object-function ,parent)) ,@(when filter-type `(',filter-type))))) (define-minor-mode-scope (:unscoped unscoped-modes) *unscoped-minor-modes*) (define-minor-mode-scope (:screen screen) (current-screen)) (define-minor-mode-scope (:group group) (current-group)) (define-minor-mode-scope (:tile-group tile-group) (current-group)) (define-minor-mode-scope (:float-group float-group) (current-group)) (define-minor-mode-scope (:dynamic-group dynamic-group) (current-group)) (defun %manual-tiling-group-p (g) (and (typep g 'tile-group) (not (typep g 'dynamic-group)))) (define-minor-mode-scope (:manual-tiling-group tile-group (satisfies %manual-tiling-group-p)) (current-group)) (define-minor-mode-scope (:frame frame) (let ((g (current-group))) (when (typep g 'tile-group) (tile-group-current-frame g)))) (define-minor-mode-scope (:head head) (current-head)) (defun %frame-but-not-head (o) (and (typep o 'frame) (not (typep o 'head)))) (define-descended-minor-mode-scope :frame-excluding-head :frame :filter-type (satisfies %frame-but-not-head)) (define-minor-mode-scope (:window window) (current-window)) (define-minor-mode-scope (:tile-window tile-window) (current-window)) (define-minor-mode-scope (:float-window float-window) (current-window)) (defmacro define-minor-mode (mode superclasses slots &rest options) "Define a minor mode as a class to be instantiated when the minor mode is activated. Minor modes are dynamically mixed in to and out of the appropriate object when they are enabled or disabled. If @var{SUPERCLASSES} is not provided a default superclass of MINOR-MODE will be provided. @var{OPTIONS} may include all normal options when defining a class, with the addition of the following options: @itemize @item (:SCOPE SCOPE-DESIGNATOR)@* The :SCOPE option determines what object(s) the minor mode can be mixed in with. New scopes can be defined with the macro DEFINE-MINOR-MODE-SCOPE. @item (:GLOBAL (OR T NIL))@* When true the :GLOBAL option changes the way enable methods are defined to track the minor mode and autoenable it in all existing scope objects, as well as autoenabled when new scope objects are instantiated. If the :SCOPE option is :UNSCOPED then this option does not need to be provided. @item (:TOP-MAP spec)@* The minor modes top map is created based upon the provided spec, which must be a list of cons cells whose car is a key sequence and whose cdr is a binding. For example: @code{(list (cons \"C-m x\" \"echo\"))}. This would bind the key sequence @kbd{C-m x} to the echo command. A reference to this keymap is stored as a slot in the minor mode object and can be accessed via the reader @code{MODE-KEYMAP} where @code{MODE} is the minor mode name. @item (:ROOT-MAP spec)@* The minor modes root map is created based upon the provided spec. The spec is as described in the :TOP-MAP option. @item (:EXPOSE-KEYMAPS (OR T NIL))@* This value is used at macroexpansion time to determine whether or not to generate keymap variables or store the keymap within the object. When T the variables *MODE-TOP-MAP* and *MODE-ROOT-MAP* will be generated. @item (:REBIND (MEMBER :TOP-MAP :ROOT-MAP :ALL-MAPS))@* This option controls rebinding of the top and root maps. When it is :TOP-MAP the top map is rebound, when it is :ROOT-MAP the root map is rebound, and when it is :ALL-MAPS both the top and root map are rebound. Any rebound map will be rebound to the provided keymap specification. This only has an effect if the minor mode has previously been defined. @item (:LIGHTER T)@* The :LIGHTER option will be used to generate a function returning a string to display in the mode line. When :LIGHTER is NULL a string is generated based upon the mode name. When it is a string that string is used as is. Otherwise :LIGHTER will assumed to be funcallable and used as is. When it is a symbol or a list that doesn't begin with LAMBDA or FUNCTION a warning is issued that DEFINE-MINOR-MODE is assuming it is funcallable. When assumed to be funcallable, it is called with the mode object as its only argument. @item (:LIGHTER-MAKE-CLICKABLE (OR T NIL))@* When :LIGHTER-MAKE-CLICKABLE is T then the :LIGHTER is wrapped in a call to FORMAT-WITH-ON-CLICK-ID, called with the id :ML-ON-CLICK-MINOR-MODE and the mode as a quoted symbol. @item (:LIGHTER-ON-CLICK FUNCTION)@* When :LIGHTER-ON-CLICK is provided it must be a function of arity one, which will be called whenever the minor modes lighter is clicked, with the button code of the click as its only argument. If this is provided then :LIGHTER-MAKE-CLICKABLE is implied to be T. @item (:INTERACTIVE (OR SYMBOL T NIL))@* The :INTERACTIVE option determines whether a command to toggle the minor mode on and off is generated. If it is T then a command with the same name as the minor mode is generated. If it is a symbol then that symbol will be used when defining the command. @item (:ENABLE-WHEN (MODE OBJECT) &BODY BODY)@* When provided, the :ENABLE-WHEN option generates a method for the enable-when generic function. MODE is bound to the mode symbol, and OBJECT is bound to the scope object. If this is not provided, a method is generated which returns T for the minor mode and its scope. If it is provided and is nil, then no method is generated and a method for ENABLE-WHEN which dispatches upon the mode as a symbol and the scope type for the minor mode must be manually defined. @item (:MAKE-HOOKS (OR T NIL))@* When :MAKE-HOOKS is T a set of hook variables are generated. These variables are fourfold: *MODE-HOOK* is run after explicitly enabling the minor mode. *MODE-ENABLE-HOOK* is run when the minor mode is autoenabled. *MODE-DISABLE-HOOK* is run when the minor mode is autodisabled. Finally *MODE-DESTROY-HOOK* is run when the minor mode is explicitly disabled. @item (:DEFINE-COMMAND-DEFINER (OR T NIL))@* When :DEFINE-COMMAND-DEFINER is T a macro is defined for defining commands that are active only when the minor mode is active. Commands defined with this macro have the special variable *MINOR-MODE* bound to the minor mode object in their body. The generated macro is called DEFINE-MODE-COMMAND. This option defaults to T. @end itemize Example: @verbatim (define-minor-mode evil-mode () () (:scope :unscoped) (:top-map '((\"j\" . \"move-focus down\") (\"k\" . \"move-focus up\") (\"h\" . \"move-focus left\") (\"l\" . \"move-focus right\") (\"x\" . *exchange-window-map*) (\"C-m b\" . \"evil-echo\"))) (:lighter \"EVIL\") (:lighter-make-clickable nil)) (define-evil-mode-command evil-echo () () (run-commands \"echo\")) @end verbatim " (when (null superclasses) (setq superclasses '(minor-mode))) (multiple-value-bind (mm-opts other-opts) (parse-minor-mode-options options) (destructuring-bind (&key top-map root-map (expose-keymaps t) rebind lighter lighter-make-clickable lighter-on-click (scope :unscoped) interactive global (enable-when nil ewpp) (make-hooks t) (define-command-definer t) default-initargs) mm-opts (when lighter-on-click (setf lighter-make-clickable t)) (with-gensyms (gmode gkeymap) `(progn ;; Ensure that the superclasses are valid for a minor mode. (validate-minor-mode-superclasses ',superclasses) ;; Ensure that SCOPE is a valid scope for the superclass list. (validate-scope ,scope ',superclasses) ,@(when expose-keymaps `((,(if (or (eql rebind :root-map) (eql rebind :all-maps)) 'defparameter 'defvar) ,(make-special-variable-name mode 'root-map) (make-minor-mode-keymap ,root-map) ,(format nil "The root map for ~A" mode)) (,(if (or (eql rebind :top-map) (eql rebind :all-maps)) 'defparameter 'defvar) ,(make-special-variable-name mode 'top-map) (make-minor-mode-top-map ,top-map ',(make-special-variable-name mode 'root-map)) ,(format nil "The top map for ~A" mode)))) (defclass ,mode ,superclasses ((,gkeymap :initform ,@(if expose-keymaps `(',(make-special-variable-name mode 'top-map)) `((make-minor-mode-top-map ',top-map (make-minor-mode-keymap ',root-map)))) :reader ,(intern (format nil "~A-KEYMAP" mode)) :allocation :class) ,@slots) (:default-initargs ,@default-initargs) ,@other-opts) ,(if global `(defmethod minor-mode-global-p ((mode (eql ',mode))) t) `(let ((method (ignore-errors (find-method #'minor-mode-global-p nil '((eql ,mode)))))) (when method (remove-method #'minor-mode-global-p method)))) (let ((fn ,(when lighter-on-click lighter-on-click))) (defmethod lighter-on-click ((,gmode (eql ',mode))) fn)) (defmethod minor-mode-lighter ((,gmode ,mode)) (cons ,(if lighter-make-clickable `(format-with-on-click-id (funcall ,(genlighter mode lighter) ,gmode) :ml-on-click-minor-mode ',mode) `(funcall ,(genlighter mode lighter) ,gmode)) (call-next-method))) (defmethod minor-mode-scope ((,gmode (eql ',mode))) (declare (ignore ,gmode)) ,scope) ,@(when make-hooks (define-hooks mode)) (defmethod minor-mode-keymap ((,gmode ,mode)) (cons (slot-value ,gmode ',gkeymap) (call-next-method))) ,@(cond (enable-when (let ((args (car enable-when)) (body (cdr enable-when))) `((defmethod enable-when ((,(car args) (eql ',mode)) (,(cadr args) ,(scope-type scope))) ,@body)))) (ewpp nil) (t `((defmethod enable-when ((mode (eql ',mode)) (obj ,(scope-type scope))) t)))) ,@(define-enable-methods mode scope) ,@(when interactive `((defcommand ,(cond ((eq interactive t) mode) (t interactive)) (&optional (yn nil ynpp)) ((:y-or-n)) (flet ((enable () (enable-minor-mode ',mode)) (disable () (disable-minor-mode ',mode))) (cond (yn (enable)) (ynpp (disable)) ((minor-mode-enabled-p ',mode) (disable)) (t (enable))))))) ,@(when define-command-definer (list (define-command-macro mode))) (sync-keys)))))) stumpwm-22.11/mode-line-formatters.lisp000066400000000000000000000224651433701203600201710ustar00rootroot00000000000000;; Copyright (C) 2006-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . (in-package :stumpwm) (export '(*hidden-window-color* *mode-line-highlight-template* bar bar-zone-color format-with-on-click-id)) ;;; Settings (defvar *hidden-window-color* "^5*" "Color command for hidden windows when using the fmt-head-window-list-hidden-windows formatter. To disable coloring hidden windows, set this to an empty string.") (defvar *mode-line-highlight-template* "^R~A^r" "The string passed to FORMAT to highlight things in the mode line.") ;;; Clickable Text (defun format-with-on-click-id (string id &rest arguments) "Wrap STRING in :on-click and :on-click-end color formatters, using ID as the id to call when clicked and ARGUMENTS as the arguments to pass to the ID's function. STRING may not contain the :> color formatter, but may contain any other color formatters." (format nil "^(:on-click ~S ~{~S~^ ~})~A^(:on-click-end)" id arguments string)) ;;; Utilities (defun mode-line-current-group (ml) (screen-current-group (mode-line-screen ml))) ;;; Formatters (add-screen-mode-line-formatter #\u 'fmt-urgent-window-list) (defun fmt-urgent-window-list (ml) "Using `*window-format*', return a 1 line list of the urgent windows, space seperated." (format nil "~{~a~^ ~}" (mapcar (lambda (w) (format-with-on-click-id (let ((str (format-expand *window-formatters* *window-format* w))) (if (eq w (current-window)) (fmt-highlight str) str)) :ml-on-click-focus-window (window-id w))) (screen-urgent-windows (mode-line-screen ml))))) (add-screen-mode-line-formatter #\w 'fmt-window-list) (defun fmt-window-list (ml) "Using *window-format*, return a 1 line list of the windows, space seperated." (format nil "~{~a~^ ~}" (mapcar (lambda (w) (format-with-on-click-id (format-expand *window-formatters* *window-format* w) :ml-on-click-focus-window (window-id w))) (sort-windows (mode-line-current-group ml))))) (add-screen-mode-line-formatter #\g 'fmt-group-list) (defun fmt-group-list (ml) "Given a group list all the groups in the group's screen." (format nil "~{~a~^ ~}" (mapcar (lambda (g) (format-with-on-click-id (let* ((str (format-expand *group-formatters* *group-format* g))) (if (eq g (current-group)) (fmt-highlight str) str)) :ml-on-click-switch-to-group (group-name g))) (sort-groups (group-screen (mode-line-current-group ml)))))) (add-screen-mode-line-formatter #\h 'fmt-head) (defun fmt-head (ml) (format nil "~d" (head-number (mode-line-head ml)))) (add-screen-mode-line-formatter #\n 'fmt-group) (defun fmt-group (ml) (format nil "~a" (group-name (mode-line-current-group ml)))) (defun fmt-highlight (s) (format nil *mode-line-highlight-template* s)) (add-screen-mode-line-formatter #\W 'fmt-head-window-list) (defun fmt-head-window-list (ml) "Using *window-format*, return a 1 line list of the windows, space seperated." (format nil "~{~a~^ ~}" (mapcar (lambda (w) (format-with-on-click-id (let ((str (format-expand *window-formatters* *window-format* w))) (if (eq w (current-window)) (fmt-highlight str) str)) :ml-on-click-focus-window (window-id w))) (sort1 (head-windows (mode-line-current-group ml) (mode-line-head ml)) #'< :key #'window-number)))) (defun fmt-hidden (s) (format nil (concat "^[" *hidden-window-color* "~A^]") s)) (add-screen-mode-line-formatter #\v 'fmt-head-window-list-hidden-windows) (defun fmt-head-window-list-hidden-windows (ml) "Using *window-format*, return a 1 line list of the windows, space separated. The currently focused window is highlighted with fmt-highlight. Any non-visible windows are colored the *hidden-window-color*." (let* ((all (head-windows (mode-line-current-group ml) (mode-line-head ml))) (non-top (set-difference all (top-windows)))) (format nil "~{~a~^ ~}" (mapcar (lambda (w) (format-with-on-click-id (let ((str (format-expand *window-formatters* *window-format* w))) (cond ((eq w (current-window)) (fmt-highlight str)) ((find w non-top) (fmt-hidden str)) (t str))) :ml-on-click-focus-window (window-id w))) (sort1 all #'< :key #'window-number))))) (add-screen-mode-line-formatter #\d 'fmt-modeline-time) (defun fmt-modeline-time (ml) (declare (ignore ml)) (time-format *time-modeline-string*)) (defun format-minor-modes-for-mode-line (mode-objects) (with-output-to-string (s) (loop for modes on mode-objects for list = (minor-mode-lighter (car modes)) do (loop for text in list unless (string= text "") do (write-string " " s) (write-string text s))))) (add-screen-mode-line-formatter #\m 'fmt-minor-modes) (defun fmt-minor-modes (ml) (let ((total-string (format-minor-modes-for-mode-line (list-current-mode-objects :screen (mode-line-screen ml))))) (if (string= "" total-string) total-string (subseq total-string 1)))) (add-screen-mode-line-formatter #\M 'fmt-all-minor-modes) (defun fmt-all-minor-modes (ml) (declare (ignore ml)) (let ((total-string (format-minor-modes-for-mode-line (list-mode-objects nil)))) (if (string= "" total-string) total-string (subseq total-string 1)))) (defvar *bar-med-color* "^B") (defvar *bar-hi-color* "^B^3*") (defvar *bar-crit-color* "^B^1*") (defun bar-zone-color (amount &optional (med 20) (hi 50) (crit 90) reverse) "Return a color command based on the magnitude of the argument. If the limits for the levels aren't specified, they default to sensible values for a percentage. With reverse, lower numbers are more critical." (labels ((past (n) (funcall (if reverse #'<= #'>=) amount n))) (cond ((past crit) *bar-crit-color*) ((past hi) *bar-hi-color*) ((past med) *bar-med-color*) (t "")))) (defun repeat (n char) (make-string n :initial-element char)) (defun bar (percent width full empty) "Return a progress bar string of WIDTH characters composed of characters FULL and EMPTY at PERCENT complete." (let ((chars (truncate (* (/ width 100) percent)))) (format nil "^[~A~A^]~A" (bar-zone-color percent) (repeat chars full) (repeat (- width chars) empty)))) (defvar *alt-prev-index* 0) (defvar *alt-prev-time* 0) ;; TODO: Figure out a way to objectify fmt-alternate and fmt-scroll so that ;; multiple instances can coexist. (defun alternate (strings period) "Show each of STRINGS, alternating at most once every PERIOD seconds." (let ((now (/ (get-internal-real-time) internal-time-units-per-second))) (when (>= (- now *alt-prev-time*) period) (setf *alt-prev-time* now) (if (< *alt-prev-index* (1- (length strings))) (incf *alt-prev-index*) (setf *alt-prev-index* 0)))) (elt strings *alt-prev-index*)) (defvar *scroll-prev-index* 0) (defvar *scroll-prev-time* 0) (defvar *scroll-prev-dir* :forward) (defun scroll (string width delay) "Scroll STRING within the space of WIDTH characters, with a step of DELAY" (let ((now (/ (get-internal-real-time) internal-time-units-per-second))) (when (>= (- now *scroll-prev-time*) delay) (setf *scroll-prev-time* now) (case *scroll-prev-dir* (:forward (if (< *scroll-prev-index* (- (length string) width)) (incf *scroll-prev-index*) (setf *scroll-prev-dir* :backward))) (:backward (if (> *scroll-prev-index* 0) (decf *scroll-prev-index*) (setf *scroll-prev-dir* :forward)))))) (subseq string *scroll-prev-index* (+ *scroll-prev-index* width))) stumpwm-22.11/mode-line.lisp000066400000000000000000000431561433701203600160050ustar00rootroot00000000000000;; Copyright (C) 2006-2008 Shawn Betts ;; Copyright (C) 2016 Joram Schrijver ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . (in-package :stumpwm) (export '(*mode-line-background-color* *mode-line-border-color* *mode-line-border-width* *mode-line-foreground-color* *mode-line-pad-x* *mode-line-pad-y* *mode-line-position* *mode-line-timeout* *screen-mode-line-format* *screen-mode-line-formatters* add-screen-mode-line-formatter register-ml-on-click-id enable-mode-line toggle-mode-line)) ;;; Settings (defvar *mode-line-position* :top "Specifies where the mode line is displayed. Valid values are :top and :bottom.") (defvar *mode-line-border-width* 1 "Specifies how thick the mode line's border will be. Integer value.") (defvar *mode-line-pad-x* 5 "Specifies the number of padding pixels between the text and the side of the mode line. Integer value.") (defvar *mode-line-pad-y* 1 "The number of padding pixels between the modeline text and the top/bottom of the modeline. Integer value.") (defvar *mode-line-background-color* "Gray20" "The mode line background color.") (defvar *mode-line-foreground-color* "Gray50" "The mode line foreground color.") (defvar *mode-line-border-color* "Gray30" "The mode line border color.") (defvar *screen-mode-line-format* "[^B%n^b] %W" "This variable describes what will be displayed on the modeline for each screen. Turn it on with the function TOGGLE-MODE-LINE or the mode-line command. It is a list where each element may be a string, a symbol, or a list. For a symbol its value is used. For a list of the form (:eval FORM) FORM is evaluated and the result is used as a mode line element. If it is a string the string is printed with the following formatting options: @table @asis @item %h List the number of the head the mode-line belongs to @item %w List all windows in the current group windows using @var{*window-format*} @item %W List all windows on the current head of the current group using @var{*window-format*} @item %g List the groups using @var{*group-format*} @item %n The current group's name @item %u Using @var{*window-format*}, return a 1 line list of the urgent windows, space seperated. @item %v Using @var{*window-format*}, return a 1 line list of the windows, space separated. The currently focused window is highlighted with fmt-highlight. Any non-visible windows are colored the *hidden-window-color*. @item %d Using @var{*time-modeline-string*}, print the time. @end table A number of modules have been written that extends the possible formatting strings. See their documentation for details.") (defvar *screen-mode-line-formatters* () "An alist containing format character format function pairs for formatting screen mode-lines. functions are passed the mode line.") (defvar *mode-line-timeout* 60 "The modeline updates after each command, when a new window appears or an existing one disappears, and on a timer. This variable controls how many seconds elapse between each update. If this variable is changed while the modeline is visible, you must toggle the modeline to update timer.") (defvar *mode-line-timer* nil "The timer that updates the modeline") ;;; Formatters (defun add-screen-mode-line-formatter (character fmt-fun) "Add a format function to a format character (or overwrite an existing one)." (setf *screen-mode-line-formatters* (cons (list character fmt-fun) (remove character *screen-mode-line-formatters* :key #'first)))) ;;; Mode lines (defvar *mode-lines* () "All current mode lines.") ;;; Utilities (defun screen-mode-lines (screen) (remove-if (lambda (mode-line) (not (eq screen (mode-line-screen mode-line)))) *mode-lines*)) (defun head-mode-line (head) (find head *mode-lines* :key #'mode-line-head)) (defun find-mode-line-by-window (xwin) (find xwin *mode-lines* :key #'mode-line-window)) (defun mode-line-gc (ml) (ccontext-gc (mode-line-cc ml))) (defun turn-on-mode-line-timer () (when (timer-p *mode-line-timer*) (cancel-timer *mode-line-timer*)) (setf *mode-line-timer* (run-with-timer *mode-line-timeout* *mode-line-timeout* 'update-all-mode-lines))) (defun maybe-cancel-mode-line-timer () (unless *mode-lines* (when (timer-p *mode-line-timer*) (cancel-timer *mode-line-timer*) (setf *mode-line-timer* nil)))) ;;; Creation (defun resize-mode-line (mode-line) (when (eq (mode-line-mode mode-line) :stump) ;; This is a StumpWM mode-line (setf (xlib:drawable-height (mode-line-window mode-line)) (+ (* 2 *mode-line-pad-y*) (nth-value 1 (rendered-size (split-string (mode-line-contents mode-line) (string #\Newline)) (mode-line-cc mode-line)))))) (with-accessors ((window mode-line-window) (head mode-line-head) (position mode-line-position) (height mode-line-height) (factor mode-line-factor)) mode-line (setf (xlib:drawable-width window) (- (frame-width head) (* 2 (xlib:drawable-border-width window))) (xlib:drawable-height window) (min (xlib:drawable-height window) (truncate (head-height head) 4)) height (+ (xlib:drawable-height window) (* 2 (xlib:drawable-border-width window))) factor (- 1 (/ height (head-height head))) (xlib:drawable-x window) (head-x head) (xlib:drawable-y window) (if (eq position :top) (head-y head) (- (+ (head-y head) (head-height head)) height))))) (defun update-mode-line-color-context (ml) (let* ((cc (mode-line-cc ml)) (screen (mode-line-screen ml)) (bright (lookup-color screen *mode-line-foreground-color*))) (adjust-color bright 0.25) (setf (ccontext-default-bright cc) (alloc-color screen bright)))) (defun make-mode-line-window (screen) "Create a window suitable for a modeline." (xlib:create-window :parent (screen-root screen) :x 0 :y 0 :width 1 :height 1 :background (alloc-color screen *mode-line-background-color*) :border (alloc-color screen *mode-line-border-color*) :border-width *mode-line-border-width* ;; You can click the modeline :event-mask (xlib:make-event-mask :button-press :exposure) ;; these windows are not controlled by the window manager :override-redirect :on)) (defun make-mode-line-gc (window screen) (xlib:create-gcontext :drawable window :font (when (typep (screen-font screen) 'xlib:font) (screen-font screen)) :foreground (alloc-color screen *mode-line-foreground-color*) :background (alloc-color screen *mode-line-background-color*))) (defun make-mode-line-cc (window screen gc) (make-ccontext :gc gc :screen screen :font (screen-font screen) :win window :default-fg (xlib:gcontext-foreground gc) :default-bg (xlib:gcontext-background gc))) (defun make-mode-line (screen head format) (let* ((window (make-mode-line-window screen)) (gc (make-mode-line-gc window screen)) (cc (make-mode-line-cc window screen gc)) (mode-line (%make-mode-line :window window :screen screen :head head :format format :position *mode-line-position* :cc cc))) (prog1 mode-line (push mode-line *mode-lines*) (update-mode-line-color-context mode-line) (resize-mode-line mode-line) (xlib:map-window window) (setf (xlib:window-priority window) :below) (redraw-mode-line mode-line) (dformat 3 "modeline: ~s~%" mode-line) (turn-on-mode-line-timer) (run-hook-with-args *new-mode-line-hook* mode-line)))) ;;; Destruction (defun sync-mode-line (ml) (dolist (group (screen-groups (mode-line-screen ml))) (group-sync-head group (mode-line-head ml)))) (defun destroy-mode-line (ml) (run-hook-with-args *destroy-mode-line-hook* ml) (xlib:destroy-window (mode-line-window ml)) (when (mode-line-cc ml) ;; mode-lines of dock-type windows do not have a cc (xlib:free-gcontext (mode-line-gc ml))) (setf *mode-lines* (remove ml *mode-lines*)) (sync-mode-line ml) (maybe-cancel-mode-line-timer)) (defun destroy-all-mode-lines () (dolist (ml *mode-lines*) (destroy-mode-line ml))) ;;; Formatting (defvar *current-mode-line-formatters* nil "used in formatting modeline strings.") (defvar *current-mode-line-formatter-args* nil "used in formatting modeline strings.") (defgeneric mode-line-format-elt (elt)) (defmethod mode-line-format-elt ((elt string)) (apply 'format-expand *current-mode-line-formatters* elt *current-mode-line-formatter-args*)) (defmethod mode-line-format-elt ((elt symbol)) (if (boundp elt) (let ((val (symbol-value elt))) ;; ignore T and nil, like emacs. (unless (typep val 'boolean) (mode-line-format-elt val))) (symbol-name elt))) (defmethod mode-line-format-elt ((elt null)) "") (defmethod mode-line-format-elt ((elt list)) (etypecase (first elt) ((or string list) (apply 'concatenate 'string (mapcar 'mode-line-format-elt elt))) (symbol (mode-line-format-elt (case (first elt) ;; FIXME: silently failing is probably not the best idea. (:eval (ignore-errors (eval (second elt)))) (t (and (boundp (first elt)) (symbol-value (first elt)) (second elt)))))))) (defun mode-line-format-string (ml) (mode-line-format-elt (mode-line-format ml))) (defun redraw-mode-line (ml &optional force) (when (eq (mode-line-mode ml) :stump) (setf (mode-line-new-bounds ml) nil) (let* ((*current-mode-line-formatters* *screen-mode-line-formatters*) (*current-mode-line-formatter-args* (list ml)) (str (handler-case (mode-line-format-string ml) (error (c) (format nil "Unable to expand mode line format string: ~S" c))))) (flet ((resize-and-render (string) (setf (mode-line-contents ml) string) (resize-mode-line ml) (render-strings (mode-line-cc ml) *mode-line-pad-x* *mode-line-pad-y* (split-string string (string #\Newline)) () :ml ml) (when (mode-line-new-bounds ml) (setf (mode-line-on-click-bounds ml) (reverse (mode-line-new-bounds ml)))))) (handler-case (when (or force (not (string= (mode-line-contents ml) str))) (resize-and-render str)) (error (c) (resize-and-render (format nil "Unable to render mode line: ~S" c)))))))) (defun update-mode-lines (screen) "Update all mode lines on SCREEN" (dolist (mode-line (screen-mode-lines screen)) (redraw-mode-line mode-line))) (defun update-all-mode-lines () "Update all mode lines." (mapc 'redraw-mode-line *mode-lines*)) ;;; Registering mode line clickable areas (defvar *mode-line-on-click-functions* nil "An alist of IDs and and functions, used by :on-click formatter calls") (defun register-ml-on-click-id (id fn) "Register FN with ID, to be used by the :on-click mode line color formatter." (let ((present (assoc id *mode-line-on-click-functions*))) (if present (setf (cdr present) fn) (push (cons id fn) *mode-line-on-click-functions*)))) (defun register-ml-boundaries-with-id (ml xbeg xend ybeg yend id args) (push (list xbeg xend ybeg yend id args) (mode-line-new-bounds ml))) (defun mode-line-click-dispatcher (ml code x y) "A function to hang on the mode line click hook which dispatches the appropriate mode line click function." (let ((registered-ids *mode-line-on-click-functions*) (bounds-list (mode-line-on-click-bounds ml))) (dformat 3 "In mode line click: x=~A~&~2Tregistered ids: ~S~&~2Tbounds: ~S~&" x registered-ids bounds-list) (loop for (xbeg xend ybeg yend id args) in bounds-list do (when (and (< xbeg x xend) (< ybeg y yend)) (let ((fn (assoc id registered-ids))) (when fn (dformat 3 "Mode line click, calling ~A" (cdr fn)) (apply (cdr fn) code args))) (loop-finish))))) (add-hook *mode-line-click-hook* 'mode-line-click-dispatcher) (flet ((ml-on-click-focus-window (code id &rest rest) (declare (ignore code rest)) (when-let ((window (window-by-id id))) (focus-all window))) (ml-on-click-switch-to-group (code group &rest rest) (declare (ignore rest code)) (when-let ((g (find-group (current-screen) group))) (switch-to-group g))) (ml-on-click-do-nothing (code &rest rest) (declare (ignore rest code)) nil)) (register-ml-on-click-id :ml-on-click-focus-window #'ml-on-click-focus-window) (register-ml-on-click-id :ml-on-click-switch-to-group #'ml-on-click-switch-to-group) (register-ml-on-click-id :ml-on-click-do-nothing #'ml-on-click-do-nothing)) ;;; External mode lines (defun move-mode-line-to-head (mode-line head) (cond ((not (head-mode-line head)) (setf (mode-line-head mode-line) head)) ((mode-line-head mode-line) (rotatef (mode-line-head mode-line) (mode-line-head (head-mode-line head)))))) (defun update-mode-line-position (mode-line x y) (let ((head (or (find-if (lambda (h) (and (= x (head-x h)) (>= y (head-y h)) (< y (+ (head-y h) (head-height h))))) (screen-heads (mode-line-screen mode-line))) ;; No luck. Just try to find a head without a mode-line ;; already. (find-if-not #'head-mode-line (screen-heads (mode-line-screen mode-line)))))) (when head (unless (eq head (mode-line-head mode-line)) (move-mode-line-to-head mode-line head)) (when (mode-line-head mode-line) (setf (mode-line-position mode-line) (if (< y (/ (head-height (mode-line-head mode-line)) 2)) :top :bottom)))))) (defun place-mode-line-window (screen xwin) (let ((ml (%make-mode-line :window xwin :screen screen :mode :visible :position *mode-line-position*))) (push ml *mode-lines*) (xlib:reparent-window xwin (screen-root screen) 0 0) (when (update-mode-line-position ml (xlib:drawable-x xwin) (xlib:drawable-y xwin)) (resize-mode-line ml) (xlib:map-window xwin) (sync-mode-line ml)))) ;;; Toggling (defun toggle-mode-line (screen head &optional (format '*screen-mode-line-format*)) "Toggle the state of the mode line for the specified screen" (check-type format (or symbol list string)) (let ((ml (head-mode-line head))) (if ml (case (mode-line-mode ml) (:visible ;; Hide it. (setf (mode-line-mode ml) :hidden) (xlib:unmap-window (mode-line-window ml))) (:hidden ;; Show it. (setf (mode-line-mode ml) :visible) (xlib:map-window (mode-line-window ml)) (setf (xlib:window-priority (mode-line-window ml)) :below)) (:stump ;; Delete it (destroy-mode-line ml))) (make-mode-line screen head format)) (dolist (group (screen-groups screen)) (group-sync-head group head)))) (defun enable-mode-line (screen head state &optional format) "Set the state of SCREEN's HEAD's mode-line. If STATE is T and FORMAT is specified, then the mode-line's format is updated." (check-type screen screen) (check-type head head) (check-type format (or symbol list string)) (let ((mode-line (head-mode-line head))) (cond ((and state mode-line) (when format (setf (mode-line-format mode-line) format))) (state (toggle-mode-line screen head (or format '*screen-mode-line-format*))) (mode-line (toggle-mode-line screen head))))) (defcommand mode-line () () "A command to toggle the mode line visibility." (toggle-mode-line (current-screen) (current-head))) stumpwm-22.11/module.lisp000066400000000000000000000105051433701203600154110ustar00rootroot00000000000000;; Copyright (C) 2008 Julian Stecklina, Shawn Betts, Ivy Foster ;; Copyright (C) 2014 David Bjergaard ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Use `set-module-dir' to set the location stumpwm searches for modules. ;; Code: (in-package #:stumpwm) (export '(load-module list-modules *load-path* *module-dir* init-load-path set-module-dir find-module add-to-load-path)) (defvar *module-dir* (pathname-as-directory (concat (getenv "HOME") "/.stumpwm.d/modules")) "The location of the contrib modules on your system.") (defun build-load-path (path) "Maps subdirectories of path, returning a list of all subdirs in the path which contain any files ending in .asd" (map 'list #'directory-namestring (remove-if-not (lambda (file) (equal "asd" (nth-value 1 (uiop:split-name-type (file-namestring file))))) (list-directory-recursive path t)))) (defvar *load-path* nil "A list of paths in which modules can be found, by default it is populated by any asdf systems found in `*module-dir*' set from the configure script when StumpWM was built, or later by the user using `add-to-load-path'") (define-stumpwm-type :module (input prompt) (or (argument-pop-rest input) (completing-read (current-screen) prompt (list-modules) :require-match t))) (defun find-asd-file (path) "Returns the first file ending with asd in `PATH', nil else." (first (remove-if-not (lambda (file) (uiop:string-suffix-p (file-namestring file) ".asd")) (list-directory path)))) (defun list-modules () "Return a list of the available modules." (flet ((list-module (dir) (pathname-name (find-asd-file dir)))) (flatten (mapcar #'list-module *load-path*)))) (defun find-module (name) (if name (find name (list-modules) :test #'string=) nil)) (defun ensure-pathname (path) (if (stringp path) (first (directory path)) path)) (defcommand set-contrib-dir () (:rest) "Deprecated, use `add-to-load-path' instead" (message "Use add-to-load-path instead.")) (defcommand add-to-load-path (path) ((:string "Directory: ")) "If `PATH' is not in `*LOAD-PATH*' add it, check if `PATH' contains an asdf system, and if so add it to the central registry" (let* ((pathspec (find (ensure-pathname path) *load-path*)) (in-central-registry (find pathspec asdf:*central-registry*)) (is-asdf-path (find-asd-file path))) (cond ((and pathspec in-central-registry is-asdf-path) *load-path*) ((and pathspec is-asdf-path (not in-central-registry)) (push pathspec asdf:*central-registry*)) ((and is-asdf-path (not pathspec)) (push (ensure-pathname path) asdf:*central-registry*) (push (ensure-pathname path) *load-path*)) (T *load-path*)))) (defcommand init-load-path (path) ((:string "Directory: ")) "Recursively builds a list of paths that contain modules, then add them to the load path. This is called each time StumpWM starts with the argument `*module-dir*'" (mapcar #'add-to-load-path (build-load-path path)) *load-path*) (defun set-module-dir (dir) "Sets the location of the for StumpWM to find modules" (when (stringp dir) (setf dir (pathname (concat dir "/")))) (setf *module-dir* dir) (init-load-path dir)) (defcommand load-module (name) ((:module "Load module: ")) "Loads the contributed module with the given NAME." (let ((module (find-module (string-downcase name)))) (if module (asdf:operate 'asdf:load-op module) (error "Could not load or find module: ~s" name)))) ;; End of file stumpwm-22.11/package.lisp000066400000000000000000000015661433701203600155260ustar00rootroot00000000000000;; package.lisp -- ;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . (defpackage :stumpwm (:use :cl #:alexandria) (:shadow #:yes-or-no-p #:y-or-n-p)) (defpackage :stumpwm-user (:use :cl :stumpwm)) stumpwm-22.11/pathnames.lisp000066400000000000000000000065741433701203600161170ustar00rootroot00000000000000;;; -*- Mode: Lisp -*- ;;; This code is taken from CL-FAD. Original copyright notice follows: ;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.35 2009/09/30 14:23:10 edi Exp $ ;;; Copyright (c) 2004, Peter Seibel. All rights reserved. ;;; Copyright (c) 2004-2009, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :stumpwm) (export '(list-directory pathname-as-directory)) (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC \(a pathname designator) does not designate a directory, PATHSPEC otherwise. It is irrelevant whether file or directory designated by PATHSPEC does actually exist." (uiop:directory-pathname-p pathspec)) (defun pathname-as-directory (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." (uiop:ensure-directory-pathname pathspec)) (defun directory-wildcard (dirname) "Returns a wild pathname designator that designates all files within the directory named by the non-wild pathname designator DIRNAME." (when (wild-pathname-p dirname) (error "Can only make wildcard directories from non-wildcard directories.")) (make-pathname :name :wild :type :wild :defaults (pathname-as-directory dirname))) (defun list-directory (dirname) "Returns a fresh list of pathnames corresponding to the truenames of all files within the directory named by the non-wild pathname designator DIRNAME. The pathnames of sub-directories are returned in directory form - see PATHNAME-AS-DIRECTORY." (when (wild-pathname-p dirname) (error "Can only list concrete directory names.")) (let ((wildcard (directory-wildcard dirname))) (directory wildcard))) (defun list-directory-recursive (dirname &optional flatten-p) "Returns a list of pathnames corresponding to the truenames all files within the directory and in any subdirectories. If `FLATTEN-P' is non-nil, flatten the list." (let ((files (map 'list (lambda (dir) (if (directory-pathname-p dir) (list-directory-recursive dir) dir)) (list-directory dirname)))) (if flatten-p (flatten files) files))) ;;; EOF stumpwm-22.11/primitives.lisp000066400000000000000000001471011433701203600163220ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file contains primitive data structures and functions used ;; throughout stumpwm. ;; ;; Code: (in-package :stumpwm) (export '(*suppress-abort-messages* *suppress-frame-indicator* *suppress-window-placement-indicator* *timeout-wait* *timeout-wait-multiline* *timeout-frame-indicator-wait* *frame-indicator-text* *frame-indicator-timer* *message-window-timer* *hooks-enabled-p* *command-mode-start-hook* *command-mode-end-hook* *urgent-window-hook* *new-window-hook* *new-head-hook* *destroy-window-hook* *focus-window-hook* *place-window-hook* *pre-thread-hook* *start-hook* *restart-hook* *quit-hook* *internal-loop-hook* *event-processing-hook* *focus-frame-hook* *new-frame-hook* *split-frame-hook* *remove-split-hook* *message-hook* *top-level-error-hook* *focus-group-hook* *key-press-hook* *root-click-hook* *new-mode-line-hook* *destroy-mode-line-hook* *mode-line-click-hook* *pre-command-hook* *post-command-hook* *selection-notify-hook* *menu-selection-hook* *display* *shell-program* *maxsize-border-width* *transient-border-width* *normal-border-width* *text-color* *window-events* *window-parent-events* *message-window-padding* *message-window-y-padding* *message-window-gravity* *message-window-real-gravity* *message-window-input-gravity* *editor-bindings* *input-window-gravity* *normal-gravity* *maxsize-gravity* *transient-gravity* *top-level-error-action* *window-name-source* *frame-number-map* *all-modifiers* *modifiers* *screen-list* *initializing* *processing-existing-windows* *executing-stumpwm-command* *debug-level* *debug-expose-events* *debug-stream* *window-formatters* *window-format* *group-formatters* *group-format* *list-hidden-groups* *x-selection* *last-command* *max-last-message-size* *record-last-msg-override* *suppress-echo-timeout* *run-or-raise-all-groups* *run-or-raise-all-screens* *deny-map-request* *deny-raise-request* *suppress-deny-messages* *honor-window-moves* *resize-hides-windows* *min-frame-width* *min-frame-height* *new-frame-action* *new-window-preferred-frame* *startup-message* *default-package* *window-placement-rules* *mouse-focus-policy* *root-click-focuses-frame* *banish-pointer-to* *xwin-to-window* *resize-map* *default-group-name* *window-border-style* *data-dir* add-hook clear-window-placement-rules concat data-dir-file dformat define-frame-preference redirect-all-output remove-hook remove-all-hooks run-hook run-hook-with-args command-mode-start-message command-mode-end-message split-string with-restarts-menu with-data-file move-to-head format-expand ;; Frame accessors frame-x frame-y frame-width frame-height ;; Screen accessors screen-heads screen-root screen-focus screen-float-focus-color screen-float-unfocus-color ;; Window states +withdrawn-state+ +normal-state+ +iconic-state+ ;; Modifiers modifiers modifiers-p modifiers-alt modifiers-altgr modifiers-super modifiers-meta modifiers-hyper modifiers-numlock ;; Conditions stumpwm-condition stumpwm-error stumpwm-warning ;; Completion Options *maximum-completions* ;; Minor mode keymaps *minor-mode-maps*)) ;;; Completions (defvar *maximum-completions* 100 "Maximum number of completions to show in interactive prompts. Setting this too high can crash the completion process due to drawing too far off screen.") ;;; Message Timer (defvar *suppress-abort-messages* nil "Suppress abort message when non-nil.") (defvar *timeout-wait* 5 "Specifies, in seconds, how long a message will appear for. This must be an integer.") (defvar *timeout-wait-multiline* nil "Specifies, in seconds, how long a message will more than one line will appear for. This must be an integer. If falsy, default to *timeout-wait*.") (defvar *timeout-frame-indicator-wait* 1 "The amount of time a frame indicator timeout takes.") (defvar *frame-indicator-timer* nil "Keep track of the timer that hides the frame indicator.") (defvar *frame-indicator-text* " Current Frame " "What appears in the frame indicator window?") (defvar *suppress-frame-indicator* nil "Set this to T if you never want to see the frame indicator.") (defvar *suppress-window-placement-indicator* nil "Set to T if you never want to see messages that windows were placed according to rules.") (defvar *message-window-timer* nil "Keep track of the timer that hides the message window.") ;;; Grabbed pointer (defvar *grab-pointer-count* 0 "The number of times the pointer has been grabbed.") (defvar *grab-pointer-font* "cursor" "The font used for the grabbed pointer.") (defvar *grab-pointer-character* 64 "ID of a character used for the grabbed pointer.") (defvar *grab-pointer-character-mask* 65 "ID of a character mask used for the grabbed pointer.") (defvar *grab-pointer-foreground* (xlib:make-color :red 0.0 :green 0.0 :blue 0.0) "The foreground color of the grabbed pointer.") (defvar *grab-pointer-background* (xlib:make-color :red 1.0 :green 1.0 :blue 1.0) "The background color of the grabbed pointer.") ;;; Hooks (defvar *command-mode-start-hook* '(command-mode-start-message) "A hook called whenever command mode is started") (defvar *command-mode-end-hook* '(command-mode-end-message) "A hook called whenever command mode is ended") (defvar *urgent-window-hook* '() "A hook called whenever a window sets the property indicating that it demands the user's attention") (defvar *map-window-hook* '() "A hook called whenever a window is mapped.") (defvar *unmap-window-hook* '() "A hook called whenever a window is withdrawn.") (defvar *new-window-hook* '() "A hook called whenever a window is added to the window list. This includes a genuinely new window as well as bringing a withdrawn window back into the window list.") (defvar *destroy-window-hook* '() "A hook called whenever a window is destroyed or withdrawn.") (defvar *focus-window-hook* '() "A hook called when a window is given focus. It is called with 2 arguments: the current window and the last window (could be nil).") (defvar *place-window-hook* '() "A hook called whenever a window is placed by rule. Arguments are window group and frame") (defvar *pre-thread-hook* '() "A hook called before any threads are started. Useful if you need to fork.") (defvar *start-hook* '() "A hook called when stumpwm starts.") (defvar *quit-hook* '() "A hook called when stumpwm quits.") (defvar *restart-hook* '() "A hook called when stumpwm restarts.") (defvar *internal-loop-hook* '() "A hook called inside stumpwm's inner loop.") (defvar *event-processing-hook* '() "A hook called inside stumpwm's inner loop, before the default event processing takes place. This hook is run inside (with-event-queue ...).") (defvar *focus-frame-hook* '() "A hook called when a frame is given focus. The hook functions are called with 2 arguments: the current frame and the last frame.") (defvar *new-frame-hook* '() "A hook called when a new frame is created. The hook is called with the frame as an argument.") (defvar *split-frame-hook* '() "A hook called when a frame is split. the hook is called with the old frame (window is removed), and two new frames as arguments.") (defvar *remove-split-hook* '() "A hook called when a split is removed. the hook is called with the current frame and removed frame as arguments.") (defvar *message-hook* '() "A hook called whenever stumpwm displays a message. The hook function is passed any number of arguments. Each argument is a line of text.") (defvar *top-level-error-hook* '() "Called when a top level error occurs. Note that this hook is run before the error is dealt with according to *top-level-error-action*.") (defvar *focus-group-hook* '() "A hook called whenever stumpwm switches groups. It is called with 2 arguments: the current group and the last group.") (defvar *key-press-hook* '() "A hook called whenever a key under *top-map* is pressed. It is called with 3 argument: the key, the (possibly incomplete) key sequence it is a part of, and command value bound to the key.") (defvar *root-click-hook* '() "A hook called whenever there is a mouse click on the root window. Called with 4 arguments, the screen containing the root window, the button clicked, and the x and y of the pointer.") (defvar *click-hook* '() "A hook called whenever there is a mouse click. Called with 4 arguments, the screen containing the window (or nil if there isn't one), the button clicked, and the x and y of the pointer.") (defvar *new-mode-line-hook* '() "Called whenever the mode-line is created. It is called with argument, the mode-line") (defvar *destroy-mode-line-hook* '() "Called whenever the mode-line is destroyed. It is called with argument, the mode-line") (defvar *mode-line-click-hook* '() "Called whenever the mode-line is clicked. It is called with 4 arguments, the mode-line, the button clicked, and the x and y of the pointer.") (defvar *pre-command-hook* '() "Called before a command is called. It is called with 1 argument: the command as a symbol.") (defvar *post-command-hook* '() "Called after a command is called. It is called with 1 argument: the command as a symbol.") (defvar *selection-notify-hook* '() "Called after a :selection-notify event is processed. It is called with 1 argument: the selection as a string.") (defvar *menu-selection-hook* '() "Called after an item is selected in the windows menu. It is called with 1 argument: the menu.") (defvar *new-head-hook* '() "A hook called whenever a head is added. It is called with 2 arguments: the new head and the current screen.") ;; Data types and globals used by stumpwm (defvar *display* nil "The display for the X server") (defvar *shell-program* "/bin/sh" "The shell program used by @code{run-shell-command}.") (defvar *maxsize-border-width* 1 "The width in pixels given to the borders of windows with maxsize or ratio hints.") (defvar *transient-border-width* 1 "The width in pixels given to the borders of transient or pop-up windows.") (defvar *normal-border-width* 1 "The width in pixels given to the borders of regular windows.") (defvar *text-color* "white" "The color of message text.") (defvar *draw-in-color* t "When NIL color formatters are ignored.") (defvar *menu-maximum-height* nil "Defines the maxium number of lines to display in the menu before enabling scrolling. If NIL scrolling is disabled.") (defvar *menu-scrolling-step* 1 "Number of lines to scroll when hitting the menu list limit.") (defparameter +netwm-supported+ '(:_NET_SUPPORTING_WM_CHECK :_NET_NUMBER_OF_DESKTOPS :_NET_DESKTOP_GEOMETRY :_NET_DESKTOP_VIEWPORT :_NET_CURRENT_DESKTOP :_NET_WM_WINDOW_TYPE :_NET_WM_STATE :_NET_WM_STATE_MODAL :_NET_WM_ALLOWED_ACTIONS :_NET_WM_STATE_FULLSCREEN :_NET_WM_STATE_HIDDEN :_NET_WM_STATE_DEMANDS_ATTENTION :_NET_WM_FULL_WINDOW_PLACEMENT :_NET_CLOSE_WINDOW :_NET_CLIENT_LIST :_NET_CLIENT_LIST_STACKING :_NET_ACTIVE_WINDOW :_NET_WM_DESKTOP :_KDE_NET_SYSTEM_TRAY_WINDOW_FOR) "Supported NETWM properties. Window types are in +WINDOW-TYPES+.") (defparameter +netwm-allowed-actions+ '(:_NET_WM_ACTION_CHANGE_DESKTOP :_NET_WM_ACTION_FULLSCREEN :_NET_WM_ACTION_CLOSE) "Allowed NETWM actions for managed windows") (defparameter +netwm-window-types+ '( ;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop) (:_NET_WM_WINDOW_TYPE_DOCK . :dock) ;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar) ;; (:_NET_WM_WINDOW_TYPE_MENU . :menu) ;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility) ;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash) (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog) (:_NET_WM_WINDOW_TYPE_NORMAL . :normal)) "Alist mapping NETWM window types to keywords. Include only those we are ready to support.") ;; Window states (defconstant +withdrawn-state+ 0) (defconstant +normal-state+ 1) (defconstant +iconic-state+ 3) (defvar *window-events* '(:structure-notify :property-change :colormap-change :focus-change :enter-window) "The events to listen for on managed windows.") (defvar *window-parent-events* '(:substructure-notify :substructure-redirect) "The events to listen for on managed windows' parents.") ;; Message window variables (defvar *message-window-padding* 5 "The number of pixels that pad the text in the message window.") (defvar *message-window-y-padding* 0 "The number of pixels that pad the text in the message window vertically.") (defvar *message-window-gravity* :top-right "This variable controls where the message window appears. The following are valid values. @table @asis @item :top-left @item :top-right @item :bottom-left @item :bottom-right @item :center @item :top @item :left @item :right @item :bottom @end table") (defvar *message-window-input-gravity* :top-left "This variable controls where the message window appears when the input window is being displayed. The following are valid values. @table @asis @item :top-left @item :top-right @item :bottom-left @item :bottom-right @item :center @item :top @item :left @item :right @item :bottom @end table") ;; line editor (defvar *editor-bindings* nil "A list of key-bindings for line editing.") (defvar *input-window-gravity* :top-right "This variable controls where the input window appears. The following are valid values. @table @asis @item :top-left @item :top-right @item :bottom-left @item :bottom-right @item :center @item :top @item :left @item :right @item :bottom @end table") ;; default values. use the set-* functions to these attributes (defparameter +default-foreground-color+ "White") (defparameter +default-background-color+ "Black") (defparameter +default-window-background-color+ "Black") (defparameter +default-border-color+ "White") (defparameter +default-font-name+ "9x15") (defparameter +default-focus-color+ "White") (defparameter +default-unfocus-color+ "Black") (defparameter +default-float-focus-color+ "Orange") (defparameter +default-float-unfocus-color+ "SteelBlue4") (defparameter +default-frame-outline-width+ 2) ;; Don't set these variables directly, use set- instead (defvar *normal-gravity* :center) (defvar *maxsize-gravity* :center) (defvar *transient-gravity* :center) (declaim (type (member :message :break :abort) *top-level-error-action*)) (defvar *top-level-error-action* :abort "If an error is encountered at the top level, in STUMPWM-INTERNAL-LOOP, then this variable decides what action shall be taken. By default it will print a message to the screen and to *standard-output*. Valid values are :message, :break, :abort. :break will break to the debugger. This can be problematic because if the user hit's a mapped key the ENTIRE keyboard will be frozen and you will have to login remotely to regain control. :abort quits stumpwm.") (defvar *window-name-source* :title "This variable controls what is used for the window's name. The default is @code{:title}. @table @code @item :title Use the window's title given to it by its owner. @item :class Use the window's resource class. @item :resource-name Use the window's resource name. @end table") (defclass swm-class () ((new-objects :initform nil :accessor swm-class-new-objects :allocation :class :documentation "Track all newly created objects in order to mix in the appropriate minor modes when they are touched"))) (defmethod initialize-instance :after ((obj swm-class) &key &allow-other-keys) ;; Register all newly created objects so that they can have the relevant minor ;; modes autoenabled. (pushnew obj (swm-class-new-objects obj) :test #'eq)) (defgeneric print-swm-object (object stream) (:method (object stream) (format stream "~A" (type-of object)))) (defmethod print-object ((object swm-class) stream) (print-unreadable-object (object stream) (print-swm-object object stream) (when-let ((minor-modes (list-minor-modes object))) (format stream " :MINOR-MODES ~A" minor-modes)))) (defun make-swm-class-instance (class &rest initargs) "Make an instance of a StumpWM class and autoenable any relevant minor modes. CLASS must be a symbol denoting a class which descends, directly or indirectly, from swm-class. INITARGS must be all initargs one would pass to make-instance." ;; This is implemented as a function instead of as an after method for ;; initialize-instance because autoenabling a minor mode involves changing the ;; class of the object, which is implied to be undefined behavior if called ;; within a method which accesses the objects slots. (declare (special *active-global-minor-modes*)) (let ((object (apply #'make-instance class initargs))) (prog1 object (loop for class in *active-global-minor-modes* when (typep object (scope-type (minor-mode-scope class))) do (autoenable-minor-mode class object)) (setf (swm-class-new-objects object) (remove object (swm-class-new-objects object) :test #'eq))))) (defmacro define-swm-class (class-name superclasses slots &rest options) "Define a class and a method for DYNAMIC-MIXINS:REPLACE-CLASS which specializes upon the class and replaces it. If SUPERCLASSES is NIL then (SWM-CLASS) is used." (unless superclasses (setq superclasses '(swm-class))) `(progn (defclass ,class-name ,superclasses ,slots ,@options) (defmethod dynamic-mixins:replace-class ((object ,class-name) new &rest r) (apply #'dynamic-mixins:replace-class-in-mixin object new ',class-name r)))) (define-swm-class frame () ((number :initform nil :initarg :number :accessor frame-number) (x :initform nil :accessor frame-x :initarg :x) (y :initform nil :accessor frame-y :initarg :y) (width :initform nil :accessor frame-width :initarg :width) (height :initform nil :accessor frame-height :initarg :height) (window :initform nil :accessor frame-window :initarg :window))) (defmethod print-swm-object ((object frame) stream) (format stream "FRAME ~d ~a ~d ~d ~d ~d" (frame-number object) (frame-window object) (frame-x object) (frame-y object) (frame-width object) (frame-height object))) (defun frame-p (object) (typep object 'frame)) (defun make-frame (&rest rest &key number x y width height window) (declare (ignore number x y width height window)) (apply 'make-swm-class-instance 'frame rest)) (defun copy-frame (instance) (make-swm-class-instance 'frame :number (frame-number instance) :x (frame-x instance) :y (frame-y instance) :width (frame-width instance) :height (frame-height instance) :window (frame-window instance))) (define-swm-class head (frame) ((name :initform "" :accessor head-name :initarg :name))) (defmethod print-swm-object ((object head) stream) (write-string "HEAD-" stream) (call-next-method)) ;; duplicate frame accessors for heads. (macrolet ((define-head-accessor (name) (let ((pkg (find-package :stumpwm))) `(progn (defgeneric ,(intern (format nil "HEAD-~A" (symbol-name name)) pkg) (head) (:method ((head head)) (,(intern (format nil "FRAME-~A" (symbol-name name)) pkg) head))) (defmethod (setf ,(intern (format nil "HEAD-~A" (symbol-name name)) pkg)) (new (head head)) (setf (,(intern (format nil "FRAME-~A" (symbol-name name)) pkg) head) new)))))) (define-head-accessor number) (define-head-accessor x) (define-head-accessor y) (define-head-accessor width) (define-head-accessor height) (define-head-accessor window)) (defun head-p (object) (typep object 'head)) (defun make-head (&rest rest &key number x y width height window name) (declare (ignore number x y width height window name)) (apply 'make-swm-class-instance 'head rest)) (defun copy-head (instance) (make-swm-class-instance 'head :number (frame-number instance) :x (frame-x instance) :y (frame-y instance) :width (frame-width instance) :height (frame-height instance) :window (frame-window instance) :name (head-name instance))) (define-swm-class screen () ((id :initarg :id :reader screen-id) (host :initarg :host :reader screen-host) (number :initarg :number :reader screen-number) (heads :initform () :accessor screen-heads) (groups :initform () :accessor screen-groups) (current-group :accessor screen-current-group) ;; various colors (as returned by alloc-color) (border-color :initarg :border-color :accessor screen-border-color) (fg-color :initarg :fg-color :accessor screen-fg-color) (bg-color :initarg :bg-color :accessor screen-bg-color) (win-bg-color :initarg :win-bg-color :accessor screen-win-bg-color) (focus-color :initarg :focus-color :accessor screen-focus-color) (unfocus-color :initarg :unfocus-color :accessor screen-unfocus-color) (float-focus-color :initarg :float-focus-color :accessor screen-float-focus-color) (float-unfocus-color :initarg :float-unfocus-color :accessor screen-float-unfocus-color) (msg-border-width :initarg :msg-border-width :accessor screen-msg-border-width) (frame-outline-width :initarg :frame-outline-width :accessor screen-frame-outline-width) (fonts :initarg :fonts :accessor screen-fonts) (mapped-windows :initform () :accessor screen-mapped-windows :documentation "A list of all mapped windows. These are the raw xlib:window's. window structures are stored in groups.") (withdrawn-windows :initform () :accessor screen-withdrawn-windows :documentation "A list of withdrawn windows. These are of type stumpwm::window and when they're mapped again they'll be put back in the group they were in when they were unmapped unless that group doesn't exist, in which case they go into the current group.") (urgent-windows :initform () :accessor screen-urgent-windows :documentation "a list of windows for which (window-urgent-p) currently true.") (input-window :initarg :input-window :reader screen-input-window) (key-window :initarg :key-window :reader screen-key-window :documentation "the window that accepts further keypresses after a toplevel key has been pressed.") (focus-window :initarg :focus-window :reader screen-focus-window :documentation "The window that gets focus when no window has focus") (frame-window :initarg :frame-window :reader screen-frame-window) (frame-outline-gc :initarg :frame-outline-gc :reader screen-frame-outline-gc) ;; color contexts (message-cc :initarg :message-cc :reader screen-message-cc) ;; color maps (color-map-normal :initform nil :accessor screen-color-map-normal) (color-map-bright :initform nil :accessor screen-color-map-bright) (ignore-msg-expose :initform 0 :accessor screen-ignore-msg-expose :documentation "used to ignore the first expose even when mapping the message window.") ;; the window that has focus (focus :initform nil :accessor screen-focus) (current-msg :initform nil :accessor screen-current-msg) (current-msg-highlights :initform nil :accessor screen-current-msg-highlights) (last-msg :initform nil :accessor screen-last-msg) (last-msg-highlights :initform nil :accessor screen-last-msg-highlights))) (defstruct ccontext screen win px gc default-fg default-bright default-bg fg bg brightp reversep color-stack font) (defvar *window-number-map* "0123456789" "Set this to a string to remap the window numbers to something more convenient.") (defvar *group-number-map* "1234567890" "Set this to a string to remap the group numbers to something more convenient.") (defvar *frame-number-map* "0123456789abcdefghijklmnopqrstuvwxyz" "Set this to a string to remap the frame numbers to more convenient keys. For instance, \"hutenosa\" would map frame 0 to 7 to be selectable by hitting the appropriate homerow key on a dvorak keyboard. Currently, only single char keys are supported. By default, the frame labels are the 36 (lower-case) alphanumeric characters, starting with numbers 0-9.") (defun get-frame-number-translation (frame) "Given a frame return its number translation using *frame-number-map* as a char." (let ((num (frame-number frame))) (if (< num (length *frame-number-map*)) (char *frame-number-map* num) ;; translate the frame number to a char. FIXME: it loops after 9 (char (prin1-to-string num) 0)))) (defstruct modifiers (meta nil) (alt nil) (hyper nil) (super nil) (altgr nil) (numlock nil)) (defvar *all-modifiers* nil "A list of all keycodes that are considered modifiers") (defvar *modifiers* nil "A mapping from modifier type to x11 modifier.") (defmethod print-swm-object ((object screen) stream) (format stream "SCREEN ~s" (screen-number object))) (defvar *screen-list* '() "The list of screens managed by stumpwm.") (defvar *initializing* nil "True when starting stumpwm. Use this variable in your rc file to run code that should only be executed once, when stumpwm starts up and loads the rc file.") (defvar *processing-existing-windows* nil "True when processing pre-existing windows at startup.") (defvar *executing-stumpwm-command* nil "True when executing external commands.") (defvar *interactivep* nil "True when a defcommand is executed from colon or a keybinding") ;;; The restarts menu macro (defmacro with-restarts-menu (&body body) "Execute BODY. If an error occurs allow the user to pick a restart from a menu of possible restarts. If a restart is not chosen, resignal the error." (let ((c (gensym))) `(handler-bind ((warning #'muffle-warning) ((or serious-condition error) (lambda (,c) (restarts-menu ,c) (signal ,c)))) ,@body))) ;;; Hook functionality (defvar *hooks-enabled-p* t "Controls whether hooks will actually run or not") (defun run-hook-with-args (hook &rest args) "Call each function in HOOK and pass args to it." (when *hooks-enabled-p* (handler-case (with-simple-restart (abort-hooks "Abort running the remaining hooks.") (with-restarts-menu (dolist (fn hook) (with-simple-restart (continue-hooks "Continue running the remaining hooks.") (apply fn args))))) (t (c) (message "^B^1*Error on hook ^b~S^B!~% ^n~A" hook c) (values nil c))))) (defun run-hook (hook) "Call each function in HOOK." (run-hook-with-args hook)) (defmacro add-hook (hook fn) "Add @var{function} to the @var{hook-variable}. For example, to display a message whenever you switch frames: @example \(defun my-rad-fn (to-frame from-frame) (stumpwm:message \"Mustard!\")) \(stumpwm:add-hook stumpwm:*focus-frame-hook* 'my-rad-fn) @end example" `(setf ,hook (adjoin ,fn ,hook))) (defmacro remove-hook (hook fn) "Remove the specified function from the hook." `(setf ,hook (remove ,fn ,hook))) (defmacro remove-all-hooks (hook) "Remove all functions from a hook" `(setf ,hook NIL)) ;; Misc. utility functions (defun sort1 (list sort-fn &rest keys &key &allow-other-keys) "Return a sorted copy of list." (let ((copy (copy-list list))) (apply 'sort copy sort-fn keys))) (defun find-free-number (l &optional (min 0) dir) "Return a number that is not in the list l. If dir is :negative then look for a free number in the negative direction. anything else means positive direction." (let* ((dirfn (if (eq dir :negative) '> '<)) ;; sort it and crop numbers below/above min depending on dir (nums (sort (remove-if (lambda (n) (funcall dirfn n min)) l) dirfn)) (max (car (last nums))) (inc (if (eq dir :negative) -1 1)) (new-num (loop for n = min then (+ n inc) for i in nums when (/= n i) do (return n)))) (dformat 3 "Free number: ~S~%" nums) (if new-num new-num ;; there was no space between the numbers, so use the max+inc (if max (+ inc max) min)))) (defun split-seq (seq separators &key test default-value) "Split a sequence into subsequences given the list of seperators." (let ((seps separators)) (labels ((sep (c) (position c seps :test test))) (or (loop for i = (position-if (complement #'sep) seq) then (position-if (complement #'sep) seq :start j) as j = (position-if #'sep seq :start (or i 0)) while i collect (subseq seq i j) while j) ;; the empty seq causes the above to return NIL, so help ;; it out a little. default-value)))) (defun split-string (string &optional (separators " ")) "Splits STRING into substrings where there are matches for SEPARATORS. Each match for SEPARATORS is a splitting point. The substrings between the splitting points are made into a list which is returned. ***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\". If there is match for SEPARATORS at the beginning of STRING, we do not include a null substring for that. Likewise, if there is a match at the end of STRING, we don't include a null substring for that. Modifies the match data; use `save-match-data' if necessary." (split-seq string separators :test #'char= :default-value '(""))) (defun match-all-regexps (regexps target-string &key (case-insensitive t)) "Return T if TARGET-STRING matches all regexps in REGEXPS. REGEXPS can be a list of strings (one regexp per element) or a single string which is split to obtain the individual regexps. " (let* ((regexps (if (listp regexps) regexps (split-string regexps " ")))) (loop for pattern in regexps always (let ((scanner (ppcre:create-scanner pattern :case-insensitive-mode case-insensitive))) (ppcre:scan scanner target-string))))) (defun insert-before (list item nth) "Insert ITEM before the NTH element of LIST." (declare (type (integer 0 *) nth)) (let* ((nth (min nth (length list))) (pre (subseq list 0 nth)) (post (subseq list nth))) (nconc pre (list item) post))) ;;; ;;; formatting routines (defun format-expand (fmt-alist fmt &rest args) (let* ((chars (coerce fmt 'list)) (output "") (cur chars)) ;; FIXME: this is horribly inneficient (loop (cond ((null cur) (return-from format-expand output)) ;; if % is the last char in the string then it's a literal. ((and (char= (car cur) #\%) (cdr cur)) (setf cur (cdr cur)) (let* ((tmp (loop while (and cur (char<= #\0 (car cur) #\9)) collect (pop cur))) (len (and tmp (parse-integer (coerce tmp 'string)))) ;; So that eg "%25^t" will trim from the left (from-left-p (when (char= #\^ (car cur)) (pop cur)))) (if (null cur) (format t "%~a~@[~a~]" len from-left-p) (let* ((fmt (cadr (assoc (car cur) fmt-alist :test 'char=))) (str (cond (fmt ;; it can return any type, not jut as string. (format nil "~a" (apply fmt args))) ((char= (car cur) #\%) (string #\%)) (t (concatenate 'string (string #\%) (string (car cur))))))) ;; crop string if needed (setf output (concatenate 'string output (cond ((null len) str) ((not from-left-p) ; Default behavior (subseq str 0 (min len (length str)))) ;; New behavior -- trim from the left (t (subseq str (max 0 (- (length str) len))))))) (setf cur (cdr cur)))))) (t (setf output (concatenate 'string output (string (car cur))) cur (cdr cur))))))) (defvar *window-formatters* '((#\n window-map-number) (#\s fmt-window-status) (#\t window-name) (#\c window-class) (#\i window-res) (#\r window-role) (#\m fmt-window-marked) (#\h window-height) (#\w window-width) (#\g gravity-for-window)) "an alist containing format character format function pairs for formatting window lists.") (defvar *window-format* "%m%n%s%50t" "This variable decides how the window list is formatted. It is a string with the following formatting options: @table @asis @item %n Substitutes the window's number translated via *window-number-map*, if there are more windows than *window-number-map* then will use the window-number. @item %s Substitute the window's status. * means current window, + means last window, and - means any other window. @item %t Substitute the window's name. @item %c Substitute the window's class. @item %i Substitute the window's resource ID. @item %m Draw a # if the window is marked. @end table Note, a prefix number can be used to crop the argument to a specified size. For instance, @samp{%20t} crops the window's title to 20 characters.") (defvar *window-info-format* "%wx%h %n (%t)" "The format used in the info command. See @var{*window-format*} for formatting details.") (defparameter *window-format-by-class* "%m%n %c %s%50t" "The format used in the info winlist-by-class command. See @var{*window-format*} for formatting details.") (defvar *group-formatters* '((#\n group-map-number) (#\s fmt-group-status) (#\t group-name)) "An alist of characters and formatter functions. The character can be used as a format character in @var{*group-format*}. When the character is encountered in the string, the corresponding function is called with a group as an argument. The functions return value is inserted into the string. If the return value isn't a string it is converted to one using @code{prin1-to-string}.") (defvar *group-format* "%n%s%t" "The format string that decides what information will show up in the group listing. The following format options are available: @table @asis @item %n Substitutes the group number translated via *group-number-map*, if there are more windows than *group-number-map* then will use the group-number. @item %s The group's status. Similar to a window's status. @item %t The group's name. @end table") (defvar *list-hidden-groups* nil "Controls whether hidden groups are displayed by 'groups' and 'vgroups' commands") ;; (defun font-height (font) ;; (+ (font-descent font) ;; (font-ascent font))) (defvar *x-selection* nil "This is a plist of stumpwm's current selections. The different properties are generally set when killing text in the input bar.") (defvar *last-command* nil "Set to the last interactive command run.") (defvar *max-last-message-size* 20 "how many previous messages to keep.") (defvar *record-last-msg-override* nil "assign this to T and messages won't be recorded. It is recommended this is assigned using LET.") (defvar *suppress-echo-timeout* nil "Assign this T and messages will not time out. It is recommended to assign this using LET.") (defvar *ignore-echo-timeout* nil "Assign this T and the message time out won't be touched. It is recommended to assign this using LET.") (defvar *run-or-raise-all-groups* t "When this is @code{T} the @code{run-or-raise} function searches all groups for a running instance. Set it to NIL to search only the current group.") (defvar *run-or-raise-all-screens* nil "When this is @code{T} the @code{run-or-raise} function searches all screens for a running instance. Set it to @code{NIL} to search only the current screen. If @var{*run-or-raise-all-groups*} is @code{NIL} this variable has no effect.") (defvar *deny-map-request* nil "A list of window properties that stumpwm should deny matching windows' requests to become mapped for the first time.") (defvar *deny-raise-request* nil "Exactly the same as @var{*deny-map-request*} but for raise requests. Note that no denial message is displayed if the window is already visible.") (defvar *suppress-deny-messages* nil "For complete focus on the task at hand, set this to @code{T} and no raise/map denial messages will be seen.") (defvar *honor-window-moves* t "Allow windows to move between frames.") (defvar *resize-hides-windows* nil "Set to T to hide windows during interactive resize") (defun deny-request-p (window deny-list) (or (eq deny-list t) (and (listp deny-list) (find-if (lambda (props) (apply 'window-matches-properties-p window props)) deny-list) t))) (defun list-splice-replace (item list &rest replacements) "splice REPLACEMENTS into LIST where ITEM is, removing ITEM. Return the new list." (let ((p (position item list))) (if p (nconc (subseq list 0 p) replacements (subseq list (1+ p))) list))) (defvar *min-frame-width* 50 "The minimum width a frame can be. A frame will not shrink below this width. Splitting will not affect frames if the new frame widths are less than this value.") (defvar *min-frame-height* 50 "The minimum height a frame can be. A frame will not shrink below this height. Splitting will not affect frames if the new frame heights are less than this value.") (defvar *new-frame-action* :last-window "When a new frame is created, this variable controls what is put in the new frame. Valid values are @table @code @item :empty The frame is left empty @item :last-window The last focused window that is not currently visible is placed in the frame. This is the default. @end table") (defvar *new-window-preferred-frame* '(:focused) "This variable controls what frame a new window appears in. It is a list of preferences. The first preference that is satisfied is used. Valid list elements are as follows: @table @code @item :focused Choose the focused frame. @item :last Choose the last focused frame. @item :empty Choose any empty frame. @item :unfocused Choose any unfocused frame. @end table Alternatively, it can be set to a function that takes one argument, the new window, and returns the preferred frame or a list of the above preferences.") (defun backtrace-string () "Similar to print-backtrace, but return the backtrace as a string." (with-output-to-string (*standard-output*) (print-backtrace))) (defvar *startup-message* "^2*Welcome to The ^BStump^b ^BW^bindow ^BM^banager! Press ^5*~a ?^2* for help." "This is the message StumpWM displays when it starts. Set it to NIL to suppress.") (defvar *default-package* (find-package '#:stumpwm-user) "This is the package eval reads and executes in. You might want to set this to @code{:stumpwm} if you find yourself using a lot of internal stumpwm symbols. Setting this variable anywhere but in your rc file will have no effect.") (defun concat (&rest strings) (apply 'concatenate 'string strings)) (defvar *window-placement-rules* '() "List of rules governing window placement. Use define-frame-preference to add rules") (defmacro define-frame-preference (target-group &body frame-rules) "Create a rule that matches windows and automatically places them in a specified group and frame. Each frame rule is a lambda list: @example \(frame-number raise lock &key from-group create restore dump-name class class-not instance instance-not type type-not role role-not title title-not match-properties-and-function match-properties-or-function) @end example @table @var @item target-group When nil, rule applies in the current group. When non nil, @var{lock} determines applicability of rule @item frame-number The frame number to send matching windows to @item raise When non-nil, raise and focus the window in its frame @item lock When this is nil, this rule will only match when @var{target-group} matches the group designated by @var{from-group}. When non-nil, this rule matches regardless of the group and the window is sent to @var{target-group}. If @var{lock} and @var{raise} are both non-nil, then stumpwm will jump to the specified group and focus the matched window. @item from-group When @var{lock} is NIL, and this is non-NIL, this rule will only match when @var{target-group} matches @var{from-group}. This should be set to either a group name(a string), or an expression that returns a group(e.g (current-group)). When this is NIL, the rule matches if @var{target-group} matches the group the window is in, or the current group if the window has no group. @item create When non-NIL the group is created and eventually restored when the value of create is a group dump filename in *DATA-DIR*. Defaults to NIL. @item restore When non-NIL the group is restored even if it already exists. This arg should be set to the dump filename to use for forced restore. Defaults to NIL @item class The windows class must match @var{class}. @item class-not The windows class must not match @var{class-not} @item instance The windows instance/resource name must match @var{instance}. @item instance-not The windows instance/resource name must not match @var{instance-not}. @item type The windows type must match @var{type}. @item type-not The windows type must not match @var{type-not}. @item role The windows role must match @var{role}. @item role-not The windows role must not match @var{role-not}. @item title The windows title must match @var{title}. @item title-not The windows title must not match @var{title-not}. @item match-properties-and-function A function that, if provided, must return true alongside the provided properties in order for the rule to match. This function takes one argument, the window. Must be an unquoted symbol to be looked up at runtime. @item match-properties-or-function A function that, if provided and returning true, will cause the rule to match regardless of whether the window properties match. Takes one argument, the window. Must be an unquoted symbol to be looked up at runtime. @end table" (let ((x (gensym "X"))) `(dolist (,x ',frame-rules) ;; verify the correct structure (destructuring-bind (frame-number raise lock &rest keys) ,x (push (list* ,target-group frame-number raise lock keys) *window-placement-rules*))))) (defun clear-window-placement-rules () "Clear all window placement rules." (setf *window-placement-rules* nil)) (defvar *fullscreen-in-frame-p-window-functions* nil "A alist of predicate functions for determining if a window should be fullscreen in frame.") (defun fullscreen-in-frame-p (win) (some (lambda (r) (let ((res (funcall (cdr r) win))) (when res (dformat 3 "Fullscreen in frame selector ~A matches window ~A" (car r) win)) res)) *fullscreen-in-frame-p-window-functions*)) (defun add-fullscreen-in-frame-rule (name function &key shadow) "Add a function to the fullscreen-in-frame window rules alist. If @var{NAME} already exists as a key in the alist and @var{SHADOW} is nil, then @var{FUNCTION} replaces the existing value. Otherwise @var{NAME} and @var{FUNCTION} are pushed onto the alist." (let ((present (assoc name *fullscreen-in-frame-p-window-functions*))) (if (and present (not shadow)) (setf (cdr present) function) (push (cons name function) *fullscreen-in-frame-p-window-functions*)))) (defun remove-fullscreen-in-frame-rule (name &key count) "Remove rules named @var{NAME} from the fullscreen-in-frame window rules alist. If @var{COUNT} is NIL then all matching rules are removed, otherwise only the first @var{COUNT} rules are removed." (setf *fullscreen-in-frame-p-window-functions* (remove name *fullscreen-in-frame-p-window-functions* :key #'car :count count))) (defmacro define-fullscreen-in-frame-rule (name (window-argument) &body body) "Define a rule for a window to be fullscreened within the frame. Each rule is a function which will be called when a window is made fullscreen. If the rule returns NIL then the fullscreen window takes up the entire head, otherwise it takes up only its frame. Within the body of the rule @var{WINDOW-ARGUMENT} is bound to the window being processed." `(flet ((,name (,window-argument) ,@body)) (add-fullscreen-in-frame-rule ',name #',name))) (defvar *mouse-focus-policy* :ignore "The mouse focus policy decides how the mouse affects input focus. Possible values are :ignore, :sloppy, and :click. :ignore means stumpwm ignores the mouse. :sloppy means input focus follows the mouse; the window that the mouse is in gets the focus. :click means input focus is transfered to the window you click on. If *MOUSE-FOCUS-POLICY* holds any value other than those listed above, mouse focus will behave as though it contains :IGNORE") (defvar *root-click-focuses-frame* t "Set to NIL if you don't want clicking the root window to focus the frame containing the pointer.") (defvar *banish-pointer-to* :head "Where to put the pointer when no argument is given to (banish-pointer) or the banish command. May be one of :screen :head :frame or :window") (defvar *xwin-to-window* (make-hash-table) "Hash table for looking up windows quickly.") (defvar *resize-map* nil "The keymap used for resizing a window") (defvar *default-group-name* "Default" "The name of the default group.") (defmacro with-focus (xwin &body body) "Set the focus to xwin, do body, then restore focus" `(progn (grab-keyboard ,xwin) (unwind-protect (progn ,@body) (ungrab-keyboard)))) (defvar *last-unhandled-error* nil "If an unrecoverable error occurs, this variable will contain the condition and the backtrace.") (defvar *show-command-backtrace* nil "When this is T a backtrace is displayed with errors that occurred within an interactive call to a command.") (defvar *window-border-style* :thick "This controls the appearance of the border around windows. valid values are: @table @var @item :thick All space within the frame not used by the window is dedicated to the border. @item :thin Only the border width as controlled by *maxsize-border-width* *normal-border-width* and *transient-border-width* is used as the border. The rest is filled with the unfocus color. @item :tight The same as :thin but the border surrounds the window and the wasted space within the frame is not obscured, revealing the background. @item :none Like :tight but no border is ever visible. @end table After changing this variable you may need to call sync-all-frame-windows to see the change.") (defvar *data-dir* nil "The directory used by stumpwm to store data between sessions.") (defun data-dir-file (name &optional type) "Return a pathname inside stumpwm's data dir with the specified name and type" (ensure-directories-exist *data-dir*) (make-pathname :name name :type type :defaults *data-dir*)) (defmacro with-data-file ((s file &rest keys &key (if-exists :supersede) &allow-other-keys) &body body) "Open a file in StumpWM's data directory. keyword arguments are sent directly to OPEN. Note that IF-EXISTS defaults to :supersede, instead of :error." (declare (ignorable if-exists)) `(progn (ensure-directories-exist *data-dir*) (with-open-file (,s ,(merge-pathnames file *data-dir*) ,@keys) ,@body))) (defmacro move-to-head (list elt) "Move the specified element in in LIST to the head of the list." `(progn (setf ,list (remove ,elt ,list)) (push ,elt ,list))) (define-condition stumpwm-condition (condition) ((message :initarg :message :reader warning-message)) (:documentation "Any stumpmwm specific condition should inherit from this.") (:report (lambda (condition stream) (format stream "~A~%" (warning-message condition))))) (define-condition stumpwm-error (stumpwm-condition error) () (:documentation "Any stumpwm specific error should inherit this.")) (define-condition stumpwm-warning (warning stumpwm-condition) () (:documentation "Adds a message slot to warning. Any stumpwm specific warning should inherit from this.")) (defun intern1 (thing &optional (package *package*) (rt *readtable*)) "A DWIM intern." (intern (ecase (readtable-case rt) (:upcase (string-upcase thing)) (:downcase (string-downcase thing)) ;; Prooobably this is what they want? It could make sense to ;; upcase them as well. (:preserve thing) (:invert (string-downcase thing))) package)) (defun command-mode-start-message () (message "Press C-g to exit command-mode.")) (defun command-mode-end-message () (message "Exited command-mode.")) (defstruct (mode-line (:constructor %make-mode-line)) screen head window format position contents cc height factor (mode :stump) on-click-bounds new-bounds) (defstruct timer time repeat function args) (defvar *minor-mode-maps* () "A list of minor mode keymaps. An element of the list may be a single keymap or a function. If an element is a function it must take a group instance and return a list of keymaps.") (defvar *custom-command-filters* () "A list of functions which take a group instance and a command structure, and return true when the command should be active.") stumpwm-22.11/remap-keys.lisp000066400000000000000000000113521433701203600162020ustar00rootroot00000000000000;; Copyright (C) 2018 Ram Krishnan ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Provides a simple way to remap keybindings in applications running ;; under StumpWM ;; ;; Code: (in-package #:stumpwm) (export '(define-remapped-keys *remapped-keys-enabled-p*)) (defvar *remap-keys-window-match-list* nil) (defvar *remapped-keys-enabled-p* t "Bool to toggle remapped-keys on/off. Defaults to t ") (defun find-remap-keys-by-window (window) (first (member-if (lambda (pattern) (cond ((stringp pattern) (string-match (window-class window) pattern)) ((or (symbolp pattern) (functionp pattern)) (funcall pattern window)))) *remap-keys-window-match-list* :key 'car))) (defun make-remap-keys (kmap) (labels ((as-list (x) (if (consp x) x (list x))) (validated-kbd (key) (or (kbd key) (throw 'error (format nil "Invalid keyspec: ~S" key))))) (mapcar (lambda (kspec) (let ((src-key (car kspec)) (target-keyseq (as-list (cdr kspec)))) (cons src-key (mapcar #'validated-kbd target-keyseq)))) kmap))) (defun remap-keys-grab-keys (win) (let* ((keymap (cdr (find-remap-keys-by-window win))) (src-keys (mapcar 'car keymap))) (dolist (key src-keys) (xwin-grab-key (window-xwin win) (kbd key))))) (defun remap-keys-focus-window-hook (new-focus cur-focus) (declare (ignorable cur-focus)) (when new-focus (remap-keys-grab-keys new-focus))) (defun remap-keys-event-handler (code state) (let* ((raw-key (code-state->key code state)) (window (current-window)) (keymap (when window (cdr (find-remap-keys-by-window window)))) (keys (cdr (assoc (print-key raw-key) keymap :test 'equal)))) (when keys (dolist (key keys) (send-fake-key window (if *remapped-keys-enabled-p* key raw-key))) t))) (defun define-remapped-keys (specs) "Define the keys to be remapped and their mappings. The SPECS argument needs to be of the following structure: (regexp-or-function . ((\"key-to-remap\" . ) ...)) EXAMPLE: (define-remapped-keys '((\"Firefox\" (\"C-n\" . \"Down\") (\"C-p\" . \"Up\") (\"C-k\" . (\"C-S-End\" \"C-x\"))))) The above form remaps Ctrl-n to Down arrow, and Ctrl-p to Up arrow keys. The Ctrl-k key is remapped to the sequence of keys Ctrl-Shift-End followed by Ctrl-x." (setq *custom-key-event-handler* nil *remap-keys-window-match-list* (mapcar (lambda (spec) (let ((pattern (car spec)) (kmap (cdr spec))) (cons pattern (make-remap-keys kmap)))) specs)) (when *remap-keys-window-match-list* (add-hook *focus-window-hook* 'remap-keys-focus-window-hook) (setq *custom-key-event-handler* 'remap-keys-event-handler))) (defcommand send-raw-key () () "Prompts for a key and forwards it to the CURRENT-WINDOW." (message "Press a key to send: ") (let* ((screen (current-screen)) (win (screen-current-window screen)) (k (with-focus (screen-key-window screen) (read-key-no-modifiers))) (code (car k)) (state (cdr k))) (unmap-message-window screen) (when win (let ((xwin (window-xwin win))) (dolist (event '(:key-press :key-release)) (xlib:send-event xwin event (xlib:make-event-mask event) :display *display* :root (screen-root screen) ;; Apparently we need these in here, though they ;; make no sense for a key event. :x 0 :y 0 :root-x 0 :root-y 0 :window xwin :event-window xwin :code code :state state)))))) stumpwm-22.11/replace-class.lisp000066400000000000000000000101261433701203600166410ustar00rootroot00000000000000(in-package :dynamic-mixins) (defgeneric replace-class-in-mixin (object new-class old-class &rest initargs) (:method ((object standard-object) n o &rest rest) (declare (ignore o)) (apply #'change-class object n rest))) (defmethod replace-class-in-mixin ((object mixin-object) (new-class class) (old-class class) &rest rest) (apply #'replace-class-in-mixin object (class-name new-class) (class-name old-class) rest)) (defmethod replace-class-in-mixin ((object mixin-object) (new-class class) (old-class symbol) &rest rest) (apply #'replace-class-in-mixin object (class-name new-class) old-class rest)) (defmethod replace-class-in-mixin ((object mixin-object) (new-class symbol) (old-class class) &rest rest) (apply #'replace-class-in-mixin object new-class (class-name old-class) rest)) (defmethod replace-class-in-mixin ((object mixin-object) (new-class symbol) (old-class symbol) &rest initargs) (cond ((eql new-class old-class) object) (t ;; First we disable all non-compatible minor modes. (loop for mode in (stumpwm::list-minor-modes object) unless (let* ((scope (stumpwm:minor-mode-scope mode)) (st (stumpwm::scope-type scope))) (or (eql new-class st) (stumpwm::superclassp new-class st))) do (stumpwm::autodisable-minor-mode mode object)) (if (typep object 'mixin-object) (flet ((mix-it (mix-list) (apply #'change-class object (ensure-mixin mix-list) initargs) (stumpwm::sync-minor-modes object) object)) (let* ((tag nil) (old-class-obj (find-class old-class)) (fn (lambda (e) (when (or (eql e old-class) (eql e old-class-obj)) (setf tag t) t))) (mix-list (make-mix-list :list (remove-duplicates (mapcar #'%find-class (subst-if new-class fn (mixin-classes (class-of object)))))))) (if tag (mix-it mix-list) (restart-case (error "~A is not an explicitly mixed class in ~A" old-class object) (continue () object) (mix-in-new-class () (ensure-mix object new-class)))))) (apply #'change-class object new-class initargs))))) (defgeneric replace-class (object new-class &rest initargs)) (defmethod replace-class :around (object new &rest rest) (restart-case (progn (handler-bind ((error (lambda (c) (let ((r1 (find-restart 'continue c)) (r2 (find-restart 'stumpwm::continue c))) (cond (r1 (invoke-restart r1)) (r2 (invoke-restart r2))))))) (call-next-method)) (unless (typep object new) (error "Failed to change class ~A ~A" object new))) (force-change () :report (lambda (s) (format s "Change class to ~A, removing all mixins" new)) (apply #'change-class object new rest))) object) stumpwm-22.11/sample-stumpwmrc.lisp000066400000000000000000000050531433701203600174460ustar00rootroot00000000000000;; -*-lisp-*- ;; ;; Here is a sample .stumpwmrc file (in-package :stumpwm) ;; change the prefix key to something else (set-prefix-key (kbd "C-z")) ;; prompt the user for an interactive command. The first arg is an ;; optional initial contents. (defcommand colon1 (&optional (initial "")) (:rest) (let ((cmd (read-one-line (current-screen) ": " :initial-input initial))) (when cmd (eval-command cmd t)))) ;; Read some doc (define-key *root-map* (kbd "d") "exec gv") ;; Browse somewhere (define-key *root-map* (kbd "b") "colon1 exec firefox http://www.") ;; Ssh somewhere (define-key *root-map* (kbd "C-s") "colon1 exec xterm -e ssh ") ;; Lock screen (define-key *root-map* (kbd "C-l") "exec xlock") ;; Web jump (works for DuckDuckGo and Imdb) (defmacro make-web-jump (name prefix) `(defcommand ,(intern name) (search) ((:rest ,(concatenate 'string name " search: "))) (nsubstitute #\+ #\Space search) (run-shell-command (concatenate 'string ,prefix search)))) (make-web-jump "duckduckgo" "firefox https://duckduckgo.com/?q=") (make-web-jump "imdb" "firefox http://www.imdb.com/find?q=") ;; C-t M-s is a terrble binding, but you get the idea. (define-key *root-map* (kbd "M-s") "duckduckgo") (define-key *root-map* (kbd "i") "imdb") ;; Message window font (set-font "-xos4-terminus-medium-r-normal--14-140-72-72-c-80-iso8859-15") ;;; Define window placement policy... ;; Clear rules (clear-window-placement-rules) ;; Last rule to match takes precedence! ;; TIP: if the argument to :title or :role begins with an ellipsis, a substring ;; match is performed. ;; TIP: if the :create flag is set then a missing group will be created and ;; restored from *data-dir*/create file. ;; TIP: if the :restore flag is set then group dump is restored even for an ;; existing group using *data-dir*/restore file. (define-frame-preference "Default" ;; frame raise lock (lock AND raise == jumpto) (0 t nil :class "Konqueror" :role "...konqueror-mainwindow") (1 t nil :class "XTerm")) (define-frame-preference "Ardour" (0 t t :instance "ardour_editor" :type :normal) (0 t t :title "Ardour - Session Control") (0 nil nil :class "XTerm") (1 t nil :type :normal) (1 t t :instance "ardour_mixer") (2 t t :instance "jvmetro") (1 t t :instance "qjackctl") (3 t t :instance "qjackctl" :role "qjackctlMainForm")) (define-frame-preference "Shareland" (0 t nil :class "XTerm") (1 nil t :class "aMule")) (define-frame-preference "Emacs" (1 t t :restore "emacs-editing-dump" :title "...xdvi") (0 t t :create "emacs-dump" :class "Emacs")) stumpwm-22.11/screen.lisp000066400000000000000000000501421433701203600154040ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Screen functionality ;; ;; Code: (in-package #:stumpwm) (export '(*default-bg-color* current-screen current-window screen-current-window screen-number screen-groups screen-windows screen-height screen-width set-fg-color set-bg-color set-border-color set-win-bg-color set-focus-color set-unfocus-color set-float-focus-color set-float-unfocus-color set-msg-border-width set-frame-outline-width set-font)) (defvar *default-bg-color* #x333333 "Default color for the desktop background.") ;; Screen helper functions (defun translate-id (src src-start src-end font dst dst-start) "A simple replacement for xlib:translate-default. just the identity with a range check." (let ((min (xlib:font-min-char font)) (max (xlib:font-max-char font))) (decf src-end) (loop for i from src-start to src-end for j from dst-start as e = (elt src i) as c = (if (characterp e) (char-code e) e) if (and (integerp c) (<= min c max)) do (setf (aref dst j) c) else ;; replace unknown characters with question marks do (setf (aref dst j) (char-code #\?)) finally (return i)))) (defun screen-x (screen) (declare (ignore screen)) 0) (defun screen-y (screen) (declare (ignore screen)) 0) (defun screen-height (screen) (let ((root (screen-root screen))) (xlib:drawable-height root))) (defun screen-width (screen) (let ((root (screen-root screen))) (xlib:drawable-width root))) (defun find-screen (root) "Return the screen containing the root window." (find-if (lambda (s) (xlib:window-equal (screen-root s) root)) *screen-list*)) (defun screen-windows (screen) (mapcan (lambda (g) (copy-list (group-windows g))) (screen-groups screen))) (defun screen-message-window (screen) (ccontext-win (screen-message-cc screen))) (defun screen-message-pixmap (screen) (ccontext-px (screen-message-cc screen))) (defun screen-message-gc (screen) (ccontext-gc (screen-message-cc screen))) (defun screen-font (screen) (first (screen-fonts screen))) (defun netwm-update-client-list-stacking (screen) (unless *initializing* (xlib:change-property (screen-root screen) :_NET_CLIENT_LIST_STACKING ;; Order is bottom to top. (reverse (mapcar 'window-xwin (all-windows))) :window 32 :transform #'xlib:drawable-id :mode :replace))) (defun netwm-update-client-list (screen) (xlib:change-property (screen-root screen) :_NET_CLIENT_LIST (screen-mapped-windows screen) :window 32 :transform #'xlib:drawable-id :mode :replace) (netwm-update-client-list-stacking screen)) (defun screen-add-mapped-window (screen xwin) (push xwin (screen-mapped-windows screen)) (netwm-update-client-list screen)) (defun screen-remove-mapped-window (screen xwin) (unregister-window xwin) (setf (screen-mapped-windows screen) (remove xwin (screen-mapped-windows screen))) (netwm-update-client-list screen)) (defun sort-screens () "Return the list of screen sorted by ID." (sort1 *screen-list* '< :key 'screen-id)) (defun next-screen (&optional (list (sort-screens))) (let ((matches (member (current-screen) list))) (if (null (cdr matches)) ;; If the last one in the list is current, then ;; use the first one. (car list) ;; Otherwise, use the next one in the list. (cadr matches)))) (defun move-screen-to-head (screen) (move-to-head *screen-list* screen)) (defun switch-to-screen (screen) (when (and screen (not (eq screen (current-screen)))) (if (screen-focus screen) (xlib:set-input-focus *display* (window-xwin (screen-focus screen)) :POINTER-ROOT) (xlib:set-input-focus *display* (screen-focus-window screen) :POINTER-ROOT)) (move-screen-to-head screen))) (defun screen-set-focus (screen window) (when (eq (window-group window) (screen-current-group screen)) (xlib:set-input-focus *display* (window-xwin window) :POINTER-ROOT) (xlib:change-property (screen-root screen) :_NET_ACTIVE_WINDOW (list (window-xwin window)) :window 32 :transform #'xlib:drawable-id :mode :replace) (setf (screen-focus screen) window) (move-screen-to-head screen))) (defun screen-current-window (screen) "Return the current window on the specified screen" (group-current-window (screen-current-group screen))) (defun current-window () "Return the current window on the current screen" (screen-current-window (current-screen))) (defun register-window (window) (setf (gethash (xlib:window-id (window-xwin window)) *xwin-to-window*) window)) (defun unregister-window (xwin) (remhash (xlib:window-id xwin) *xwin-to-window*)) (defun window-by-id (id) (gethash id *xwin-to-window*)) (defun find-window (xwin) (window-by-id (xlib:window-id xwin))) (defun find-window-by-parent (xwin &optional (windows (all-windows))) (dformat 3 "find-window-by-parent!~%") (find xwin windows :key 'window-parent :test 'xlib:window-equal)) (defun screen-root (screen) (xlib:screen-root (screen-number screen))) (defun update-colors-for-screen (screen) (let ((fg (screen-fg-color screen)) (bg (screen-bg-color screen))) (setf (xlib:gcontext-foreground (screen-message-gc screen)) fg (xlib:gcontext-background (screen-message-gc screen)) bg (xlib:gcontext-foreground (screen-frame-outline-gc screen)) fg (xlib:gcontext-background (screen-frame-outline-gc screen)) bg (ccontext-default-fg (screen-message-cc screen)) fg (ccontext-default-bg (screen-message-cc screen)) bg)) (dolist (i (list (screen-message-window screen) (screen-input-window screen) (screen-frame-window screen))) (setf (xlib:window-border i) (screen-border-color screen) (xlib:window-background i) (screen-bg-color screen))) ;; update the backgrounds of all the managed windows (dolist (g (screen-groups screen)) (dolist (w (group-windows g)) (unless (eq w (group-current-window g)) (setf (xlib:window-background (window-parent w)) (screen-win-bg-color screen)) (xlib:clear-area (window-parent w))))) (dolist (i (screen-withdrawn-windows screen)) (setf (xlib:window-background (window-parent i)) (screen-win-bg-color screen)) (xlib:clear-area (window-parent i))) (update-screen-color-context screen)) (defun update-colors-all-screens () "After setting the fg, bg, or border colors, call this to sync any existing windows." (mapc 'update-colors-for-screen *screen-list*)) (defun update-border-for-screen (screen) (setf (xlib:drawable-border-width (screen-input-window screen)) (screen-msg-border-width screen) (xlib:drawable-border-width (screen-message-window screen)) (screen-msg-border-width screen) (xlib:drawable-border-width (screen-frame-window screen)) (screen-msg-border-width screen))) (defun update-border-all-screens () "After setting the border width call this to sync any existing windows." (mapc 'update-border-for-screen *screen-list*)) (defun internal-window-p (screen win) "Return t if win is a window used by stumpwm" (or (xlib:window-equal (screen-message-window screen) win) (xlib:window-equal (screen-input-window screen) win) (xlib:window-equal (screen-focus-window screen) win) (xlib:window-equal (screen-key-window screen) win))) (defmacro set-any-color (val color) `(progn (dolist (s *screen-list*) (setf (,val s) (alloc-color s ,color))) (update-colors-all-screens))) ;; FIXME: I don't like any of this. Isn't there a way to define ;; a setf method to call (update-colors-all-screens) when the user ;; does eg. (setf *foreground-color* "green") instead of having ;; these redundant set-foo functions? (defun set-fg-color (color) "Set the foreground color for the message bar and input bar. @var{color} can be any color recognized by X." (setf *text-color* color) (set-any-color screen-fg-color color)) (defun set-bg-color (color) "Set the background color for the message bar and input bar. @var{color} can be any color recognized by X." (set-any-color screen-bg-color color)) (defun set-border-color (color) "Set the border color for the message bar and input bar. @var{color} can be any color recognized by X." (set-any-color screen-border-color color)) (defun set-win-bg-color (color) "Set the background color of the window. The background color will only be visible for windows with size increment hints such as @samp{emacs} and @samp{xterm}." (set-any-color screen-win-bg-color color)) (defun set-focus-color (color) "Set the border color for focused windows. This is only used when there is more than one frame." (set-any-color screen-focus-color color)) (defun set-unfocus-color (color) "Set the border color for windows without focus. This is only used when there is more than one frame." (set-any-color screen-unfocus-color color)) (defun set-float-focus-color (color) "Set the border color for focused windows in a float group." (set-any-color screen-float-focus-color color)) (defun set-float-unfocus-color (color) "Set the border color for windows without focus in a float group." (set-any-color screen-float-unfocus-color color)) (defun set-msg-border-width (width) "Set the border width for the message bar, input bar and frame indicator." (check-type width (integer 0)) (dolist (i *screen-list*) (setf (screen-msg-border-width i) width)) (update-border-all-screens) t) (defun set-frame-outline-width (width) (check-type width (integer 0)) (dolist (i *screen-list*) (setf (screen-frame-outline-width i) (if (oddp width) (1+ width) width) (xlib:gcontext-line-width (screen-frame-outline-gc i)) (screen-frame-outline-width i))) (update-border-all-screens) t) (defun set-font (font) "Set the font(s) for the message bar and input bar." (when (if (listp font) (every #'identity (mapcar #'font-exists-p font)) (font-exists-p font)) (dolist (screen *screen-list*) (let ((fonts (if (listp font) (mapcar (lambda (font) (open-font *display* font)) font) (list (open-font *display* font))))) (mapc #'close-font (screen-fonts screen)) (setf (screen-fonts screen) fonts))) t)) (defmacro with-current-screen (screen &body body) "A macro to help us out with early set up." `(let ((*screen-list* (list ,screen))) ,@body)) (defun current-screen () "Return the current screen." (car *screen-list*)) (defun netwm-set-properties (screen) "Set NETWM properties on the root window of the specified screen. FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." (let* ((screen-number (screen-number screen)) (focus-window (screen-focus-window screen)) (root (screen-root screen))) ;; _NET_SUPPORTED (xlib:change-property root :_NET_SUPPORTED (mapcar (lambda (a) (xlib:intern-atom *display* a)) (append +netwm-supported+ (mapcar #'car +netwm-window-types+))) :atom 32) ;; _NET_SUPPORTING_WM_CHECK (xlib:change-property root :_NET_SUPPORTING_WM_CHECK (list focus-window) :window 32 :transform #'xlib:drawable-id) (xlib:change-property focus-window :_NET_SUPPORTING_WM_CHECK (list focus-window) :window 32 :transform #'xlib:drawable-id) (xlib:change-property focus-window :_NET_WM_NAME "stumpwm" :string 8 :transform #'xlib:char->card8) ;; _NET_CLIENT_LIST (xlib:change-property root :_NET_CLIENT_LIST () :window 32 :transform #'xlib:drawable-id) ;; _NET_DESKTOP_GEOMETRY (xlib:change-property root :_NET_DESKTOP_GEOMETRY (list (xlib:screen-width screen-number) (xlib:screen-height screen-number)) :cardinal 32) ;; _NET_DESKTOP_VIEWPORT (xlib:change-property root :_NET_DESKTOP_VIEWPORT (list 0 0) :cardinal 32) (netwm-set-group-properties screen))) (defun init-screen (screen-number id host) "Given a screen number, returns a screen structure with initialized members" ;; Listen for the window manager events on the root window (dformat 1 "Initializing screen: ~a ~a~%" host id) (setf (xlib:window-event-mask (xlib:screen-root screen-number)) '(:substructure-redirect :substructure-notify :property-change :structure-notify :button-press :exposure)) (xlib:display-finish-output *display*) ;; Initialize the screen structure (labels ((ac (color) ;; We add an alpha channel to the color returned by ;; xlib:alloc-color. This is normally done by stumpwm:alloc-color, ;; but that requires a screen instance. (logior (xlib:alloc-color (xlib:screen-default-colormap screen-number) color) (ash #xff 24)))) (let* ((default-colormap (xlib:screen-default-colormap screen-number)) (screen-root (xlib:screen-root screen-number)) (fg-color (ac +default-foreground-color+)) (bg-color (ac +default-background-color+)) (win-bg-color (ac +default-window-background-color+)) (border-color (ac +default-border-color+)) (focus-color (ac +default-focus-color+)) (unfocus-color (ac +default-unfocus-color+)) (float-focus-color (ac +default-float-focus-color+)) (float-unfocus-color (ac +default-float-unfocus-color+)) (font (open-font *display* (cond ((font-exists-p +default-font-name+) +default-font-name+) ((font-exists-p "fixed") "fixed") (t "*")))) (message-window (xlib:create-window :parent screen-root :x 0 :y 0 :width 1 :height 1 :colormap default-colormap :background bg-color :border border-color :border-width 1 :bit-gravity :north-east :event-mask '(:exposure))) (screen (make-swm-class-instance 'screen :id id :host host :number screen-number :border-color border-color :fg-color fg-color :bg-color bg-color :win-bg-color win-bg-color :focus-color focus-color :unfocus-color unfocus-color :float-focus-color float-focus-color :float-unfocus-color float-unfocus-color :msg-border-width 1 :frame-outline-width +default-frame-outline-width+ :fonts (list font) :input-window (xlib:create-window :parent screen-root :x 0 :y 0 :width 20 :height 20 :colormap default-colormap :background bg-color :border border-color :border-width 1 :event-mask '(:key-press :key-release)) :focus-window (xlib:create-window :parent screen-root :x 0 :y 0 :width 1 :height 1) :key-window (xlib:create-window :parent screen-root :x 0 :y 0 :width 1 :height 1 :event-mask '(:key-press :key-release)) :frame-window (xlib:create-window :parent screen-root :x 0 :y 0 :width 20 :height 20 :colormap default-colormap :background bg-color :border border-color :border-width 1 :event-mask '(:exposure)) :frame-outline-gc (xlib:create-gcontext :drawable screen-root :font (when (typep font 'xlib:font) font) :foreground fg-color :background fg-color :line-style :double-dash :line-width +default-frame-outline-width+) :message-cc (make-ccontext :win message-window :font font :gc (xlib:create-gcontext :drawable message-window :font (when (typep font 'xlib:font) font) :foreground fg-color :background bg-color)))) (group (make-swm-class-instance 'tile-group :screen screen :number 1 :name *default-group-name*))) (setf (screen-groups screen) (list group) (screen-current-group screen) group (ccontext-screen (screen-message-cc screen)) screen (screen-heads screen) (make-screen-heads screen screen-root) (tile-group-frame-tree group) (copy-heads screen) (tile-group-current-frame group) (first (tile-group-frame-tree group)) (xlib:window-background screen-root) *default-bg-color*) ;; The focus window is mapped at all times (xlib:map-window (screen-focus-window screen)) (xlib:map-window (screen-key-window screen)) (netwm-set-properties screen) (update-colors-for-screen screen) (update-color-map screen) (xwin-grab-keys (screen-focus-window screen) group) screen))) ;;; Screen commands (defcommand snext () () "Go to the next screen." (switch-to-screen (next-screen)) (group-wake-up (current-group))) (defcommand sprev () () "Go to the previous screen." (switch-to-screen (next-screen (reverse (sort-screens)))) (group-wake-up (current-group))) (defcommand sother () () "Go to the last screen." (switch-to-screen (cadr *screen-list*)) (group-wake-up (current-group))) stumpwm-22.11/selection.lisp000066400000000000000000000137641433701203600161230ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Handle the X selection. ;; ;; Code: (in-package #:stumpwm) (export '(get-x-selection set-x-selection *default-selections*)) (defvar *default-selections* '(:primary) #.(format nil "~@{~A~%~}" "A keyword or list, one of:" ":primary or '(:primary) uses only the \"primary\" selection" ":clipboard or '(:clipboard) uses only the \"clipboard\" selection" "Both can be specified in a list like '(:primary :clipboard). In this case," "set-x-selection will clobber both, and get-x-selection will default to the first item.")) (defun export-selection (selection) (let* ((screen (current-screen)) (selwin (screen-focus-window (current-screen))) (root (screen-root screen))) (xlib:set-selection-owner *display* selection selwin) (unless (xlib:window-equal (xlib:selection-owner *display* selection) selwin) (error "Can't set selection owner")) ;; also set the cut buffer for completeness. Note that this always sets cut ;; buffer 0. (xlib:change-property root :cut-buffer0 (sb-ext:string-to-octets (getf *x-selection* selection) :external-format :utf-8) :utf8_string 8 :mode :replace))) (defmacro multiselect (selection &body body) "Put the x selection into multiple selection places." `(call-with-multiselect ,selection (lambda (,selection) ,@body))) (defun call-with-multiselect (selection fn) "Helper function for multiselect." (let ((selection (if (listp selection) selection (list selection)))) (mapc fn selection))) (defun set-x-selection (text &optional (selection *default-selections*)) "Set the X11 selection string to @var{string}." (multiselect selection (setf (getf *x-selection* selection) text) (export-selection selection))) (defun send-selection (requestor property selection target time) (dformat 1 "send-selection ~s ~s ~s ~s ~s~%" requestor property selection target time) (case target ;; they're requesting what targets are available (:targets (xlib:change-property requestor property (mapcar (lambda (x) (xlib:intern-atom *display* x)) '(:targets :string :utf8_string)) :atom 32 :mode :replace)) ;; send them a string (:string (xlib:change-property requestor property (getf *x-selection* selection) :string 8 :mode :replace :transform #'xlib:char->card8)) (:utf8_string (xlib:change-property requestor property (sb-ext:string-to-octets (getf *x-selection* selection) :external-format :utf-8) target 8 :mode :replace)) ;; we don't know how to handle anything else (t (setf property nil))) (xlib:send-event requestor :selection-notify nil :display *display* :window requestor :selection selection :property property :target target :time time) (xlib:display-finish-output *display*)) (defun get-x-selection (&optional timeout (selection *default-selections*)) "Return the x selection no matter which client owns it." (let ((selection (if (listp selection) (car selection) selection))) (labels ((wait-for-selection (&rest event-slots &key display event-key &allow-other-keys) (declare (ignore display)) (when (eq event-key :selection-notify) (destructuring-bind (&key window property &allow-other-keys) event-slots (if property (utf8-to-string (xlib:get-property window property :type :utf8_string :result-type 'vector :delete-p t)) ""))))) (or (getf *x-selection* selection) (progn (xlib:convert-selection selection :utf8_string (screen-input-window (current-screen)) :stumpwm-selection) ;; Note: this may spend longer than timeout in this loop but it will eventually return. (let ((time (get-internal-real-time))) (loop for ret = (xlib:process-event *display* :handler #'wait-for-selection :timeout timeout :discard-p nil) when (or ret (> (/ (- time (get-internal-real-time)) internal-time-units-per-second) timeout)) ;; make sure we return a string return (or ret "")))))))) ;;; Commands ;;; FIXME: These two commands are basically useless. See issue #673 for details. (defcommand putsel (string) ((:rest "text: ")) "Stuff the string @var{string} into the x selection." (set-x-selection string)) (defcommand getsel () () "Echo the X selection." (message "~a" (get-x-selection))) (defcommand copy-last-message () () "Copy the last message displayed into the X selection" (when (screen-last-msg (current-screen)) (set-x-selection (uncolorify (format nil "~{~a~^~%~}" (car (screen-last-msg (current-screen)))))))) stumpwm-22.11/stumpwm-tests.asd000066400000000000000000000005211433701203600165750ustar00rootroot00000000000000(defsystem "stumpwm-tests" :name "StumpWM tests" :serial t :depends-on ("stumpwm" "fiasco") :pathname "tests/" :components ((:file "package") (:file "kmap") (:file "pathnames")) :perform (test-op (o c) (uiop/package:symbol-call "FIASCO" "ALL-TESTS" 'stumpwm-tests))) stumpwm-22.11/stumpwm.asd000066400000000000000000000051301433701203600154360ustar00rootroot00000000000000;;; -*- Mode: Lisp -*- (defpackage :stumpwm-system (:use :cl :asdf)) (in-package :stumpwm-system) (defsystem :stumpwm :name "StumpWM" :author "Shawn Betts " :version "1.0.1" :maintainer "David Bjergaard " ;; :license "GNU General Public License" :description "A tiling, keyboard driven window manager" :serial t :depends-on (#:alexandria #:cl-ppcre #:clx #:sb-posix #:sb-introspect #:dynamic-mixins) :components ((:file "package") (:file "debug") (:file "primitives") (:file "wrappers") (:file "pathnames") (:file "font-rendering") (:file "keysyms") (:file "keytrans") (:file "kmap") (:file "input") (:file "core") (:file "command") (:file "menu-declarations") (:file "menu-definitions") (:file "screen") (:file "head") (:file "group") (:file "bindings") (:file "events") (:file "window") (:file "floating-group") (:file "tile-window") (:file "tile-group") (:file "window-placement") (:file "message-window") (:file "selection") (:file "module") (:file "ioloop") (:file "timers") (:file "stumpwm") (:file "user") (:file "interactive-keymap") (:file "iresize") (:file "help") (:file "fdump") (:file "time") (:file "mode-line") (:file "mode-line-formatters") (:file "color") (:file "wse") (:file "dynamic-window") (:file "dynamic-group") (:file "remap-keys") (:file "manual") (:file "minor-modes") (:file "replace-class") ;; keep this last so it always gets recompiled if ;; anything changes (:file "version")) :in-order-to ((test-op (test-op "stumpwm-tests")))) (defsystem "stumpwm/build" :depends-on ("stumpwm") :build-operation program-op :build-pathname "stumpwm" :entry-point "stumpwm:main" :components ((:file "main"))) ;;; Explicitly load the vendored dynamic mixins asd file (asdf:load-asd (asdf:system-relative-pathname "stumpwm" "dynamic-mixins/dynamic-mixins.asd")) stumpwm-22.11/stumpwm.lisp000066400000000000000000000337241433701203600156500ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Code: (in-package :stumpwm) (export '(*toplevel-io* stumpwm call-in-main-thread in-main-thread-p push-event close-resources)) (defvar *in-main-thread* nil "Dynamically bound to T during the execution of the main stumpwm function.") ;;; Main (defun load-rc-file (&optional (catch-errors t)) "Load the user's .stumpwmrc file or the system wide one if that doesn't exist. Returns a values list: whether the file loaded (t if no rc files exist), the error if it didn't, and the rc file that was loaded. When CATCH-ERRORS is nil, errors are left to be handled further up. " (let* ((user-rc (probe-file (merge-pathnames #p".stumpwmrc" (user-homedir-pathname)))) (dir-rc (probe-file (merge-pathnames #p".stumpwm.d/init.lisp" (user-homedir-pathname)))) (conf-rc (probe-file (uiop:xdg-config-home #p"stumpwm/config/"))) (etc-rc (probe-file #p"/etc/stumpwmrc")) (rc (or user-rc dir-rc conf-rc etc-rc))) (if rc (if catch-errors (handler-case (load rc) (error (c) (values nil (format nil "~a" c) rc)) (:no-error (&rest args) (declare (ignore args)) (values t nil rc))) (progn (load rc) (values t nil rc))) (values t nil nil)))) (defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) "Handle X errors" (cond ;; ignore asynchronous window errors ((and asynchronous (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))) (dformat 4 "Ignoring error: ~s~%" error-key)) ((eq error-key 'xlib:access-error) (write-line "Another window manager is running.") (throw :top-level :quit)) ;; all other asynchronous errors are printed. (asynchronous (message "Caught Asynchronous X Error: ~s ~s." error-key key-vals)) (t (apply 'error error-key :display display :error-key error-key key-vals)))) (defgeneric handle-top-level-condition (c)) (defmethod handle-top-level-condition (c) ;; Do nothing by default; there's nothing wrong with signalling ;; arbitrary conditions ) (defmethod handle-top-level-condition ((c warning)) (muffle-warning)) (defmethod handle-top-level-condition ((c serious-condition)) (when (and (find-restart :remove-channel) (not (typep *current-io-channel* '(or stumpwm-timer-channel display-channel request-channel)))) (message "Removed channel ~S due to uncaught error '~A'." *current-io-channel* c) (invoke-restart :remove-channel)) (ecase *top-level-error-action* (:message (let ((s (format nil "~&Caught '~a' at the top level. Please report this." c))) (write-line s) (print-backtrace) (message "^1*^B~a" s))) (:break (restart-case (invoke-debugger c) (:abort-debugging () :report (lambda (stream) (format stream "abort debugging")) (throw :top-level (list c (backtrace-string)))))) (:abort (throw :top-level (list c (backtrace-string)))))) (defclass request-channel () ((in :initarg :in :reader request-channel-in) (out :initarg :out :reader request-channel-out) (queue :initform nil :accessor request-channel-queue) (lock :initform (sb-thread:make-mutex) :reader request-channel-lock))) (defvar *request-channel* nil) (defmethod io-channel-ioport (io-loop (channel request-channel)) (io-channel-ioport io-loop (request-channel-in channel))) (defmethod io-channel-events ((channel request-channel)) (list :read)) (defmethod io-channel-handle ((channel request-channel) (event (eql :read)) &key) ;; At this point, we know that there is at least one request written ;; on the pipe. We read all the data off the pipe and then evaluate ;; all the waiting jobs. (loop with in = (request-channel-in channel) do (read-byte in) while (listen in)) (let ((events (sb-thread:with-mutex ((request-channel-lock channel)) (let ((queue-copy (request-channel-queue channel))) (setf (request-channel-queue channel) nil) queue-copy)))) (dolist (event (reverse events)) (funcall event)))) (defun in-main-thread-p () *in-main-thread*) (defun push-event (fn) (sb-thread:with-mutex ((request-channel-lock *request-channel*)) (push fn (request-channel-queue *request-channel*))) (let ((out (request-channel-out *request-channel*))) ;; For now, just write a single byte since all we want is for the ;; main thread to process the queue. If we want to handle ;; different types of events, we'll have to change this so that ;; the message sent indicates the event type instead. (write-byte 0 out) (finish-output out))) (defun call-in-main-thread (fn) (cond ((in-main-thread-p) (funcall fn)) (t (push-event fn)))) (defclass display-channel () ((display :initarg :display))) (defmethod io-channel-ioport (io-loop (channel display-channel)) (io-channel-ioport io-loop (slot-value channel 'display))) (defmethod io-channel-events ((channel display-channel)) (list :read :loop)) (flet ((dispatch-all (display) (block handle (loop (xlib:display-finish-output display) (let ((nevents (xlib:event-listen display 0))) (unless nevents (return-from handle)) (xlib:with-event-queue (display) (run-hook *event-processing-hook*) ;; Note: process-event appears to hang for an unknown ;; reason. This is why it is passed a timeout in hopes that ;; this will keep it from hanging. (xlib:process-event display :handler #'handle-event :timeout 0))))))) (defmethod io-channel-handle ((channel display-channel) (event (eql :read)) &key) (dispatch-all (slot-value channel 'display))) (defmethod io-channel-handle ((channel display-channel) (event (eql :loop)) &key) (dispatch-all (slot-value channel 'display)))) (defun stumpwm-internal-loop () (loop (with-simple-restart (:new-io-loop "Recreate I/O loop") (let ((io (make-instance *default-io-loop*))) (io-loop-add io (make-instance 'stumpwm-timer-channel)) (io-loop-add io (make-instance 'display-channel :display *display*)) ;; If we have no implementation for the current CL, then ;; don't register the channel. (multiple-value-bind (in out) (open-pipe) (let ((channel (make-instance 'request-channel :in in :out out))) (io-loop-add io channel) (setq *request-channel* channel))) (setf *toplevel-io* io) (loop (handler-bind ((t (lambda (c) (handle-top-level-condition c)))) (io-loop io :description "StumpWM"))))))) (defun parse-display-string (display) "Parse an X11 DISPLAY string and return the host and display from it." (ppcre:register-groups-bind (protocol host ('parse-integer display screen)) ("^(?:(.*?)/)?(.*?)?:(\\d+)(?:\\.(\\d+))?" display :sharedp t) (values ;; clx doesn't like (vector character *) (coerce (or host "") '(simple-array character (*))) display screen (cond (protocol (intern1 protocol :keyword)) ((or (string= host "") (string-equal host "unix")) :local) (t :internet))))) (defun ensure-data-dir () (ensure-directories-exist (data-dir) :mode #o700)) (defun data-dir () (merge-pathnames ".stumpwm.d/" (user-homedir-pathname))) (defun close-resources () (xlib:close-display *display*) (close-log)) (defun stumpwm-internal (display-str) (multiple-value-bind (host display screen protocol) (parse-display-string display-str) (declare (ignore screen)) (setf *display* (xlib:open-display host :display display :protocol protocol) (xlib:display-error-handler *display*) 'error-handler) (with-simple-restart (quit-stumpwm "Quit Stumpwm") ;; In the event of an error, we always need to close the display (unwind-protect (progn (let ((*initializing* t)) (ensure-data-dir) (open-log) ;; we need to do this first because init-screen grabs ;; keys (update-modifier-map) ;; Initialize all the screens (setf *screen-list* (loop for i in (xlib:display-roots *display*) for n from 0 collect (init-screen i n host))) (xlib:display-finish-output *display*) ;; Enable minor mode keymap lookup. This needs to be done after ;; screens are initialized. (push #'minor-mode-top-maps *minor-mode-maps*) ;; Load rc file (let ((*package* (find-package *default-package*))) (multiple-value-bind (success err rc) (load-rc-file) (if success (and *startup-message* (message *startup-message* (print-key *escape-key*))) (message "^B^1*Error loading ^b~A^B: ^n~A." rc err)))) (when *last-unhandled-error* (message-no-timeout "^B^1*StumpWM Crashed With An Unhandled Error!~%Copy the error to the clipboard with the 'copy-unhandled-error' command.~%^b~a^B^n~%~%~a." (first *last-unhandled-error*) (second *last-unhandled-error*))) (mapc 'process-existing-windows *screen-list*) ;; We need to setup each screen with its current window. Go ;; through them in reverse so the first screen's frame ends up ;; with focus. (dolist (s (reverse *screen-list*)) ;; map the current group's windows (mapc 'unhide-window (reverse (group-windows (screen-current-group s)))) ;; update groups (dolist (g (reverse (screen-groups s))) (dformat 3 "Group windows: ~S~%" (group-windows g)) (group-startup g)) ;; switch to the (old) current group. (let ((netwm-id (first (xlib:get-property (screen-root s) :_NET_CURRENT_DESKTOP)))) (when (and netwm-id (< netwm-id (length (screen-groups s)))) (switch-to-group (elt (sort-groups s) netwm-id)))) (redraw-current-message (current-screen)))) (run-hook *pre-thread-hook*) ;; Start hashing the user's PATH so completion is quick ;; the first time they try to run a command. (sb-thread:make-thread #'rehash) ;; Let's manage. (let ((*package* (find-package *default-package*))) (run-hook *start-hook*) (stumpwm-internal-loop))) (close-resources)))) ;; what should the top level loop do? :quit) (defun force-stumpwm-restart (&key (close-display t)) (when close-display (xlib:close-display *display*)) (apply 'execv (first sb-ext:*posix-argv*) sb-ext:*posix-argv*)) ;; based on cffi version of set-signal-handler from Andrew Lyon at https://stackoverflow.com/a/10442062 ;; rewritten to use SBCL's Foreign Function Interface directly by Max-Gerd Retzlaff (defmacro set-signal-handler (signo &body body) `(sb-alien:alien-funcall (sb-alien:extern-alien "signal" (function sb-alien:void sb-alien:int sb-alien:system-area-pointer)) ,signo ;; callback function (sb-alien:alien-sap (sb-alien::alien-lambda sb-alien:void ((signum sb-alien:int)) (declare (ignore signum)) ,@body)))) ;; Usage: (stumpwm) (defun stumpwm (&optional (display-str (or (getenv "DISPLAY") ":0"))) "Start the stump window manager." (set-signal-handler sb-posix:sighup (dformat 0 "SIGHUP received: forcing immediate restart of stumpwm~%") ;; debug level 0 to "force" logging (force-stumpwm-restart)) (let ((*in-main-thread* t)) (setf *data-dir* (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list ".stumpwm.d")))) (init-load-path *module-dir*) (loop (let ((ret (catch :top-level (stumpwm-internal display-str)))) (setf *last-unhandled-error* nil) (cond ((and (consp ret) (typep (first ret) 'condition)) (format t "~&Caught '~a' at the top level. Please report this.~%~a" (first ret) (second ret)) (setf *last-unhandled-error* ret)) ;; we need to jump out of the event loop in order to hup ;; the process because otherwise we get errors. ((eq ret :hup-process) (run-hook *restart-hook*) (force-stumpwm-restart :close-display nil)) ((eq ret :restart) (run-hook *restart-hook*)) (t (run-hook *quit-hook*) ;; the number is the unix return code (return-from stumpwm 0))))))) stumpwm-22.11/stumpwm.texi.in000066400000000000000000003375421433701203600162640ustar00rootroot00000000000000\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename stumpwm.info @settitle StumpWM Manual @setchapternewpage odd @c %**end of header @dircategory X11 @direntry * StumpWM: (stumpwm). A Common Lisp window manager @end direntry @ifinfo This is the Stump Window Manager user manual. Copyright @copyright{} 2000-2008 Shawn Betts Copyright @copyright{} 2014 David Bjergaard Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @ignore Permission is granted to process this file through TeX and print the results, provided the printed document carries a copying permission notice identical to this one except for the removal of this paragraph (this paragraph not being relevant to the printed manual). @end ignore Permission is granted to copy and distribute modified versions of this manual under the conditions for verbatim copying, provided also that the sections entitled ``Copying'' and ``GNU General Public License'' are included exactly as in the original, and provided that the entire resulting derived work is distributed under the terms of a permission notice identical to this one. Permission is granted to copy and distribute translations of this manual into another language, under the above conditions for modified versions, except that this permission notice may be stated in a translation approved by the Free Software Foundation. @end ifinfo @iftex @kbdinputstyle code @end iftex @titlepage @sp 10 @titlefont{The Stump Window Manager} @author Shawn Betts, David Bjergaard @page @vskip 0pt plus 1filll Copyright @copyright{} 2000-2008 Shawn Betts Copyright @copyright{} 2014 David Bjergaard Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. Permission is granted to copy and distribute modified versions of this manual under the conditions for verbatim copying, provided also that the sections entitled ``Copying'' and ``GNU General Public License'' are included exactly as in the original, and provided that the entire resulting derived work is distributed under the terms of a permission notice identical to this one. Permission is granted to copy and distribute translations of this manual into another language, under the above conditions for modified versions, except that this permission notice may be stated in a translation approved by the Free Software Foundation. @end titlepage @node Top, Introduction, (dir), (dir) @ifinfo This document explains how to use The Stump Window Manager. @end ifinfo @menu * Introduction:: * Key Bindings:: * Commands:: * Message and Input Bar:: * Windows:: * Frames:: * Mode-line:: * Groups:: * Screens:: * Minor Modes:: * Internals:: * Interacting With Unix:: * Interacting With X11:: * Miscellaneous Commands:: * Colors:: * Hooks:: * Modules:: * Hacking:: * Advanced Configuration:: * Command and Function Index:: * Variable Index:: @detailmenu --- The Detailed Node Listing --- Introduction * Starting StumpWM:: * Basic Usage:: * Basic Concepts:: * Manipulating Frames and Windows:: * Interacting with the Lisp process:: * Init File:: * Contact the StumpWM developers:: Basic Concepts * Screens and Heads:: * Group Basics:: * Floating Group Basics:: * Dynamic Group Basics:: * Frame Basics:: * Window Basics:: * System Trays and the Mode Line:: Manipulating Frames and Windows * Moving Between Frames:: * Manipulating Windows:: Key Bindings * List of Default Keybindings:: * Binding Keys:: * Modifiers:: * Remapped Keys:: Commands * Writing Commands:: * StumpWM Types:: Message and Input Bar * Customizing The Bar:: * Using The Input Bar:: * Programming The Message Bar:: * Programming the Input Bar:: Windows * Window Marks:: * Customizing Window Appearance:: * Controlling Raise And Map Requests:: * Programming With Windows:: * Rule Based Window Placement:: * Window Selection Expressions:: Frames * Interactively Resizing Frames:: * Frame Dumping:: Groups * Customizing Groups:: Screens * External Monitors:: * Programming With Screens:: Minor Modes * Minor Mode Example:: * Programming With Minor Modes:: Internals * IO Loop:: Miscellaneous Commands * Menus:: * StumpWM's Data Directory:: * Debugging StumpWM:: * Sending a Bug Report:: * Timers:: * Getting Help:: Colors * Behind The Scenes Look At Colors:: Modules * Writing Modules:: Hacking * General Advice:: * Adding Documentation and Editing This Manual:: * Using git with StumpWM:: * Sending Patches:: @end detailmenu @end menu @node Introduction, Key Bindings, Top, Top @chapter Introduction StumpWM is a manual, tiling X11 window manager written entirely in Common Lisp. Unlike traditional window managers, StumpWM places windows in order to maximize the amount of the screen used. The window layouts managed by StumpWM are defined by the user in much the same way that windows are managed by GNU screen, or emacs. Before StumpWM, there was ratpoison, another tiling window manager written entirely in C. StumpWM grew out of the authors' frustration with writing ratpoison in C. Very quickly we realized we were building into ratpoison lispy-emacs style paradigms. StumpWM's goals are similar to ratpoison's but with an emphasis on customizability, completeness, and cushiness. @menu * Starting StumpWM:: * Basic Usage:: * Basic Concepts:: * Manipulating Frames and Windows:: * Interacting with the Lisp process:: * Init File:: * Contact the StumpWM developers:: @end menu @node Starting StumpWM, Basic Usage, Introduction, Introduction @section Starting StumpWM There are a number of ways to start StumpWM but the most straight forward method is as follows. This assumes you have a copy of the StumpWM source code and are using the @samp{SBCL} Common Lisp environment. @enumerate @item Install the prerequisites and build StumpWM as described in @file{README}. This should give you a @file{stumpwm} executable. @item In your @file{~/.xinitrc} file include the line @command{/path/to/stumpwm}. Remember to replace @samp{/path/to/} with the actual path. @item Finally, start X windows with @command{startx}. Cross your fingers. You should see a @samp{Welcome To the Stump Window Manager} message pop up in the upper, right corner. At this point, you have successfully started StumpWM. @end enumerate @@@ stumpwm @node Basic Usage, Basic Concepts, Starting StumpWM, Introduction @section Basic Usage Once you have StumpWM up and running, the first thing you might want to do is start @command{emacs}. Type @kbd{C-t e}, or in other words @kbd{Control + t} followed by @kbd{e}. Now perhaps you want an @command{xterm}. Type @kbd{C-t c}. Now you have some programs running. To see a list of windows StumpWM is managing, type @kbd{C-t w}. The highlighted window is the one you're looking at right now. It's the focused window. All of StumpWM's keys are bound to named commands, which can be executed not only by keys but also from the input bar. Type @kbd{C-t ;} to open a command prompt. Now type @command{time} and press return. Note, @command{time} can also be called by typing @kbd{C-t a}. Throughout this manual you'll find definitions for commands, functions, and variables. Any command you see in this manual can be executed from the input bar or bound to a key. At this point you probably want to switch back from your new @command{xterm} to @command{emacs}. Type @kbd{C-t C-t}. This runs the @command{other} command. Type it again and you're back to xterm. Perhaps you'd like to see @command{emacs} and @command{xterm} side-by-side. Type @kbd{C-t s}. You have now split the screen into 2 @command{frames}. For more information see @ref{Frames}. To switch to the empty frame type @kbd{C-t TAB}. Now let's pull the xterm window into this empty frame. Type @kbd{C-t w} for a window listing. Find the @command{xterm} window. See the number beside it? Type @kbd{C-t} followed by @command{xterm}'s window number. Another common activity is browsing the internet. Type @kbd{C-t !}. The input bar pops up again. You can now run a shell command. Let's start a web browser: type @command{firefox} into the input bar and press return. Unfortunately, @command{firefox} probably isn't wide enough because it's in one of the frames. Type @kbd{C-t Q} to remove all frames but the current one and resize it to fit the screen. For a full list of key bindings, see @ref{List of Default Keybindings}. @node Basic Concepts, Manipulating Frames and Windows, Basic Usage, Introduction @section Basic Concepts An introduction to some of the basic concepts used by StumpWM. @menu * Screens and Heads:: * Group Basics:: * Floating Group Basics:: * Dynamic Group Basics:: * Frame Basics:: * Window Basics:: * System Trays and the Mode Line:: @end menu @node Screens and Heads, Group Basics, Basic Concepts, Basic Concepts @subsection Screens and Heads A screen is an Xlib concept representing a section of video memory onto which physical monitors, called ``heads'', are mapped. A screen can be thought of as an abstract rectangle containing all the heads arranged in a particular layout. With most modern systems, you'll only have a single screen no matter how many heads are connected to your computer. Each head will have its own frame, and you can move between heads using the normal frame movement commands. The layout of the heads within the screen can be specified in one of two ways: either at startup using your system's Xorg configuration files, or on the fly using tools like XRandR. If the computer is booted with multiple monitors attached, but without specifying a layout for them, they will all show identical output. StumpWM will attempt to detect the layout of the heads once at startup, or any time a RandR command is issued. In rarer setups you may have multiple screens, with one head per screen. That means that you'll move between heads using screen movement commands (`snext', `sprev', and `sother') rather than frame movement commands. @node Group Basics, Floating Group Basics, Screens and Heads, Basic Concepts @subsection Group Basics A group is usually referred to as a ``desktop'' or ``workspace'' in other window managers. StumpWM starts with a single group, called ``Default''. Each group has its own configuration of frames and windows that is separate from and independent of other groups. You can't have different groups display in different monitors: when you switch groups, all monitors switch to that group. Each group contains an ordered list of frames. @node Floating Group Basics, Dynamic Group Basics, Group Basics, Basic Concepts @subsection Floating Group Basics Within a floating group, windows behave more like they do in traditional window managers: rather than being arranged into frames, they each have their own box, which can be freely resized and repositioned, and allowed to overlap. Each window has a thicker border at the top. Left click in this border and drag to move the window, or right click and drag to resize it. A modifier key can be used to perform the move and resize operations by clicking in the window itself instead of on its top border. The default modifier is super, and can be configured with @var{*float-window-modifier*}. ### *float-window-modifier* Most of the window-switching commands listed below do not function in a floating group. You're restricted to `other', the `select-window-*' commands, and `windowlist'. @node Dynamic Group Basics, Frame Basics, Floating Group Basics, Basic Concepts @subsection Dynamic Group Basics Within a dynamic group, windows are organized into a @dfn{master window} and a @dfn{window stack}, with one of each per head. When a new window is added to a head within a dynamic group, that heads master window is pushed onto that heads window stack, and the new window becomes the master window. When a head becomes to full (ie more windows cannot be placed upon the stack) a overflow policy is used to determine which window to move to a separate head or group. !!! gnew-dynamic !!! gnewbg-dynamic !!! rotate-windows !!! change-layout !!! change-default-layout !!! change-split-ratio !!! change-default-split-ratio !!! retile !!! select-floating-window ### *rotation-focus-policy* When defining commands, anything restricted to tiling groups will also be active in dynamic groups. To fully restrict it to tiling groups, call the function dyn-blacklist-command on the command in question. @node Frame Basics, Window Basics, Floating Group Basics, Basic Concepts @subsection Frame Basics Frames are the boxes within which windows are displayed. StumpWM starts with a single frame per head, meaning that each monitor shows a single window, full screen. If you want to see windows side-by-side, you can ``split'' this frame in two, either vertically or horizontally. These frames can be further split, creating nested boxes. Technically speaking, frames live within a ``frame tree''. When you split a frame, the command actually creates @emph{two} new frames side-by-side within the original parent frame. This has implications for the behaviour of many commands that interact with frames. Within this frame tree model, all frames either contain other frames, or contain windows, or are empty. The command `fclear' will hide all of a frame's windows and show the background. @node Window Basics, System Trays and the Mode Line, Frame Basics, Basic Concepts @subsection Window Basics Windows are created by programs to display their output. They take the shape of the frame in which they are created. The windows within a frame are ordered by how recently that window was focused. Only the top window in the stack is visible. @node System Trays and the Mode Line, , Window Basics, Basic Concepts @subsection System Trays and the Mode Line Many users choose to sacrifice a little screen real-estate to display some generally useful information: the current time and date, wireless network connections, the names of open windows, etc. StumpWM allows you to display this information in a bar across either the top or the bottom of the screen. There are two ways to do this: using external programs called system trays, or using StumpWM's own mode line. System trays are a special kind of X window. They advertise to running programs that they are available for embedding icons or notifications from those programs. They often also display clickable icons for each open window. Common tray programs include the GNOME panel or KDE's kicker, or simpler programs such as stalonetray. Simply starting one of these programs is usually enough for StumpWM to detect it, place it correctly, and allow it to function normally. The mode line, a concept borrowed from Emacs, is a built-in part of StumpWM. It is essentially a string of text that can include a variety of information about your current session, including the names of current groups and windows. Several modules provide for different types of information. @xref{Mode-line, Mode Line}, (and the modules directory) for more. @node Manipulating Frames and Windows, Interacting with the Lisp process, Basic Concepts, Introduction @section Manipulating Frames and Windows Frames and windows are concepts borrowed from Emacs and the GNU Screen program, and should be familiar to users of those programs. Others may find the terms a little confusing. In other window managers, a ``window'' usually refers to a bounded box on the screen, showing output from a single program. StumpWM splits this into two concepts: the ``frame'' is the bounded box, the ``window'' is the visible output of a program. One frame can contain many windows. As new windows are created, they appear at the top of the window-stack of the current frame. This is also a little different from other tiling window managers, many of which automatically create new frames for new windows. Both frames and windows are ordered by when they were last focused. In the following commands and documentation, the terms ``next'' and ``previous'' refer to this order. ``Other'' refers to the most-recently focused object. Calling ``other'' commands multiple times will bounce back and forth between the two most recent objects. By default, StumpWM starts with a single group, called ``Default'', which contains one full-screen frame per head. You can split individual frames horizontally or vertically using the `hsplit' and `vsplit' commands, bound to ``C-t S'' and ``C-t s'' by default. When a frame is split, the next-most-recently-focused window is pulled into the new frame. @xref{Frames}, and @ref{Windows}, for a complete listing of commands. @menu * Moving Between Frames:: * Manipulating Windows:: @end menu @node Moving Between Frames, Manipulating Windows, Manipulating Frames and Windows, Manipulating Frames and Windows @subsection Moving Between Frames Once you have multiple frames, you can move between them in various ways: @itemize @item @command{fnext} (@kbd{C-t o} or @kbd{C-t TAB}) jumps to the next frame in the current group's frame list. @item @command{fother} (@kbd{C-t M-TAB}) jumps to the last frame that had focus. @item @command{fselect} (@kbd{C-t f}) displays numbers on each visible frame: hit a number key or click it to move to that frame. @item @command{move-focus} (@kbd{C-t }) focus the frame in the direction of the arrow key pressed. @item @command{sibling} (unbound by default) focus the frame from which the current frame was split. @end itemize @node Manipulating Windows, , Moving Between Frames, Manipulating Frames and Windows @subsection Manipulating Windows Some commands change which window is currently focused, some move windows between frames, and some may do both at once. There are two general ways to move focus between windows: either between windows belonging to the current frame, or between all windows within the current group. Within a single frame: @itemize @item @command{next-in-frame} (@kbd{C-t C-M-n}) focus the next window in the current frame's list of windows. @item @command{prev-in-frame} (@kbd{C-t C-M-p}) focus the previous window in the current frame's list of windows. @item @command{other-in-frame} (@kbd{C-t M-t}) focus the most recently focused window in the current frame's list of windows. @item @command{frame-windowlist} (unbound by default) display a menu of windows in the currently-focused frame, and allow the user to choose one. Alternately, the command @command{frame-windows} will simply display the list of window names, with no menu choice available. @end itemize Within the current group, the following commands will go straight to the specified window. They will never move a window from its original frame, and so may result in focus switching frames. @itemize @item @command{next} (@kbd{C-t M-n}) focus the next window in the current group. @item @command{prev} (@kbd{C-t M-p}) focus the previous window in the current group. @item @command{other} or @command{other-window} (unbound by default) focus the most recently focused window in the current group. @item @command{next-urgent} (@kbd{C-t C-u}) focus the next window that has marked itself ``urgent''. @item @command{select} or @command{select-window} (@kbd{C-t '}) prompt for the title of a window and focus it. Works with partial completion of the title. @item @command{select-window-by-name} (unbound by default) prompt for the title of a window and focus it. Requires the window title to be entered exactly. @item @command{select-window-by-number} (@kbd{C-t }) choose a window by number. @item @command{windowlist} (@kbd{C-t "}) display a menu of windows in the currently-focused group, and allow the user to choose one. @end itemize The following commands always keep the current frame focused. If the selected window is not in the current frame, it will be pulled there from wherever it is (hence the ``pull'' naming scheme). @itemize @item @command{pull} or @command{pull-window-by-number} (@kbd{C-t C-}) pull the numbered window into the current frame. @item @command{pull-hidden-next} (@kbd{C-t n} or @kbd{C-t SPC}) pull the next currently undisplayed window in the window list into the current frame. @item @command{pull-hidden-previous} (@kbd{C-t p}) pull the previous currently undisplayed window in the window list into the current frame. @item @command{pull-hidden-other} (@kbd{C-t C-t}) pull the most recently focused, currently undisplayed window into the current frame. @end itemize The following commands move the current window from one frame to another, bringing focus with them. @itemize @item @command{move-window} (@kbd{C-t M-}) move the currently focused window in the direction indicated by the arrow key. @item @command{exchange-direction} (unbound by default) prompt for a direction, then swap the currently focused window with the top window of the frame in that direction. @end itemize @node Interacting with the Lisp process, Init File, Manipulating Frames and Windows, Introduction @section Interacting with the Lisp process Since StumpWM is a Lisp program, there is a way for you to evaluate Lisp code directly, on the same Lisp process that StumpWM is running on. Type @kbd{C-t :} and an input box will appear. Then type some Lisp expression. When you call @command{eval} this way, you will be in the STUMPWM-USER package, which imports all the exported symbols from the main STUMPWM package. @table @code @item *mode-line-border-width* Reads the value of @var{*mode-line-border-width*}. @item (setf *mode-line-border-width* 3) Sets the variable @var{*mode-line-border-width*} to 3. @item (set-prefix-key (kbd "C-M-H-s-z")) Calls the @code{set-prefix-key} function (and sets a new keyboard prefix) @end table @node Init File, Contact the StumpWM developers, Interacting with the Lisp process, Introduction @section Init File Like other window managers, StumpWM's configuration and startup state can be controlled by an initialization file. Unlike other window managers, StumpWM's init is not limited to changing settings and keybindings. The init file is itself a Common Lisp program running in a Common Lisp environment, so you can write your own hacks and make them a part of your StumpWM experience. On launch, StumpWM searches for an init file of different names and locations on your system, and will use the first one found in this order: @itemize @item `~/.stumpwmrc' is the classic UNIX-style configuration name; @item `~/.stumpwm.d/init.lisp' is an Emacs-style location and name; @item `~/.config/stumpwm/config' is the XDG standard; @item `/etc/stumpwmrc' is a system-wide file giving all users a standardized environment. @end itemize StumpWM includes a basic `sample-stumpwmrc.lisp' in its source directory. You can use this as a template when you're starting out: copy it to the above name and location you prefer and edit it to suit your preferences. It is possible to split your initialization among multiple files, if you call the additional files from within an init file matching the names and locations listed above. ### *processing-existing-windows* @node Contact the StumpWM developers, , Init File, Introduction @section Contact the StumpWM developers The StumpWM home page is @url{http://stumpwm.nongnu.org/}. The StumpWM mailing list is @email{stumpwm-devel@@nongnu.org} which you can subscribe to at @url{https://lists.nongnu.org/mailman/listinfo/stumpwm-devel}. It is the preferred way of contacting developers for questions. If you have a bug report or patch, please open an issue or pull request at @url{https://github.com/stumpwm/stumpwm/issues}. The StumpWM IRC channel can be found on Freenode at @uref{irc://irc.libera.chat/#stumpwm, @code{#stumpwm}}. @node Key Bindings, Commands, Introduction, Top @chapter Key Bindings StumpWM is controlled entirely by keystrokes and Lisp commands. It mimics GNU Screen's keyboard handling. StumpWM's default prefix key is @kbd{C-t}. @menu * List of Default Keybindings:: * Binding Keys:: * Modifiers:: * AltGr Keys:: * Remapped Keys:: @end menu @node List of Default Keybindings, Binding Keys, Key Bindings, Key Bindings @section List of Default Keybindings The following is a list of keybindings. @table @kbd @item C-t @var{d} Select the window with the corresponding digit@tie{}@var{d} @item C-t C-@var{d} Pull the window with the corresponding digit@tie{}@var{d} into the current frame @item C-t n @itemx C-t C-n @itemx C-t Space Go to the next window in the window list @item C-t p @itemx C-t C-p Go to the previous window in the window list @item C-t ' Go to a window by name @item C-t " Select a window from a list and focus the window. @item C-t C-g Abort the current command. This is useful if you accidentally hit @kbd{C-t} @item C-t i Display information about the current window. @item C-t f Select a frame by number @item C-t s Split current frame vertically @item C-t S Split current frame horizontally @item C-t k @itemx C-t C-k Sends a kill message to the current frame and the running program. @item C-t K Kills the current frame and running program; like a @command{kill -9}. @item C-t c @itemx C-t C-c Run an X terminal; by default @command{xterm} @item C-t e @itemx C-t C-e Run Emacs or raise it if it is already running. @item C-t t Sends a @kbd{C-t} to the frame; this is useful for applications like Firefox which make heavy use of @kbd{C-t} (in Firefox's case, for opening a new tab). This is similar to how GNU screen uses @kbd{C-a a}. @item C-t w @itemx C-t C-w Prints out a list of all the windows, their number, and their name. @item C-t RET @itemx C-t C-RET Show all windows and let the user select one, make that window the focus. @item C-t b @itemx C-t C-b Banish the mouse point to the lower right corner of the screen. @item C-t a @itemx C-t C-a Display the current time and date, much like the Unix command @command{date}. @item C-t C-t Switch to the last window to have focus in the current frame. @item C-t ! Prompt for a shell command to run via @file{/bin/sh}. All output is discarded. @item C-t R If the screen is split into multiple frames, one split will be undone. If there is only one split, the effect will be the same as @kbd{C-t Q}. @item C-t o @itemx C-t TAB If the screen is split into multiple frames, focus shifts to the @command{next} frame, where it cycles to the right and then down; analogous to @kbd{C-x o} in Emacs. @item C-t F Display ``Current Frame'' in the frame which has focus. @item C-t ; Opens the input box. StumpWM commands can be run from here, and the input history moved through. @item C-t : Opens the input box, but all things typed in here will be sent to the Common Lisp interpreter where they will be run as Lisp programs; thus, input should be valid Common Lisp. @item C-t C-h @itemx C-t ? The help. These can be customized using the @var{*help-keys*} variable. @item C-t - Hide all frames and show the root window. @item C-t Q Removes all splits and maximizes the frame with focus. @item C-t Up @itemx C-t Down @itemx C-t Left @itemx C-t Right Shift focus to an adjacent frame in the specified direction. @kbd{C-t Up} will shift focus up, if possible, @kbd{C-t Down} will shift downwards, etc. @item C-t v Prints out the version of the running StumpWM. @item C-t # Toggle the mark on the current window @item C-t m @itemx C-t C-m Display the last message. Hitting this keybinding again displays the message before that, and so on. @item C-t l @itemx C-t C-l redisplay the current window and force it to take up the entire frame. @item C-t G Display all groups and windows in each group. For more information see @ref{Groups}. @item C-t F@var{n} Jump to the corresponding group @var{n}. @kbd{C-t F1} jumps to group 1 and so on. @item C-t g g Show the list of groups. @item C-t g c Create a new group. @item C-t g n @itemx C-t g C-n @itemx C-t g SPC @itemx C-t g C-SPC Go to the next group in the list. @item C-t g N Go to the next group in the list and bring the current window along. @item C-t g p @itemx C-t g C-p Go to the previous group in the list. @item C-t g P Go to the previous group in the list and bring the current window along. @item C-t g ' Select a group by name or by number. @item C-t g " Select a group from a list and switch to it. @item C-t g m Move the current window to the specified group. @item C-t g k Kill the current group. All windows are merged into the next group. @item C-t g A @itemx C-t g r Change the current group's name. @item C-t g @var{d} Go to the group with digit @var{d}. @kbd{C-t g 1} jumps to group 1 and so on. @item C-t + Make frames the same height or width in the current frame's subtree. @item C-t h k Describe the specified key binding. @item C-t h f Describe the specified function. @item C-t h v Describe the specified variable. @item C-t h w List all key sequences that are bound to the specified command @item C-t h c Describe the specified command. @end table @node Binding Keys, Modifiers, List of Default Keybindings, Key Bindings @section Binding Keys @@@ define-key @@@ undefine-key @@@ kbd !!! set-prefix-key @@@ make-sparse-keymap ### *root-map* ### *top-map* ### *groups-map* ### *group-top-maps* ### *exchange-window-map* ### *key-seq-color* !!! bind !!! unbind !!! send-escape @@@ grab-pointer @@@ ungrab-pointer ### *banish-pointer-to* @@@ final-key-p @@@ help-key-p @@@ cancel-key-p ### *editor-bindings* ### *numpad-map* @node Modifiers, AltGr Keys, Binding Keys, Key Bindings @section Modifiers Many users have had some difficulty with setting up modifiers for StumpWM keybindings. This is caused by a combination of how StumpWM handles modifiers and the default modifiers list for many users' X servers. @itemize @item My ``Super'' key doesn't work! This is most likely caused by having the Hyper and Super keys listed as the same modifier in the modifier list. @example $ xmodmap xmodmap: up to 3 keys per modifier, (keycodes in parentheses): shift Shift_L (0x32), Shift_R (0x3e) lock Caps_Lock (0x42) control Control_L (0x25), Control_R (0x6d) mod1 Alt_L (0x40), Alt_R (0x71), Meta_L (0x9c) mod2 Num_Lock (0x4d) mod3 mod4 Super_L (0x7f), Hyper_L (0x80) mod5 Mode_switch (0x5d), ISO_Level3_Shift (0x7c) @end example The problem is in the line beginning with ``mod4''. The way to set up the modifier list correctly is to have just the Super key as the mod4 modifier. The following @command{xmodmap} commands will do just that. @example # clear out the mod4 modifier $ xmodmap -e 'clear mod4' $ xmodmap xmodmap: up to 3 keys per modifier, (keycodes in parentheses): shift Shift_L (0x32), Shift_R (0x3e) lock Caps_Lock (0x42) control Control_L (0x25), Control_R (0x6d) mod1 Alt_L (0x40), Alt_R (0x71), Meta_L (0x9c) mod2 Num_Lock (0x4d) mod3 mod4 mod5 Mode_switch (0x5d), ISO_Level3_Shift (0x7c) # add Super as a mod4 modifier $ xmodmap -e 'add mod4 = Super_L' $ xmodmap xmodmap: up to 3 keys per modifier, (keycodes in parentheses): shift Shift_L (0x32), Shift_R (0x3e) lock Caps_Lock (0x42) control Control_L (0x25), Control_R (0x6d) mod1 Alt_L (0x40), Alt_R (0x71), Meta_L (0x9c) mod2 Num_Lock (0x4d) mod3 mod4 Super_L (0x73), Super_L (0x7f) mod5 Mode_switch (0x5d), ISO_Level3_Shift (0x7c) @end example You can automate this by storing the commands in a file and calling xmodmap when you start your X session. @example $ cat ~/.Xmodmap clear mod4 add mod4 = Super_L @end example If you use @command{startx}, modify your @file{~/.xsession} or @file{~/.xinitrc} file. @example $ cat ~/.xsession #!/bin/sh xmodmap ~/.Xmodmap exec /usr/bin/stumpwm @end example If you use a settings daemon from one of the major desktop environments (Gnome,KDE, or Unity) you may be able to set keyboard modifiers from their respective configuration GUIs. If not, @command{xmodmap} should always work if invoked at the right place. @item Handling Meta and Alt: when do I use @kbd{M-} and @kbd{A-}? If you have no Meta keys defined (see the output of the @command{xmodmap} command), then StumpWM will treat the @kbd{M-} prefix in keybindings to mean Alt. However, if there are Meta keys defined, then the @kbd{M-} prefix refers to them, and the @kbd{A-} prefix refers to Alt. Most users will simply use @kbd{M-} to refer to their Alt keys. However, users that define separate Meta and Alt keys will use @kbd{M-} to refer to the former, and @kbd{A-} to refer to the latter. @item How can I set up a Hyper key and use it with StumpWM? To set up a Hyper key, you need to do two things: bind a physical key to be a Hyper key, and add that key to the modifiers list. The following example shows how to bind the control key at the bottom-left of most keyboards to be Hyper. This is useful if you've made Caps Lock into a control key, and have no use for the bottom-left key. @example $ xmodmap -e 'keycode 37 = Hyper_L' $ xmodmap -e 'clear mod5' $ xmodmap -e 'add mod5 = Hyper_L' @end example To use a different key for Hyper, replace the keycode ``37'' above. Use the @command{xev} program to see the keycode that any physical key has. Refer to the section above on setting up the Super key to see how to automate setting the Hyper key when you start X. Now you can use @kbd{H-} as a prefix in StumpWM bindings. @example (define-key *top-map* (kbd "H-RET") "fullscreen") (define-key *top-map* (kbd "H-Left") "gprev") (define-key *top-map* (kbd "H-Right") "gnext") (define-key *top-map* (kbd "H-TAB") "other") @end example Since essentially no programs have Hyper bindings, you can safely bind commands to the @var{*top-map*}. @end itemize ### *all-modifiers* ### *modifiers* @node AltGr Keys, Remapped Keys, Modifiers, Key Bindings @section AltGr Keys StumpWM uses the CLX client library for X11, which doesnt support the XKB extension. As such support for Alt Graph must be handled specially. Preliminary support for Alt Graph in StumpWM is done by registering AltGr as a modifier key and specially handling it when it is a member of a key press' state. By default StumpWM treats AltGr key presses as a normal key and not a modifier, and this behavior should not be changed unless necessary. To enable treating AltGr as a modifier, the user must place the following in their stumpwmrc: @example (register-altgr-as-modifier) @end example Additionally, the variable @var{*altgr-offset*} defaults to 2, which may be appropriate for the users keyboard layout, or may not. Some users may have an AltGr offset of 4, or potentially 6. If, after calling @code{register-altgr-as-modifier}, keys on AltGr aren't being registered properly, then the offset may need to be changed. The user can check this explicitly by finding a keysym that requires AltGr and passing it to @code{keysym-requires-altgr}. As an example, some layouts have @kbd{ł} on @kbd{AltGr+l}. In such a case, the following example would return true when @var{*altgr-offset*} is correct: @example (stumpwm::keysym-requires-altgr (stumpwm::stumpwm-name->keysym "lstroke")) @end example @@@ register-altgr-as-modifier ### *altgr-offset* @node Remapped Keys, , AltGr Keys, Key Bindings @section Remapped Keys StumpWM may be configured to translate certain familiar top level keybindings to alternative key sequences that are understood by specific applications. For example, Emacs users are very familiar with @kbd{C-n} and @kbd{C-p} as keybindings for scrolling down and up one line at a time. However, most applications use these specific keybindings for other actions. The @code{stumpwm:define-remapped-keys} function may be used to define such application specific remapping of keybindings. @@@ define-remapped-keys @example (define-remapped-keys '(("(Firefox|Chrome)" ("C-n" . "Down") ("C-p" . "Up") ("C-f" . "Right") ("C-b" . "Left") ("C-v" . "Next") ("M-v" . "Prior") ("M-w" . "C-c") ("C-w" . "C-x") ("C-y" . "C-v") ("M-<" . "Home") ("M->" . "End") ("C-M-b" . "M-Left") ("C-M-f" . "M-Right") ("M-f" . "C-Right") ("M-b" . "C-Left") ("C-k" . ("C-S-End" "C-x"))))) @end example The above form adds Emacs like keybindings to windows whose @var{window-class} matches ``Firefox'' or ``Chrome''. Additional application specific bindings may be included by using the specific X @var{window-class} values. The window matching pattern can also be specified as a function which returns @code{T} if the focused window matches. @example ;; Match any window with a window-class matching "Firefox" (define-remapped-keys `((,(lambda (win) (string-equal "Firefox" (window-class win))) ("C-n" . "Down") ("C-p" . "Up") ("C-f" . "Right") ("C-b" . "Left") ("C-v" . "Next") ("M-v" . "Prior") ("M-w" . "C-c") ("C-w" . "C-x") ("C-y" . "C-v") ("M-<" . "Home") ("M->" . "End") ("C-M-b" . "M-Left") ("C-M-f" . "M-Right") ("M-f" . "C-Right") ("M-b" . "C-Left") ("C-k" . ("C-S-End" "C-x"))))) @end example @subsection Circumventing Remapped Keys However, if the original key binding needs to be explictly applied the @command{send-raw-key} command may be used. It will prompt for a key which will be passed to the application as-is. For example, if the @command{send-raw-key} command were bound to @kbd{C-t C-q} as follows: @example (define-key *root-map* (kbd "C-q") "send-raw-key") @end example Then, pressing @kbd{C-t C-q}, while the Firefox window has focus, would prompt asking for ``Press a key to send''. Pressing @kbd{C-n} at the prompt will send the keystroke as-is to Firefox, causing it to open a new window. If more than a single key needs to be passed to the application as-is, the variable @var{*remapped-keys-enabled-p*} may be used. Set to nil it will disable all remapped keys. !!! send-raw-key ### *remapped-keys-enabled-p* @node Commands, Message and Input Bar, Key Bindings, Top @chapter Commands If you've used Emacs before you'll find the distinction between commands and functions familiar. Commands are simply functions that can be bound to keys and executed interactively from StumpWM's input bar. Whereas, in Emacs, the special "(interactive)" declaration is used to turn a function into a command, in StumpWM commands are made with a separate @command{defcommand} or @command{define-interactive-keymap} macro. Once a command is defined, you can call it by invoking the @command{colon} command (@kbd{C-t ;}), and typing the name of the command. This may be sufficient for commands that aren't used very often. To see all the currently-defined commands, invoke the command called @command{commands}: ie press @kbd{C-t ;}, type ``commands'', and hit return. Commonly-used commands can also be bound to a keystroke, which is much more convenient. To do this, use the @command{define-key} function (see @ref{Key Bindings}), giving the name of the command as a string. For example: @example (define-key *root-map* (kbd "d") "exchange-direction") @end example You cannot give the command name as a symbol, nor can you bind a key to a regular function defined with @command{defun}. If the command takes arguments (see @ref{Writing Commands}), you can fix those arguments when defining the key-binding, by including the arguments in the same string as the command name, separated by a space. For instance, the @command{exchange-direction} command, which is unbound by default, requires a direction in which to exchange windows. If you call @command{exchange-direction} directly, it will prompt you for the direction. If you know that you often exchange in left/right directions, and want those actions bound to keys, you can use the following in your customization file: @example (define-key *root-map* (kbd "[") "exchange-direction left") (define-key *root-map* (kbd "]") "exchange-direction right") @end example Multiple arguments can be included by adding them to the command string, separated by spaces. Not all argument types can be represented as strings, but StumpWM will do its best to convert types. StumpWM does not implement the Emacs concept of prefix arguments. @menu * Writing Commands:: * StumpWM Types:: * Common Built-in Commands:: @end menu @node Writing Commands, StumpWM Types, Commands, Commands @section Writing Commands StumpWM commands are written much like any Lisp function. The main difference is in the way command arguments are specified. The @command{defcommand} macro takes a list of arguments as its first form (similar to the @command{defun} macro), and a corresponding list of types as its second form. All arguments must belong to a ``type''. Each type specification has two parts: a keyword specifying the argument type, and a string prompt that will be displayed when asking the user to enter the argument value. A typical @command{defcommand} might look like this: @example (defcommand now-we-are-six (name age) ((:string "Enter your name: ") (:number "Enter your age: ")) (message "~a, in six years you will be ~a" name (+ 6 age))) @end example If @command{now-we-are-six} is called interactively via the @command{colon} command, the user will be prompted for a string and a number, which will then be bound to ``name'' and ``age'', respectively, in the body of the command. When invoking the command via a key-binding, it is possible to provide some or all of the arguments directly: @example (define-key *root-map* (kbd "L") "now-we-are-six John") @end example In this case, hitting @kbd{C-t L} will only prompt for an age (the first string argument is already bound to ``John''). Argument values provided this way always bind to the earliest arguments defined: ie, it is not possible to specify an age, but prompt the user for a name. If the type declaration does not include a prompt (ie, it looks like ``(:type nil)'', or ``(:type)'' or just ``:type''), the argument is considered optional. It can be provided via a key-binding invocation, as above, but if it isn't, the user will not be prompted, and the argument will be bound to nil. It is possible to limit the scope under which the command will be usable: a command can be defined to work only a specific group type; the three currently implemented are tile groups,f loating groups, and dynamic groups. This is done by replacing the name of the command with a two-element list: the name of the command as a symbol, and either the symbol tile-group or floating-group. For instance, the @command{next} command, which only functions in tile groups, is defined this way: @example (defcommand (next tile-group) @dots{}) @end example %%% defcommand %%% defcommand-alias ### *last-command* @section Interactive Keymaps Interactive keymaps are a special type of command that basically pushes another keymap on top of the current one. The new keymap will only be removed after an exit command is run. An example is @command{iresize}. The macro @command{define-interactive-keymap} is used to define an interactive keymap. The first argument is the same as @command{defcommand}. The second argument is a list of extra configurations that can be used for controlling the command and the rest are the key bindings for the new command, optionally with a @code{t} appended; this tells @code{define-interactive-keymap} to exit the keymap upon use of that keybinding. For instance, a simple interactive keymap: @example (define-interactive-keymap my-new-command nil ((kbd "a") "execute-a-command") ((kbd "b") "execute-b-command" t)) @end example This creates a command called @code{my-new-command} that, when called, will activate the interactive keymap mode. In this mode, the user can press ``a'' or ``b'' repeatedly, omitting any prefix. The default exit commands are @code{RET}, @code{C-g} and @code{ESC}. This creates a command called @code{my-new-command} that, when called, will activate the interactive keymap mode. In this mode, the user can press ``a'' or ``b'', omitting any prefix. The user can press ``a'' repeatedly, however pressing ``b'' exits the keymap. The default exit commands are @code{RET}, @code{C-g} and @code{ESC}. The available configuration is @code{on-enter}, @code{on-exit} and @code{abort-if}: @example (defun before-foo () (message "start foo")) (defun after-foo () (message "end foo")) (defun foo-p () (and *bar* *baz*)) (defparameter *custom-exit-keys* '((kbd "RET") (kbd "SPC") (kbd "C-g") (kbd "ESC"))) (define-interactive-keymap foo (:on-enter #'before-foo :on-exit #'after-foo :abort-if #'foo-p :exit-on *custom-exit-keys*)) @end example In the above example, the message ``start foo'' will appear before starting the interactive keymap, ``end foo'' will appear right after the command exits; We've added SPC as an exit key with custom exit keys. Also, the command executes only if the variables @code{*bar*} and @code{*baz*} are true. %%% define-interactive-keymap !!! call-and-exit-kmap @node StumpWM Types, , Writing Commands, Commands @section StumpWM Types All command arguments must be of a defined ``StumpWM type''. The following types are pre-defined: @table @var @item :y-or-n A yes or no question returning T or NIL. @item :variable A lisp variable @item :function A lisp function @item :command A StumpWM command as a string. @item :key-seq A key sequence starting from *TOP-MAP* @item :window-number An existing window number @item :number An integer number @item :string A string @item :key A single key chord @item :window-name An existing window's name @item :direction A direction symbol. One of :UP :DOWN :LEFT :RIGHT @item :gravity A gravity symbol. One of :center :top :right :bottom :left :top-right :top-left :bottom-right :bottom-left @item :group An existing group @item :frame A frame @item :shell A shell command @item :rest The rest of the input yet to be parsed. @item :module An existing StumpWM module @end table Additional types can be defined using the macro @command{define-stumpwm-type}. Emacs users who are accustomed to writing more complicated interactive declarations using "(interactive (list @dots{}))" forms will find that similar logic can be put into StumpWM type definitions. The macro is called like this: @example (define-stumpwm-type :type-name (input prompt) body) @end example The keyword :type-name will then be available for use in @command{defcommand} macros. When commands are called, the bodies of these type definitions are called in turn to produce actual argument values. Type definitions produce their value in one of several ways: by reading it from the argument line bound to a keystroke, by prompting the user to enter a value, or by generating it programmatically. Within the body of the type definition, the argument ``input'' is bound to the argument line provided in the command string, and ``prompt'' to the string prompt provided in the @command{defcommand} form. The usual convention is to first check if an argument has been provided in ``input'' and, if it hasn't, to prompt for it using ``prompt''. StumpWM provides several convenience functions for handling the value of ``input'': @itemize @item @command{argument-pop} (input) pop the next space-delimited word or a double quote delimited string argument from the argument line. Backslashes may be used to escape double quotes or backslashes inside double quoted strings. @item @command{argument-pop-rest} (input) return the remainder of the argument line as a single string, leaving input empty @item @command{argument-pop-or-read} (input prompt &optional completions) either pop an argument from the argument line, or if it is empty use ``prompt'' to prompt the user for a value @item @command{argument-pop-rest-or-read} (input prompt &optional completions) either return the remainder of the argument line as a string, leaving input empty, or use ``prompt'' to prompt the user for a value @end itemize As an example, here's a new type called :smart-direction. The existing :direction type simply asks for one of the four directions ``left'', ``right'', ``up'' or ``down'', without checking to see if there's a frame in that direction. Our new type, :smart-direction, will look around the current frame, and only allow the user to choose a direction in which another frame lies. If only one direction is possible it will return that automatically without troubling the user. It signals an error for invalid directions; it could alternately return a ``nil'' value in those cases, and let the command handle that. @example (define-stumpwm-type :smart-direction (input prompt) (let ((valid-dirs (loop ; gather all the directions in which there's a neighbouring frame with values = '(("up" :up) ("down" :down) ("left" :left) ("right" :right)) with frame-set = (group-frames (window-group (current-window))) for dir in values for neighbour = (neighbour (second dir) (window-frame (current-window)) frame-set) if (and neighbour (frame-window neighbour)) collect dir)) (arg (argument-pop input))) ; store a possible argument (cond ((null valid-dirs) ; no directions, bail out (throw 'error "No valid directions")) (arg ; an arg was bound, but is it valid? (or (second (assoc arg valid-dirs :test #'string=)) (throw 'error "Not a valid direction"))) ((= 1 (length valid-dirs)) ; only one valid direction (second (car valid-dirs))) (t ; multiple possibilities, prompt for direction (second (assoc (completing-read input prompt valid-dirs :require-match t) valid-dirs :test #'string=)))))) (defcommand smarty (dir) ((:smart-direction "Pick a direction: ")) ;; `dir' is a keyword here (message "You're going ~a" (string-downcase dir))) (define-key *root-map* (kbd "R") "smarty right") @end example %%% define-stumpwm-type @node Common Built-in Commands, , Writing Commands, Commands @section Common Built-in Commands !!! emacs !!! version !!! banish !!! ratwarp !!! ratrelwarp !!! ratclick !!! restart-hard !!! restart-soft !!! lastmsg !!! commands !!! keyboard-quit !!! quit !!! reload !!! echo-date !!! eval-line !!! command-mode !!! list-window-properties !!! show-window-properties !!! time @node Message and Input Bar, Windows, Commands, Top @chapter Message and Input Bar ### *suppress-echo-timeout* !!! echo @@@ err @@@ wrap ### *message-max-width* ### *help-max-height* ### *which-key-format* !!! colon %%% with-restarts-menu @@@ restarts-menu @menu * Customizing The Bar:: * Using The Input Bar:: * Programming The Message Bar:: * Programming the Input Bar:: @end menu @node Customizing The Bar, Using The Input Bar, Message and Input Bar, Message and Input Bar @section Customizing The Bar The bar's appearance and behavior can be modified with the following functions and variables. See @ref{Colors} for an explanation of how to set these color variables. @@@ set-fg-color @@@ set-bg-color @@@ set-border-color @@@ set-msg-border-width @@@ set-font ### *message-window-padding* ### *message-window-y-padding* ### *message-window-gravity* ### *message-window-input-gravity* ### *message-window-timer* ### *timeout-wait* ### *timeout-wait-multiline* ### *input-window-gravity* @node Using The Input Bar, Programming The Message Bar, Customizing The Bar, Message and Input Bar @section Using The Input Bar The following is a list of keybindings for the Input Bar. Users of Emacs will recognize them. @table @kbd @item DEL Delete the character before point (@code{delete-backward-char}). @item M-DEL Kill back to the beginning of the previous word (@code{backward-kill-word}). @item C-d @itemx Delete Delete the character after point (@code{delete-forward-char}). @item M-d Kill forward to the end of the next word (@code{forward-kill-word}). @item C-f @itemx Right Move forward one character (@code{forward-char}). @item M-f Move forward one word (@code{forward-word}). @item C-b @itemx Left Move backward one character (@code{backward-char}). @item M-b Move backward one word (@code{backward-word}). @item C-a @itemx Home Move to the beginning of the current line (@code{move-beginning-of-line}). @item C-e @itemx End Move to the end of the current line (@code{move-end-of-line}). @item C-k Kill to the end of the line (@code{kill-line}). @item C-u Kill to the beginning of the line (@code{kill-to-beginning}), the same as @kbd{C-a C-k}. @item C-p @itemx Up Move to the next earlier entry saved in the command history (@command{history-back}). @item C-n @itemx Down Move to the next later entry saved in the command history (@command{history-forward}). @item RET Submit the entered command (@command{submit}). @item C-g Abort the current action by closing the Input Bar (@command{abort}). @item C-y Paste text from clipboard into the Input Bar (@command{yank-selection}). @item TAB Clockwise tab complete the current string, if possible. Press @kbd{TAB} again to cycle through completions. @item S-TAB Counter-clockwise tab complete the current string, if possible. Press @kbd{S-TAB} again to cycle through completions. @end table @node Programming The Message Bar, Programming the Input Bar, Using The Input Bar, Message and Input Bar @section Programming The Message Bar @@@ echo-string @@@ message %%% with-message-queuing ### *queue-messages-p* ### *input-history-ignore-duplicates* ### *input-completion-style* @@@ make-input-completion-style-cyclic @@@ make-input-completion-style-unambiguous !!! copy-last-message @node Programming the Input Bar, , Programming The Message Bar, Message and Input Bar @section Programming the Input Bar New input behavior can be added to the input bar by creating editing functions and binding them to keys in the @var{*input-map*} using @command{define-key}, just like other key bindings. An input function takes 2 arguments: the input structure and the key pressed. @@@ read-one-line @@@ read-one-char @@@ completing-read @@@ input-insert-string @@@ input-insert-char ### *input-map* @node Windows, Frames, Message and Input Bar, Top @chapter Windows !!! next !!! prev !!! delete-window !!! kill-window !!! kill-windows-current-group !!! kill-windows-other !!! echo-windows !!! other-window !!! pull-hidden-next !!! pull-hidden-previous !!! pull-hidden-other !!! pull-from-windowlist !!! renumber !!! meta !!! select-window !!! select-window-by-number !!! select-window-by-name !!! repack-window-numbers !!! title !!! windowlist !!! windowlist-by-class !!! fullscreen !!! info !!! refresh !!! redisplay !!! float-this !!! unfloat-this !!! flatten-floats !!! unmaximize !!! toggle-always-on-top !!! toggle-always-show !!! window-send-string @@@ window-head @@@ window-sync @@@ window-visible-p @@@ raise-window @@@ focus-window ### *xwin-to-window* ### *window-format* ### *window-info-format* ### *window-name-source* ### *new-window-preferred-frame* ### *hidden-window-color* ### *honor-window-moves* %%% define-fullscreen-in-frame-rule @@@ add-fullscreen-in-frame-rule @@@ remove-fullscreen-in-frame-rule ### *fullscreen-in-frame-p-window-functions* @menu * Window Marks:: * Customizing Window Appearance:: * Controlling Raise And Map Requests:: * Programming With Windows:: * Rule Based Window Placement:: * Window Selection Expressions:: @end menu @node Window Marks, Customizing Window Appearance, Windows, Windows @section Window Marks Windows can be marked. A marked window has a # beside it in the window list. Some commands operate only on marked windows. !!! mark !!! clear-window-marks !!! pull-marked @node Customizing Window Appearance, Controlling Raise And Map Requests, Window Marks, Windows @section Customizing Window Appearance ### *maxsize-border-width* ### *transient-border-width* ### *normal-border-width* ### *window-border-style* See @ref{Colors} for an explanation of how to set these color variables. @@@ set-win-bg-color @@@ set-focus-color @@@ set-unfocus-color @@@ set-float-focus-color @@@ set-float-unfocus-color @@@ set-normal-gravity @@@ set-maxsize-gravity @@@ set-transient-gravity !!! gravity @@@ gravity-coords @node Controlling Raise And Map Requests, Programming With Windows, Customizing Window Appearance, Windows @section Controlling Raise And Map Requests It is sometimes handy to deny a window's request to be focused. The following variables determine such behavior. A map request occurs when a new or withdrawn window requests to be mapped for the first time. A raise request occurs when a client asks the window manager to give an existing window focus. ### *deny-map-request* ### *deny-raise-request* ### *suppress-deny-messages* Some examples follow. @example ;; Deny the firefox window from taking focus when clicked upon. (push '(:class "gecko") stumpwm:*deny-raise-request*) ;; Deny all map requests (setf stumpwm:*deny-map-request* t) ;; Deny transient raise requests (push '(:transient) stumpwm:*deny-map-request*) ;; Deny the all windows in the xterm class from taking focus. (push '(:class "Xterm") stumpwm:*deny-raise-request*) @end example @node Programming With Windows, Rule Based Window Placement, Controlling Raise And Map Requests, Windows @section Programming With Windows %%% define-window-slot @@@ window-send-string ### *default-window-name* ### *window-events* ### *window-parent-events* @node Rule Based Window Placement, Window Selection Expressions, Programming With Windows, Windows @section Rule Based Window Placement %%% define-frame-preference @@@ clear-window-placement-rules !!! remember !!! forget !!! dump-window-placement-rules !!! restore-window-placement-rules ### *window-placement-rules* @node Window Selection Expressions, , Rule Based Window Placement, Windows @section Window Selection Expressions Window Selection Expressions (WSE) were inspired by SQL. The intent is to allow writing consise code to select the windows you need and to act upon them (or just to get the list of selected windows). The implementation includes a set of (hopefully) consistent concisely-named wrappers for the StumpWM functionality useful for window set description and the act-on-matching-windows macro that encapsulates the logic of iterating over a window set. If we had SQL in StumpWM, we would write @code{select window_id from windows as w where w.title = 'XTerm'}. WSE chooses to be more Lisp-style and instead uses @code{(act-on-matching-windows (w) (titled-p w "XTerm") w)} The @code{act-on-matching-windows} function also allows performing some actions, for example getting all the windows titled XTerm into the current group: @code{(act-on-matching-windows (w) (titled-p w "XTerm") (pull-w w))} @@@ move-windows-to-group %%% act-on-matching-windows @@@ pull-w @@@ titled-p @@@ title-re-p @@@ classed-p @@@ class-re-p @@@ typed-p @@@ type-re-p @@@ roled-p @@@ role-re-p @@@ resed-p @@@ res-re-p @@@ grouped-p @@@ in-frame-p @node Frames, Mode-line, Windows, Top @chapter Frames Frames contain windows. All windows exist within a frame. Those used to ratpoison will notice that this differs from ratpoison's window pool, where windows and frames are not so tightly connected. !!! pull-window-by-number !!! hsplit !!! vsplit !!! hsplit-equally !!! vsplit-uniformly !!! vsplit-equally !!! hsplit-uniformly !!! remove-split !!! only !!! curframe !!! fnext !!! fprev !!! sibling !!! fother !!! fselect !!! resize !!! resize-direction !!! balance-frames !!! fclear !!! move-focus !!! move-window !!! next-in-frame !!! prev-in-frame !!! other-in-frame !!! next-urgent !!! frame-windowlist !!! echo-frame-windows !!! exchange-direction !!! expose %%% save-frame-excursion @@@ run-or-pull @@@ only-one-frame-p ### *min-frame-width* ### *min-frame-height* ### *new-frame-action* ### *expose-auto-tile-fn* ### *expose-n-max* ### *frame-indicator-text* ### *frame-indicator-timer* ### *frame-number-map* @menu * Interactively Resizing Frames:: * Frame Dumping:: @end menu @node Interactively Resizing Frames, Frame Dumping, Frames, Frames @section Interactively Resizing Frames There is a mode called @code{iresize} that lets you interactively resize the current frame. To enter the mode use the @code{iresize} command or type @key{C-t r}. The following keybindings apply to the mode: @table @kbd @item C-p @itemx Up @itemx k Shrink the frame vertically. @item C-n @itemx Down @itemx j Expand the frame vertically. @item C-f @itemx Right @itemx l Expand the frame horizontally. @item C-b @itemx Left @itemx h Shrink the frame horizontally. @item C-g @itemx ESC Abort the interactive resize. @item RET Select the highlighted option. @end table !!! iresize @@@ setup-iresize ### *resize-map* ### *resize-increment* @node Frame Dumping, , Interactively Resizing Frames, Frames @section Frame Dumping The configuration of frames and groups can be saved and restored using the following commands. !!! dump-desktop-to-file !!! dump-group-to-file !!! dump-screen-to-file !!! restore-from-file !!! place-existing-windows !!! place-current-window The configuration files are stored in the @var{$XDG_CONFIG_HOME/stumpwm}. The file name specified is saved as a @code{.dump} file type. For example, @code{: dump-desktop-to-file example} may save a file in @code{~/.local/share/stumpwm/example.dump}. @code{restore-from-file} also adds the @code{.dump} extension by default. @node Mode-line, Groups, Frames, Top @chapter The Mode Line The mode line is a bar that runs across either the top or bottom of a head and is used to display information. By default the mode line displays the list of windows, similar to the output @kbd{C-t w} produces. Alternatively, external panel applications such as the GNOME panel and KDE's kicker may be used. Simply starting one of these programs is enough to set it as the mode line of the head it would like to be on (if the panel is XRandR aware) or whichever head is available. In order to avoid problems displaying menus, configure your panel application for positioning at the top or bottom of the head rather than relying on @var{*mode-line-position*} The mode line can be turned on and off with the @command{mode-line} command or the lisp function @code{stumpwm:toggle-mode-line}. Each head has its own mode line. For example: @example ;; turn on/off the mode line for the current head only. (stumpwm:toggle-mode-line (stumpwm:current-screen) (stumpwm:current-head)) @end example The mode line is updated after every StumpWM command. To display the window list and the current date on the modeline, one might do the following: @example (setf stumpwm:*screen-mode-line-format* (list "%w | " '(:eval (stumpwm:run-shell-command "date" t)))) @end example @code{(stumpwm:run-shell-command "date" t)} runs the command @command{date} and returns its output as a string. !!! mode-line @@@ toggle-mode-line ### *screen-mode-line-format* ### *time-format-string-default* ### *time-modeline-string* $$$ *new-mode-line-hook* ### *screen-mode-line-formatters* ### *window-formatters* @@@ bar @@@ bar-zone-color @@@ add-screen-mode-line-formatter @@@ enable-mode-line The following variables control the color, position, and size of the mode line. See @ref{Colors} for an explanation of how to set these color variables. ### *mode-line-position* ### *mode-line-border-width* ### *mode-line-highlight-template* ### *mode-line-pad-x* ### *mode-line-pad-y* ### *mode-line-background-color* ### *mode-line-foreground-color* ### *mode-line-border-color* ### *mode-line-timeout* @menu * Mode-line Interaction:: @end menu @node Mode-line Interaction, , Mode-line, Mode-line @section Mode-line Interaction Mode line formatters can register sections of text to be clickable by use of the color formatters @code{:on-click} and @code{:on-click-end}. Any text enclosed by these formatters has its bounds saved, and when the mode line recieves a button press event these bounds are checked against to find a clickable area, whose registered function is then called. These formatters can be thought of as similar to XML tags. To disable the on-click behavior, remove the function @code{check-for-ml-press} from the hook @var{*mode-line-click-hook*}. To call a function by click the function must first be registered. The function must take at least one argument, the button code. Here is an example of a click-to-focus function and its registration: @example (defun ml-on-click-focus-window (code id &rest rest) (declare (ignore code rest)) (when-let ((window (window-by-id id))) (focus-all window))) (register-ml-on-click-id :ml-on-click-focus-window #'ml-on-click-focus-window) @end example This defines a function that focuses a window based upon its X11 window ID, and registers it under the ID @code{:ml-on-click-focus-window}. Here is an example of a mode line formatter that makes use of this function: @example (add-screen-mode-line-formatter #\i 'fmt-head-window-list-clickable) (defun fmt-head-window-list-clickable (ml) "Using *window-format*, return a 1 line list of the windows, space seperated and clickable." (flet ((fmt-w (w) (let ((str (format-expand *window-formatters* *window-format* w))) (format-with-on-click-id (if (eq w (current-window)) (fmt-highlight str) str) :ml-on-click-focus-window (window-id w))))) @verbatim (format nil "~{~a~^ ~}" @end verbatim (mapcar #'fmt-w (sort1 (head-windows (mode-line-current-group ml) (mode-line-head ml)) #'< :key #'window-number))))) @end example In the above formatter, every windows expansion is wrapped in a :on-click/end pair, which takes the ID we registered as the function to call and the window ID as an argument to be passed to its function. The arguments provided to @code{:on-click} will be read but not evaluated. The string generated will look like so: @example "^(:on-click :ml-on-click-focus-window 308242)window text^(:on-click-end)" @end example Clickable text can be nested, in which case the innermost clickable text will take precendent. In the following example @code{:id2} will be dispatched when clicking @code{2}, but @code{:id1} will be dispatched when clicking @code{1} and @code{3}: @example "^(:on-click :id1)1^(:on-click :id2)2^(:on-click-end)3^(:on-click-end)" @end example If one wished for right click to delete windows, then the following example could be placed in the .stumpwmrc: @example (labels ((ml-on-click-focus-or-delete-window (code id &rest rest) (declare (ignore rest)) (when-let ((window (window-by-id id))) (let ((button (decode-button-code code))) (case button ((:left-button) (focus-all window)) ((:right-button) (delete-window window))))))) (register-ml-on-click-id :ml-on-click-focus-window #'ml-on-click-focus-or-delete-window)) @end example This will replace the @code{:ml-on-click-focus-window} function, and all uses of @code{:on-click} formatters referring to @code{:ml-on-click-focus-window} will use the new function. @@@ register-ml-on-click-id @@@ format-with-on-click-id @node Groups, Screens, Mode-line, Top @chapter Groups Groups in StumpWM are more commonly known as @dfn{virtual desktops} or @dfn{workspaces}. Why not create a new term for it? !!! gnew !!! gnew-float !!! gnew-dynamic !!! gnewbg !!! gnewbg-float !!! gnewbg-dynamic !!! gnext !!! gprev !!! gnext-with-window !!! gprev-with-window !!! gother !!! gmerge !!! groups !!! vgroups !!! gselect !!! gmove !!! gmove-and-follow !!! gmove-marked !!! gkill !!! gkill-other !!! grename !!! grouplist ### *list-hidden-groups* ### *group-top-maps* ### *default-group-name* @@@ add-group @@@ group-add-head @@@ group-add-window @@@ group-button-press @@@ group-current-head @@@ group-current-window @@@ group-delete-window @@@ group-focus-window @@@ group-indicate-focus @@@ group-lost-focus @@@ group-move-request @@@ group-raise-request @@@ group-remove-head @@@ group-before-resize-head @@@ group-after-resize-head @@@ group-resize-request @@@ group-root-exposure @@@ group-startup @@@ group-suspend @@@ group-sync-all-heads @@@ group-sync-head @@@ group-wake-up @@@ really-raise-window ### *run-or-raise-all-groups* @menu * Customizing Groups:: @end menu @node Customizing Groups, , Groups, Groups @section Customizing Groups ### *group-formatters* ### *group-format* @@@ current-group @node Screens, Minor Modes, Groups, Top @chapter Screens StumpWM handles multiple screens. !!! snext !!! sprev !!! sother ### *run-or-raise-all-screens* @menu * External Monitors:: * Programming With Screens:: @end menu @node External Monitors, Programming With Screens, Screens, Screens @section External Monitors StumpWM refers to each monitor as a head. Heads are logically contained by screens. In a dual-monitor configuration, there will be one screen with two heads. Non-rectangular layouts are supported (frames will not be created in the 'dead zone'.) And message windows will be displayed on the current head--that is, the head to which the currently focused frame belongs. In addition, StumpWM listens for XRandR events and re-configures the heads to match the new monitor configuration. Occasionally StumpWM will miss an XRandR event, use @code{refresh-heads} to synchronize the head configuration. !!! refresh-heads @node Programming With Screens, , External Monitors, Screens @section Programming With Screens @@@ current-screen @@@ screen-current-window @@@ current-window ### *screen-list* @node Minor Modes, Internals, Screens, Top @chapter Minor Modes Like Emacs, StumpWM has the concept of minor modes. These are defined by the macro @code{DEFINE-MINOR-MODE}. Defining a minor mode creates a class and a set of methods specializing upon it. Minor modes are scoped to a window, head, group, or screen, or they may be unscoped. In addition to this minor modes may be local or global. When a minor mode is global all new instances of the scope object will be created with the minor mode already active in them. Minor modes define their own top level and root level keymaps, as well as hooks that are run upon enabling or disabling the minor mode, and a lighter to display in the mode line. Minor modes are mixins that get added to the appropriate scope object when enabled. As such minor modes allow the augmenting, modifying, and overriding of default StumpWM behavior by defining methods for the generic functions of the scope object. For example, a minor mode may be scoped to a window and define a method for the generic function @code{UPDATE-DECORATION} to change how window decoration is handled for the windows it is enabled in. %%% define-minor-mode @menu * Programming With Minor Modes:: * Minor Mode Scopes:: * Minor Mode Example:: @end menu @node Programming With Minor Modes, Minor Mode Scopes, Minor Modes, Minor Modes @section Programming With Minor Modes Minor modes get their power from their ability to override and augment generic functions which are called with the minor mode's scope object as an argument. If you find a function whose behavior you wish to augment or override in the process of writing a minor mode, open an issue or submit a PR to generify the function. Generification is easily done like so: @example (defun somefun (a b) "docstring" (otherfun (+ a b))) ;; the above becomes (defgeneric somefun (a b) (:documentation "docstring") (:method (a b) (otherfun (+ a b)))) @end example When defining a minor mode, the programmer may desire to perform setup for the minor mode. This is can be done in three ways. The first is to hang a function upon the minor modes enable hook. However this runs the risk of users potentially clobbering the initialization function, or modifying the hook such that the initialization function is not the first function run. The second way is to define a method for the generic function @code{update-instance-for-different-class}. This function should specialize upon the minor mode as the second argument. As a final option, one can define before, after, and around methods for the generic function @code{autoenable-minor-mode} if and only if the method does not access any slots within the object. One of the pitfalls of minor modes is that they are ultimately enabled by calling @code{change-class}, which places some restrictions upon where they can be enabled. Specifically, it is implied to be undefined behavior if a minor mode is enabled in an object from within a method which accesses slots of that object. While in practice this has not proven to be an issue at the time of writing, this is undefined behavior and future versions of SBCL may break if this is done. When writing a minor mode, it is often useful to separate out the desired functionality into its own mixin classes and use those in the superclass list of the minor mode. For example: @example (define-minor-mode my-mode (my-mixin minor-mode) ()) @end example This prevents issues with inheritance and dynamic mixins from cropping up. Since minor modes are just classes, a minor mode can descend from another minor mode. However after enabling the subclass minor mode, the superclass minor mode cannot be enabled. However if the superclass minor mode is enabled first, then the subclass minor mode can be enabled. The easiest way around this is the aforementioned approach of mixins. As an example of the inheritance issue, take the following minor mode definitions: @example (define-minor-mode x () ()) (define-minor-mode y (x) ()) (enable-minor-mode 'x) (enable-minor-mode 'y) ; both modes are enabled ;; As opposed to (enable-minor-mode 'y) (enable-minor-mode 'x) ; signals an error @end example When enabling and disabling minor modes theres a set of generic functions in charge of determining what object to mix the minor mode in to and whether or not to mix it. @@@ autoenable-minor-mode Defining a minor mode defines a main method for this generic function which will mix the minor mode into the scope object when called and returns T. This method specializes upon the minor mode symbol and the scope type. The minor mode will only be enabled and the hooks run when the function @code{ENABLE-WHEN} returns T. Any before after or around methods for this function must not access any slots. @@@ autodisable-minor-mode Defining a minor mode defines a main method for this generic function which specializes upon the mode symbol and the mode, and removes the minor mode from the object. Any methods for this function must not access any slots. @@@ enable-when Outside of autoenabling and autodisabling minor modes, there are several generic functions which dispatch upon minor modes and their names. @@@ minor-mode-global-p @@@ minor-mode-scope @@@ minor-mode-enable-hook @@@ minor-mode-disable-hook @@@ minor-mode-hook @@@ minor-mode-keymap This function has a set of main methods defined which all call the next method to obtain a list of top maps for every minor mode. Any extra keymaps one wishes to add to the minor mode may be added by defining a main method which calls @code{call-next-method} and returns a flat list. Similarly, an around method may be used which abides by the same rules. @@@ minor-mode-lighter This function operates similarly to @code{minor-mode-keymap}, with a main method defined for every minor mode which calls @code{call-next-method} and returns a flat list. In addition there is a single around method defined which concatenates all these strings together. There are also a set of regular functions and special variables which which may be of use when working with minor modes. @@@ enable-minor-mode @@@ disable-minor-mode @@@ list-modes @@@ list-minor-modes @@@ current-minor-modes @@@ minor-mode-enabled-p @@@ find-minor-mode ### *minor-mode* ### *minor-mode-enable-hook* ### *minor-mode-disable-hook* ### *unscoped-minor-modes* €€€ minor-mode @node Minor Mode Scopes, Minor Mode Example, Programming With Minor Modes, Minor Modes @section Minor Mode Scopes Minor modes can be scoped to different objects in a rather arbitrary manner. These scopes are defined by the macro @code{DEFINE-MINOR-MODE-SCOPE}. Because minor modes are implemented as mixins, the object returned by a scopes current object function must be a class instance. %%% define-minor-mode-scope %%% define-descended-minor-mode-scope @@@ add-minor-mode-scope When a minor mode is defined its scope is looked up and validated by the function @code{VALIDATE-SCOPE}. This function takes a scope and a list of superclasses, and ensures that the scope can descend from the superclasses scopes. This restricts the valid scopes to ensure that a minor mode scoped to @code{:GROUP} cant be a subclass of a minor mode scoped to @code{:WINDOW}, for example. However there is a way to override this by explicitly stating that two otherwise incompatible scopes are compatible. This is done by defining methods for the generic function @code{VALIDATE-SUPERSCOPE} which dispatch upon the scope designators. Such methods should return at least one value, indicating if the superscope is a valid parent of the scope. If multiple values are returned, the second value must indicate whether the superscope is an invalid parent of the scope. For example: @verbatim (defmethod stumpwm:validate-superscope ((c (eql :id1)) (p (eql :id2))) "Explicitly allow id1 to descend from id2" (values t nil)) (defmethod stumpwm:validate-superscope ((c (eql :id3)) (p (eql :id4))) "Explicitly prevent id3 from descending from id4" (values nil t)) @end verbatim When defining and using scopes the type specifier is important; it is used to determine what minor modes should be mixed into an object when it is created. For this reason it is important when defining a minor mode or minor mode scope to understand the type hierarchy. It may also be in the programmers best interests to define an accompanying type. The following scopes are predefined: @itemize @item Designator: @code{:UNSCOPED}, type: @code{T} Current object: return the global unscoped object.@* @item Designator: @code{:SCREEN}, type: @code{SCREEN} Current object: return the current screen.@* @item Designator: @code{:GROUP}, type: @code{GROUP} Current object: return the current group.@* @item Designator: @code{:TILE-GROUP}, type: @code{TILE-GROUP} Current object: return the current group.@* @item Designator: @code{:DYNAMIC-GROUP}, type: @code{DYNAMIC-GROUP} Current object: return the current group.@* @item Designator: @code{:FLOAT-GROUP}, type: @code{FLOAT-GROUP} Current object: return the current group.@* @item Designator: @code{:TILING-NON-DYNAMIC-GROUP}, type: @code{TILE-GROUP} Current object: return the current group when it is a non-dynamic tiling group.@* @item Designator: @code{:HEAD}, type: @code{HEAD} Current object: return the current head.@* @item Designator: @code{:FRAME}, type: @code{FRAME} Current object: return the current frame when in a tiling group.@* @item Designator: @code{:FRAME-EXCLUDING-HEAD}, type: @code{ONLY-FRAME-NO-HEADS} Descends from minor mode scope @code{:FRAME}. @item Designator: @code{:WINDOW}, type: @code{WINDOW} Current object: return the current window.@* All objects: collect every window from every group in the current screen. @item Designator: @code{:TILE-WINDOW}, type: @code{TILE-WINDOW} Current object: return the current window.@* All objects: collect every window from every tiling group, filtering all floating windows. @item Designator: @code{:FLOAT-WINDOW}, type: @code{FLOAT-WINDOW} Current object: return the current window.@* All objects: colelct every window from every group, filtering all non floating windows. @end itemize @node Minor Mode Example, , Minor Mode Scopes, Minor Modes @section Minor Mode Example A simple example of a minor mode is a version of the Emacs modes viper or evil for StumpWM. Such a minor mode might look like this: @verbatim (define-minor-mode swm-evil-mode () () (:scope :screen) (:interactive t) (:top-map '(("i" . "swm-evil-mode") ("j" . "move-focus down") ("k" . "move-focus up") ("h" . "move-focus left") ("l" . "move-focus right") ("p" . "pull-hidden-previous") ("n" . "pull-hidden-next") ("S" . "hsplit") ("s" . "vsplit") ("r" . "remove-split") ("g" . *groups-map*) ("x" . *exchange-window-map*))) (:lighter-make-clickable nil) (:lighter "EVIL")) @end verbatim In the above example, the minor mode @code{swm-evil-mode} is defined, alongside a command of the same name which toggles it on and off. The minor mode is scoped to a screen, meaning that upon activation it will be dynamically mixed in to the screen object. The lighter is the string @code{"EVIL"} and the lighter is not made clickable. When defining a minor mode top map it is important to avoid multi-key bindings that clobber the prefix key. For example, if the prefix key is @kbd{C-t} then defining the keybinding @kbd{C-t n} in the top map of a minor mode is an error. Instead bind the key @kbd{n} in the minor mode's root map. As another example we can define a frame topbar mode. This should adjust every frame to leave extra space at the top of the frame to display a bar of some sort. The following assumes that the functions @code{frame-display-height} and @code{frame-display-y} are generic. @example (defclass frame-topbar () ((frame-topbar-height :initform 10 :accessor frame-topbar-height))) (defmethod frame-display-height :around (group (frame frame-topbar)) (let ((height (call-next-method))) (- height (frame-topbar-height frame)))) (defmethod frame-display-y :around (group (frame frame-topbar)) (let ((y (call-next-method))) (+ y (frame-topbar-height frame)))) (define-minor-mode frame-bar (frame-topbar minor-mode) () (:global t) (:scope :frame) (:lighter "T-BAR") (:interactive frame-topbar-mode)) (defmethod update-instance-for-different-class :after (prev (obj frame-bar) &rest rest) (declare (ignore prev rest)) (when (frame-window obj) (let* ((group (window-group (frame-window obj))) (windows (frame-windows group obj))) (mapc #'maximize-window windows)))) @end example In the above example, a class is defined which holds the height of the frame topbar. Then two around methods are defined such that windows querying the frame for their y position and height get an updated value reflecting the topbars presence. Then a minor mode is defined which inherits from the class we defined. It is scoped to frames and is a global minor mode, so it will be enabled in all existing frames and any other frames as they are created. Finally the initialization is handled in the after method for update-instance-for-different-class, which updates every window to have a new size which respects the topbar. The implementation of the actual topbar is left as an exercise for the reader. @node Internals, Interacting With Unix, Minor Modes, Top @chapter Internals @menu * IO Loop:: * Internal Functions Documentation:: @end menu @node IO Loop, Internal Functions Documentation, , Internals @section IO Loop StumpWM's internal loop is implemented by a generic multiplexing I/O loop for listening to I/O events from multiple sources. The model is as follows: An I/O multiplexer is represented as an object, with which I/O channels can be registered to be monitored for events when the I/O loop runs. An I/O channel is any object for which the generic functions IO-CHANNEL-IOPORT, IO-CHANNEL-EVENTS and IO-CHANNEL-HANDLE are implemented. IO-CHANNEL-IOPORT, given an I/O multiplexer and an I/O channel, should return the underlying system I/O facility that the channel operates on. The actual objects used to represent an I/O facility depends on the Lisp implementation, operating system and the specific I/O loop implementation, but, for example, on Unix implementations they will likely be numeric file descriptors. The I/O loop implementation implements IO-CHANNEL-IOPORT methods for the facilities it understands (such as FD-STREAMs on SBCL), so user-implemented channels should simply call IO-CHANNEL-IOPORT recursively on whatever it operates on. IO-CHANNEL-EVENTS, given an I/O channel, should return a list of the events that the channel is interested in. See the documentation for IO-CHANNEL-EVENTS for further details. The I/O loop guarantees that it will check what events a channel is interested in when it is first registered, and also at any time the channel has been notified of an event. If the channel changes its mind at any other point in time, it should use the IO-LOOP-UPDATE function to notify the I/O loop of such changes. The I/O loop may very well also update spuriously at other times, but such updates are not guaranteed. IO-CHANNEL-HANDLE is called by the I/O loop to notify a channel of an event. An I/O multiplexer is created with a MAKE-INSTANCE call on the class of the desired multiplexer implementation. If the code using the multiplexer has no certain preferences on an implementation (which should be the usual case), the variable *DEFAULT-IO-LOOP* points to a class that should be generally optimal given the current Lisp implementation and operating system. Given a multiplexer, channels can be registered with it using IO-LOOP-ADD, unregistered with IO-LOOP-REMOVE, and updated with IO-LOOP-UPDATE (as described above). Call IO-LOOP on the multiplexer to actually run it. ### *default-io-loop* ### *current-io-loop* ### *current-io-channel* @@@ io-channel-ioport @@@ io-channel-events @@@ io-channel-handle @@@ io-loop-add @@@ io-loop-remove @@@ io-loop-update @@@ io-loop @node Internal Functions Documentation, , IO Loop, Internals @section Internal Functions Documentation ### *executing-stumpwm-command* ### *suppress-abort-messages* !!! refresh-time-zone !!! getsel !!! putsel !!! copy-unhandled-error @@@ define-stumpwm-command !!! set-contrib-dir @node Interacting With Unix, Interacting With X11, Screens, Top @chapter Interacting With Unix !!! run-shell-command @@@ programs-in-path @@@ pathname-is-executable-p @@@ pathname-as-directory @@@ run-or-raise ### *shell-program* @@@ getenv @@@ (setf getenv) @node Interacting With X11, Miscellaneous Commands, Interacting With Unix, Top @chapter Interacting With X11 @@@ set-x-selection @@@ get-x-selection ### *default-selections* ### *x-selection* @node Miscellaneous Commands, Colors, Interacting With X11, Top @chapter Miscellaneous Commands The following is a list of commands that don't really fit in any other @@@ split-string @@@ argument-line-end-p @@@ argument-pop @@@ argument-pop-rest ### *display* @@@ input-delete-region @@@ input-goto-char @@@ input-point @@@ input-substring @@@ input-validate-region @@@ list-directory %%% move-to-head @@@ no-focus ### *record-last-msg-override* ### *toplevel-io* @menu * Menus:: * StumpWM's Data Directory:: * Debugging StumpWM:: * Sending a Bug Report:: * Timers:: * Getting Help:: @end menu @node Menus, StumpWM's Data Directory, , Miscellaneous Commands @section Menus @section Menus There are three different types of menus in StumpWM; single selection menus; interactive menus; and batch menus. Single-selection menus, as the name suggests, are used to pick a single item from a list. Interactive menus are used for marking multiple selections. Batch menus are used for performing actions on multiple menu items. Both batch and interactive menus share the same navigational keybindings, which are found in the table below. These can be customized by modifying the @var{*menu-map*} variable. Commands specific to each menu type can be modified by @var{*single-menu-map*} and @var{*batch-menu-map*}. @table @kbd @item C-p @itemx Up @itemx k Highlight the previous menu option. @item C-n @itemx Down @itemx j Highlight the next menu option. @item S-Down Scroll the entire page down one entry. @item S-Up Scroll the entire page up one entry. @item PageUp Scroll up one page. @item PageDown Scroll down one page. @item C-g @itemx ESC Abort the menu. @end table In addition, you can customize the number of items shown at a time (a page) with the @var{*menu-maximum-height*} variable. The default value, @code{50}, limits the menu size to 50 items. Setting it to @code{nil} will remove the limit on how many menu entries are shown (be careful, this can crash X11 when attempting to display a large amount of items). ### *menu-map* @@@ menu-page-up @@@ menu-page-down @@@ menu-up @@@ menu-down @@@ menu-scroll-up @@@ menu-scroll-down @@@ menu-abort @@@ menu-backspace @@@ menu-entry-apply @@@ menu-entry-display @@@ menu-finish @@@ command-menu @subsection Single Selection Menus Single selection menus can be searched; start typing when the menu is active, and the results are immediately filtered. Use @key{RET} to selected the highlighted option. @table @kbd @item RET Select the highlighted option. @end table ### *single-menu-map* @@@ select-from-menu @subsection Batch Menus Batch menus provide a menu that allows the user to mark items. Items are marked by highlighting an item, then pressing a corresponding key. The key pressed depends on the menu being shown, and the desired action. For example, in a menu allowing users to manage windows, windows to be closed/removed could be marked by @key{d}, and windows to be raised could be marked by @key{r}. All available actions and their keybindings are shown below. These can be customized with @var{*batch-menu-map*}. @table @kbd @item n @item Space Highlight the next item. @item p Highlight the previous item. @item u Unmark the selected item, then move the cursor down. @item DEL Unmark the selected item, then move the cursor up if it is not at the top of the menu. @item x @item RET Exit the menu and perform the actions associated with each mark. @end table ### *batch-menu-map* @@@ select-from-batch-menu @node StumpWM's Data Directory, Debugging StumpWM, Menus, Miscellaneous Commands @section StumpWM's Data Directory If you want to store StumpWM data between sessions, the recommended method is to store them in @file{~/.stumpwm.d/}. StumpWM supplies some functions to make doing this easier. ### *data-dir* @@@ data-dir-file %%% with-data-file @node Debugging StumpWM, Sending a Bug Report, StumpWM's Data Directory, Miscellaneous Commands @section Debugging StumpWM ### *debug-level* ### *debug-stream* ### *debug-expose-events* @@@ redirect-all-output @node Sending a Bug Report, Timers, Debugging StumpWM, Miscellaneous Commands @section Sending a Bug Report While StumpWM's code-base is quite mature, it still contains some bugs. If you encounter one here are some guidelines for making sure the developers can fix it: @itemize @bullet @item Include a procedure for reproducing the bug/bad behavior. Ideally this will include numbered steps starting with instructions on how you start StumpWM. Also include what the expected behavior was. @item Be as detailed as possible. Then add more detail! @item Make sure its not something you introduced by using an empty @file{.xinitrc} containing only @samp{exec /path/to/stumpwm}. @item Make sure the bug is present even when @file{.stumpwmrc} is empty. @item If you are using the git version, include the hash of the master branch, or better include the commit when you started to notice the bug. @item If you have code that fixes the bug, then open a pull request at @url{https://github.com/stumpwm/stumpwm/compare/}. @item If you don't have code to fix the bug, then open an issue at @url{https://github.com/stumpwm/stumpwm/issues/new}. @end itemize @node Timers, Getting Help, Sending a Bug Report, Miscellaneous Commands @section Timers StumpWM has a timer system similar to that of @dfn{Emacs}. @@@ idle-time @@@ run-with-timer @@@ cancel-timer @defun timer-p @var{timer} Return T if TIMER is a timer structure. @end defun @node Getting Help, , Timers, Miscellaneous Commands @section Getting Help !!! describe-key !!! describe-variable !!! describe-function !!! describe-command !!! where-is !!! modifiers !!! which-key-mode @@@ lookup-command ### *help-map* ### *help-keys* @node Colors, Hooks, Miscellaneous Commands, Top @chapter Colors When specifying a color, it is possible to use its X11 Color Name (usually in the file @file{/etc/X11/rgb.txt}). You can also use a six digit hex string prefixed by a '#' character in the same way that you can specify colors in HTML. All text printed by StumpWM is run through a coloring engine before being displayed. All color commands start with a @samp{^} (caret) character and apply to all text after it. @table @code @item ^0-9 A caret followed by a single digit number changes the foreground color to the specified color. A @samp{*} can be used to specify the normal color. See the color listing below. @item ^0-90-9 A caret followed by two digits sets the foreground and background color. The first digit refers to the foreground color and the second digit to the background color. A @samp{*} can be used in place of either digit to specify the normal color. See the color listing below. @item ^B Turn on bright colors. @item ^b Turn off bright colors. @item ^n Use the normal background and foreground color. @item ^R Reverse the foreground and background colors. @item ^r Turn off reverse colors. @item ^[ Push the current colors onto the color stack. The current colors remain unchanged. @item ^] Pop the colors off the color stack. @item ^> Align the rest of the line to the right of the window. @item ^f Sets the current font to the font at index n in the screen's font list. @item ^( &rest arguments) Allows for more complicated color settings: can be one of :fg, :bg, :reverse, :bright, :push, :pop, :font and :>. The arguments for each modifier differ: @itemize @item :fg and :bg take a color as an argument, which can either be a numeric index into the color map or a hexadecimal color in the form of "#fff" or "#ffffff". @item :reverse and :bright take either t or nil as an argument. T enables the setting and nil disables it. @item :push and :pop take no arguments. :push pushes the current settings onto the color stack, leaving the current settings intact. :pop pops color settings off the stack, updating the current settings. @item :font takes an integer that represents an index into the screen's list of fonts, or, possibly, a literal font object that can immediately be used. In a string you'll probably only want to specify an integer. @item :> takes no arguments. It triggers right-alignment for the rest of the line. @item :on-click takes one or more arguments and registers the following text area as clickable. The initial argument must be an ID registered using the function REGISTER-ML-ON-CLICK-ID. @item :on-click-end takes no arguments. It marks the end of clickable text begun by :on-click. @end itemize @item ^^ Print a regular caret. @end table The default colors are made to resemble the 16 VGA colors and are: @table @asis @item 0 black @item 1 red @item 2 green @item 3 yellow @item 4 blue @item 5 magenta @item 6 cyan @item 7 white @end table There are only 8 colors by default but 10 available digits. The last two digits are left up to the user. @ref{Behind The Scenes Look At Colors} for information on customizing colors. @menu * Behind The Scenes Look At Colors:: @end menu @node Behind The Scenes Look At Colors, , Colors, Colors @section Behind The Scenes Look At Colors Color indexes are stored in @var{*colors*} as a list. The default list of colors leave 2 slots for the user to choose. If you'd like to use @samp{Papaya Whip} and @samp{Dark Golden Rod 3} you might eval the following: @example (setf *colors* (append *colors* (list "PapayaWhip" "DarkGoldenRod3"))) (update-color-map (current-screen)) @end example Of course, you can change all the colors if you like. Additionally, both the normal and bright versions of a color can be specified by using a list of the form @code{(normal-color bright-color)}, for instance: @example (setf *colors* (append *colors* (list (list "PeachPuff" "PapayaWhip") (list "DarkGoldenRod3" "PaleGoldenrod")))) (update-color-map (current-screen)) @end example @@@ parse-color-string @@@ uncolorify ### *colors* @@@ update-color-map @node Hooks, Modules, Colors, Top @chapter Hooks StumpWM exports a number of hooks you can use to add customizations; like hooks in Emacs, you add to a hook with the @code{add-hook} function. For example: @example (stumpwm:add-hook 'stumpwm:*new-window-hook* 'my-new-window-custos) @end example adds your @code{my-new-window-custos} function to the list of functions called when a new window appears. %%% add-hook %%% remove-hook %%% remove-all-hooks @@@ run-hook @@@ run-hook-with-args The following hooks are available: $$$ *new-window-hook* $$$ *destroy-window-hook* $$$ *focus-window-hook* $$$ *place-window-hook* $$$ *start-hook* $$$ *internal-loop-hook* $$$ *focus-frame-hook* $$$ *new-frame-hook* $$$ *message-hook* $$$ *top-level-error-hook* $$$ *focus-group-hook* $$$ *hooks-enabled-p* $$$ *remove-split-hook* $$$ *key-press-hook* $$$ *root-click-hook* $$$ *click-hook* $$$ *mode-line-click-hook* $$$ *urgent-window-hook* $$$ *event-processing-hook* $$$ *pre-command-hook* $$$ *post-command-hook* $$$ *menu-selection-hook* $$$ *new-head-hook* $$$ *command-mode-end-hook* $$$ *command-mode-start-hook* $$$ *destroy-mode-line-hook* $$$ *quit-hook* $$$ *restart-hook* $$$ *selection-notify-hook* $$$ *split-frame-hook* @node Modules, Hacking, Hooks, Top @chapter Modules A module is an ASDF system that adds additional functionality to StumpWM. StumpWM searches for modules in the @var{*data-dir*}@file{/modules} directory. By default this is @file{~/.stumpwm.d/modules}. Officially supported modules exist in a separate repository within the StumpWM organization on github. You can install the latest copy by issuing @command{make install-modules} from StumpWM's root source directory. This will run: @example git clone git@@github.com:stumpwm/stumpwm-contrib.git ~/.stumpwm.d/modules @end example !!! load-module @@@ list-modules ### *load-path* !!! add-to-load-path @@@ init-load-path @@@ find-module @menu * Writing Modules:: @end menu @node Writing Modules, , Modules, Modules @section Writing Modules Make sure to read @ref{Hacking}. If you are familiar with writing lisp packages for ASDF then you can jump in and get started. In either case, quicklisp ships a @code{quickproject} package that makes setting up a new module very easy. After installing quicklisp (see the README.md for a link): We're going to put our new module in the @file{modules/} directory of @var{*data-dir*} so that it will be immediately loadable by StumpWM. First make the directory @file{new-module}, then from a REPL issue: @example (ql:quickload "quickproject") (quickproject:make-project #p"~/.stumpwm.d/modules/new-module" :depends-on '(stumpwm) :name "new-module") @end example This will create: @example -rw-rw-r-- 1 dave dave 68 Apr 6 19:38 package.lisp -rw-rw-r-- 1 dave dave 53 Mar 16 2014 README.txt -rw-rw-r-- 1 dave dave 271 Mar 16 2014 new-module.asd -rw-rw-r-- 1 dave dave 1.8K Apr 6 17:51 new-module.lisp @end example The file @file{new-module.lisp} will contain the actual implementation of your module. ASDF requires two other files in order to understand how to load and compile your module. They are @file{new-module.asd} and @file{package.lisp}. In our example, @file{new-module.asd} should contain: @example (asdf:defsystem #:new-module :serial t :description "Describe new-module here" :author "Anne N. O'Nymous" :license "GPLv3" :depends-on (#:stumpwm) :components ((:file "package") (:file "new-module"))) ; any other files you make go here @end example The @file{package.lisp} will contain: @example (defpackage #:new-module (:use #:cl :stumpwm)) @end example With these two files defined, and the implementation written in @file{new-module.lisp}, you should be able to load your module. Before we load it, we have to add the path to our @var{*load-path*}. This can be accomplished by running the following from a REPL: @example (stumpwm:add-to-load-path "~/.stumpwm.d/modules/new-module") @end example You can also run this interactively with @kbd{C-t ;}, which is bound to the @command{colon} command. Because we've put our module in a sub-directory of the default @var{*module-dir*}, it will automatically get added to the @var{*load-path*} the next time StumpWM starts. If you choose to develop your module somewhere else (e.g. @file{~/quicklisp/local-projects}), then you'll have add @example (add-to-load-path "~/quicklisp/local-projects/new-module") @end example to your @file{.stumpwmrc}. When you've finished writing your module, you can distribute it however you see fit. If it becomes very popular, or you would like the StumpWM devs to maintain it (and they agree), you can have your module merged with the stumpwm-contrib repository on github, just open a pull request to start the discussion. @node Hacking, Advanced Configuration, Modules, Top @chapter Hacking @menu * General Advice:: * Adding Documentation and Editing This Manual:: * Using git with StumpWM:: * Sending Patches:: @end menu @node General Advice, Adding Documentation and Editing This Manual, Hacking, Hacking @section Hacking: General Advice @enumerate @item Pay attention to file names and contents. If you're making changes to mode-line related code, don't put it in @file{core.lisp}. If you're introducing some completely new featureset, consider putting all of the new code in a new file. @item Does a command need to be user-visible (``interactive'') or is it just called by other commands? @itemize @item If it's not going to be user-visible, you can just use the familiar @code{(defun foo () ...)} syntax. @item If you want the command to be used interactively, you use StumpWM's @code{defcommand} syntax, as in the examples below. @example (defcommand test (foo bar) ((:string "How you're going to prompt for variable foo: ") (:number "How you want to prompt for variable bar: ")) "This command is a test" (body...)) (defcommand test2 () () "This is also a test" (body...)) (defcommand title (args) (interactive-args) "Doc string" (body...)) @end example So basically, inside the first set of parentheses after the function name, you specify what (if any) arguments will be passed to the command. The second set of parentheses tells StumpWM how to get those arguments if they're not explicitly passed to the command. For example, @example ((:string "What do you want to do: ")) @end example will read a string from the input the user provides. The quoted text is the prompt the user will see. Of course, if you were to, say, call the command test, as defined above, from another piece of code, it wouldn't give the prompt as long as you fed it arguments. @end itemize @item Note that all commands defined using the @code{defcommand} syntax are available both to be called with @kbd{C-t ;} and from within other lisp programs, as though they had been defun-ned (which, in fact, they have). @item Any code that depends on external libraries or programs that some users might not have installed should be packaged as a module and placed in the @file{*data-dir*/modules/} directory. @item Don't be afraid to submit your patches to the StumpWM mailing list! It may not immediately make it into the official git repository, but individual users might find it useful and apply it to their own setup, or might be willing to offer suggestions on how to improve the code. @end enumerate @node Adding Documentation and Editing This Manual, Using git with StumpWM, General Advice, Hacking @section Hacking: Adding Documentation and Editing This Manual The manual is written in @command{texinfo}, so you may want to read that manual. The @file{stumpwm.texi.in} is processed by StumpWM with some additional markup in the form of three letter character entries @c need to double up the at-signs in the @code{@@@ function} to escape @c them. at the beginning of a line. @code{@@@@@@ function} defines functions, @code{%%% some-macro} expands to that macro and its docstring, etc. Contributors are strongly encouraged to add these items to this manual whenever something new is defined in a patch. You can test if your texinfo edits are valid by generating them with @command{make stumpwm.info}, and viewing the new @file{stumpwm.info} with @command{info -f /path/to/stumpwm.info}, or @command{make stumpwm.texi} for the raw stuff. @table @asis @item %%% macro @item @@@@@@ function @item ### variable @item $$$ hook @item !!! StumpWM command @end table @node Using git with StumpWM, Sending Patches, Adding Documentation and Editing This Manual, Hacking @section Hacking: Using git with StumpWM For quite a while now, StumpWM has been using the git version control system for development. If you're using one of the official releases, you can get the bleeding-edge source code from the official git repository with a single command: @example $ git clone git@@github.com:stumpwm/stumpwm.git @end example After this, you'll have a complete git repository, along with the complete revision history since the switch. Feel free to play around; git has some important features that actually make this safe! Before we get to that stuff, though, you're going to want to tell git about yourself so that your information is included in your commits and patches. The very minimum you're going to want to do is: @example $ git config --global user.name "Anne N. O'Nymous" $ git config --global user.email "anonymous@@foo.org" @end example Be sure to check out the manual for @command{git-config}--there are several options you might want to set, such as enabling colorized output or changing the editor and pager you use when making commits and viewing logs. For the sake of argument, let's say you want to make some major changes to both @file{user.lisp} and @file{core.lisp}, add a file called @file{DANGEROUS_EXPERIMENT_DO_NOT_USE_OR_@-ELSE.lisp}, and remove the manual because you're too 1337 for such things. However, you don't want to break your entire StumpWM setup and start over. Thankfully, you don't have to. Before you get started, issue this command from the StumpWM source directory: @example $ git checkout -b experimental @end example You should now find yourself in a new branch, called experimental. To confirm this, type @command{git branch}; there should be an asterisk next to the branch you're currently viewing. At any time, you can type @command{git checkout master} to return to your master branch, and at any time you can have as many branches of the project as you like. If you want to create a new branch based not on the master branch but on your experimental branch, for example, you'd type: @example $ git checkout -b new-experiment experimental @end example This will place you in a newly-created branch called ``new-experiment'' which should be identical to your experimental branch as of the last commit (more on that soon). If you're actually typing out the directions, switch back to your old experimental branch like so: @example $ git checkout experimental @end example Anyway, now that you have a new branch, create that new file with the long name, which we'll just call @file{danger.lisp} for brevity. Make whatever changes you want to it, and when you're done, tell git about your new file. @example $ git add dangerous.lisp @end example Now, let's pretend you're done making changes. Tell git you're done for now: @example $ git commit @end example This will open up a prompt in your editor of choice for you to describe your changes. Try to keep the first line short, and then add more explanation underneath (for an example, run the command @command{git log} and take a look at some of the longer commit explanations). Save that file and then do this: @example $ git checkout master $ ls @end example Then look for your new file. It's not there! That's because you've done all of your work in another branch, which git is currently hiding from you so that you can ``check out'' the branch called ``master.'' All is as it should be---your master repository is still safe. @example $ git checkout experimental @end example Now, delete @file{manual.lisp} and @file{stumpwm.texi}. That's right. Wipe them off the face of the Earth, or at least off the hard drive of your computer. When you're done, you don't have to tell git you've deleted them; it'll figure it out on its own (though things may not compile properly unless you edit @file{Makefile.in} and @file{stumpwm.asd}. Anyway, go ahead and edit @file{core.lisp} and @file{user.lisp}. Really break 'em. Run free! When you're done, do another commit, as above, and give it a stupid title like ``lolz i b0rked stUmpwm guys wTF!?!?!!111!'' Now try to compile. Just try. It won't work. If it does, you're some kind of savant or something. Keep up the good work. If you've actually managed to break StumpWM like you were supposed to, never fear! You have two options at this point. One is to go back to the master branch (with another git checkout) and just delete your experimental branch, like so: @example $ git branch -D @end example The ``@code{-D}'' means to force a delete, even if the changes you've made aren't available elsewhere. A ``@code{-d}'' means to delete the branch if and only if you've merged the changes in elsewhere. The other option is to create patches for each of your commits so far, delete the branch, and then apply any working/wanted patches in a new branch. Create your patches (after committing) like so: @example $ git format-patch -o patches origin @end example (Before doing that you can review your changes with @command{git log origin..}) You can also use the @command{format-patch} command to create a patch of working code to send in to the mailing list. A developer might ask you to try out something they're working on. To fetch their master branch, you'd do this: @example $ git remote add -f -m master -t master foo git://bar.org/~foo/stumpwm @end example Here, ``foo'' is the shorthand name you'll use to refer to that repository in the future. To checkout a local copy of that repository, you'd then do @example $ git checkout --track -b foo-master foo/master @end example Later you could use @command{git pull foo} to update while looking at that branch (and note that @command{git pull} with no arguments, in the master branch, will update your StumpWM from the official repository). Finally, if you want to move your experimental changes into your master branch, you'd checkout your master branch and run: @example $ git merge experimental @end example If there are file conflicts, @command{git diff} will show you where they are; you have to fix them by hand. When you're done, do another @example $ git commit -a @end example to finalize the changes to your master branch. You can then delete your experimental branch. Alternately, you can wait until your changes (assuming you sent them in) make it into the official repository before deleting your experimental branch. @node Sending Patches, , Using git with StumpWM, Hacking @section Sending Patches While patches are still welcome on the mailing list, StumpWM's development has mostly migrated to github's issue tracker. This means you can open a pull request to submit a patch to StumpWM. The following guidelines apply to pull requests and patches sent to the mailing list. @itemize @item Make sure it applies clean to the main git repository @item Ensure that you aren't introducing tabs, extra blank lines, or whitespace at the end of lines. @item Ensure your patch doesn't contain irrelevant indenting or reformatting changes. @item Try to make your patch address a single issue. If your patch changes two unrelated issues, break them into two seperate patches that can stand on their own. @item Don't send intermediate patches. When you're working on a feature you might make several commits to your local repository as you refine it and work out the bugs. When it's polished and ready to ship, send it as one patch! Sometimes it makes sense to send it as multiple patches if each patch contains a discrete feature or bug fix that can stand on its own. If one of your patches changes code that was added or modified in an earlier patch, consider merging them together and sending them as one. @end itemize @node Advanced Configuration, Command and Function Index, Hacking, Top @chapter Advanced Configuration ### *default-package* ### *default-bg-color* @@@ run-commands ### *startup-message* ### *list-hidden-groups* %%% defprogram-shortcut ### *initializing* !!! loadrc ### *ignore-wm-inc-hints* ### *max-last-message-size* ### *module-dir* @@@ set-module-dir ### *mouse-focus-policy* ### *resize-hides-windows* ### *root-click-focuses-frame* ### *suppress-frame-indicator* ### *suppress-window-placement-indicator* ### *text-color* ### *draw-in-color* ### *timeout-frame-indicator-wait* ### *top-level-error-action* @node Command and Function Index, Variable Index, Advanced Configuration, Top @unnumbered Command and Function Index @printindex fn @node Variable Index, , Command and Function Index, Top @unnumbered Variable Index @printindex vr @bye stumpwm-22.11/test-wm.lisp000066400000000000000000000230051433701203600155230ustar00rootroot00000000000000(defpackage :test-wm (:use :cl)) (in-package :test-wm) (defparameter *current-test-num* 0) (defparameter *tests* nil) (defmacro define-test ((dpy screen) &body body) (let ((name (intern (format nil "TEST-~d" *current-test-num*)))) `(progn (defun ,name (,dpy ,screen) (format t "Starting test ~d~%" ,*current-test-num*) ,@body (format t "Done.~%")) (push ',name *tests*) (incf *current-test-num*)))) (define-test (dpy screen) (let ((w (xlib:create-window :parent (xlib:screen-root screen) :x 10 :y 10 :width 100 :height 100 :border-width 1))) (xlib:map-window w) (xlib:display-finish-output dpy) (xlib:destroy-window w) (xlib:display-finish-output dpy))) (define-test (dpy screen) (let ((w (xlib:create-window :parent (xlib:screen-root screen) :x 10 :y 10 :width 100 :height 100 :border-width 1))) (xlib:map-window w) (xlib:display-finish-output dpy) (sleep 1) (setf (xlib:window-priority w) :above) ;; (setf (xlib:drawable-border-width w) 3) (xlib:display-finish-output dpy) (xlib:destroy-window w) (xlib:display-finish-output dpy))) (define-test (dpy screen) (let ((windows (loop for i from 0 to 100 collect (let ((w (xlib:create-window :parent (xlib:screen-root screen) :x 10 :y 10 :width 100 :height 100 :border-width 1))) (xlib:map-window w) (xlib:display-finish-output dpy) (setf (xlib:window-priority w) :above) w)))) (xlib:display-finish-output dpy) (loop for i in windows do (xlib:unmap-window i)) (xlib:display-finish-output dpy) (sleep 3) (loop for i in windows do (xlib:destroy-window i)))) ;; (define-test (dpy screen) ;; (let ((windows (loop for i from 0 to 100 ;; collect (let ((w (xlib:create-window :parent (xlib:screen-root screen) ;; :x 10 :y 10 :width 100 :height 100 :border-width 1))) ;; (xlib:map-window w) ;; (xlib:display-finish-output dpy) ;; (setf (xlib:window-priority w) :above) ;; w)))) ;; (xlib:display-finish-output dpy) ;; (loop for i in windows do ;; (xlib:unmap-window i)) ;; (xlib:display-finish-output dpy) ;; (sleep 3) ;; (loop for i in windows do ;; (xlib:destroy-window i)))) (define-test (dpy screen) (let ((w (xlib:create-window :parent (xlib:screen-root screen) :x 10 :y 10 :width 100 :height 100 :border-width 1))) (xlib:map-window w) (setf (xlib:window-priority w) :above) (xlib:display-finish-output dpy) (xlib:unmap-window w) (setf (xlib:drawable-x w) 5) (xlib:display-finish-output dpy))) (define-test (dpy screen) ;; create a window and set its role after being mapped (let ((w (xlib:create-window :parent (xlib:screen-root screen) :x 10 :y 10 :width 100 :height 100 :border-width 1))) (xlib:map-window w) (xlib:display-finish-output dpy) (sleep 1) (xlib:change-property w :WM_WINDOW_ROLE (map 'list 'char-code "rad dude") :string 8) (xlib:display-finish-output dpy) (sleep 10))) (defun break-display-xid-cache () (labels ((make-win (dpy) (xlib:create-window :parent (xlib:screen-root (first (xlib:display-roots dpy))) :x 0 :y 0 :width 50 :height 50)) (make-pixmap (window) (xlib:create-pixmap :width (random 100) :height (random 100) :depth 8 :drawable window)) (first-pass (dpy) ;; Open a fresh connection. Create a window and a pixmap. (let* ((dpy2 (xlib:open-default-display)) (window (make-win dpy2)) (pixmap (make-pixmap window))) ;; make the pixmap the window's icon pixmap hint. (setf (xlib:wm-hints window) (xlib:make-wm-hints :icon-pixmap pixmap)) (format t "Window ID: ~s pixmap ID: ~s~%" (xlib:window-id window) (xlib:pixmap-id pixmap)) (xlib:map-window window) (xlib:display-finish-output dpy2) (sleep 1) ;; On the old connection, list the root window children ;; and the icon pixmap hint to cache their XIDs. (loop for w in (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy)))) for hints = (xlib:wm-hints w) when hints do (format t "top level window id: ~s | icon pixmap hint: ~s~%" (xlib:window-id w) (xlib:wm-hints-icon-pixmap hints))) (xlib:close-display dpy2))) (second-pass (dpy) ;; Open a fresh connection and create 2 windows. (let* ((dpy2 (xlib:open-default-display)) (window1 (make-win dpy2)) (window2 (make-win dpy2))) (format t "Window#1 ID: ~s Window#2 ID: ~s~%" (xlib:window-id window1) (xlib:window-id window2)) (xlib:display-finish-output dpy2) ;; On the old connection, list the root window children ;; and note the second window is erroneously a pixmap ;; due to too agressive caching in clx. (loop for w in (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy)))) do (format t "window: ~s~%" w)) (xlib:close-display dpy2)))) (let ((dpy (xlib:open-default-display))) (first-pass dpy) (second-pass dpy) (xlib:close-display dpy)))) (defun test-wm-class (map-p) "Test the robustness of CLX's wm-class function. If MAP-P is T then map the window. Useful if you want to test the running window manager." (labels ((test-it (w &rest strings) (xlib:change-property w :WM_CLASS (apply #'concatenate '(vector xlib:card8) strings) :string 8) (print (multiple-value-list (xlib:get-wm-class w))) ;; give the wm a chance to try out the value (when map-p (sleep 1))) (convert (s) (map '(vector xlib:card8) #'xlib:char->card8 s))) (let* ((dpy (xlib:open-default-display)) (screen (first (xlib:display-roots dpy))) (root (xlib:screen-root screen)) (win (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100 :background (xlib:screen-white-pixel screen)))) (unwind-protect (when map-p (xlib:map-window win)) (progn (test-it win (convert "string 1") #(0) (convert "string 2") #(0)) (test-it win (convert "Manifold X") #(0) (convert "Powercoupling Y") #(0) (convert "Magistrate Z") #(0)) (test-it win #(0)) (test-it win) (test-it win #(0) (convert "checkity checkfoo")) (test-it win (convert "ohh bother") #(0) (convert "Magic Fudge")) (test-it win (convert "You Gellin?") #(0)) (test-it win (convert "Blinky The Cloon"))) (xlib:close-display dpy)) (values)))) (defun get-wm-hints () "simias reports that on sbcl the wm-hints property is all screwed up when he runs an x server on 32 or 64bit freebsd and runs any x client on a fedora 32bit, connecting through an ssh tunnel. clisp works fine. so run this function on clisp and sbcl and compare the numbers. This assumes you're running a reparenting wm." (let ((dpy (xlib:open-default-display))) (write-line "you gotta have some windows open for this to work.") (dolist (top (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy))))) (dolist (w (xlib:query-tree top)) (format t "~s ~s: ~s~%" w (xlib:wm-name w) (xlib:get-property w :WM_HINTS :type :WM_HINTS :result-type 'vector)))) (xlib:close-display dpy))) (defun parse-display-string (display) "Parse an X11 DISPLAY string and return the host and display from it." (let* ((colon (position #\: display)) (host (subseq display 0 colon)) (rest (subseq display (1+ colon))) (dot (position #\. rest)) (num (parse-integer (subseq rest 0 dot)))) (values host num))) (defvar *dpy* nil) (defun test-wm (display-str) (multiple-value-bind (host display) (parse-display-string display-str) (setf *dpy* (xlib:open-display host :display display :protocol nil)) (let* ((dpy *dpy*) (screen (first (xlib:display-roots dpy)))) (unwind-protect (progn ;; (dolist (i *tests*) ;; (funcall i dpy screen)) (funcall (car *tests*) dpy screen) ) (xlib:close-display *dpy*))))) stumpwm-22.11/tests/000077500000000000000000000000001433701203600143745ustar00rootroot00000000000000stumpwm-22.11/tests/integration-tests/000077500000000000000000000000001433701203600200575ustar00rootroot00000000000000stumpwm-22.11/tests/integration-tests/Dockerfile000077500000000000000000000010221433701203600220470ustar00rootroot00000000000000FROM ubuntu:20.04 USER root WORKDIR /root ENV DISPLAY=":7" ARG userUID RUN useradd -u $userUID -m -s /bin/bash user COPY tests/integration-tests/container-scripts/install-deps . RUN ./install-deps COPY . stumpwm RUN cd stumpwm \ && mv tests/integration-tests/container-scripts/* /usr/local/bin/ \ && mv tests/integration-tests/stumpwm.d /home/user/.stumpwm.d \ && chown -R user:user /home/user/.stumpwm.d \ && ./autogen.sh \ && ./configure \ && make \ && make install USER user WORKDIR /home/user stumpwm-22.11/tests/integration-tests/Makefile000066400000000000000000000011721433701203600215200ustar00rootroot00000000000000run-tests: $(shell ./script internal-get-run-tests-deps) ci: $(shell ./script internal-get-ci-deps) generate-tests: test-runner.iid ./script internal-generate-tests "${COUNT}" testcases/%.results/success: testcases/%.sh test-runner.iid ./script internal-run-one-test "$*" expect-success testcases/%.results/fail: testcases/%.sh test-runner.iid ./script internal-run-one-test "$*" expect-failure test-runner.iid: $(shell find ../.. -path ../../tests/integration-tests/testcases -prune -o -print) docker build --iidfile test-runner.iid --build-arg userUID="$(shell id -u)" -f Dockerfile ../.. .PHONY: run-tests generate-tests stumpwm-22.11/tests/integration-tests/README.md000066400000000000000000000027631433701203600213460ustar00rootroot00000000000000# Generative, end-to-end test suite for stumpwm ## Why A window manager's primary purpose is to interact with the windowing system and the user. Since (end-to-end) integration tests are the only kind that actually test this primary functionality, they are arguably the most important kind of tests for any window manager. Property based testing, or generative testing, is an approach to partly automate bug finding. Rather than manually writing each test case, they are generated based on certain rules. When an automatically generated test case fails, it is investigated manually to confirm that the test is correct, and then committed to the repository. The repository therefore contains both 1. individual test cases that have previously failed, to prevent regression 2. rules to generate new test cases. ## Generating and running tests For usage help, run: ``` ./script ``` When you run tests, the test results will be in `testcases/*.results/`. Successful tests will have a `success` file while failed tests will have a `fail` file containing a message. Usually, the `stdout.txt` and `screenshot-*.png` files will show the necessary details. If you generate tests, they will be named `testcases/generated-*.sh`. If you want to commit a generated test to the repository, rename it first. It can also be a good idea to minimize the test, i.e. make it shorter while retaining the failure. ## Development The file `container-scripts/generate-test-code` contains the code and rules to generate a random test case. stumpwm-22.11/tests/integration-tests/container-scripts/000077500000000000000000000000001433701203600235265ustar00rootroot00000000000000stumpwm-22.11/tests/integration-tests/container-scripts/check-invariants000077500000000000000000000003131433701203600267020ustar00rootroot00000000000000#!/bin/bash set -e screenshot "$1-before-check-invariants" stumpwm-cmd check-invariants screenshot "$1-after-check-invariants" screenshots-match "$1-before-check-invariants" "$1-after-check-invariants" stumpwm-22.11/tests/integration-tests/container-scripts/generate-test-code000077500000000000000000000362531433701203600271440ustar00rootroot00000000000000#!/usr/bin/env -S sbcl --script ;; -*- mode: lisp -*- (defvar *min-x-resolution* 640) (defvar *min-y-resolution* 480) (defvar *max-x-resolution* 2000) (defvar *max-y-resolution* 2000) (defvar *min-frame-width* 50) (defvar *min-frame-height* 50) (defvar *list-of-generators* '()) (defvar *line-count* 0) (defvar *screenshot-index* 0) (defvar *state* nil) (setq *random-state* (make-random-state t)) (defmacro define-generator (test-form &rest generator) `(push (cons (lambda () ,test-form) (lambda () ,@generator)) *list-of-generators*)) (defun set-state (&rest args) (when args (setf (getf *state* (car args)) (cadr args)) (apply #'set-state (cddr args)))) (defun filter (fun list) (mapcan (lambda (x) (when (funcall fun x) (list x))) list)) (defun random-from-list (list) (nth (random (list-length list)) list)) (defun random-boolean () (random-from-list '(t nil))) (defun random-color () (format nil "#~6,'0x" (random #x1000000))) (defun random-int-between (low high) (let ((l (ceiling low)) (h (floor high))) (unless (<= l h) (error "Out of range")) (+ l (random (+ (- h l) 1))))) (defun random-sort (list) (sort (apply #'list list) (lambda (a b) (random-boolean)) :key nil)) (defun generate () (let* ((can-stop (state :can-stop)) ;; Stop 1/3 of the time we have the chance, or if the script is already quite long (want-to-stop (or (< (random 3) 1) (< 100 *line-count*))) (valid-generators (filter (lambda (x) (funcall (car x))) *list-of-generators*)) (can-continue valid-generators)) (when (not (state :start)) (line)) (when (not (or can-stop can-continue)) (error "Dead end: We can neither continue nor stop.")) (when (< 1000 *line-count*) (error (format nil "We seem to be stuck in state ~A" *state*))) (when (if want-to-stop (not can-stop) can-continue) (let ((generator (cdr (random-from-list valid-generators)))) (funcall generator))))) (defun state (key) (getf *state* key)) (defun next (&rest args) (apply #'set-state args) (generate)) (defun line (&rest args) (mapcar (lambda (x) (write-string (if (stringp x) x (format nil "~a" x)))) args) (write-char #\linefeed) (setq *line-count* (+ *line-count* 1))) (defun screenshot () (setq *screenshot-index* (+ *screenshot-index* 1)) (line "screenshot " *screenshot-index*) *screenshot-index*) (defun screenshots-match (a b) (line "screenshots-match " a " " b)) (defun screenshots-differ (a b) (line "screenshots-differ " a " " b)) (defun str-contains (str char) (loop for x across str when (eq x char) return t)) (defun stumpwm-eval (form) (let ((form-str (format nil "~s" form))) (if (or (str-contains form-str #\\) (str-contains form-str #\')) (progn (line "stumpwm-load < "${temp_file}"; then true # Good else cat "${temp_file}" > /dev/stderr false fi test_id=$(sha256sum "${temp_file}" | sed -r 's/^(.{8}).*$/\1/') to_file="testcases/generated-${test_id}.sh" if [ -e "${to_file}" ]; then echo "${to_file}" already generated. else mv "${temp_file}" "${to_file}" chmod a+x "${to_file}" echo Generated "${to_file}" count=$((count+1)) fi } [ 0 -lt "$1" ] count=0 while [ $count -lt "$1" ]; do generate-one-test done stumpwm-22.11/tests/integration-tests/container-scripts/install-deps000077500000000000000000000013641433701203600260570ustar00rootroot00000000000000#!/bin/bash set -e sbcl_version=2.2.7 export DEBIAN_FRONTEND=noninteractive apt-get -qy update apt-get -qy install curl build-essential autoconf git bzip2 make farbfeld netpbm procps x11-apps x11-xserver-utils xdotool xvfb xterm rm -rf /var/lib/apt/lists/* curl -L https://downloads.sourceforge.net/project/sbcl/sbcl/${sbcl_version}/sbcl-${sbcl_version}-x86-64-linux-binary.tar.bz2 | tar xjf - cd sbcl-${sbcl_version}-x86-64-linux ./install.sh cd .. curl -O https://beta.quicklisp.org/quicklisp.lisp sbcl --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" sbcl --load "/root/quicklisp/setup.lisp" --eval "(progn (setf ql-util::*do-not-prompt* t)(ql:add-to-init-file))" sbcl --eval "(progn (ql:quickload '(clx cl-ppcre alexandria fiasco)))" stumpwm-22.11/tests/integration-tests/container-scripts/open-test-window000077500000000000000000000001771433701203600267040ustar00rootroot00000000000000#!/bin/bash set -e file=$(mktemp) xterm -e bash -c "sleep .5; rm $file; sleep 3600" & while [ -e "$file" ]; do sleep .2; done stumpwm-22.11/tests/integration-tests/container-scripts/open-test-window-with-bash000077500000000000000000000001711433701203600305620ustar00rootroot00000000000000#!/bin/bash set -e file=$(mktemp) xterm -e bash -c "sleep .5; rm $file; bash" & while [ -e "$file" ]; do sleep .2; done stumpwm-22.11/tests/integration-tests/container-scripts/open-test-window-with-font-size000077500000000000000000000002641433701203600315660ustar00rootroot00000000000000#!/bin/bash set -e file=$(mktemp) xterm -fa Monospace -fs "$1" -T "Fontsize $1 xterm window" -e bash -c "sleep .5; rm $file; sleep 3600" & while [ -e "$file" ]; do sleep .2; done stumpwm-22.11/tests/integration-tests/container-scripts/run-test000077500000000000000000000022331433701203600252350ustar00rootroot00000000000000#!/bin/bash set -e testname="$1" expectation="$2" is_tty="$3" results="testcases/${testname}.results" rm -rf "$results" mkdir -p "$results" cd "$results" set +e "../${testname}.sh" > stdout.txt 2> stderr.txt ec="$?" set -e if [ "$ec" == 0 ] && ! [ -e fail ]; then touch success result=success else echo "Test $testname exited with error code $ec" >> fail result=failure fi echo-with-color () { color="$1"; shift; if [ "$is_tty" == yes ]; then echo -e "\\e[${color}m$*\\e[0m" else echo "$@" fi } echo-red () { echo-with-color 31 "$@"; } echo-green () { echo-with-color 32 "$@"; } echo-yellow () { echo-with-color 33 "$@"; } case "$expectation->$result" in "expect-failure->failure") echo-yellow "Test $testname FAILED as expected";; "expect-failure->success") echo-red "Test $testname SUCCEEDED when expected to fail."; echo-red "Perhaps remove it from tests/integration-tests/tests-expected-to-fail"; exit 1;; "expect-success->failure") echo-red "Test $testname FAILED"; exit 1;; "expect-success->success") echo-green "Test $testname SUCCEEDED";; esac stumpwm-22.11/tests/integration-tests/container-scripts/screenshot000077500000000000000000000005151433701203600256320ustar00rootroot00000000000000#!/bin/bash set -e [ -n "$1" ] xwdfile=$(mktemp --suffix=.xwd) pnmfile=$(mktemp --suffix=.pnm) pngfile="screenshot-${1}.png" if [ -e "$pngfile" ]; then echo "$pngfile already exists." exit 1 fi xwd -root > "$xwdfile" xwdtopnm "$xwdfile" > "$pnmfile" pnmtopng "$pnmfile" > "$pngfile" rm "$xwdfile" "$pnmfile" echo "$pngfile" stumpwm-22.11/tests/integration-tests/container-scripts/screenshots-differ000077500000000000000000000005651433701203600272570ustar00rootroot00000000000000#!/bin/bash set -e hashofscreenshot() { file="screenshot-${1}.png" [ -e "$file" ] < "$file" png2ff | sha256sum | cut -d " " -f 1 } if [ "$(hashofscreenshot "$1")" == "$(hashofscreenshot "$2")" ]; then echo FAIL: Screenshots "$1" and "$2" match, but they should differ. exit 1 else echo Screenshots "$1" and "$2" differ, as expected. exit 0 fi stumpwm-22.11/tests/integration-tests/container-scripts/screenshots-match000077500000000000000000000005641433701203600271130ustar00rootroot00000000000000#!/bin/bash set -e hashofscreenshot() { file="screenshot-${1}.png" [ -e "$file" ] < "$file" png2ff | sha256sum | cut -d " " -f 1 } if [ "$(hashofscreenshot "$1")" == "$(hashofscreenshot "$2")" ]; then echo Screenshots "$1" and "$2" match, as expected. exit 0 else echo FAIL: Screenshots "$1" and "$2" differ, but they should match. exit 1 fi stumpwm-22.11/tests/integration-tests/container-scripts/send-keys000077500000000000000000000004541433701203600253610ustar00rootroot00000000000000#!/bin/bash set -e convert-from-stumpwm-to-xdotool() { sed -rf <(cat </dev/null | grep -qE "^ $mode +0\.00"; then true # Do nothing since mode already exists else xrandr --newmode "$mode" 0 "$w" 0 0 0 "$h" 0 0 0 2>/dev/null fi xrandr --addmode screen "$mode" 2>/dev/null xrandr --output screen --mode "$mode" "$@" 2>/dev/null sleep 1 stumpwm-22.11/tests/integration-tests/container-scripts/start-stumpwm000077500000000000000000000003601433701203600263220ustar00rootroot00000000000000#!/bin/bash set -e ( set +e stumpwm > stumpwm.stdout.txt 2> stumpwm.stderr.txt ec="$?" set -e if [ "$ec" != 0 ]; then echo "stumpwm exited with code $ec" >> "fail" fi ) & sleep 1 # Wait for stumpwm to start stumpwm-22.11/tests/integration-tests/container-scripts/start-xvfb-with-max-resolution000077500000000000000000000002401433701203600315050ustar00rootroot00000000000000#!/bin/bash set -e startup_width="$1" startup_height="$2" Xvfb "$DISPLAY" -screen 0 "${startup_width}x${startup_height}x24" & sleep 1 # Wait for Xvfb to start stumpwm-22.11/tests/integration-tests/container-scripts/stumpwm-cmd000077500000000000000000000001361433701203600257310ustar00rootroot00000000000000#!/bin/bash set -e xprop -root -format STUMPWM_COMMAND 8u -set STUMPWM_COMMAND "$*" sleep .3 stumpwm-22.11/tests/integration-tests/container-scripts/stumpwm-load000077500000000000000000000001571433701203600261100ustar00rootroot00000000000000#!/bin/bash set -e file=$(mktemp --suffix=.lisp) cat > "$file" stumpwm-cmd "eval (load \"$file\")" rm "$file" stumpwm-22.11/tests/integration-tests/container-scripts/x-remap-modifiers000077500000000000000000000017721433701203600270130ustar00rootroot00000000000000#!/bin/bash set -e mm() { xmodmap -e "$1"; } clear-mod() { mm "clear mod$1" # Clear modifier mapping if [ -n "$2" ]; then for ks in "${2}_L" "${2}_R";do mm "keycode any = $ks"; # Dummy mapping suppressing error on next line mm "keysym $ks ="; # Remove all mappings for this keysym done fi } map-mod() { if [ -n "$2" ]; then for ks in "${2}_L" "${2}_R";do mm "keycode any = $ks $ks"; # Add one clean mapping for this keysym done mm "add mod$1 = ${2}_L ${2}_R"; # Add modifier mapping fi } loop2args() { cmd="$1" shift while [ -n "$1" ]; do $cmd "$1" "$2" shift; shift done } tf=$(mktemp) xmodmap -pk -pm > "$tf" # Modifiers loop2args clear-mod "$@" loop2args map-mod "$@" echo Remapped modifiers, resulting in the following change: if diff "$tf" <(xmodmap -pk -pm); then echo Error: Ineffective modifier remap exit 1 else true fi rm "$tf" stumpwm-22.11/tests/integration-tests/container-scripts/x-swap-keys000077500000000000000000000004651433701203600256510ustar00rootroot00000000000000#!/bin/bash set -e tf=$(mktemp) xmodmap -pk -pm > "$tf" xmodmap -e "keysym $1 = $3 $4 $3 $4" -e "keysym $3 = $1 $2 $1 $2" echo "Swapped keys $1 $2 with $3 $4, resulting in the following change:" if diff "$tf" <(xmodmap -pk -pm); then echo Error: Ineffective key swap exit 1 else true fi rm "$tf" stumpwm-22.11/tests/integration-tests/script000077500000000000000000000100121433701203600213030ustar00rootroot00000000000000#!/bin/bash set -e echo-with-color () { color="$1"; shift; if [ -t 1 ]; then echo -e "\\e[${color}m$*\\e[0m" else echo "$@" fi } echo-red () { echo-with-color 31 "$@"; } die() { echo-red "$@" exit 1 } docker-interrupt() { echo-red "Got interrupt, sending SIGTERM to docker process $dockerprocess" kill -s SIGTERM "$dockerprocess" exit 2 } docker-wrapper() { greeting="$1" shift trap docker-interrupt INT docker "$@" & dockerprocess=$! echo "$greeting: Docker process $dockerprocess started" if ! wait "$dockerprocess"; then echo "$greeting: Docker process $dockerprocess failed"; die; fi echo "$greeting: Docker process $dockerprocess done" } generate-tests() { count="$1" [ 1 -le "$count" ] || die COUNT must be a positive integer. COUNT="$count" make generate-tests } internal-generate-tests() { count="$1" [ 1 -le "$count" ] || die COUNT must be a positive integer. docker-wrapper "Generating $count tests" run --rm -v "$(pwd)/testcases":/home/user/testcases --init "$(cat test-runner.iid)" generate-tests "$count" } internal-get-run-tests-deps() { find testcases/ -maxdepth 1 -name '*.sh' | sed -r 's/\.sh/.results\/success/' } internal-get-ci-deps() { cases=$(mktemp) find testcases/ -maxdepth 1 -name '*.sh' > "$cases" failcases=$(mktemp) sed -r '/^(#|$)/d;s/^/testcases\//;s/$/.sh/' < tests-expected-to-fail > "$failcases" grep -vFf "$failcases" "$cases" | sed -r 's/\.sh/.results\/success/' grep -Ff "$failcases" "$cases" | sed -r 's/\.sh/.results\/fail/' rm "$cases" "$failcases" } generate-tests-locally() { count="$1" [ 1 -le "$count" ] || die COUNT must be a positive integer. which sbcl || die Requires sbcl installed. PATH="$(pwd)/container-scripts:$PATH" container-scripts/generate-tests "$count" } number_of_processors="$(nproc)" run-tests() { make -j "$number_of_processors" -k -l "$number_of_processors" -s run-tests } ci() { make -j "$number_of_processors" -k -l "$number_of_processors" -s ci } run-one-test() { testname="$1" [ -n "$testname" ] || die NAME must be given. [ -e "testcases/$testname.sh" ] || die "testcases/$testname.sh" does not exist. if grep -E "^${testname}\$" tests-expected-to-fail >/dev/null; then make "testcases/${testname}.results/fail" else make "testcases/${testname}.results/success" fi } IS_TTY=no if [ -t 1 ]; then IS_TTY=yes; fi internal-run-one-test() { testname="$1" expectation="$2" [ -n "$testname" ] || die NAME must be given. [ -e "testcases/$testname.sh" ] || die "testcases/$testname.sh" does not exist. docker-wrapper "Test $testname" run --rm -v "$(pwd)/testcases":/home/user/testcases --init "$(cat test-runner.iid)" run-test "$testname" "$expectation" "$IS_TTY" } clean-results() { rm -rf test-runner.iid testcases/*.results } remove-generated-testcases() { rm -rf testcases/generated-* } show-help() { cat < ~}" args (reverse *complain-at*))) (defmacro with-complain-context ((&rest context) &body body) `(let ((*complain-at* (cons (list ,@context) *complain-at*))) ,@body)) (defun get-invariant-violations-for-float-group (float-group) (declare (ignore float-group)) nil ;; todo ) (defun get-invariant-violations-for-dynamic-group (dynamic-group) (declare (ignore dynamic-group)) nil ;; todo ) (defun get-invariant-violations-for-tile-group-and-tree (tile-group tree) (with-complain-context ("tile group" tile-group "for tree" tree) (let ((x (tree-x tree)) (y (tree-y tree)) (width (tree-width tree)) (height (tree-height tree)) (branch (not (atom tree)))) (list (unless (<= *min-frame-width* width) (complain "Width" width "is smaller than *min-frame-width*" *min-frame-width*)) (unless (<= *min-frame-height* height) (complain "Height" height "is smaller than *min-frame-height*" *min-frame-height*)) (unless (implies branch (xor (tree-row-split tree) (tree-column-split tree))) (complain "Inconsistent split" :tree-row-split (tree-row-split tree) :tree-column-split (tree-column-split tree))) (unless (implies branch (tree-row-split tree) (and (loop for i in tree always (= x (tree-x i))) (loop for i in tree always (= width (tree-width i))))) (complain "Unequal x or width in row split")) (unless (implies branch (tree-column-split tree) (and (loop for i in tree always (= y (tree-y i))) (loop for i in tree always (= height (tree-height i))))) (complain "Unequal y or height in column split")) (unless (implies branch (= 2 (length tree))) (complain "Branch with other than 2 children")) (unless (implies branch (tree-row-split tree) (let ((f1 (first tree)) (f2 (second tree))) (= (+ (tree-y f1) (tree-height f1)) (tree-y f2)))) (complain "Bottom of first does not match top of second in row split")) (unless (implies branch (tree-column-split tree) (let ((f1 (first tree)) (f2 (second tree))) (= (+ (tree-x f1) (tree-width f1)) (tree-x f2)))) (complain "Right of first does not match left of second in column split")) (when branch (mapcar (lambda (child) (get-invariant-violations-for-tile-group-and-tree tile-group child)) tree)))))) (defun get-invariant-violations-for-tile-group-and-head (tile-group head) (let ((tree (tile-group-frame-head tile-group head))) (get-invariant-violations-for-tile-group-and-tree tile-group tree))) (defun get-invariant-violations-for-tile-group (tile-group) (with-complain-context ("tile group" tile-group) (let* ((frame-tree (tile-group-frame-tree tile-group)) (frames (flatten frame-tree)) ;; (last-frame (tile-group-last-frame tile-group)) (current-frame (tile-group-current-frame tile-group)) (screen (group-screen tile-group)) (heads (screen-heads screen))) (list (unless (= (length frame-tree) (length heads)) (complain "frame-tree length" (length frame-tree) "does not equal number of heads" (length heads))) (mapcar (lambda (head) (get-invariant-violations-for-tile-group-and-head tile-group head)) heads) ;; last-frame can be stale. When fixed, add this invariant. ;; (unless (or (eq last-frame nil) ;; (and (typep last-frame 'frame) ;; (member last-frame frames))) ;; (complain "Weird last-frame" :last-frame last-frame :frames frames)) (unless (and (typep current-frame 'frame) (member current-frame frames)) (complain "Weird current-frame")) (unless (setp (mapcar #'frame-number frames)) (complain "Frame numbers not unique within group")) )))) (defun get-invariant-violations-for-group (group) (with-complain-context ("group" group) (let ((type-gtdf (list (typep group 'group) (typep group 'tile-group) (typep group 'dynamic-group) (typep group 'float-group)))) (cond ((equal type-gtdf '(t t nil nil)) (get-invariant-violations-for-tile-group group)) ((equal type-gtdf '(t nil t nil)) (get-invariant-violations-for-dynamic-group group)) ((equal type-gtdf '(t nil nil t)) (get-invariant-violations-for-float-group group)) (t (complain "Weird group typing")))))) (defun get-invariant-violations-for-color (color) (declare (ignore color)) nil ;; todo ) (defun get-invariant-violations-for-screen (screen) (with-complain-context ("screen" screen) (let ((groups (screen-groups screen)) (current-group (screen-current-group screen))) (list (unless (member current-group groups) (complain "Weird current-group")) (unless (setp (mapcar #'group-number groups)) (complain "Group numbers not unique within screen")) (mapcar (lambda (group) (unless (eq screen (group-screen group)) (complain "Inconsistent screen for group"))) groups) (mapcar (lambda (color-accessor) (with-complain-context ("color fetched by" color-accessor) (get-invariant-violations-for-color (funcall color-accessor screen)))) '(screen-border-color screen-fg-color screen-bg-color screen-win-bg-color screen-focus-color screen-unfocus-color screen-float-focus-color screen-float-unfocus-color)) (mapcar #'get-invariant-violations-for-group groups))))) (defun get-invariant-violations () (collect-strings (with-complain-context ("root") (let ((screens *screen-list*)) (list (unless (< 0 *resize-increment*) ;; This is used in ../testcases/test-check-invariants.sh to induce a violation (complain "Invalid *resize-increment*" *resize-increment*)) (unless (member (current-screen) screens) (complain "Weird current-screen")) (unless (<= 1 (length screens)) (complain "No screen")) (mapcar #'get-invariant-violations-for-screen screens)))))) ;; Commands (defcommand check-invariants () () (let ((v (join-strings (get-invariant-violations)))) (when v (format t "~&~A~&" v) (echo v)))) stumpwm-22.11/tests/integration-tests/testcases/000077500000000000000000000000001433701203600220555ustar00rootroot00000000000000stumpwm-22.11/tests/integration-tests/testcases/issue-0928.sh000077500000000000000000000007001433701203600241410ustar00rootroot00000000000000#!/bin/bash set -ex # Try to break the tiling by resizing (see issue #928) start-xvfb-with-max-resolution 1280 1024 start-stumpwm stumpwm-cmd eval ' (setf *suppress-frame-indicator* t *resize-increment* 50) ' for i in {1..4}; do open-test-window; done stumpwm-cmd hsplit stumpwm-cmd vsplit stumpwm-cmd move-focus down stumpwm-cmd vsplit screenshot 1 stumpwm-cmd resize-direction left screenshot 2 screenshots-differ 1 2 check-invariants 3 stumpwm-22.11/tests/integration-tests/testcases/issue-0993.sh000077500000000000000000000015241433701203600241500ustar00rootroot00000000000000#!/bin/bash set -ex # Try to reproduce issue with sending C-t to terminals (see issue #993) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 open-test-window-with-bash screenshot 1 # Should show "" send-keys a b screenshot 2 # Should show "ab|" send-keys Left C-t t # Since `C-t' is the prefix key, this should send `Left C-t' to the terminal screenshot 3 # Should show "ba|" but with issue #993 will show "a|b" stumpwm-cmd eval '(set-prefix-key (kbd "C-q"))' send-keys Right BackSpace BackSpace screenshot 4 # Should show "" send-keys a b screenshot 5 # Should show "ab|" send-keys Left C-t # Since `C-t' is not the prefix key, this should send `Left C-t' to the terminal screenshot 6 # Should show "ba|" screenshots-match 1 4 screenshots-match 2 5 screenshots-match 3 6 screenshots-differ 1 2 screenshots-differ 1 3 stumpwm-22.11/tests/integration-tests/testcases/issue-1000.sh000077500000000000000000000005231433701203600241220ustar00rootroot00000000000000#!/bin/bash set -ex # Test that frame indicator and frame outlines are updated correctly after resolution change (see issue #1000) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 stumpwm-cmd hsplit set-resolution 1280 960 screenshot 1 stumpwm-cmd only stumpwm-cmd hsplit screenshot 2 screenshots-match 1 2 stumpwm-22.11/tests/integration-tests/testcases/issue-1002.sh000077500000000000000000000010631433701203600241240ustar00rootroot00000000000000#!/bin/bash set -ex # Try to reproduce frame indicator issues (see issue #1002) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 # Test that frame indicator is not drawn after `remove` results in an only frame screenshot 1 stumpwm-cmd hsplit stumpwm-cmd remove screenshot 2 screenshots-match 1 2 # Test that the frame indicator does not remain in the previous position after `only` stumpwm-cmd vsplit stumpwm-cmd only screenshot 3 stumpwm-cmd vsplit stumpwm-cmd move-focus down stumpwm-cmd only screenshot 4 screenshots-match 3 4 stumpwm-22.11/tests/integration-tests/testcases/issue-1004.sh000077500000000000000000000004451433701203600241310ustar00rootroot00000000000000#!/bin/bash set -ex # Test that frame indicator still renders correctly after a window opens (see issue #1004) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 open-test-window stumpwm-cmd vsplit screenshot 1 open-test-window screenshot 2 screenshots-match 1 2 stumpwm-22.11/tests/integration-tests/testcases/issue-1005.sh000077500000000000000000000010241433701203600241240ustar00rootroot00000000000000#!/bin/bash set -ex # Try to reproduce top-left pixel bug (see issue #1005) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 427 stumpwm-cmd eval '(setf *window-border-style* :none)' stumpwm-cmd eval '(setf *mode-line-border-color* "#ff00ff")' screenshot 1 stumpwm-cmd mode-line stumpwm-cmd mode-line screenshot 2 open-test-window-with-font-size 3 screenshot 3 set-resolution 1280 854 screenshot 4 set-resolution 640 427 screenshot 5 screenshots-match 1 2 screenshots-differ 3 4 screenshots-match 3 5 stumpwm-22.11/tests/integration-tests/testcases/issue-1006.sh000077500000000000000000000021261433701203600241310ustar00rootroot00000000000000#!/bin/bash set -ex # Test that window-related color setting functions update correctly (see issue #1006) start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 stumpwm-cmd eval ' (setf *suppress-frame-indicator* t *normal-border-width* 10 *window-border-style* :thin)' open-test-window-with-font-size 75 open-test-window-with-font-size 75 open-test-window-with-font-size 75 resetview() { stumpwm-cmd only stumpwm-cmd hsplit stumpwm-cmd vsplit } setcolorfuns="set-win-bg-color set-focus-color set-unfocus-color" on() { stumpwm-cmd eval '('"$1"' "#FF00FF")'; } off() { stumpwm-cmd eval '('"$1"' "#000000")'; } for setcolor in $setcolorfuns; do off "$setcolor" done for setcolor in $setcolorfuns; do resetview screenshot "${setcolor}-before" on "$setcolor" screenshot "${setcolor}-after" resetview screenshot "${setcolor}-after2" off "$setcolor" done for setcolor in $setcolorfuns; do screenshots-differ "${setcolor}-before" "${setcolor}-after" screenshots-match "${setcolor}-after" "${setcolor}-after2" done stumpwm-22.11/tests/integration-tests/testcases/issue-1015.sh000077500000000000000000000023071433701203600241320ustar00rootroot00000000000000#!/bin/bash set -ex # Try to reproduce a configuration where a split cannot be moved by resizing any frame (see issue #1015) start-xvfb-with-max-resolution 2000 2000 cat >> ~/.stumpwm.d/init.lisp <> ~/.stumpwm.d/init.lisp <> ~/.stumpwm.d/init.lisp </dev/null; then echo "Some invariant should have been violated but was not." exit 1 else echo "Some invariant was violated, as expected." fi stumpwm-22.11/tests/integration-tests/testcases/test-send-keys.sh000077500000000000000000000007741433701203600253030ustar00rootroot00000000000000#!/bin/bash set -ex # Test that some key sequences give the same result as the corresponding commands start-xvfb-with-max-resolution 2000 2000 start-stumpwm set-resolution 640 480 open-test-window stumpwm-cmd only stumpwm-cmd vsplit screenshot 1 stumpwm-cmd only screenshot 2 screenshots-differ 1 2 send-keys C-t s screenshot 3 screenshots-match 1 3 stumpwm-cmd only stumpwm-cmd hsplit screenshot 4 stumpwm-cmd only screenshot 5 screenshots-differ 4 5 send-keys C-t S screenshot 6 screenshots-match 4 6 stumpwm-22.11/tests/integration-tests/tests-expected-to-fail000066400000000000000000000003311433701203600242710ustar00rootroot00000000000000# This is a list of test case names, one per line, that are to be excluded from CI. # This is necessary in order to allow merging test cases that reproduce unfixed issues. issue-0993 issue-1004 issue-1005 issue-1006 stumpwm-22.11/tests/kmap.lisp000066400000000000000000000012421433701203600162140ustar00rootroot00000000000000(in-package #:stumpwm-tests) (defun expand-key-description (&rest desc) (let ((args (list (car desc) :keysym))) (dolist (mod (cdr desc)) (push mod args) (push t args)) (apply 'stumpwm::make-key (nreverse args)))) (defmacro expect-key (kbd &key to-be) `(is (equalp (stumpwm::parse-key ,kbd) (expand-key-description ,@to-be)))) (fiasco:deftest test-parse-key () (expect-key "C-l" :to-be (108 :control)) (expect-key "C-S-l" :to-be (108 :control :shift)) (expect-key "C-s-l" :to-be (108 :control :super)) (expect-key "C--" :to-be (45 :control)) (expect-key "-" :to-be (45)) (signals stumpwm::kbd-parse-error (stumpwm::parse-key "C-"))) stumpwm-22.11/tests/package.lisp000066400000000000000000000001001433701203600166470ustar00rootroot00000000000000(fiasco:define-test-package #:stumpwm-tests (:use #:stumpwm)) stumpwm-22.11/tests/pathnames.lisp000066400000000000000000000004221433701203600172430ustar00rootroot00000000000000(in-package #:stumpwm-tests) (deftest test-directory-pathname-p () (is (stumpwm::directory-pathname-p "/"))) (deftest test-ensure-directory-pathname () (is (equal (pathname-as-directory "/") #P"/")) (is (equal (pathname-as-directory "/test.lisp") #P"/test.lisp/"))) stumpwm-22.11/tile-group.lisp000066400000000000000000001733221433701203600162220ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Frame functions ;; ;; Code: (in-package #:stumpwm) (export '(save-frame-excursion only-one-frame-p)) (define-swm-class tile-group (group) ((frame-tree :accessor tile-group-frame-tree) (last-frame :initform nil :accessor tile-group-last-frame) (current-frame :accessor tile-group-current-frame))) (defmethod print-swm-object ((object tile-group) stream) (write-string "TILE-" stream) (call-next-method)) (defmethod initialize-instance :after ((group tile-group) &key &allow-other-keys) (let* ((heads (copy-heads (group-screen group)))) (setf (tile-group-frame-tree group) heads (tile-group-current-frame group) (first heads)))) (defmethod group-startup ((group tile-group)) (let* ((window (first (group-tile-windows group))) (frame (if (typep window 'tile-window) (window-frame window) (tile-group-current-frame group)))) (focus-frame group frame))) (defmethod group-wake-up ((group tile-group)) (focus-frame group (tile-group-current-frame group)) ;; doesn't get called by focus-frame (show-frame-indicator group)) (defmethod group-delete-window ((group tile-group) (window tile-window)) (let ((f (window-frame window))) ;; maybe pick a new window for the old frame (when (eq (frame-window f) window) (frame-raise-window group f (first (frame-windows group f)) nil)))) (defmethod group-delete-window ((group tile-group) (window float-window)) (let* ((windows (group-windows group)) (float-w (some (lambda (w) (when (typep w 'float-window) w)) windows)) (tile-w (some (lambda (w) (when (typep w 'tile-window) w)) windows))) (cond (float-w (group-focus-window group float-w)) (tile-w (frame-raise-window group (window-frame tile-w) tile-w)) (t (no-focus group nil))))) (defmethod group-add-window ((group tile-group) window &key frame raise &allow-other-keys) ;; This is important to get the frame slot (cond ((typep window 'float-window) (call-next-method)) ((eq frame :float) (dynamic-mixins:replace-class window 'float-window) ;; (change-class-preserving-minor-modes window 'float-window) (float-window-align window) (sync-minor-modes window) (when raise (group-focus-window group window))) (t (dynamic-mixins:replace-class window 'tile-window) ;; (change-class-preserving-minor-modes window 'tile-window) ;; (change-class window 'tile-window) ;; Try to put the window in the appropriate frame for the group. (setf (window-frame window) (or frame (when *processing-existing-windows* (find-frame group (xlib:drawable-x (window-parent window)) (xlib:drawable-y (window-parent window)))) (pick-preferred-frame window))) (when *processing-existing-windows* (setf (frame-window (window-frame window)) window)) (when (and frame raise) (setf (tile-group-current-frame group) frame (frame-window frame) nil)) (sync-frame-windows group (window-frame window)) (when (null (frame-window (window-frame window))) (frame-raise-window (window-group window) (window-frame window) window nil)) (sync-minor-modes window)))) (defmethod group-current-head ((group tile-group)) (if-let ((current-window (group-current-window group))) (window-head current-window) (frame-head group (tile-group-current-frame group)))) (defmethod group-move-request ((group tile-group) (window tile-window) x y relative-to) (when *honor-window-moves* (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y relative-to) (let* ((pointer-pos (multiple-value-list (xlib:global-pointer-position *display*))) (pos (if (eq relative-to :parent) (list (+ (xlib:drawable-x (window-parent window)) x) (+ (xlib:drawable-y (window-parent window)) y)) (list (first pointer-pos) (second pointer-pos)))) (frame (apply #'find-frame group pos))) (when frame (pull-window window frame))))) (defmethod group-resize-request ((group tile-group) (window tile-window) width height) ;; it's important to grant the resize request first so that resize ;; increment hints use the proper base size to resize from. (set-window-geometry window :width width :height height) (maximize-window window)) (defmethod group-resize-request ((group tile-group) (window float-window) width height) (float-window-move-resize window :width width :height height)) (defmethod group-move-request ((group tile-group) (window float-window) x y relative-to) (declare (ignore relative-to)) (float-window-move-resize window :x x :y y)) (defmethod group-raise-request ((group tile-group) window stack-mode) (when (window-in-current-group-p window) (case stack-mode (:map (maybe-map-window window)) (:above (maybe-raise-window window))))) (defmethod group-lost-focus ((group tile-group)) ;; If this window had the focus, try to avoid losing it. (let ((frame (tile-group-current-frame group))) (setf (frame-window frame) (first (remove-if 'window-hidden-p (frame-windows group frame)))) (focus-frame group frame))) (defmethod group-indicate-focus ((group tile-group)) (show-frame-indicator group)) (defmethod group-focus-window ((group tile-group) (win tile-window)) (frame-raise-window group (window-frame win) win)) (defmethod group-focus-window ((group tile-group) (window float-window)) (focus-window window)) (defmethod group-button-press ((group tile-group) button x y (where (eql :root))) (when *root-click-focuses-frame* (when-let ((frame (find-frame group x y))) (focus-frame group frame) (unless (or (eq *mouse-focus-policy* :click) (scroll-button-keyword-p button)) (update-all-mode-lines))))) (defmethod group-button-press ((group tile-group) button x y (where window)) (declare (ignore x y)) (when (typep where 'float-window) (call-next-method)) (when (member *mouse-focus-policy* '(:click :sloppy)) (focus-all where) (unless (scroll-button-keyword-p button) (update-all-mode-lines)))) (defmethod group-root-exposure ((group tile-group)) (show-frame-outline group nil)) (defmethod group-add-head ((group tile-group) head) (let ((new-frame-num (find-free-frame-number group))) (setf (tile-group-frame-tree group) (insert-before (tile-group-frame-tree group) (copy-frame head) (head-number head))) ;; Try to put something in the new frame and give it an unused number (let ((frame (tile-group-frame-head group head))) (setf (frame-number frame) new-frame-num) ;; try to fix the current-frame nil issue (unless (tile-group-current-frame group) (setf (tile-group-current-frame group) frame)) (choose-new-frame-window frame group) (when (frame-window frame) (unhide-window (frame-window frame)))))) ;; TODO: This method has not been updated for floating windows (defmethod group-remove-head ((group tile-group) head) ;; first ensure the data is up to date (group-sync-all-heads group) (let ((windows (head-windows group head)) (frames-to-delete (tile-group-frame-head group head)) (group-frame-tree (tile-group-frame-tree group))) ;; Remove this head's frames from the frame tree. (setf (tile-group-frame-tree group) (delete frames-to-delete group-frame-tree)) ;; Just set current frame to whatever. (let ((frame (first (group-frames group)))) (unless (frame-p frame) (error "Couldn't locate a frame in group ~A" group)) (setf (tile-group-current-frame group) frame (tile-group-last-frame group) nil) ;; Hide its windows. (dolist (window windows) (hide-window window) (setf (window-frame window) frame)))) ;; Try to do something with the orphaned windows (populate-frames group)) (defmethod group-replace-head (screen (group tile-group) old-head new-head) (let ((head-frame-tree (tile-group-frame-head group old-head))) ;; we remove and then re-add it to make sure it winds up in the correct position: ;; the top level of a group's frame-tree must be in the same order as the screen's head's slot (let ((new-frame-tree (remove head-frame-tree (tile-group-frame-tree group)))) (setf (tile-group-frame-tree group) (insert-before new-frame-tree head-frame-tree (head-number new-head)))))) (defmethod group-before-resize-head ((group tile-group) oh nh) (clear-frame-outlines group) (resize-tree group (tile-group-frame-head group oh) (head-width nh) (head-height nh) (head-x nh) (head-y nh))) (defmethod group-after-resize-head ((group tile-group) head) (declare (ignore head)) (redraw-frame-indicator group) (redraw-frame-outline group)) (defmethod group-sync-all-heads ((group tile-group)) (sync-all-frame-windows group)) (defmethod group-sync-head ((group tile-group) head) (dolist (f (head-frames group head)) (sync-frame-windows group f))) ;;;;; ;; (defun tile-group-frame-head (group head) ;; (let ((index (position head (group-heads group))) ;; (frame-tree (tile-group-frame-tree group))) ;; (when (> index (length frame-tree)) ;; (elt frame-tree index)))) (defun group-tile-windows (group) (only-tile-windows (group-windows group))) (defmethod group-windows-for-cycling ((group tile-group) &key sorting) (declare (ignore sorting)) (only-tile-windows (call-next-method))) (defmethod group-repack-frame-numbers ((group tile-group)) (let ((frames (group-frames group))) (loop for i from 0 for frame in frames do (setf (frame-number frame) i)))) (defmethod focus-next-window ((group tile-group)) (focus-forward group (group-windows-for-cycling group :sorting t))) (defmethod focus-prev-window ((group tile-group)) (focus-forward group (reverse (group-windows-for-cycling group :sorting t)))) (defun tile-group-frame-head (group head) (elt (tile-group-frame-tree group) (position head (group-heads group)))) (defun (setf tile-group-frame-head) (frame group head) (setf (elt (tile-group-frame-tree group) (position head (group-heads group))) frame)) (defun current-frame () (window-frame (current-window))) (defgeneric populate-frames (group) (:documentation "Try to fill empty frames in GROUP with hidden windows") (:method (group) (dolist (f (group-frames group)) (unless (frame-window f) (choose-new-frame-window f group) (when (frame-window f) (maximize-window (frame-window f)) (unhide-window (frame-window f))))))) (defun frame-by-number (group n) (unless (eq n nil) (find n (group-frames group) :key 'frame-number :test '=))) (defun find-frame (group x y) "Return the frame of GROUP containing the pixel at X Y" (dolist (f (group-frames group)) (let* ((fy (frame-y f)) (fx (frame-x f)) (fwx (+ fx (frame-width f))) (fhy (+ fy (frame-height f)))) (when (and (<= fy y fhy) (<= fx x fwx)) (return f))))) (defgeneric frame-set-x (frame v) (:method (frame v) (decf (frame-width frame) (- v (frame-x frame))) (setf (frame-x frame) v))) (defgeneric frame-set-y (frame v) (:method (frame v) (decf (frame-height frame) (- v (frame-y frame))) (setf (frame-y frame) v))) (defgeneric frame-set-r (frame v) (:method (frame v) (setf (frame-width frame) (- v (frame-x frame))))) (defgeneric frame-set-b (frame v) (:method (frame v) (setf (frame-height frame) (- v (frame-y frame))))) (defgeneric frame-r (frame) (:method (frame) (+ (frame-x frame) (frame-width frame)))) (defgeneric frame-b (frame) (:method (frame) (+ (frame-y frame) (frame-height frame)))) (defmethod frame-head ((group tile-group) frame) (find-if (lambda (head) (or (eq head frame) (find frame (flatten (tile-group-frame-head group head))))) (group-heads group))) (defun project-x (head x) (declare (ignore head)) "Return an integer X coordinate." (round x)) (defun project-y (head y) "Return an integer Y coordinate that takes the mode-line into account." (round (let* ((ml (head-mode-line head))) (if (and ml (not (eq (mode-line-mode ml) :hidden))) (let* ((head-y (frame-y head)) (rel-y (- y head-y))) (+ (* rel-y (mode-line-factor ml)) (case (mode-line-position ml) (:top (mode-line-height ml)) (:bottom 0)))) y)))) (defgeneric frame-display-x (group frame) (:documentation "Return an integer X for frame.") (:method (group frame) (project-x (frame-head group frame) (frame-x frame)))) (defgeneric frame-display-y (group frame) (:documentation "Return an integer Y for frame that takes the mode-line into account.") (:method (group frame) (let ((head (frame-head group frame)) (y (frame-y frame))) (when (> y (+ (frame-y head) (frame-height head))) (error "Frame ~A is below head ~A" frame head)) (project-y head y)))) (defgeneric frame-display-height (group frame) (:documentation "Return an integer HEIGHT for frame that fits within its head and doesn't overlap the mode-line.") (:method (group frame) (let ((head (frame-head group frame))) (flet ((projected-height (frame) (let ((y (frame-y frame)) (height (frame-height frame))) (- (project-y head (+ y height)) (project-y head y))))) (min (projected-height frame) (projected-height head)))))) (defgeneric frame-display-width (group frame) (:documentation "Return an integer WIDTH for frame that fits within its head.") (:method (group frame) (let* ((head (frame-head group frame))) (flet ((projected-width (frame) (let ((x (frame-x frame)) (width (frame-width frame))) (- (project-x head (+ x width)) (project-x head x))))) (min (projected-width frame) (projected-width head)))))) (defun frame-intersect (f1 f2) "Return a new frame representing (only) the intersection of F1 and F2. WIDTH and HEIGHT will be <= 0 if there is no overlap" (let ((r (copy-frame f1))) (when (> (frame-x f2) (frame-x f1)) (frame-set-x r (frame-x f2))) (when (< (+ (frame-x f2) (frame-width f2)) (+ (frame-x f1) (frame-width f1))) (frame-set-r r (frame-r f2))) (when (> (frame-y f2) (frame-y f1)) (frame-set-y r (frame-y f2))) (when (< (+ (frame-y f2) (frame-height f2)) (+ (frame-y f1) (frame-height f1))) (frame-set-b r (frame-b f2))) (values r))) (defun frames-overlap-p (f1 f2) "Returns T if frames F1 and F2 overlap at all" (check-type f1 frame) (check-type f2 frame) (and (and (frame-p f1) (frame-p f2)) (let ((frame (frame-intersect f1 f2))) (values (and (plusp (frame-width frame)) (plusp (frame-height frame))))))) (defun frame-raise-window (g f w &optional (focus t)) "Raise the window w in frame f in group g. if FOCUS is T (default) then also focus the frame." (let ((oldw (frame-window f))) ;; nothing to do when W is nil (setf (frame-window f) w) (unless (and w (eq oldw w)) (if w (raise-window w) (mapc 'hide-window (reverse (frame-windows g f))))) ;; If raising a window in the current frame we must focus it or ;; the group and screen will get out of sync. (when (or focus (eq (tile-group-current-frame g) f)) (focus-frame g f)) (when (and w (not (window-modal-p w))) (raise-modals-of w)))) (defun focus-frame (group f) (let ((w (frame-window f)) (last (tile-group-current-frame group)) (show-indicator nil)) (setf (tile-group-current-frame group) f) ;; record the last frame to be used in the fother command. (unless (eq f last) (setf (tile-group-last-frame group) last) (run-hook-with-args *focus-frame-hook* f last) (setf show-indicator t)) (if w (focus-window w) (no-focus group (frame-window last))) (if show-indicator (show-frame-indicator group) (show-frame-outline group)))) (defun frame-windows (group f) (remove-if-not (lambda (w) (eq (window-frame w) f)) (group-tile-windows group))) (defun frame-sort-windows (group f) (remove-if-not (lambda (w) (and (typep w 'tile-window) (eq (window-frame w) f))) (sort-windows group))) (defun copy-frame-tree (tree) "Return a copy of the frame tree." (cond ((null tree) tree) ((typep tree 'frame) (copy-structure tree)) (t (mapcar #'copy-frame-tree tree)))) (defun group-frames (group) (tree-accum-fn (tile-group-frame-tree group) 'nconc 'list)) (defun head-frames (group head) (tree-accum-fn (tile-group-frame-head group head) 'nconc 'list)) (defun screen-frames (screen) "Returns a list of all frames associated with any window in a screen" (remove-duplicates (mapcar #'(lambda (window) (window-frame window)) (list-windows screen)))) (defun orphaned-frames (screen) "Returns a list of frames on a screen not associated with any group. These shouldn't exist." (let ((adopted-frames (loop for group in (screen-groups screen) append (group-frames group)))) (set-difference (screen-frames screen) adopted-frames))) (defmethod group-adopt-orphaned-windows ((group tile-group) &optional (screen (current-screen))) "Picks an arbitray frame in the given group and moves any windows in frames without a group thereinto" (let ((orphaned-frames (orphaned-frames screen)) (foster-frame (tree-leaf (tile-group-frame-tree group)))) (unless foster-frame (error "Could not find a valid frame in group ~A to adopt windows with group-less frames ~A on screen ~A" group orphaned-frames screen)) (loop for window in (list-windows screen) when (member (window-frame window) orphaned-frames) do (setf (window-frame window) foster-frame)))) (defun find-free-frame-number (group) (find-free-number (mapcar 'frame-number (group-frames group)))) (defun choose-new-frame-window (frame group) "Find out what window should go in a newly created frame." (let ((win (case *new-frame-action* (:last-window (other-hidden-window group)) (t nil)))) (setf (frame-window frame) win) (when win (setf (window-frame win) frame)))) (defun split-frame-h (group p ratio) "Return 2 new frames. The first one stealing P's number and window" (let* ((w (ratio-or-pixel (frame-width p) ratio)) (h (frame-height p)) (f2 (make-frame :number (find-free-frame-number group) :x (+ (frame-x p) w) :y (frame-y p) ;; gobble up the modulo :width (- (frame-width p) w) :height h :window nil))) (setf (frame-width p) w (frame-height p) h) (run-hook-with-args *split-frame-hook* p p f2) (run-hook-with-args *new-frame-hook* f2) (values p f2))) (defun split-frame-v (group p ratio) "Return 2 new frames. The first one stealing P's number and window" (let* ((w (frame-width p)) (h (ratio-or-pixel (frame-height p) ratio)) (f2 (make-frame :number (find-free-frame-number group) :x (frame-x p) :y (+ (frame-y p) h) :width w ;; gobble up the modulo :height (- (frame-height p) h) :window nil))) (setf (frame-width p) w (frame-height p) h) (run-hook-with-args *split-frame-hook* p p f2) (run-hook-with-args *new-frame-hook* f2) (values p f2))) (defun ratio-or-pixel (length ratio) "Return a ratio of length unless ratio is an integer. If ratio is an integer return the number of pixel desired." (if (integerp ratio) ratio (* length ratio))) (defun funcall-on-leaf (tree leaf fn) "Return a new tree with LEAF replaced with the result of calling FN on LEAF." (cond ((atom tree) (if (eq leaf tree) (funcall fn leaf) tree)) (t (mapcar (lambda (sib) (funcall-on-leaf sib leaf fn)) tree)))) (defun funcall-on-node (tree fn match) "Call fn on the node where match returns t." (if (funcall match tree) (funcall fn tree) (cond ((atom tree) tree) (t (mapcar (lambda (sib) (funcall-on-node sib fn match)) tree))))) (defun replace-frame-in-tree (tree f &rest frames) (funcall-on-leaf tree f (lambda (f) (declare (ignore f)) frames))) (defun sibling-internal (tree leaf fn) "helper for next-sibling and prev-sibling." (cond ((atom tree) nil) ((find leaf tree) (let* ((rest (cdr (member leaf (funcall fn tree)))) (pick (car (if (null rest) (funcall fn tree) rest)))) (unless (eq pick leaf) pick))) (t (find-if (lambda (x) (sibling-internal x leaf fn)) tree)))) (defun next-sibling (tree leaf) "Return the sibling of LEAF in TREE." (sibling-internal tree leaf 'identity)) (defun prev-sibling (tree leaf) (sibling-internal tree leaf 'reverse)) (defun closest-sibling (tree leaf) "Return the sibling to the right/below of leaf or left/above if leaf is the most right/below of its siblings." (let* ((parent (tree-parent tree leaf)) (lastp (= (position leaf parent) (1- (length parent))))) (if lastp (prev-sibling parent leaf) (next-sibling parent leaf)))) (defun migrate-frame-windows (group src dest) "Migrate all windows in SRC frame to DEST frame." (mapc (lambda (w) (handler-case (when (eq (window-frame w) src) (setf (window-frame w) dest)) (unbound-slot () nil))) (group-tile-windows group))) (defun tree-accum-fn (tree acc fn) "Run an accumulator function on fn applied to each leaf" (cond ((null tree) nil) ((atom tree) (funcall fn tree)) (t (apply acc (mapcar (lambda (x) (tree-accum-fn x acc fn)) tree))))) (defun tree-iterate (tree fn) "Call FN on every leaf in TREE" (cond ((null tree) nil) ((atom tree) (funcall fn tree)) (t (mapc (lambda (x) (tree-iterate x fn)) tree)))) (defun tree-x (tree) (tree-accum-fn tree 'min 'frame-x)) (defun tree-y (tree) (tree-accum-fn tree 'min 'frame-y)) (defun tree-width (tree) (cond ((atom tree) (frame-width tree)) ((tree-row-split tree) ;; in row splits, all children have the same width, so use the ;; first one. (tree-width (first tree))) (t ;; for column splits we add the width of each child (reduce '+ tree :key 'tree-width)))) (defun tree-height (tree) (cond ((atom tree) (frame-height tree)) ((tree-column-split tree) ;; in column splits, all children have the same height, so use the ;; first one. (tree-height (first tree))) (t ;; for row splits we add the height of each child (reduce '+ tree :key 'tree-height)))) (defun tree-min-width (tree) (cond ((atom tree) *min-frame-width*) ((tree-row-split tree) (reduce 'max tree :key 'tree-min-width)) (t (reduce '+ tree :key 'tree-min-width)))) (defun tree-min-height (tree) (cond ((atom tree) *min-frame-height*) ((tree-column-split tree) (reduce 'max tree :key 'tree-min-height)) (t (reduce '+ tree :key 'tree-min-height)))) (defun tree-parent (top node) "Return the list in TOP that contains NODE." (cond ((atom top) nil) ((find node top) top) (t (loop for i in top thereis (tree-parent i node))))) (defun tree-leaf (top) "Return a leaf of the tree. Use this when you need a leaf but you don't care which one." (tree-accum-fn top (lambda (&rest siblings) (car siblings)) #'identity)) (defun tree-row-split (tree) "Return t if the children of tree are stacked vertically" (loop for i in (cdr tree) with head = (car tree) always (= (tree-x head) (tree-x i)))) (defun tree-column-split (tree) "Return t if the children of tree are side-by-side" (loop for i in (cdr tree) with head = (car tree) always (= (tree-y head) (tree-y i)))) (defun tree-split-type (tree) "return :row or :column" (cond ((tree-column-split tree) :column) ((tree-row-split tree) :row) (t (error "tree-split-type unknown")))) (defun offset-tree (tree x y) "move the screen's frames around." (tree-iterate tree (lambda (frame) (incf (frame-x frame) x) (incf (frame-y frame) y)))) (defun offset-tree-dir (tree amount dir) (ecase dir (:left (offset-tree tree (- amount) 0)) (:right (offset-tree tree amount 0)) (:top (offset-tree tree 0 (- amount))) (:bottom (offset-tree tree 0 amount)))) (defun expand-tree (tree amount dir) "expand the frames in tree by AMOUNT in DIR direction. DIR can be :top :bottom :left :right" (labels ((expand-frame (f amount dir) (ecase dir (:left (decf (frame-x f) amount) (incf (frame-width f) amount)) (:right (incf (frame-width f) amount)) (:top (decf (frame-y f) amount) (incf (frame-height f) amount)) (:bottom (incf (frame-height f) amount))))) (cond ((null tree) nil) ((atom tree) (expand-frame tree amount dir)) ((or (and (find dir '(:left :right)) (tree-row-split tree)) (and (find dir '(:top :bottom)) (tree-column-split tree))) (dolist (i tree) (expand-tree i amount dir))) (t (let* ((children (if (find dir '(:left :top)) (reverse tree) tree)) (sz-fn (if (find dir '(:left :right)) 'tree-width 'tree-height)) (total (funcall sz-fn tree)) (amt-list (loop for i in children for old-sz = (funcall sz-fn i) collect (/ (* amount old-sz) total))) (ofs 0)) ;; resize proportionally (loop for i in children for amt in amt-list do (expand-tree i amt dir) (offset-tree-dir i ofs dir) (incf ofs amt))))))) (defun join-subtrees (tree leaf) "expand the children of tree to occupy the space of LEAF. Return tree with leaf removed." (let* ((others (remove leaf tree)) (newtree (if (= (length others) 1) (car others) others)) (split-type (tree-split-type tree)) (dir (if (eq split-type :column) :right :bottom)) (ofsdir (if (eq split-type :column) :left :top)) (amt (if (eq split-type :column) (tree-width leaf) (tree-height leaf))) (after (cdr (member leaf tree)))) ;; align all children after the leaf with the edge of the ;; frame before leaf. (offset-tree-dir after amt ofsdir) (expand-tree newtree amt dir) newtree)) (defun resize-tree (group tree w h &optional (x (tree-x tree)) (y (tree-y tree))) "Scale TREE to width W and height H, ignoring aspect. If X and Y are provided, reposition the TREE as well. Remove frames as necessary and possible, to respect the minimum frame size." (cond ((atom tree) ;; We don't check here whether we respect minimum frame size. That ;; should've been done earlier, unless it's impossible anyway e.g. due to ;; the minimum frame size being larger than the head. (let ((frame tree)) (setf (frame-height frame) h (frame-y frame) y (frame-width frame) w (frame-x frame) x) (if-let (win (frame-window frame)) (update-decoration win)))) ((or (< w (tree-min-width tree)) (< h (tree-min-height tree))) ;; We can't fit this tree in the assigned area, so we remove all frames ;; beyond the split and try again (let ((tree-to-resize (car tree)) (tree-to-discard (cdr tree)) (target-frame (tree-leaf tree)) (parent (tree-parent (tile-group-frame-tree group) tree))) ;; Hoist the frames before the split (setf (elt parent (position tree parent)) tree-to-resize) ;; Move windows in removed frames (tree-iterate tree-to-discard (lambda (f) (if-let (win (frame-window f)) (hide-window win)) (migrate-frame-windows group f target-frame))) (resize-tree group tree-to-resize w h x y))) (t ;; We should have a tree that is possible to resize while respecting ;; minimum frame size (let ((child1 (first tree)) (child2 (second tree))) (ecase (tree-split-type tree) (:column (let* ((child1-new-size (min (max (tree-min-width child1) (* w (/ (tree-width child1) (tree-width tree)))) (- w (tree-min-width child2))))) (resize-tree group child1 child1-new-size h x y) (resize-tree group child2 (- w child1-new-size) h (+ x child1-new-size) y))) (:row (let* ((child1-new-size (min (max (tree-min-height child1) (* h (/ (tree-height child1) (tree-height tree)))) (- h (tree-min-height child2))))) (resize-tree group child1 w child1-new-size x y) (resize-tree group child2 w (- h child1-new-size) x (+ y child1-new-size))))))))) (defun remove-frame (tree leaf) "Return a new tree with LEAF and it's sibling merged into one." (cond ((atom tree) tree) ((find leaf tree) (join-subtrees tree leaf)) (t (mapcar (lambda (sib) (remove-frame sib leaf)) tree)))) (defgeneric sync-frame-windows (group frame) (:documentation "synchronize windows attached to FRAME.") (:method (group frame) (mapc (lambda (w) (when (eq (window-frame w) frame) (dformat 3 "maximizing ~S~%" w) (maximize-window w))) (group-tile-windows group)))) (defun sync-all-frame-windows (group) "synchronize all frames in GROUP." (let ((tree (tile-group-frame-tree group))) (tree-iterate tree (lambda (f) (sync-frame-windows group f))))) (defun sync-head-frame-windows (group head) "synchronize all frames in GROUP and HEAD." (dolist (f (head-frames group head)) (sync-frame-windows group f))) (defun offset-frames (group x y) "move the screen's frames around." (let ((tree (tile-group-frame-tree group))) (tree-iterate tree (lambda (frame) (incf (frame-x frame) x) (incf (frame-y frame) y))))) (defun move-split-in-tree (group tree amount) "Move the split in tree by amount if possible, otherwise as much as posible." (assert (and (listp tree) (= (length tree) 2))) (let* ((split-type (tree-split-type tree)) (tree-wh (ecase split-type (:column 'tree-width) (:row 'tree-height))) (child1 (first tree)) (child2 (second tree)) (child1-wh (funcall tree-wh (first tree))) (child2-wh (funcall tree-wh (second tree))) (tree-min-wh (ecase split-type (:column 'tree-min-width) (:row 'tree-min-height))) (min-child1-wh (funcall tree-min-wh (first tree))) (min-child2-wh (funcall tree-min-wh (second tree))) (min-amount (- min-child1-wh child1-wh)) ;; <=0 (max-amount (- child2-wh min-child2-wh)) ;; >=0 (effective-amount (max (min amount max-amount) min-amount))) (ecase split-type (:column (resize-tree group child1 (+ child1-wh effective-amount) (tree-height child1)) (resize-tree group child2 (- child2-wh effective-amount) (tree-height child2) (+ (tree-x child2) effective-amount) (tree-y child2))) (:row (resize-tree group child1 (tree-width child1) (+ child1-wh effective-amount)) (resize-tree group child2 (tree-width child2) (- child2-wh effective-amount) (tree-x child2) (+ (tree-y child2) effective-amount)))))) (defun resize-frame (group frame amount dim) "Move the frame split directly below (if DIM is :height) or to the right (if DIM is :width) of FRAME as much as possible up to AMOUNT. If moving it isn't possible at all, try instead with the split directly above or to the left, respectively." (check-type group group) (check-type frame frame) (check-type amount integer) (check-type dim (member :width :height)) (labels ((is-frame-in-dim (frame) (ecase dim (:width (tree-column-split frame)) (:height (tree-row-split frame)))) (first-ancestor-that (direction frame top) (let* ((parent (tree-parent top frame))) (cond ((and (is-frame-in-dim parent) (eq frame (ecase direction (:expands-dim-positive (first parent)) (:expands-dim-negative (second parent))))) parent) (parent (first-ancestor-that direction parent top)) (t nil))))) (let* ((head (frame-head group frame)) (frame-head (tile-group-frame-head group head)) (candidate-frames-to-alter (list (first-ancestor-that :expands-dim-positive frame frame-head) (first-ancestor-that :expands-dim-negative frame frame-head))) (frame-to-alter (or (first candidate-frames-to-alter) (second candidate-frames-to-alter))) (invert-amount (not (first candidate-frames-to-alter))) (effective-amount (if invert-amount (- amount) amount))) (when (and frame-to-alter (not (= effective-amount 0))) (dformat 10 "Resizing frame ~s ~s~%" dim effective-amount) (move-split-in-tree group frame-to-alter effective-amount) (unless (and *resize-hides-windows* (eq *top-map* *resize-map*)) (tree-iterate frame-to-alter (lambda (leaf) (sync-frame-windows group leaf)))))))) (defun balance-frames-internal (group tree &optional (sync t)) "Fully balance all the frames contained in tree." (labels ((balance (tree x y width height) (etypecase tree (frame (balance-frame tree x y width height)) (list (balance-tree tree x y width height)))) (balance-frame (frame x y width height) (setf (frame-x frame) x (frame-y frame) y (frame-width frame) width (frame-height frame) height) (when sync (sync-frame-windows group frame))) (count-splits (tree split-type) "Count the number of top-level splits of split-type in tree." (cond ((frame-p tree) 1) ((eql split-type (tree-split-type tree)) (+ (count-splits (first tree) split-type) (count-splits (second tree) split-type))) (t 1))) (divide-dimension (value first-splits second-splits) "Divide a width or height between two sides of a binary tree. Returns two values: the number of pixels to give to the first and second child, respectively. For example: (divide-dimension 500 3 2) will divide 500 pixels into 300 for the first 3 splits and 200 for the second 2 splits. " ;; First divide the two groups as evenly as possible. (let ((base (/ value (+ first-splits second-splits)))) (values (* base first-splits) (* base second-splits)))) (balance-tree (tree x y width height) "Balance the binary tree to fit the given dimensions." (let* ((split-type (tree-split-type tree)) (first-splits (count-splits (first tree) split-type)) (second-splits (count-splits (second tree) split-type))) (ecase split-type (:row (multiple-value-bind (top-height bottom-height) (divide-dimension height first-splits second-splits) (balance (first tree) x y width top-height) (balance (second tree) x (+ y top-height) width bottom-height))) (:column (multiple-value-bind (left-width right-width) (divide-dimension width first-splits second-splits) (balance (first tree) x y left-width height) (balance (second tree) (+ x left-width) y right-width height))))))) (balance tree (tree-x tree) (tree-y tree) (tree-width tree) (tree-height tree)))) (defun split-frame (group how &optional (ratio 1/2)) "Split the current frame into 2 frames. Return new frame number, if it succeeded. NIL otherwise. RATIO is a fraction of the screen to allocate to the new split window. If ratio is an integer then the number of pixels will be used. This can be handy to setup the desktop when starting." (check-type how (member :row :column)) (let* ((frame (tile-group-current-frame group)) (head (frame-head group frame))) ;; don't create frames smaller than the minimum size (when (or (and (eq how :row) (>= (frame-height frame) (* *min-frame-height* 2))) (and (eq how :column) (>= (frame-width frame) (* *min-frame-width* 2)))) (multiple-value-bind (f1 f2) (funcall (if (eq how :column) 'split-frame-h 'split-frame-v) group frame ratio) (setf (tile-group-frame-head group head) (if (atom (tile-group-frame-head group head)) (list f1 f2) (funcall-on-node (tile-group-frame-head group head) (lambda (tree) (substitute (list f1 f2) frame tree)) (lambda (tree) (unless (atom tree) (find frame tree)))))) (migrate-frame-windows group frame f1) (choose-new-frame-window f2 group) (if (eq (tile-group-current-frame group) frame) (setf (tile-group-current-frame group) f1)) (setf (tile-group-last-frame group) f2) (sync-frame-windows group f1) (sync-frame-windows group f2) ;; we also need to show the new window in the other frame (when (frame-window f2) (unhide-window (frame-window f2))) (frame-number f2))))) (defun draw-frame-outline (group f tl br) "Draw an outline around FRAME." (let* ((screen (group-screen group)) (win (if (frame-window f) (window-xwin (frame-window f)) (screen-root screen))) (width (screen-frame-outline-width screen)) (gc (screen-frame-outline-gc screen)) (halfwidth (/ width 2))) (when (> width 0) (let ((x (frame-display-x group f)) (y (frame-display-y group f)) (w (frame-display-width group f)) (h (frame-display-height group f))) (when tl (xlib:draw-line win gc x (+ halfwidth y) w 0 t) (xlib:draw-line win gc (+ halfwidth x) y 0 h t)) (when br (xlib:draw-line win gc (+ x (- w halfwidth)) y 0 h t) (xlib:draw-line win gc x (+ y (- h halfwidth)) w 0 t)))))) (defun draw-frame-outlines (group &optional head) "Draw an outline around all frames in GROUP." (clear-frame-outlines group) (dolist (h (if head (list head) (group-heads group))) (draw-frame-outline group h nil t) (tree-iterate (tile-group-frame-head group h) (lambda (f) (draw-frame-outline group f t nil))))) (defun clear-frame-outlines (group) "Clear the outlines drawn with DRAW-FRAME-OUTLINES." (xlib:clear-area (screen-root (group-screen group)))) (defun draw-frame-numbers (group) "Draw the number of each frame in its corner. Return the list of windows used to draw the numbers in. The caller must destroy them." (let ((screen (group-screen group))) (mapcar (lambda (f) (let ((w (xlib:create-window :parent (screen-root screen) :x (frame-display-x group f) :y (frame-display-y group f) :width 1 :height 1 :background (screen-fg-color screen) :border (screen-border-color screen) :border-width 1 :event-mask '()))) (xlib:map-window w) (setf (xlib:window-priority w) :above) (echo-in-window w (screen-font screen) (screen-fg-color screen) (screen-bg-color screen) (string (get-frame-number-translation f))) (xlib:display-finish-output *display*) (dformat 3 "mapped ~S~%" (frame-number f)) w)) (group-frames group)))) (defmacro save-frame-excursion (&body body) "Execute body and then restore the current frame." (let ((oframe (gensym "OFRAME")) (ogroup (gensym "OGROUP"))) `(let ((,oframe (tile-group-current-frame (current-group))) (,ogroup (current-group))) (unwind-protect (progn ,@body) (focus-frame ,ogroup ,oframe))))) ;;; Frame commands (defun split-frame-in-dir (group dir &optional (ratio 1/2)) (let ((f (tile-group-current-frame group))) (if (split-frame group dir ratio) (progn (when (frame-window f) (update-decoration (frame-window f))) (show-frame-indicator group)) (message "Cannot split smaller than minimum size.")))) (defcommand (hsplit tile-group) (&optional (ratio "1/2")) (:string) "Split the current frame into 2 side-by-side frames." (split-frame-in-dir (current-group) :column (read-from-string ratio))) (defcommand (vsplit tile-group) (&optional (ratio "1/2")) (:string) "Split the current frame into 2 frames, one on top of the other." (split-frame-in-dir (current-group) :row (read-from-string ratio))) (defun split-frame-eql-parts* (group dir amt) (when (> amt 1) (when-let ((new-frame (split-frame group dir (/ (- amt 1) amt)))) (cons new-frame (split-frame-eql-parts* group dir (- amt 1)))))) (defun split-frame-eql-parts (group dir amt) "Splits frame in equal parts defined by amt." (assert (> amt 1)) (let ((f (tile-group-current-frame group)) (new-frame-numbers (split-frame-eql-parts* group dir amt))) (if (= (list-length new-frame-numbers) (- amt 1)) (progn (when (frame-window f) (update-decoration (frame-window f))) (show-frame-indicator group)) (let ((head (frame-head group f))) (setf (tile-group-frame-head group head) (reduce (lambda (tree num) (remove-frame tree (frame-by-number group num))) new-frame-numbers :initial-value (tile-group-frame-head group head))) (message "Cannot split. Maybe current frame is too small."))))) (defcommand (hsplit-equally tile-group) (amt) ((:number "Enter the number of frames: ")) "Deprecated. Use `vsplit-uniformly' instead." (split-frame-eql-parts (current-group) :row amt)) (defcommand (vsplit-uniformly tile-group) (amt) ((:number "Enter the number of frames: ")) "Split current frame in n rows of equal size." (split-frame-eql-parts (current-group) :row amt)) (defcommand (vsplit-equally tile-group) (amt) ((:number "Enter the number of frames: ")) "Deprecated. Use `hsplit-uniformly' instead." (split-frame-eql-parts (current-group) :column amt)) (defcommand (hsplit-uniformly tile-group) (amt) ((:number "Enter the number of frames: ")) "Split current frame in n columns of equal size." (split-frame-eql-parts (current-group) :column amt)) (defcommand (remove-split tile-group) (&optional (group (current-group)) (frame (tile-group-current-frame group))) () "Remove the specified frame in the specified group (defaults to current group, current frame). Windows in the frame are migrated to the frame taking up its space." (let* ((head (frame-head group frame)) (current (tile-group-current-frame group)) (tree (tile-group-frame-head group head)) (s (closest-sibling (list tree) frame)) ;; grab a leaf of the siblings. The siblings doesn't have to be ;; a frame. (l (tree-accum-fn s (lambda (&rest siblings) (car siblings)) #'identity))) ;; Only remove the current frame if it has a sibling (if (atom tree) (message "No more frames!") (when s (when (frame-is-head group frame) (setf (frame-number l) (frame-number frame))) ;; Move the windows from the removed frame to its sibling (migrate-frame-windows group frame l) ;; If the frame has no window, give it the current window of ;; the current frame. (unless (frame-window l) (setf (frame-window l) (frame-window frame))) ;; Unsplit (setf (tile-group-frame-head group head) (remove-frame tree frame)) ;; update the current frame and sync all windows (when (eq frame current) (setf (tile-group-current-frame group) l)) (tree-iterate tree (lambda (leaf) (sync-frame-windows group leaf))) (frame-raise-window group l (frame-window l) nil) (when (frame-window l) (update-decoration (frame-window l))) (if (and (eq frame current) (not (only-one-frame-p))) (show-frame-indicator group) (unmap-all-frame-indicator-windows)) (run-hook-with-args *remove-split-hook* l frame))))) (defcommand-alias remove remove-split) (defun only-one-frame-p () "T if there is only one maximized frame in the current head. This can be used around a the \"only\" command to avoid the warning message." (let* ((group (screen-current-group (current-screen))) (head (current-head group))) (atom (tile-group-frame-head group head)))) (defcommand (only tile-group) () () "Delete all the frames but the current one and grow it to take up the entire head." (let* ((screen (current-screen)) (group (screen-current-group screen)) (win (group-current-window group)) (head (current-head group)) (frame (copy-frame head))) (if (only-one-frame-p) (message "There's only one frame.") (progn (mapc (lambda (w) ;; windows in other frames disappear (unless (eq (window-frame w) (tile-group-current-frame group)) (hide-window w)) (setf (window-frame w) frame)) (remove-if (lambda (w) (typep w 'float-window)) (head-windows group head))) (setf (frame-window frame) win (tile-group-frame-head group head) frame (tile-group-current-frame group) frame) (focus-frame group frame) (if (frame-window frame) (update-decoration (frame-window frame)) (show-frame-indicator group)) (sync-frame-windows group (tile-group-current-frame group)) (unmap-all-frame-indicator-windows))))) (defcommand (curframe tile-group) () () "Display a window indicating which frame is focused." (show-frame-indicator (current-group) t)) (defun focus-frame-next-sibling (group) (let* ((sib (next-sibling (tile-group-frame-tree group) (tile-group-current-frame group)))) (when sib (focus-frame group (tree-accum-fn sib (lambda (x y) (declare (ignore y)) x) 'identity)) (show-frame-indicator group)))) (defun focus-last-frame (group) ;; make sure the last frame still exists in the frame tree (let ((last-frame (tile-group-last-frame group))) (when (and last-frame (find last-frame (group-frames group))) (focus-frame group last-frame)))) (defun focus-frame-after (group frames) "Given a list of frames focus the next one in the list after the current frame." (let ((rest (cdr (member (tile-group-current-frame group) frames :test 'eq)))) (if (= (length frames) 1) (message "No other frames.") (focus-frame group (if (null rest) (car frames) (car rest)))))) (defun focus-next-frame (group) (focus-frame-after group (group-frames group))) (defun focus-prev-frame (group) (focus-frame-after group (nreverse (group-frames group)))) (defcommand (fnext tile-group) () () "Cycle through the frame tree to the next frame." (focus-next-frame (current-group))) (defcommand (fprev tile-group) () () "Cycle through the frame tree to the previous frame." (focus-prev-frame (current-group))) (defcommand (sibling tile-group) () () "Jump to the frame's sibling. If a frame is split into two frames, these two frames are siblings." (focus-frame-next-sibling (current-group))) (defcommand (fother tile-group) () () "Jump to the last frame that had focus." (focus-last-frame (current-group))) (defun choose-frame-by-number (group) "show a number in the corner of each frame and wait for the user to select one. Returns the selected frame or nil if aborted." (let ((wins (progn (draw-frame-outlines group) (draw-frame-numbers group)))) (unwind-protect (multiple-value-bind (has-click ch x y) (read-one-char-or-click group) (if has-click (let ((winner)) ;; frame-width and frame-height are not updated in this ;; context, so we need to loop through all of them until ;; we find the most satisfying one. (dolist (f (group-frames group)) (when (and (> x (frame-x f)) (> y (frame-y f))) (if winner (when (or (> (frame-x f) (frame-x winner)) (> (frame-y f) (frame-y winner))) (setf winner f)) (setf winner f)))) (ungrab-pointer) winner) (when ch (let ((num (read-from-string (string ch) nil nil))) (dformat 3 "read ~S ~S~%" ch num) (find ch (group-frames group) :test 'char= :key 'get-frame-number-translation))))) (mapc #'xlib:destroy-window wins) (clear-frame-outlines group)))) (defcommand (fselect tile-group) (frame-number) ((:frame t)) "Display a number in the corner of each frame and let the user to select a frame by number or click. If @var{frame-number} is specified, just jump to that frame." (let ((group (current-group))) (focus-frame group frame-number))) (defcommand (resize tile-group) (width height) ((:number "+ Width: ") (:number "+ Height: ")) "Move the frame split directly to the right of the current frame as much as possible up to @var{width} pixels, or if impossible try the split directly to the left instead. Similarly, also move the frame split directly below the current frame as much as possible up to @var{height} pixels, or if impossible try the split directly above instead." (let* ((group (current-group)) (f (tile-group-current-frame group))) (if (atom (tile-group-frame-tree group)) (message "No more frames!") (progn (clear-frame-outlines group) (resize-frame group f width :width) (resize-frame group f height :height) (draw-frame-outlines group (current-head)))))) (defun clear-frame (frame group) "Clear the given frame." (frame-raise-window group frame nil (eq (tile-group-current-frame group) frame))) (defcommand (fclear tile-group) () () "Clear the current frame." (clear-frame (tile-group-current-frame (current-group)) (current-group))) (defun get-edge (frame edge) "Returns the specified edge of FRAME. Valid values for EDGE are :TOP, :BOTTOM, :LEFT, and :RIGHT. An edge is a START, END, and OFFSET. For horizontal edges, START is the left coordinate, END is the right coordinate, and OFFSET is the Y coordinate. Similarly, for vertical lines, START is top, END is bottom, and OFFSET is X coordinate." (let* ((x1 (frame-x frame)) (y1 (frame-y frame)) (x2 (+ x1 (frame-width frame))) (y2 (+ y1 (frame-height frame)))) (ecase edge (:top (values x1 x2 y1)) (:bottom (values x1 x2 y2)) (:left (values y1 y2 x1)) (:right (values y1 y2 x2))))) (defun neighbour (direction frame frameset) "Returns the best neighbour of FRAME in FRAMESET on the DIRECTION edge. Valid directions are :UP, :DOWN, :LEFT, :RIGHT. eg: (NEIGHBOUR :UP F FS) finds the frame in FS that is the 'best' neighbour above F." (let ((src-edge (ecase direction (:up :top) (:down :bottom) (:left :left) (:right :right))) (opposite (ecase direction (:up :bottom) (:down :top) (:left :right) (:right :left))) (best-frame nil) (best-overlap 0)) (multiple-value-bind (src-s src-e src-offset) (get-edge frame src-edge) (dolist (f frameset) (multiple-value-bind (s e offset) (get-edge f opposite) (let ((overlap (- (min src-e e) (max src-s s)))) ;; Two edges are neighbours if they have the same offset and their starts and ends ;; overlap. We want to find the neighbour that overlaps the most. (when (and (= src-offset offset) (> overlap best-overlap)) (setf best-frame f) (setf best-overlap overlap)))))) best-frame)) (defun move-focus-and-or-window (dir &optional win-p) (declare (type (member :up :down :left :right) dir)) (let* ((group (current-group)) (new-frame (neighbour dir (tile-group-current-frame group) (group-frames group))) (window (current-window))) (when new-frame (if (and win-p window) (pull-window window new-frame) (focus-frame group new-frame))))) (defcommand (move-focus tile-group) (dir) ((:direction "Direction: ")) "Focus the frame adjacent to the current one in the specified direction. The following are valid directions: @table @asis @item up @item down @item left @item right @end table" (move-focus-and-or-window dir)) (defcommand (move-window tile-group) (dir) ((:direction "Direction: ")) "Just like move-focus except that the current is pulled along." (move-focus-and-or-window dir t)) (defcommand (next-in-frame tile-group) () () "Go to the next window in the current frame." (let ((group (current-group))) (if (group-current-window group) (focus-forward group (frame-sort-windows group (tile-group-current-frame group))) (other-window-in-frame group)))) (defcommand (prev-in-frame tile-group) () () "Go to the previous window in the current frame." (let ((group (current-group))) (if (group-current-window group) (focus-forward group (reverse (frame-sort-windows group (tile-group-current-frame group)))) (other-window-in-frame group)))) (defcommand (other-in-frame tile-group) () () "Go to the last accessed window in the current frame." (other-window-in-frame (current-group))) (defcommand (balance-frames tile-group) (&aux (group (current-group))) () "Make frames the same height or width in the current frame's subtree." (let ((tree (tile-group-frame-head group (current-head)))) (if (frame-p tree) (message "There's only one frame.") (balance-frames-internal group tree)))) (defun window-centroid (win) "Return the centroid of WIN." (let ((x (window-x win)) (y (window-y win)) (w (window-width win)) (h (window-height win))) (cons (+ x (/ w 2)) (+ y (/ h 2))))) (defun frame-centroid (frame) "Return the centroid of frame, excluding the borders." (let ((x (frame-x frame)) (y (frame-y frame)) (w (frame-width frame)) (h (frame-height frame))) (cons (+ x (/ w 2)) (+ y (/ h 2))))) (defun closest-frame (win group) "Returns the frame closet to the window, WIN." (flet ((square (n) (* n n))) (let (shortest) (destructuring-bind (win-x . win-y) (window-centroid win) (loop :for frame :in (group-frames group) :for (frame-x . frame-y) := (frame-centroid frame) :for distance := (sqrt (+ (square (- win-x frame-x)) (square (- win-y frame-y)))) :unless shortest :do (setf shortest (cons distance frame)) :when (> (car shortest) distance) :do (setf shortest (cons distance frame)))) (cdr shortest)))) (defun unfloat-window (window group) (typecase group (dynamic-group (dynamic-group-unfloat-window window group)) (tile-group (tile-group-unfloat-window window group)))) (defun tile-group-unfloat-window (window group) (let ((frame (closest-frame window group))) (dynamic-mixins:replace-class window 'tile-window :frame frame) ;; (change-class window 'tile-window :frame frame) (setf (window-frame window) frame (frame-window frame) window (tile-group-current-frame group) frame) (update-decoration window) (sync-frame-windows group frame) (sync-minor-modes window))) (defun float-window (window group) (typecase group (dynamic-group (dynamic-group-float-window window group)) (tile-group (tile-group-float-window window group)))) (defun tile-group-float-window (window group) (let ((frame (tile-group-current-frame group))) (dynamic-mixins:replace-class window 'float-window) ;; (change-class window 'float-window) (float-window-align window) (update-decoration window) (funcall-on-node (tile-group-frame-tree group) (lambda (f) (setf (slot-value f 'window) nil)) (lambda (f) (eq frame f))) (sync-minor-modes window))) (defcommand (float-this tile-group) () () "Transforms a tile-window into a float-window" (float-window (current-window) (current-group))) (defcommand (unfloat-this tile-group) () () "Transforms a float-window into a tile-window" (unfloat-window (current-window) (current-group))) (defcommand flatten-floats () () "Transform all floating windows in this group to tiled windows. Puts all tiled windows in the first frame of the group. " (let ((group (current-group))) (mapc (lambda (w) (when (typep w 'float-window) (unfloat-window w group))) (head-windows group (current-head))))) stumpwm-22.11/tile-window.lisp000066400000000000000000000541261433701203600163750ustar00rootroot00000000000000;;; a dumping spot for window stuff that has tiling stuff in it (in-package :stumpwm) (export '(*ignore-wm-inc-hints*)) (defvar *ignore-wm-inc-hints* nil "Set this to T if you never want windows to resize based on incremental WM_HINTs, like xterm and emacs.") (define-swm-class tile-window (window) ((frame :initarg :frame :accessor window-frame :type frame) (normal-size :initform nil :accessor window-normal-size))) (defmethod print-swm-object ((object tile-window) stream) (write-string "TILE-" stream) (call-next-method)) (defmethod update-decoration ((window tile-window)) ;; give it a colored border but only if there are more than 1 frames. (let* ((group (window-group window)) (screen (group-screen group))) (let ((c (if (eq (group-current-window group) window) (screen-focus-color screen) (screen-unfocus-color screen)))) (setf (xlib:window-border (window-parent window)) c ;; windows that dont fill the entire screen have a transparent background. (xlib:window-background (window-parent window)) (if (eq (window-type window) :normal) (if (eq *window-border-style* :thick) c (screen-win-bg-color screen)) :none)) ;; get the background updated (xlib:clear-area (window-parent window))))) (defmethod window-sync ((window tile-window) hint) (case hint ((:normal-hints :type) (maximize-window window)))) (defmethod window-visible-p ((window tile-window)) ;; A TILE-WINDOW is visible is it is the top window in the frame or when the ;; focused window is a FLOAT-WINDOW and the TILE-WINDOW can be seen below. (let* ((frame (window-frame window)) (frame-windows (frame-windows (window-group window) frame))) (flet ((full-frame-p (win) (not (and (window-normal-hints win) (xlib:wm-size-hints-x (window-normal-hints win)) (xlib:wm-size-hints-y (window-normal-hints win)))))) (or (eq window (or (frame-window frame) (first frame-windows))) (when (> (length frame-windows) 1) (loop :for (current-window next-window) :on frame-windows :until (full-frame-p current-window) :when (eq window next-window) :do (return t))))))) (defmethod window-head ((window tile-window)) (frame-head (window-group window) (window-frame window))) (defmethod (setf window-fullscreen) :after (val (window tile-window)) (if val (maximize-window window) (progn (setf (xlib:drawable-border-width (window-parent window)) (default-border-width-for-type window)) (maximize-window window)))) ;;;; (defmethod really-raise-window ((window tile-window)) (frame-raise-window (window-group window) (window-frame window) window)) (defun raise-modals-of (window) (mapc 'really-raise-window (modals-of window))) (defun raise-modals-of-gang (window) (mapc 'really-raise-window (only-modals (window-gang window)))) (defun raise-transients-of-gang (window) (mapc 'really-raise-window (only-transients (window-gang window)))) ;;; (defgeneric geometry-hints (win) (:documentation "Return hints for max width and height and increment hints. These hints have been modified to always be defined and never be greater than the root window's width and height.") (:method (win) (let* ((f (window-frame win)) (x (frame-display-x (window-group win) f)) (y (frame-display-y (window-group win) f)) (border (if (or (eq *window-border-style* :none) (= (length (group-frames (window-group win))) 1)) 0 (default-border-width-for-type win))) (fwidth (- (frame-display-width (window-group win) f) (* 2 border))) (fheight (- (frame-display-height (window-group win) f) (* 2 border))) (width fwidth) (height fheight) (hints (window-normal-hints win)) (hints-min-width (and hints (xlib:wm-size-hints-min-width hints))) (hints-min-height (and hints (xlib:wm-size-hints-min-height hints))) (hints-max-width (and hints (xlib:wm-size-hints-max-width hints))) (hints-max-height (and hints (xlib:wm-size-hints-max-height hints))) (hints-width (and hints (xlib:wm-size-hints-base-width hints))) (hints-height (and hints (xlib:wm-size-hints-base-height hints))) (hints-spec-width (and hints (xlib:wm-size-hints-width hints))) (hints-spec-height (and hints (xlib:wm-size-hints-height hints))) (hints-inc-x (and hints (xlib:wm-size-hints-width-inc hints))) (hints-inc-y (and hints (xlib:wm-size-hints-height-inc hints))) (hints-min-aspect (and hints (xlib:wm-size-hints-min-aspect hints))) (hints-max-aspect (and hints (xlib:wm-size-hints-max-aspect hints))) center) ;; (dformat 4 "hints: ~s~%" hints) ;; determine what the width and height should be (cond ;; handle specially fullscreen windows. ((window-fullscreen win) (let* ((win-group (window-group win)) (fs-in-frame (fullscreen-in-frame-p win)) (head (frame-head win-group f)) (frame-to-fill (if fs-in-frame f head))) ;; Determine if the window should be fullscreened in the frame or the ;; head. If fullscreening a frame, use the frame-display functions to ;; account for the modeline and non-integer splits. (if fs-in-frame (setf x (frame-display-x win-group frame-to-fill) y (frame-display-y win-group frame-to-fill) width (frame-display-width win-group frame-to-fill) height (frame-display-height win-group frame-to-fill)) (setf x (frame-x frame-to-fill) y (frame-y frame-to-fill) width (frame-width frame-to-fill) height (frame-height frame-to-fill)))) (return-from geometry-hints (values x y 0 0 width height 0 t))) ;; Adjust the defaults if the window is a transient_for window. ((find (window-type win) '(:transient :dialog)) (setf center t width (min (max (or hints-width 0) (or hints-min-width 0) (window-width win)) width) height (min (max (or hints-height 0) (or hints-min-height 0) (window-height win)) height))) ;; Set requested size for non-maximized windows ((and (window-normal-size win) hints-spec-width hints-spec-height) (setf center t width (min hints-spec-width width) height (min hints-spec-height height))) ;; aspect hints are handled similar to max size hints ((and hints-min-aspect hints-max-aspect) (let ((ratio (/ width height))) (cond ((< ratio hints-min-aspect) (setf height (ceiling width hints-min-aspect))) ((> ratio hints-max-aspect) (setf width (ceiling (* height hints-max-aspect))))) (setf center t))) ;; Update our defaults if the window has the maxsize hints ((or hints-max-width hints-max-height) (when (and hints-max-width (< hints-max-width width)) (setf width hints-max-width)) (when (and hints-max-height (< hints-max-height height)) (setf height hints-max-height)) (setf center t)) (t ;; if they have inc hints then start with the size and adjust ;; based on those increments until the window fits in the frame (when (and (not *ignore-wm-inc-hints*) hints-inc-x (plusp hints-inc-x)) (let ((w (or hints-width (window-width win)))) (setf width (+ w (* hints-inc-x (+ (floor (- fwidth w) hints-inc-x))))))) (when (and (not *ignore-wm-inc-hints*) hints-inc-y (plusp hints-inc-y)) (let ((h (or hints-height (window-height win)))) (setf height (+ h (* hints-inc-y (+ (floor (- fheight h) hints-inc-y))))))))) ;; adjust for gravity (multiple-value-bind (wx wy) (gravity-coords (gravity-for-window win) width height 0 0 fwidth fheight) (when (or center (find *window-border-style* '(:tight :none))) (setf x (+ wx (frame-display-x (window-group win) f)) y (+ wy (frame-display-y (window-group win) f)) wx 0 wy 0)) ;; Now return our findings (values x y wx wy width height border center))))) (defun maximize-window (win) "Maximize the window." (multiple-value-bind (x y wx wy width height border stick) (geometry-hints win) (dformat 4 "maximize window ~a x: ~d y: ~d width: ~d height: ~d border: ~d stick: ~s~%" win x y width height border stick) ;; This is the only place a window's geometry should change (set-window-geometry win :x wx :y wy :width width :height height :border-width 0) (xlib:with-state ((window-parent win)) ;; FIXME: updating the border doesn't need to be run everytime ;; the window is maximized, but only when the border style or ;; window type changes. The overhead is probably minimal, ;; though. (setf (xlib:drawable-x (window-parent win)) x (xlib:drawable-y (window-parent win)) y (xlib:drawable-border-width (window-parent win)) border) ;; the parent window should stick to the size of the window ;; unless it isn't being maximized to fill the frame. (if (or stick (find *window-border-style* '(:tight :none))) (setf (xlib:drawable-width (window-parent win)) (window-width win) (xlib:drawable-height (window-parent win)) (window-height win)) (let ((frame (window-frame win))) (setf (xlib:drawable-width (window-parent win)) (- (frame-display-width (window-group win) frame) (* 2 (xlib:drawable-border-width (window-parent win)))) (xlib:drawable-height (window-parent win)) (- (frame-display-height (window-group win) frame) (* 2 (xlib:drawable-border-width (window-parent win))))))) ;; update the "extents" (xlib:change-property (window-xwin win) :_NET_FRAME_EXTENTS (list wx (- (xlib:drawable-width (window-parent win)) width wx) wy (- (xlib:drawable-height (window-parent win)) height wy)) :cardinal 32)) (update-decoration win) (update-configuration win))) ;;; (defun only-tile-windows (windows) (remove-if-not (lambda (w) (typep w 'tile-window)) windows)) (defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win))) (focus-p t)) (let ((f (window-frame win)) (group (window-group win))) (unless (eq (frame-window to-frame) win) (xwin-hide win) (setf (window-frame win) to-frame) (maximize-window win) (when (eq (window-group win) (current-group)) (xwin-unhide (window-xwin win) (window-parent win))) ;; We have to restore the focus after hiding. (when (eq win (screen-focus (window-screen win))) (screen-set-focus (window-screen win) win)) (frame-raise-window group to-frame win focus-p) ;; if win was focused in its old frame then give the old ;; frame the frame's last focused window. (when (eq (frame-window f) win) ;; the current value is no longer valid. (setf (frame-window f) nil) (frame-raise-window group f (first (frame-windows group f)) nil))))) ;; In the future, this window will raise the window into the current ;; frame. (defun focus-forward (group window-list &optional pull-p (predicate (constantly t))) "Set the focus to the next item in window-list from the focused window. If PULL-P is T then pull the window into the current frame." ;; The window with focus is the "current" window, so find it in the ;; list and give that window focus (let* ((w (group-current-window group)) (wins (remove-if-not predicate (cdr (member w window-list)))) (nw (if (null wins) ;; If the last window in the list is focused, then ;; focus the first one. (car (remove-if-not predicate window-list)) ;; Otherwise, focus the next one in the list. (first wins)))) ;; there's still the case when the window is the only one in the ;; list, so make sure its not the same as the current window. (if (and nw (not (eq w nw))) (if pull-p (pull-window nw) (frame-raise-window group (window-frame nw) nw)) (message "No other window.")))) (defcommand (pull-window-by-number tile-group) (n &optional (group (current-group))) ((:window-number "Pull: ")) "Pull window N from another frame into the current frame and focus it." (let ((win (find n (group-windows group) :key 'window-number :test '=))) (when win (pull-window win)))) (defcommand-alias pull pull-window-by-number) (defun other-hidden-window (group) "Return the last window that was accessed and that is hidden." (let ((wins (remove-if (lambda (w) (eq (frame-window (window-frame w)) w)) (only-tile-windows (group-windows group))))) (first wins))) (defun pull-other-hidden-window (group) "pull the last accessed hidden window from any frame into the current frame and raise it." (let ((win (other-hidden-window group))) (if win (pull-window win) (echo-string (group-screen group) "No other window.")))) (defun other-window-in-frame (group) (let* ((f (tile-group-current-frame group)) (wins (frame-windows group f)) (win (if (frame-window f) (second wins) (first wins)))) (if win (frame-raise-window group (window-frame win) win) (echo-string (group-screen group) "No other window.")))) (defcommand (pull-hidden-next tile-group) () () "Pull the next hidden window into the current frame." (let ((group (current-group))) (focus-forward group (only-tile-windows (sort-windows group)) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) (defcommand (pull-hidden-previous tile-group) () () "Pull the next hidden window into the current frame." (let ((group (current-group))) (focus-forward group (nreverse (only-tile-windows (sort-windows group))) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) (defcommand (pull-hidden-other tile-group) () () "Pull the last focused, hidden window into the current frame." (let ((group (current-group))) (pull-other-hidden-window group))) (defcommand (pull-from-windowlist tile-group) (&optional (fmt *window-format*)) (:rest) "Pulls a window selected from the list of windows. This allows a behavior similar to Emacs' switch-to-buffer when selecting another window." (let ((pulled-window (select-window-from-menu (group-windows (current-group)) fmt))) (when pulled-window (pull-window pulled-window)))) (defgeneric exchange-windows (win1 win2) (:documentation "Exchange the windows in their respective frames.")) (defmethod exchange-windows ((win1 tile-window) (win2 tile-window)) "Exchange tile windows in their respective frames." (let ((f1 (window-frame win1)) (f2 (window-frame win2))) (unless (eq f1 f2) (pull-window win1 f2) (pull-window win2 f1) (focus-frame (window-group win1) f2)))) (defcommand (exchange-direction tile-group) (dir &optional (win (current-window))) ((:direction "Direction: ")) "Exchange the current window (by default) with the top window of the frame in specified direction. (bound to @kbd{C-t x} by default) @table @asis @item up @item down @item left @item right @end table" (if win (let* ((frame-set (group-frames (window-group win))) (neighbour (neighbour dir (window-frame win) frame-set))) (if (and neighbour (frame-window neighbour)) (exchange-windows win (frame-window neighbour)) (message "No window in direction ~A!" dir))) (message "No window in current frame!"))) (defcommand (echo-frame-windows tile-group) (&optional (fmt *window-format*)) (:rest) "Display a list of all the windows in the current frame." (echo-windows fmt (current-group) (frame-windows (current-group) (tile-group-current-frame (current-group))))) (defcommand-alias frame-windows echo-frame-windows) (defcommand (gravity tile-group) (gravity) ((:gravity "Gravity: ")) "Set a window's gravity within its frame. Gravity controls where the window will appear in a frame if it is smaller that the frame. Possible values are: @table @var @item center @item top @item right @item bottom @item left @item top-right @item top-left @item bottom-right @item bottom-left @end table" (when (current-window) (setf (window-gravity (current-window)) gravity) (maximize-window (current-window)))) (defcommand (pull-marked tile-group) () () "Pull all marked windows into the current frame and clear the marks." (let ((group (current-group))) (dolist (i (marked-windows group)) (pull-window i)) (clear-window-marks group))) ;;; window placement commands (defun make-rule-for-window (window &optional lock title) "Guess at a placement rule for WINDOW and add it to the current set." (let* ((group (window-group window)) (group-name (group-name group)) (frame-number-or-float (if (typep window 'float-window) :float (frame-number (window-frame window)))) (role (window-role window))) (push (list group-name frame-number-or-float t lock :class (window-class window) :instance (window-res window) :title (and title (window-name window)) :role (and (not (equal role "")) role)) *window-placement-rules*))) (defcommand (remember tile-group) (lock title) ((:y-or-n "Lock to group? ") (:y-or-n "Use title? ")) "Make a generic placement rule for the current window. Might be too specific/not specific enough!" (make-rule-for-window (current-window) lock title)) (defcommand (forget tile-group) () () "Forget the window placement rule that matches the current window." (let* ((window (current-window)) (match (rule-matching-window window))) (if match (progn (setf *window-placement-rules* (delete match *window-placement-rules*)) (message "Rule forgotten.")) (message "No matching rule.")))) (defcommand (dump-window-placement-rules tile-group) (file) ((:rest "Filename: ")) "Dump *window-placement-rules* to FILE." (dump-to-file *window-placement-rules* file)) (defcommand-alias dump-rules dump-window-placement-rules) (defcommand (restore-window-placement-rules tile-group) (file) ((:rest "Filename: ")) "Restore *window-placement-rules* from FILE." (setf *window-placement-rules* (read-dump-from-file file))) (defcommand-alias restore-rules restore-window-placement-rules) (defcommand (redisplay tile-group) () () "Refresh current window by a pair of resizes, also make it occupy entire frame." (let ((window (current-window))) (when window (with-slots (width height frame) window (set-window-geometry window :width (- width (window-width-inc window)) :height (- height (window-height-inc window))) ;; make sure the first one goes through before sending the second (xlib:display-finish-output *display*) (set-window-geometry window :width (+ width (* (window-width-inc window) (floor (- (frame-width frame) width) (window-width-inc window)))) :height (+ height (* (window-height-inc window) (floor (- (frame-height frame) height) (window-height-inc window))))) (maximize-window window))))) (defcommand (unmaximize tile-group) (&optional (window (current-window))) (:rest) "Use the size the program requested for current window (if any) instead of maximizing it." (let ((status (not (window-normal-size window))) (hints (window-normal-hints window))) (if (and (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-height hints)) (progn (setf (window-normal-size window) status) ;; This makes the naming a bit funny. (maximize-window window)) (message "Window has no normal size.")))) (defcommand frame-windowlist (&optional (fmt *window-format*)) (:rest) "Allow the user to select a window from the list of windows in the current frame and focus the selected window. The optional argument @var{fmt} can be specified to override the default window formatting." (let* ((group (current-group)) (frame (tile-group-current-frame group))) (if (null (frame-windows group frame)) (message "No Managed Windows.") (let ((window (select-window-from-menu (frame-sort-windows group frame) fmt))) (if window (group-focus-window group window) (throw 'error :abort)))))) stumpwm-22.11/time.lisp000066400000000000000000000164271433701203600150730ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Ivy Foster ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file contains code relating to the display of time. ;; ;; When setting `*time-format-string-default*' to look like you want, the ;; options are exactly the same as those in the output of date --help (with date ;; 6.12), with the exception of a few unimplemented functions (see the comments ;; in *time-format-string-alist*, below). `*time-modeline-string*' is also ;; customizable; it defaults to the same value as *time-format-string-default*. ;; ;; TODO: ;; ;; - Implement all options from date. ;; - Simplify code (fewer helper functions somehow?) ;; Code: (in-package :stumpwm) (export '(*time-format-string-default* *time-modeline-string* time-format echo-date time refresh-time-zone)) (defvar *time-format-string-default* "%a %b %e %Y %k:%M:%S" "The default value for `echo-date', (e.g, Thu Mar 3 2005 23:05:25).") (defvar *time-modeline-string* "%a %b %e %k:%M:%S" "The default time value to pass to the modeline.") (defvar *time-month-names* #("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (defvar *time-day-names* #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) ;; `date --help` with date_6.12 (defvar *time-format-string-alist* '((#\a time-dow-shortname) (#\A time-dow-name) (#\b time-month-shortname) (#\B time-month-name) (#\c time-date-and-time) (#\C time-century) (#\d time-day-of-month) (#\D time-date) (#\e time-day-of-month-zero) (#\F time-date-full) ;; (#\g) last two digits of year of ISO week number (see %G) ;; (#\G) year of ISO week number (see %V); normally useful only with %V (#\h time-month-shortname) (#\H time-hour-zero) (#\I time-hour-12hr-zero) ;; (#\j) day of year (001..366) (#\k time-hour) (#\l time-hour-12hr) (#\m time-month) (#\M time-minute) (#\n time-newline) ;; (#\N) nanoseconds (000000000..999999999) (#\p time-am-pm) (#\P time-am-pm-caps) (#\r time-12hr-time) (#\R time-24hr-and-minute) (#\s time-unix-era) (#\S time-second) (#\t time-tab) (#\T time-24hr-time) (#\u time-day-of-week) ;; (#\U) week number of year, with Sunday as first day of week (00..53) ;; (#\V) ISO week number, with Monday as first day of week (01..53) (#\w time-day-of-week-sun-start) ;; (#\W) week number of year, with Monday as first day of week (00..53) ;; (#\x) locale's date representation (e.g., 12/31/99) ;; (#\X) locale's time representation (e.g., 23:13:48) (#\y time-year-short) (#\Y time-year) (#\z time-tz) ;; (#\:z) +hh:mm numeric timezone (e.g., -04:00) ;; (#\::z) +hh:mm:ss numeric time zone (e.g., -04:00:00) ;; (#\:::z) numeric time zone with : to necessary precision (e.g., -04, +05:30) ;; %Z alphabetic time zone abbreviation (e.g., EDT) )) (defcommand echo-date () () "Display the date and time." (message "~a" (time-format *time-format-string-default*))) (defcommand-alias time echo-date) (defcommand refresh-time-zone () () "Refresh the time zone information from the system. If you change the system time zone while StumpWM is running you can run this command to make StumpWM notice the change." (sb-alien:alien-funcall (sb-alien:extern-alien "tzset" (function sb-alien:void)))) ;;; ------------------------------------------------------------------ ;;; Helper functions ;;; ------------------------------------------------------------------ (defun get-decoded-system-time () (decode-universal-time (+ (encode-universal-time 0 0 0 1 1 1970 0) (sb-posix:time)))) (defun time-plist (&optional time) (multiple-value-bind (sec min hour dom mon year dow dstp tz) (or time (get-decoded-system-time)) (list :second sec :minute min :hour hour :dom dom :month mon :year year :dow dow :dlsavings-p dstp :tz tz))) (defun time-second () (format nil "~2,'0D" (getf (time-plist) :second))) (defun time-minute () (format nil "~2,'0D" (getf (time-plist) :minute))) (defun time-hour () (format nil "~2,D" (getf (time-plist) :hour))) (defun time-hour-zero () (format nil "~2,'0D" (getf (time-plist) :hour))) (defun time-hour-12hr () (let ((hour (rem (getf (time-plist) :hour) 12))) (format nil "~2,D" (if (zerop hour) 12 hour)))) (defun time-hour-12hr-zero () (let ((hour (rem (getf (time-plist) :hour) 12))) (format nil "~2,'0D" (if (zerop hour) 12 hour)))) (defun time-day-of-month-zero () (format nil "~2,'0D" (getf (time-plist) :dom))) (defun time-day-of-month () (format nil "~2,' D" (getf (time-plist) :dom))) (defun time-month () (format nil "~2,'0D" (getf (time-plist) :month))) (defun time-month-name () (aref *time-month-names* (1- (getf (time-plist) :month)))) (defun time-month-shortname () (subseq (time-month-name) 0 3)) (defun time-year () (write-to-string (getf (time-plist) :year))) (defun time-century () (subseq (time-year) 0 2)) (defun time-year-short () (subseq (time-year) 2)) (defun time-day-of-week () (write-to-string (1+ (getf (time-plist) :dow)))) (defun time-day-of-week-sun-start () (let ((dow (getf (time-plist) :dow))) (write-to-string (if (= dow 6) 0 (1+ dow))))) (defun time-dow-name () (aref *time-day-names* (getf (time-plist) :dow))) (defun time-dow-shortname () (subseq (time-dow-name) 0 3)) (defun time-newline () (format nil "~a" #\newline)) (defun time-tab () (format nil "~T")) (defun time-am-pm () (if (>= (getf (time-plist) :hour) 12) "pm" "am")) (defun time-am-pm-caps () (if (>= (getf (time-plist) :hour) 12) "PM" "AM")) (defun time-tz () (let ((tz (getf (time-plist) :tz)) (dlsave (if (getf (time-plist) :dlsavings-p) 1 0))) (multiple-value-bind (hour-local decimal-local) (truncate (+ (* (float tz) -1) (if dlsave 1 0))) (format nil "~A~2,'0D~2,'0D" (if (> hour-local 0) '+ '-) (abs hour-local) (truncate (if (/= decimal-local 0) (* 60 decimal-local) 0)))))) (defun time-unix-era () (format nil "~D" (sb-posix:time))) (defun time-date-and-time () (time-format "%a %h %d %H:%M:%S %Y")) (defun time-date () (time-format "%m/%d/%y")) (defun time-date-full () (time-format "%Y-%m-%d")) (defun time-12hr-time () (time-format "%I:%M:%S %P")) (defun time-24hr-and-minute () (time-format "%H:%M")) (defun time-24hr-time () (time-format "%H:%M:%S")) (defun time-format (str) (format-expand *time-format-string-alist* str)) ;;; End of file stumpwm-22.11/timers.lisp000066400000000000000000000106561433701203600154360ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; Copyright (C) 2017 David Bjergaard ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Provides the code for timers. ;; ;; Code: (in-package :stumpwm) (export '(cancel-timer timer-p idle-time run-with-timer)) ;;; Timers (defvar *toplevel-io* nil "Top-level I/O loop") (defvar *timer-list* nil "List of active timers.") (defvar *timer-list-lock* (sb-thread:make-mutex) "Lock that should be held whenever *TIMER-LIST* is modified.") (defun idle-time (screen) "Returns the time in seconds since idle according to the root window of the `screen'." (/ (xlib:screen-saver-get-idle *display* (screen-root screen)) 1000.0)) (defun run-with-timer (secs repeat function &rest args) "Perform an action after a delay of SECS seconds. Repeat the action every REPEAT seconds, if repeat is non-nil. SECS and REPEAT may be reals. The action is to call FUNCTION with arguments ARGS." (check-type secs (real 0 *)) (check-type repeat (or null (real 0 *))) (check-type function (or function symbol)) (let ((timer (make-timer :repeat repeat :function function :args args))) (schedule-timer timer secs) (labels ((append-to-list () (sb-thread:with-mutex (*timer-list-lock*) (setf *timer-list* (merge 'list *timer-list* (list timer) #'< :key #'timer-time))))) (call-in-main-thread #'append-to-list) timer))) (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (check-type timer timer) (sb-thread:with-mutex (*timer-list-lock*) (setf *timer-list* (remove timer *timer-list*)))) (defun schedule-timer (timer when) (setf (timer-time timer) (+ (get-internal-real-time) (* when internal-time-units-per-second)))) (defun sort-timers (timers) (let ((now (get-internal-real-time)) (pending ()) (remaining ())) (dolist (timer timers) (if (<= (timer-time timer) now) (progn (push timer pending) (when (timer-repeat timer) (schedule-timer timer (timer-repeat timer)) (push timer remaining))) (push timer remaining))) (values pending remaining))) (defun execute-timers (timers) (map nil #'execute-timer timers)) (defun execute-timer (timer) (apply (timer-function timer) (timer-args timer))) (defun run-expired-timers () (let ((expired (sb-thread:with-mutex (*timer-list-lock*) (multiple-value-bind (pending remaining) (sort-timers *timer-list*) (update-timer-list remaining) pending)))) ;; Call the timers after the lock has been released (execute-timers expired))) (defun update-timer-list (timers) "Update the timer list, sorting the timers by which is closer expiry." (setf *timer-list* (sort timers #'< :key #'timer-time))) (defun get-next-timeout (timers) "Return the number of seconds until the next timeout or nil if there are no timers." (when timers (max (/ (- (timer-time (car timers)) (get-internal-real-time)) internal-time-units-per-second) 0))) (defclass stumpwm-timer-channel () ()) (defmethod io-channel-ioport (io-loop (channel stumpwm-timer-channel)) (declare (ignore io-loop)) nil) (defmethod io-channel-events ((channel stumpwm-timer-channel)) (sb-thread:with-mutex (*timer-list-lock*) (if *timer-list* `((:timeout ,(timer-time (car *timer-list*)))) '(:loop)))) (defmethod io-channel-handle ((channel stumpwm-timer-channel) (event (eql :timeout)) &key) (run-expired-timers)) (defmethod io-channel-handle ((channel stumpwm-timer-channel) (event (eql :loop)) &key) (run-expired-timers)) stumpwm-22.11/user.lisp000066400000000000000000000424151433701203600151070ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Window Manager commands that users can use to manipulate stumpwm. ;; ;; Code: (in-package :stumpwm) (export '(defprogram-shortcut pathname-is-executable-p programs-in-path restarts-menu run-or-raise run-or-pull run-shell-command window-send-string)) (defun restarts-menu (err) "Display a menu with the active restarts and let the user pick one. Error is the error being recovered from. If the user aborts the menu, the error is re-signalled." (let* ((*hooks-enabled-p* nil) ;;disable hooks to avoid deadlocks involving errors in *message-hook* (restart (select-from-menu (current-screen) (mapcar (lambda (r) (list (format nil "[~a] ~a" (restart-name r) (substitute #\Space #\Newline (write-to-string r :escape nil))) r)) ;; a crusty way to get only ;; the restarts from ;; stumpwm's top-level ;; restart inward. (reverse (member 'top-level (reverse (compute-restarts)) :key 'restart-name))) (format nil "Error: ~a" (substitute #\Space #\Newline (write-to-string err :escape nil)))))) (when restart (invoke-restart (second restart))))) (defun banish-pointer (&optional (where *banish-pointer-to*)) "Move the pointer to the lower right corner of the head, or WHEREever (one of :screen :head :frame or :window)" (let* ((screen (current-screen)) (group (current-group)) (head (current-head)) (frame (tile-group-current-frame group)) (window (frame-window frame)) (x (1- (+ (frame-display-x group frame) (frame-display-width group frame)))) (y (1- (+ (frame-display-y group frame) (frame-display-height group frame))))) (ecase where (:screen (setf x (1- (+ (screen-x screen) (screen-width screen))) y (1- (+ (screen-y screen) (screen-height screen))))) (:head (setf x (1- (+ (head-x head) (head-width head))) y (1- (+ (head-y head) (head-height head))))) (:frame) (:window (when window (let ((win (window-parent window))) (setf x (1- (+ (xlib:drawable-x win) (xlib:drawable-width win))) y (1- (+ (xlib:drawable-y win) (xlib:drawable-height win)))))))) (warp-pointer (group-screen group) x y))) (defcommand banish (&optional where) (:rest) "Warp the mouse the lower right corner of the current head." (if where (banish-pointer (intern1 where :keyword)) (banish-pointer))) (defcommand ratwarp (x y) ((:number "X: ") (:number "Y: ")) "Warp the mouse to the specified location." (warp-pointer (current-screen) x y)) (defcommand ratrelwarp (dx dy) ((:number "Delta X: ") (:number "Delta Y: ")) "Warp the mouse by the specified amount from its current position." (warp-pointer-relative dx dy)) (defcommand ratclick (&optional (button 1)) (:number) "Simulate a pointer button event at the current pointer location. Note: this function is unlikely to work unless your X server and CLX implementation support XTEST." (when (current-window) (send-fake-click (current-window) button))) (defun programs-in-path (&optional full-path (path (split-string (getenv "PATH") ":"))) "Return a list of programs in the path. If @var{full-path} is @var{t} then return the full path, otherwise just return the filename. @var{path} is by default the @env{PATH} evironment variable but can be specified. It should be a string containing each directory seperated by a colon." (loop for p in path for dir = (probe-path p) when dir nconc (loop for file in (directory (merge-pathnames (make-pathname :name :wild :type :wild) dir) :resolve-symlinks nil) for namestring = (file-namestring file) when (pathname-is-executable-p file) collect (if full-path (namestring file) namestring)))) (defstruct path-cache programs modification-dates paths) (defvar *path-cache-lock* (sb-thread:make-mutex) "A lock for accessing the *path-cache* during calls to rehash.") (defvar *path-cache* nil "A cache containing the programs in the path, used for completion.") (defun rehash (&optional (paths (mapcar 'parse-namestring (split-string (getenv "PATH") ":")))) "Update the cache of programs in the path stored in @var{*programs-list*} when needed." (let ((dates (mapcar (lambda (p) (when (probe-path p) (file-write-date p))) paths))) (finish-output) (sb-thread:with-mutex (*path-cache-lock*) (unless (and *path-cache* (equal (path-cache-paths *path-cache*) paths) (equal (path-cache-modification-dates *path-cache*) dates)) (setf *path-cache* (make-path-cache :programs (programs-in-path nil paths) :modification-dates dates :paths paths)))))) (defun complete-program (base) "return the list of programs in @var{*path-cache*} whose names begin with base. Automagically update the cache." (rehash) (remove-if-not #'(lambda (p) (when (<= (length base) (length p)) (string= base p :end1 (length base) :end2 (length base)))) (path-cache-programs *path-cache*))) (defcommand run-shell-command (cmd &optional collect-output-p) ((:shell "/bin/sh -c ")) "Run the specified shell command. If @var{collect-output-p} is @code{T} then run the command synchonously and collect the output. Be careful. If the shell command doesn't return, it will hang StumpWM. In such a case, kill the shell command to resume StumpWM." (if collect-output-p (run-prog-collect-output *shell-program* "-c" cmd) (run-prog *shell-program* :args (list "-c" cmd) :wait nil))) (defcommand-alias exec run-shell-command) (defcommand eval-line (cmd) ((:rest "Eval: ")) "Evaluate the s-expression and display the result(s)." (handler-case (if cmd (message "^20~{~a~^~%~}" (mapcar 'prin1-to-string (multiple-value-list (eval (read-from-string cmd))))) (throw 'error :abort)) (error (c) (err "^B^1*~A" c)))) (defcommand-alias eval eval-line) (defcommand echo (string) ((:rest "Echo: ")) "Display @var{string} in the message bar." ;; The purpose of echo is always to pop up a message window. (let ((*executing-stumpwm-command* nil)) (message "~a" string))) (defun send-meta-key (screen key) "Send the key to the current window on the specified screen." (when (screen-current-window screen) (send-fake-key (screen-current-window screen) key))) (defcommand meta (key) ((:key "Key: ")) "Send a fake key to the current window. @var{key} is a typical StumpWM key, like @kbd{C-M-o}." (send-meta-key (current-screen) key)) (defcommand loadrc () () "Reload the @file{~/.stumpwmrc} file." (handler-case (with-restarts-menu (load-rc-file nil)) (error (c) (message "^1*^BError loading rc file: ^n~A" c)) (:no-error (&rest args) (declare (ignore args)) (message "rc file loaded successfully.")))) (defcommand keyboard-quit () () "This way you can exit from command mode. Also aliased as abort." (let ((in-command-mode (eq *top-map* *root-map*))) (when (pop-top-map) (if in-command-mode (run-hook *command-mode-end-hook*) (message "Exited."))))) (defcommand-alias abort keyboard-quit) (defcommand quit-confirm () () "Prompt the user to confirm quitting StumpWM." (if (y-or-n-p (format nil "~@{~a~^~%~}" "You are about to quit the window manager to TTY." "Really ^1^Bquit^b^n ^B^2StumpWM^n^b?" "^B^6Confirm?^n ")) (quit) (xlib:unmap-window (screen-message-window (current-screen))))) (defcommand quit () () "Quit StumpWM." (throw :top-level :quit)) (defcommand restart-soft () () "Soft restart StumpWM. The lisp process isn't restarted. Instead, control jumps to the very beginning of the stumpwm program. This differs from RESTART, which restarts the unix process. Since the process isn't restarted, existing customizations remain after the restart." (destroy-all-mode-lines) (throw :top-level :restart)) (defcommand restart-hard () () "Restart stumpwm. This is handy if a new stumpwm executable has been made and you wish to replace the existing process with it. Any run-time customizations will be lost after the restart." (destroy-all-mode-lines) (throw :top-level :hup-process)) (defun find-matching-windows (props all-groups all-screens) "Returns list of windows matching @var{props} (see run-or-raise documentation for details). @var{all-groups} will find windows on all groups. Same for @{all-screens}. Result is sorted by group and window number, with group being more significant (think radix sort)." (let* ((screens (if all-screens *screen-list* (list (current-screen)))) (winlist (if all-groups (mapcan (lambda (s) (screen-windows s)) screens) (group-windows (current-group)))) (matches (remove-if-not (lambda (w) (apply 'window-matches-properties-p w props)) winlist))) (stable-sort (sort matches #'< :key #'window-number) #'< :key (lambda (w) (group-number (window-group w)))))) (defun run-or-raise (cmd props &optional (all-groups *run-or-raise-all-groups*) (all-screens *run-or-raise-all-screens*)) "Run the shell command, @var{cmd}, unless an existing window matches @var{props}. @var{props} is a property list with the following keys: @table @code @item :class Match the window's class. @item :instance Match the window's instance or resource-name. @item :role Match the window's @code{WM_WINDOW_ROLE}. @item :title Match the window's title. @end table By default, the global @var{*run-or-raise-all-groups*} decides whether to search all groups or the current one for a running instance. @var{all-groups} overrides this default. Similarily for @var{*run-or-raise-all-screens*} and @var{all-screens}." (let* ((matches (find-matching-windows props all-groups all-screens)) ;; other-matches is list of matches "after" the current ;; win, if current win matches. getting 2nd element means ;; skipping over the current win, to cycle through matches (other-matches (member (current-window) matches)) (win (if (> (length other-matches) 1) (second other-matches) (first matches)))) (if win (focus-all win) (run-shell-command cmd)))) (defun run-or-pull (cmd props &optional (all-groups *run-or-raise-all-groups*) (all-screens *run-or-raise-all-screens*)) "Similar to run-or-raise, but move the matching window to the current frame instead of switching to the window." (let* ((matches (find-matching-windows props all-groups all-screens)) ;; other-matches is for cycling through matches (other-matches (member (current-window) matches)) (win (if (> (length other-matches) 1) (second other-matches) (first matches)))) (if win (progn (move-window-to-group win (current-group)) (pull-window win)) (run-shell-command cmd)))) (defcommand reload () () "Reload StumpWM using @code{asdf}." (message "Reloading StumpWM...") #+asdf (with-restarts-menu (asdf:operate 'asdf:load-op :stumpwm)) #-asdf (message "^B^1*Sorry, StumpWM can only be reloaded with asdf (for now).") #+asdf (message "Reloading StumpWM...^B^2*Done^n.")) (defcommand emacs () () "Start emacs unless it is already running, in which case focus it." (run-or-raise "emacs" '(:class "Emacs"))) (defcommand copy-unhandled-error () () "When an unhandled error occurs, StumpWM restarts and attempts to continue. Unhandled errors should be reported to the mailing list so they can be fixed. Use this command to copy the unhandled error and backtrace to the X11 selection so you can paste in your email when submitting the bug report." (if *last-unhandled-error* (progn (set-x-selection (format nil "~a~%~a" (first *last-unhandled-error*) (second *last-unhandled-error*))) (message "Copied to clipboard.")) (message "There was no unhandled error!"))) (defmacro defprogram-shortcut (name &key (command (string-downcase (string name))) (props `'(:class ,(string-capitalize command))) (map '*top-map*) (key `(kbd ,(concat "H-" (subseq command 0 1)))) (pullp nil) (pull-name (intern1 (concat (string name) "-PULL"))) (pull-key `(kbd ,(concat "H-M-" (subseq command 0 1))))) "Define a command and key binding to run or raise a program. If @var{pullp} is set, also define a command and key binding to run or pull the program." `(progn (defcommand ,name () () (run-or-raise ,command ,props)) (define-key ,map ,key ,(string-downcase (string name))) ,(when pullp `(progn (defcommand (,pull-name tile-group) () () (run-or-pull ,command ,props)) (define-key ,map ,pull-key ,(string-downcase (string pull-name))))))) (defcommand show-window-properties () () "Shows the properties of the current window. These properties can be used for matching windows with run-or-raise or window placement rules." (let ((w (current-window))) (if (not w) (message "No active window!") (message-no-timeout "class: ~A~%instance: ~A~%type: :~A~%role: ~A~%title: ~A" (window-class w) (window-res w) (string (window-type w)) (window-role w) (window-title w))))) (defcommand list-window-properties () () "List all the properties of the current window and their values, like xprop." (message-no-timeout "~{~30a: ~a~^~%~}" (let ((win (if (current-window) (window-xwin (current-window)) (screen-root (current-screen))))) (loop for i in (xlib:list-properties win) collect i collect (multiple-value-bind (values type) (xlib:get-property win i) (case type (:wm_state (format nil "~{~a~^, ~}" (loop for v in values collect (case v (0 "Iconic") (1 "Normal") (2 "Withdrawn") (t "Unknown"))))) (:window i) ;; _NET_WM_ICON is huuuuuge (:cardinal (if (> (length values) 20) (format nil "~{~d~^, ~}..." (subseq values 0 15)) (format nil "~{~d~^, ~}" values))) (:atom (format nil "~{~a~^, ~}" (mapcar (lambda (v) (xlib:atom-name *display* v)) values))) (:string (format nil "~{~s~^, ~}" (mapcar (lambda (x) (map 'string 'xlib:card8->char x)) (split-seq values '(0))))) (:utf8_string (format nil "~{~s~^, ~}" (mapcar 'utf8-to-string (split-seq values '(0))))) (t values))))))) stumpwm-22.11/version.lisp000066400000000000000000000027271433701203600156200ustar00rootroot00000000000000;; Copyright (C) 2006-2008 Martin Bishop, Ivy Foster ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; This file contains version information. ;; ;; Code: (in-package :stumpwm) (export '(*version* version)) (defparameter *version* #.(concatenate 'string (let* ((sys (asdf:find-system :stumpwm)) (git-dir (probe-path (asdf:system-relative-pathname sys ".git")))) (if git-dir (string-trim '(#\Newline) (run-shell-command (format nil "GIT_DIR=~a git describe --tags" git-dir) t)) (asdf:component-version sys))) " Compiled On " (format-expand *time-format-string-alist* *time-format-string-default*))) (defcommand version () () "Print version information and compilation date." (message *version*)) ;; End of file stumpwm-22.11/window-placement.lisp000066400000000000000000000255731433701203600174140ustar00rootroot00000000000000;;; Window placement routines (in-package :stumpwm) (defun xwin-to-window (xwin) "Build a window for XWIN" (make-swm-class-instance 'window :xwin xwin :width (xlib:drawable-width xwin) :height (xlib:drawable-height xwin) :x (xlib:drawable-x xwin) :y (xlib:drawable-y xwin) :title (xwin-name xwin) :class (xwin-class xwin) :res (xwin-res-name xwin) :role (xwin-role xwin) :type (xwin-type xwin) :normal-hints (get-normalized-normal-hints xwin) :state +iconic-state+ :plist (make-hash-table) :unmap-ignores 0)) (defvar *rule-scanners-cache* (make-hash-table :test 'equal) "A cache for the ppcre scanners") (defun get-or-create-rule-scanner (regex) (ensure-gethash regex *rule-scanners-cache* (ppcre:create-scanner regex))) (defun string-match (string pat) (ppcre:scan (get-or-create-rule-scanner pat) string)) (defun window-matches-properties-p (window &key class class-not instance instance-not type type-not role role-not title title-not) "Returns T if window matches all the given properties" (and (if class (string-match (window-class window) class) t) (if class-not (not (string-match (window-class window) class-not)) t) (if instance (string-match (window-res window) instance) t) (if instance-not (not (string-match (window-res window) instance-not)) t) (if type (eq (window-type window) type) t) (if type-not (not (eq (window-type window) type-not)) t) (if role (string-match (window-role window) role) t) (if role-not (not (string-match (window-role window) role-not)) t) (if title (string-match (window-title window) title) t) (if title-not (not (string-match (window-title window) title-not)) t) t)) (defun window-matches-rule-p (w rule) "Returns T if window matches rule" (destructuring-bind (group-name frame raise lock &key from-group class class-not instance instance-not type type-not role role-not title title-not match-properties-and-function match-properties-or-function &allow-other-keys) rule (declare (ignore frame raise)) (let* ((from-group (cond ((not from-group) (group-name (or (when (slot-boundp w 'group) (window-group w)) (current-group)))) ((stringp from-group) from-group) (t (group-name (eval from-group))))) (properties-matched (if (or lock (equal group-name from-group)) (window-matches-properties-p w :class class :class-not class-not :instance instance :instance-not instance-not :type type :type-not type-not :role role :role-not role-not :title title :title-not title-not)))) (cond ((and match-properties-and-function match-properties-or-function) (or (and properties-matched (funcall match-properties-and-function w)) (funcall match-properties-or-function w))) (match-properties-or-function (or properties-matched (funcall match-properties-or-function w))) (match-properties-and-function (and properties-matched (funcall match-properties-and-function w))) (t properties-matched))))) (defun rule-matching-window (window) (dolist (rule *window-placement-rules*) (when (window-matches-rule-p window rule) (return rule)))) (defun get-window-placement (screen window) "Returns the ideal group and frame that WINDOW should belong to and whether the window should be raised." (let ((match (rule-matching-window window))) (if match (destructuring-bind (group-name frame raise lock &key create restore &allow-other-keys) match (declare (ignore lock)) (let ((group (find-group screen group-name))) (cond (group (when (and restore (stringp restore)) (let ((restore-file (data-dir-file restore))) (if (probe-file restore-file) (restore-group group (read-dump-from-file restore-file)) (message "^B^1*Can't restore group \"^b~a^B\" with \"^b~a^B\"." group-name restore-file)))) (values group (if (eq frame :float) frame (frame-by-number group frame)) raise)) (create (let ((new-group (add-group (current-screen) group-name)) (restore-file (if (stringp create) (data-dir-file create) (data-dir-file group-name)))) (if (and new-group (probe-file restore-file)) (restore-group new-group (read-dump-from-file restore-file)) (when (stringp create) (message "^B^1*Can't restore group \"^b~a^B\" with \"^b~a^B\"." group-name restore-file))) (values new-group (if (eq frame :float) frame (frame-by-number new-group frame)) raise))) ((not group-name) (values (current-group) (if (eq frame :float) frame (frame-by-number (current-group) frame)) raise)) (t (message "^B^1*Error placing window, group \"^b~a^B\" does not exist." group-name) (values))))) (values)))) (defun sync-single-window-placement (screen window &optional show) "Re-arrange the window according to placement rules" (multiple-value-bind (to-group frame raise) (with-current-screen screen (get-window-placement screen window)) (when to-group (unless (eq (window-group window) to-group) (move-window-to-group window to-group))) (when frame (unless (eq (window-frame window) frame) (pull-window window frame raise))) (when show (switch-to-group (window-group window)) (really-raise-window window)))) (defun sync-window-placement () "Re-arrange existing windows according to placement rules" (dolist (screen *screen-list*) (dolist (window (screen-windows screen)) (sync-single-window-placement screen window)))) (defun assign-window (window group &optional (where :tail)) "Assign the window to the specified group and perform the necessary housekeeping." (setf (window-group window) group (window-number window) (find-free-window-number group)) (if (eq where :head) (push window (group-windows group)) (setf (group-windows group) (append (group-windows group) (list window)))) (setf (xwin-state (window-xwin window)) +iconic-state+) (netwm-set-group window)) (defun place-window (screen window) "Pick a group WINDOW and return the group-specific placement hints, if any." (let* ((netwm-group (netwm-group window screen)) (placement (multiple-value-list (get-window-placement screen window))) (placement-group (first placement)) (group (or (when *processing-existing-windows* netwm-group) placement-group netwm-group (screen-current-group screen)))) (assign-window window group (if *processing-existing-windows* :head :tail)) ;; if we're using the placement group, then return the extra data. (when (eq group placement-group) (list :frame (second placement) :raise (third placement))))) (defun pick-preferred-frame (window) (let* ((group (window-group window)) (frames (group-frames group)) (default (tile-group-current-frame group)) (preferred-frame (or *new-window-preferred-frame* default))) (when (or (functionp *new-window-preferred-frame*) (and (symbolp *new-window-preferred-frame*) (fboundp *new-window-preferred-frame*))) (setq preferred-frame (handler-case (funcall *new-window-preferred-frame* window) (t (c) (message "^1*^BError while calling ^b^3**new-window-preferred-frame*^1*^B: ^n~a" c) default)))) (cond ;; If we already have a frame use it. ((frame-p preferred-frame) preferred-frame) ;; If `preferred-frame' is a list of keyword use it to determine the ;; frame. The sanity check doesn't cover not recognized keywords. We ;; simply fall back to the default then. ((and (listp preferred-frame) (every #'keywordp preferred-frame)) (or (loop for i in preferred-frame thereis (case i (:last ;; last-frame can be stale (and (> (length frames) 1) (tile-group-last-frame group))) (:unfocused (find-if (lambda (f) (not (eq f (tile-group-current-frame group)))) frames)) (:empty (find-if (lambda (f) (null (frame-window f))) frames)) (:choice ;; Transient windows sometimes specify a location ;; relative to the TRANSIENT_FOR window. Just ignore ;; these hints. (unless (find (window-type window) '(:transient :dialog)) (let ((hints (window-normal-hints window))) (when (and hints (xlib:wm-size-hints-user-specified-position-p hints)) (find-frame group (window-x window) (window-y window)))))))) default)) ;; Not well formed `*new-window-preferred-frame*'. Message an error and ;; return the default. (t (message "^1*^BInvalid ^b^3**new-window-preferred-frame*^1*^B: ^n~a" preferred-frame) default)))) stumpwm-22.11/window.lisp000066400000000000000000001506171433701203600154440ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; Window functionality. ;; ;; Code: (in-package #:stumpwm) (export '(*default-window-name* define-window-slot set-normal-gravity set-maxsize-gravity set-transient-gravity set-window-geometry find-wm-state add-wm-state remove-wm-state)) (export '(window window-xwin window-width window-height window-x window-y window-gravity window-group window-number window-parent window-title window-user-title window-class window-type window-res window-role window-unmap-ignores window-state window-normal-hints window-marked window-plist window-fullscreen window-screen ;; Window utilities update-configuration no-focus ;; Window management API update-decoration focus-window raise-window window-visible-p window-sync window-head really-raise-window)) (defvar *default-window-name* "Unnamed" "The name given to a window that does not supply its own name.") (define-swm-class window () ((xwin :initarg :xwin :accessor window-xwin) (width :initarg :width :accessor window-width) (height :initarg :height :accessor window-height) ;; these are only used to hold the requested map location. (x :initarg :x :accessor window-x) (y :initarg :y :accessor window-y) (gravity :initform nil :accessor window-gravity) (group :initarg :group :accessor window-group) (number :initarg :number :accessor window-number) (parent :accessor window-parent) (title :initarg :title :accessor window-title) (user-title :initform nil :accessor window-user-title) (class :initarg :class :accessor window-class) (type :initarg :type :accessor window-type) (res :initarg :res :accessor window-res) (role :initarg :role :accessor window-role) (unmap-ignores :initarg :unmap-ignores :accessor window-unmap-ignores) (state :initarg :state :accessor window-state) (normal-hints :initarg :normal-hints :accessor window-normal-hints) (marked :initform nil :accessor window-marked) (plist :initarg :plist :accessor window-plist) (fullscreen :initform nil :accessor window-fullscreen))) (defmethod print-swm-object ((object window) stream) (format stream "WINDOW ~s #x~x" (window-name object) (window-id object))) ;;; Window Management API (defgeneric update-decoration (window) (:documentation "Update the window decoration.")) (defgeneric focus-window (window &optional raise) (:documentation "Give the specified window keyboard focus and (optionally) raise.")) (defgeneric raise-window (window) (:documentation "Bring the window to the top of the window stack.")) (defgeneric window-visible-p (window) (:documentation "Return T if the window is visible")) (defgeneric window-sync (window what-changed) (:documentation "Some window slot has been updated and the window may need to sync itself. WHAT-CHANGED is a hint at what changed.")) (defgeneric window-head (window) (:documentation "Report what window the head is currently on.")) (defgeneric really-raise-window (window) (:documentation "Really bring the window to the top of the window stack in group")) (defmethod window-group :around ((window window)) (if (find window *always-show-windows*) (current-group) (call-next-method))) ;; Urgency / demands attention (defun register-urgent-window (window) "Add WINDOW to its screen's list of urgent windows" (if (eq (screen-current-window (window-screen window)) window) ;; window is already current, clear the urgent state to let it know we know. (window-clear-urgency window) (progn (push window (screen-urgent-windows (window-screen window))) (update-mode-lines (window-screen window)) (values t)))) (defun unregister-urgent-window (window) "Remove WINDOW to its screen's list of urgent windows" (setf (screen-urgent-windows (window-screen window)) (delete window (screen-urgent-windows (window-screen window)))) (update-mode-lines (window-screen window))) (defun window-clear-urgency (window) "Clear the urgency bit and/or _NET_WM_STATE_DEMANDS_ATTENTION on WINDOW" (let* ((hints (xlib:wm-hints (window-xwin window))) (flags (when hints (xlib:wm-hints-flags hints)))) (when flags (setf (xlib:wm-hints-flags hints) (logand (lognot 256) flags) (xlib:wm-hints (window-xwin window)) hints))) (remove-wm-state (window-xwin window) :_NET_WM_STATE_DEMANDS_ATTENTION) (unregister-urgent-window window)) (defun window-urgent-p (window) "Returns T if WINDOW has the urgency bit and/or _NET_WM_STATE_DEMANDS_ATTENTION set" (let* ((hints (xlib:wm-hints (window-xwin window))) (flags (when hints (xlib:wm-hints-flags hints)))) (or (and flags (logtest 256 flags)) (find-wm-state (window-xwin window) :_NET_WM_STATE_DEMANDS_ATTENTION)))) (defcommand next-urgent () () "Jump to the next urgent window" (and (screen-urgent-windows (current-screen)) (focus-all (first (screen-urgent-windows (current-screen)))))) ;; Since StumpWM already uses the term 'group' to refer to Virtual Desktops, ;; we'll call the grouped windows of an application a 'gang' ;; maybe follow transient_for to find leader. (defun window-leader (window) (when window (or (first (window-property window :WM_CLIENT_LEADER)) (let ((id (window-transient-for window))) (when id (window-leader (window-by-id id))))))) ;; A modal dialog can either shadow a single window, or all windows ;; in its gang, depending on the value of WM_TRANSIENT_FOR ;; If a window is shadowed by a modal dialog, so are any other ;; transients belonging to that window. (defun window-transient-for (window) (first (window-property window :WM_TRANSIENT_FOR))) (defun window-modal-p (window) (find-wm-state (window-xwin window) :_NET_WM_STATE_MODAL)) (defun window-transient-p (window) (find (window-type window) '(:transient :dialog))) ;; FIXME: use WM_HINTS.group_leader (defun window-gang (window) "Return a list of other windows in WINDOW's gang." (let ((leader (window-leader window)) (screen (window-screen window))) (when leader (loop for w in (screen-windows screen) as l = (window-leader w) if (and (not (eq w window)) l (= leader l)) collect w)))) (defun only-modals (windows) "Out of WINDOWS, return a list of those which are modal." (remove-if-not 'window-modal-p (copy-list windows))) (defun x-of (window filter) (let* ((root (screen-root (window-screen window))) (root-id (xlib:drawable-id root)) (win-id (xlib:window-id (window-xwin window)))) (loop for w in (funcall filter (window-gang window)) as tr = (window-transient-for w) when (or (not tr) ; modal for group (eq tr root-id) ; ditto (eq tr win-id)) ; modal for win collect w))) ;; The modals of a transient are the modals of the window ;; the transient belongs to. (defun modals-of (window) "Given WINDOW return the modal dialogs which are shadowing it, if any." (loop for m in (only-modals (window-gang window)) when (find window (shadows-of m)) collect m)) (defun transients-of (window) "Return the transient dialogs belonging to WINDOW" (x-of window 'only-transients)) (defun shadows-of (window) "Given modal window WINDOW return the list of windows in its shadow." (let* ((root (screen-root (window-screen window))) (root-id (xlib:drawable-id root)) (tr (window-transient-for window))) (cond ((or (not tr) (eq tr root-id)) (window-gang window)) (t (let ((w (window-by-id tr))) (if w (append (list w) (transients-of w)) '())))))) (defun only-transients (windows) "Out of WINDOWS, return a list of those which are transient." (remove-if-not 'window-transient-p (copy-list windows))) (defun all-windows () (mapcan (lambda (s) (copy-list (screen-windows s))) *screen-list*)) (defun visible-windows () "Return a list of visible windows (on all screens)" (loop for s in *screen-list* nconc (delete-if 'window-hidden-p (copy-list (group-windows (screen-current-group s)))))) (defun top-windows () "Return a list of semantically visible windows (on all screens)" (loop for s in *screen-list* nconc (delete-if-not 'window-visible-p (copy-list (group-windows (screen-current-group s)))))) (defun window-name (window) (or (window-user-title window) (case *window-name-source* (:resource-name (window-res window)) (:class (window-class window)) (t (window-title window))) *default-window-name*)) (defun window-id (window) (xlib:window-id (window-xwin window))) (defun window-in-current-group-p (window) (or (find window *always-show-windows*) (eq (window-group window) (screen-current-group (window-screen window))))) (defun window-screen (window) (group-screen (window-group window))) (defun send-client-message (window type &rest data) "Send a client message to a client's window." (xlib:send-event (window-xwin window) :client-message nil :window (window-xwin window) :type type :format 32 :data data)) (defun window-map-number (window) (princ-to-string (let ((num (window-number window))) (or (and (< num (length *window-number-map*)) (elt *window-number-map* num)) num)))) (defun fmt-window-status (window) (let ((group (window-group window))) (cond ((eq window (group-current-window group)) #\*) ((and (typep (second (group-windows group)) 'window) (eq window (second (group-windows group)))) #\+) (t #\-)))) (defun fmt-window-marked (window) (if (window-marked window) #\# #\Space)) ;; (defun update-window-mark (window) ;; "Called when we need to draw or clear the mark." ;; ;; FIXME: This doesn't work at all. I'd like to have little squares ;; ;; that look like clamps on the corners of the window, likes its ;; ;; sorta grabbed. But i dunno how to properly draw them. ;; (let* ((screen (window-screen window))) ;; (if (window-marked window) ;; (xlib:draw-rectangle (window-parent window) (screen-marked-gc (window-screen window)) ;; 0 0 300 200 t) ;; (xlib:clear-area (window-parent window))))) (defun escape-caret (str) "Escape carets by doubling them" (coerce (loop :for char :across str :collect char :when (char= char #\^) :collect char) 'string)) (defun get-normalized-normal-hints (xwin) (macrolet ((validate-hint (fn) (setf fn (intern1 (concatenate 'string (string '#:wm-size-hints-) (string fn)) :xlib)) `(setf (,fn hints) (and (,fn hints) (plusp (,fn hints)) (,fn hints))))) (let ((hints (xlib:wm-normal-hints xwin))) (when hints (validate-hint :min-width) (validate-hint :min-height) (validate-hint :max-width) (validate-hint :max-height) (validate-hint :base-width) (validate-hint :base-height) (validate-hint :width-inc) (validate-hint :height-inc) (validate-hint :min-aspect) (validate-hint :max-aspect)) hints))) (defun xwin-net-wm-name (win) "Return the netwm wm name" (when-let ((name (xlib:get-property win :_NET_WM_NAME))) (utf8-to-string name))) (defun safely-decode-x11-string (string) (handler-case (map 'string 'xlib:card8->char string) (type-error () nil))) (defun xwin-wm-name (win) (multiple-value-bind (name encoding) (xlib:get-property win :WM_NAME :result-type '(vector (unsigned-byte 8))) (when name (if (eq encoding :string) (safely-decode-x11-string name) (utf8-to-string name))))) (defun xwin-name (win) (escape-caret (or (xwin-net-wm-name win) (xwin-wm-name win) ""))) (defun update-configuration (win) ;; Send a synthetic configure-notify event so that the window ;; knows where it is onscreen. (handler-case (xwin-send-configuration-notify (window-xwin win) (+ (xlib:drawable-x (window-parent win)) (xlib:drawable-x (window-xwin win))) (+ (xlib:drawable-y (window-parent win)) (xlib:drawable-y (window-xwin win))) (window-width win) (window-height win) 0) (xlib:drawable-error (c) (dformat 4 "ignore ~S in ~S on ~S" c 'update-configuration win)))) ;; FIXME: should we raise the window or its parent? (defmethod raise-window (win) "Map the window if needed and bring it to the top of the stack. Does not affect focus." (when (window-urgent-p win) (window-clear-urgency win)) (when (window-hidden-p win) (unhide-window win) (update-configuration win)) (when (window-in-current-group-p win) (let ((group (window-group win))) (unless (null (group-raised-window group)) (setf (xlib:window-priority (window-parent win) (window-parent (group-raised-window group))) :above)) (setf (group-raised-window group) win))) (raise-top-windows)) ;; some handy wrappers (defun raise-top-windows () (mapc (lambda (w) (when (window-in-current-group-p w) (setf (xlib:window-priority (window-parent w)) :top-if))) (group-on-top-windows (current-group)))) (defun xwin-border-width (win) (xlib:drawable-border-width win)) (defun (setf xwin-border-width) (width win) (setf (xlib:drawable-border-width win) width)) (defun default-border-width-for-type (window) (or (and (window-maxsize-p window) *maxsize-border-width*) (ecase (window-type window) (:dock 0) (:normal *normal-border-width*) ((:transient :dialog) *transient-border-width*)))) (defun xwin-class (win) (multiple-value-bind (res class) (xlib:get-wm-class win) (declare (ignore res)) class)) (defun xwin-res-name (win) (multiple-value-bind (res class) (xlib:get-wm-class win) (declare (ignore class)) res)) (defun xwin-role (win) "Return WM_WINDOW_ROLE" (let ((name (xlib:get-property win :WM_WINDOW_ROLE))) (dformat 10 "role: ~a~%" name) (if name (utf8-to-string name) ""))) (defmacro define-window-slot (attr) "Create a new window attribute and corresponding get/set functions." (let ((win (gensym)) (val (gensym))) `(progn (defun ,(intern1 (format nil "WINDOW-~a" attr)) (,win) (gethash ,attr (window-plist ,win))) (defun (setf ,(intern1 (format nil "WINDOW-~a" attr))) (,val ,win) (setf (gethash ,attr (window-plist ,win)) ,val))))) (defgeneric sort-windows-by-number (window-list-spec) (:documentation "Return a copy of the provided window list sorted by number.")) (defmethod sort-windows-by-number ((window-list list)) "Return a copy of the screen's window list sorted by number." (sort1 window-list '< :key 'window-number)) (defmethod sort-windows-by-number ((group group)) "Return a copy of the screen's window list sorted by number." (sort1 (group-windows group) '< :key 'window-number)) (defgeneric sort-windows-by-class (window-list-spec) (:documentation "Return a copy of the provided window list sortes by class then by numer.")) (defmethod sort-windows-by-class ((window-list list)) "Return a copy of the provided window list sorted by class then by number." (sort1 window-list (lambda (w1 w2) (let ((class1 (window-class w1)) (class2 (window-class w2))) (if (string= class1 class2) (< (window-number w1) (window-number w2)) (string< class1 class2)))))) (defmethod sort-windows-by-class (group) "Return a copy of the provided window list sorted by class then by number." (sort-windows-by-class (group-windows group))) (defun sort-windows (group) "Return a copy of the screen's window list sorted by number." (sort-windows-by-number group)) (defun marked-windows (group) "Return the marked windows in the specified group." (loop for i in (sort-windows group) when (window-marked i) collect i)) (defun (setf xwin-state) (state xwin) "Set the state (iconic, normal, withdrawn) of a window." (xlib:change-property xwin :WM_STATE (list state) :WM_STATE 32)) (defun xwin-state (xwin) "Get the state (iconic, normal, withdrawn) of a window." (first (xlib:get-property xwin :WM_STATE))) (defun window-hidden-p (window) (eql (window-state window) +iconic-state+)) (defun add-wm-state (xwin state) (xlib:change-property xwin :_NET_WM_STATE (list (xlib:find-atom *display* state)) :atom 32 :mode :append)) (defun remove-wm-state (xwin state) (xlib:change-property xwin :_NET_WM_STATE (delete (xlib:find-atom *display* state) (xlib:get-property xwin :_NET_WM_STATE)) :atom 32)) (defun window-property (window prop) (xlib:get-property (window-xwin window) prop)) (defun find-wm-state (xwin state) (find (xlib:find-atom *display* state) (xlib:get-property xwin :_NET_WM_STATE) :test #'=)) (defun xwin-unhide (xwin parent) (xlib:map-subwindows parent) (xlib:map-window parent) (setf (xwin-state xwin) +normal-state+)) (defun unhide-window (window) (when (window-in-current-group-p window) (xwin-unhide (window-xwin window) (window-parent window))) (setf (window-state window) +normal-state+) ;; Mark window as unhiden (remove-wm-state (window-xwin window) :_NET_WM_STATE_HIDDEN)) ;; Despite the naming convention, this function takes a window struct, ;; not an xlib:window. (defun xwin-hide (window) (declare (type window window)) (unless (eq (xlib:window-map-state (window-xwin window)) :unmapped) (setf (xwin-state (window-xwin window)) +iconic-state+) (incf (window-unmap-ignores window)) (xlib:unmap-window (window-parent window)) (xlib:unmap-subwindows (window-parent window)))) (defun hide-window (window) (dformat 2 "hide window: ~s~%" window) (unless (eql (window-state window) +iconic-state+) (setf (window-state window) +iconic-state+) ;; Mark window as hidden (add-wm-state (window-xwin window) :_NET_WM_STATE_HIDDEN) (when (window-in-current-group-p window) (xwin-hide window) (when (eq window (current-window)) (group-lost-focus (window-group window)))))) (defun window-maxsize-p (win) "Returns T if WIN specifies maximum dimensions." (let ((hints (window-normal-hints win))) (and hints (or (xlib:wm-size-hints-max-width hints) (xlib:wm-size-hints-max-height hints) (xlib:wm-size-hints-min-aspect hints) (xlib:wm-size-hints-max-aspect hints))))) (defun xwin-type (win) "Return one of :desktop, :dock, :toolbar, :utility, :splash, :dialog, :transient, and :normal. Right now only :dock, :dialog, :normal, and :transient are actually returned; see +NETWM-WINDOW-TYPES+." (or (let ((net-wm-window-type (xlib:get-property win :_NET_WM_WINDOW_TYPE))) (when net-wm-window-type (dolist (type-atom net-wm-window-type) (let ((net-wm-window-type (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+))) (when net-wm-window-type (return (cdr net-wm-window-type))))))) (and (xlib:get-property win :WM_TRANSIENT_FOR) :transient) :normal)) (defun xwin-strut (screen win) "Return the area that the window wants to reserve along the edges of the screen. Values are left, right, top, bottom, left_start_y, left_end_y, right_start_y, right_end_y, top_start_x, top_end_x, bottom_start_x and bottom_end_x." (let ((net-wm-strut-partial (xlib:get-property win :_NET_WM_STRUT_PARTIAL))) (if (= (length net-wm-strut-partial) 12) (apply 'values net-wm-strut-partial) (let ((net-wm-strut (xlib:get-property win :_NET_WM_STRUT))) (if (= (length net-wm-strut) 4) (apply 'values (concatenate 'list net-wm-strut (list 0 (screen-height screen) 0 (screen-height screen) 0 (screen-width screen) 0 (screen-width screen)))) (values 0 0 0 0 0 0 0 0 0 0 0 0)))))) ;; Stolen from Eclipse (defun xwin-send-configuration-notify (xwin x y w h bw) "Send a synthetic configure notify event to the given window (ICCCM 4.1.5)" (xlib:send-event xwin :configure-notify nil :event-window xwin :window xwin :x x :y y :width w :height h :border-width bw :propagate-p nil)) (defun update-window-gravity () (dolist (s *screen-list*) (dolist (g (screen-groups s)) (mapc 'maximize-window (group-windows g))))) (defun set-normal-gravity (gravity) "Set the default gravity for normal windows. Possible values are @code{:center} @code{:top} @code{:left} @code{:right} @code{:bottom} @code{:top-left} @code{:top-right} @code{:bottom-left} and @code{:bottom-right}." (setf *normal-gravity* gravity) (update-window-gravity)) (defun set-maxsize-gravity (gravity) "Set the default gravity for maxsize windows." (setf *maxsize-gravity* gravity) (update-window-gravity)) (defun set-transient-gravity (gravity) "Set the default gravity for transient/pop-up windows." (setf *transient-gravity* gravity) (update-window-gravity)) (defun gravity-for-window (win) (or (window-gravity win) (and (window-maxsize-p win) *maxsize-gravity*) (ecase (window-type win) (:dock *normal-gravity*) (:normal *normal-gravity*) ((:transient :dialog) *transient-gravity*)))) (defun window-width-inc (window) "Find out what is the correct step to change window width" (or (when-let ((window-hints (window-normal-hints window))) (xlib:wm-size-hints-width-inc (window-normal-hints window))) 1)) (defun window-height-inc (window) "Find out what is the correct step to change window height" (or (when-let ((window-hints (window-normal-hints window))) (xlib:wm-size-hints-height-inc (window-normal-hints window))) 1)) (defun set-window-geometry (win &key x y width height border-width) (macrolet ((update (xfn wfn v) `(when ,v ;; (/= (,wfn win) ,v)) (setf (,xfn (window-xwin win)) ,v) ,(when wfn `(setf (,wfn win) ,v))))) (xlib:with-state ((window-xwin win)) (update xlib:drawable-x nil x) (update xlib:drawable-y nil y) (update xlib:drawable-width window-width width) (update xlib:drawable-height window-height height) (update xlib:drawable-border-width nil border-width) ))) (defun find-free-window-number (group) "Return a free window number for GROUP." (find-free-number (mapcar 'window-number (group-windows group)))) (defun reparent-window (screen window) ;; apparently we need to grab the server so the client doesn't get ;; the mapnotify event before the reparent event. that's what fvwm ;; says. (let* ((xwin (window-xwin window)) (master-window (xlib:create-window :parent (screen-root screen) :x (xlib:drawable-x (window-xwin window)) :y (xlib:drawable-y (window-xwin window)) :width (window-width window) :height (window-height window) :background (if (eq (window-type window) :normal) (screen-win-bg-color screen) :none) :border (screen-unfocus-color screen) :border-width (default-border-width-for-type window) :event-mask *window-parent-events* :depth (xlib:drawable-depth xwin) :visual (xlib:window-visual-info xwin) :colormap (xlib:window-colormap xwin)))) (unless (eq (xlib:window-map-state (window-xwin window)) :unmapped) (incf (window-unmap-ignores window))) (xlib:reparent-window (window-xwin window) master-window 0 0) (xwin-grab-buttons xwin) ;; ;; we need to update these values since they get set to 0,0 on reparent ;; (setf (window-x window) 0 ;; (window-y window) 0) (xlib:add-to-save-set (window-xwin window)) (setf (window-parent window) master-window))) (defun process-existing-windows (screen) "Windows present when stumpwm starts up must be absorbed by stumpwm." (let ((children (xlib:query-tree (screen-root screen))) (*processing-existing-windows* t) (stacking (xlib:get-property (screen-root screen) :_NET_CLIENT_LIST_STACKING :type :window))) (when stacking (dformat 3 "Using window stacking: ~{~X ~}~%" stacking) ;; sort by _NET_CLIENT_LIST_STACKING (setf children (stable-sort children #'< :key (lambda (xwin) (or (position (xlib:drawable-id xwin) stacking :test #'=) 0))))) (dolist (win children) (let ((map-state (xlib:window-map-state win)) (wm-state (xwin-state win))) ;; Don't process override-redirect windows. (unless (or (eq (xlib:window-override-redirect win) :on) (internal-window-p screen win)) (if (eq (xwin-type win) :dock) (progn (dformat 1 "Window ~S is dock-type. Placing in mode-line.~%" win) (place-mode-line-window screen win)) (if (or (eql map-state :viewable) (eql wm-state +iconic-state+)) (progn (dformat 1 "Processing ~S ~S~%" (xwin-name win) win) (xlib:with-server-grabbed (*display*) (process-mapped-window screen win))))))))) (dolist (w (screen-windows screen)) (setf (window-state w) +normal-state+) (xwin-hide w))) (defun xwin-grab-key (w key) (labels ((add-shift-modifier (key) ;; don't butcher the caller's structure (let ((key (copy-structure key))) (setf (key-shift key) t) key)) (key-modifiers-exist-p (key) (and (or (not (key-meta key)) (modifiers-meta *modifiers*)) (or (not (key-alt key)) (modifiers-alt *modifiers*)) (or (not (key-hyper key)) (modifiers-hyper *modifiers*)) (or (not (key-super key)) (modifiers-super *modifiers*))))) (loop for code in (multiple-value-list (xlib:keysym->keycodes *display* (key-keysym key))) ;; some keysyms aren't mapped to keycodes so just ignore them. when (and code (key-modifiers-exist-p key)) do ;; Some keysyms, such as upper case letters, need the ;; shift modifier to be set in order to grab properly. (let ((key (if (and (not (eql (key-keysym key) (xlib:keycode->keysym *display* code 0))) (eql (key-keysym key) (xlib:keycode->keysym *display* code 1))) (add-shift-modifier key) key))) (xlib:grab-key w code :modifiers (x11-mods key) :owner-p t :sync-pointer-p nil :sync-keyboard-p nil) ;; Ignore capslock and numlock by also grabbing the ;; keycombos with them on. (xlib:grab-key w code :modifiers (x11-mods key nil t) :owner-p t :sync-keyboard-p nil :sync-keyboard-p nil) (when (modifiers-numlock *modifiers*) (xlib:grab-key w code :modifiers (x11-mods key t nil) :owner-p t :sync-pointer-p nil :sync-keyboard-p nil) (xlib:grab-key w code :modifiers (x11-mods key t t) :owner-p t :sync-keyboard-p nil :sync-keyboard-p nil)))))) (defun xwin-grab-keys (win group) (dolist (map (dereference-kmaps (top-maps group))) (dolist (i (kmap-bindings map)) (xwin-grab-key win (binding-key i))))) (defun grab-keys-on-window (win) (xwin-grab-keys (window-xwin win) (window-group win))) (defun xwin-ungrab-keys (win) (xlib:ungrab-key win :any :modifiers :any)) (defun ungrab-keys-on-window (win) (xwin-ungrab-keys (window-xwin win))) (defun xwin-grab-buttons (win) ;; FIXME: Why doesn't grabbing button :any work? We have to ;; grab them one by one instead. (xwin-ungrab-buttons win) (loop for i from 1 to 32 do (xlib:grab-button win i '(:button-press) :modifiers :any :owner-p nil :sync-pointer-p t :sync-keyboard-p nil))) (defun xwin-ungrab-buttons (win) (xlib:ungrab-button win :any :modifiers :any)) (defun sync-keys () "Any time *top-map* is modified this must be called." (loop for i in *screen-list* do (xwin-ungrab-keys (screen-focus-window i)) do (loop for j in (screen-mapped-windows i) do (xwin-ungrab-keys j)) do (xlib:display-finish-output *display*) do (loop for j in (screen-mapped-windows i) do (xwin-grab-keys j (window-group (find-window j)))) do (xwin-grab-keys (screen-focus-window i) (screen-current-group i))) (when (current-window) (remap-keys-grab-keys (current-window))) (xlib:display-finish-output *display*)) (defun netwm-remove-window (window) (xlib:delete-property (window-xwin window) :_NET_WM_DESKTOP)) (defun process-mapped-window (screen xwin) "Add the window to the screen's mapped window list and process it as needed." (let ((window (xwin-to-window xwin))) (screen-add-mapped-window screen xwin) ;; windows always have border width 0. Their parents provide the ;; border. (set-window-geometry window :border-width 0) (setf (xlib:window-event-mask (window-xwin window)) *window-events*) (register-window window) (reparent-window screen window) (netwm-set-allowed-actions window) (let ((placement-data (place-window screen window))) (apply 'group-add-window (window-group window) window placement-data) ;; If the placement rule matched then either the window's group ;; is the current group or the rule's :lock attribute was ;; on. Either way the window's group should become the current ;; one (if it isn't already) if :raise is T. (when placement-data (if (getf placement-data :raise) (switch-to-group (window-group window)) (unless *suppress-window-placement-indicator* (message "Placing window ~a in group ~a." (window-name window) (group-name (window-group window))))) (apply 'run-hook-with-args *place-window-hook* window (window-group window) placement-data))) ;; must call this after the group slot is set for the window. (grab-keys-on-window window) ;; quite often the modeline displays the window list, so update it (update-all-mode-lines) ;; Run the new window hook on it. (run-hook-with-args *new-window-hook* window) window)) (defun find-withdrawn-window (xwin) "Return the window and screen for a withdrawn window." (declare (type xlib:window xwin)) (dolist (i *screen-list*) (let ((w (find xwin (screen-withdrawn-windows i) :key 'window-xwin :test 'xlib:window-equal))) (when w (return-from find-withdrawn-window (values w i)))))) (defun restore-window (window) "Restore a withdrawn window" (declare (type window window)) ;; put it in a valid group (let* ((screen (window-screen window)) (group (get-window-placement screen window))) (unless (find (window-group window) (screen-groups screen)) (setf (window-group window) (or group (screen-current-group screen)))) ;; FIXME: somehow it feels like this could be merged with group-add-window (setf (window-title window) (xwin-name (window-xwin window)) (window-class window) (xwin-class (window-xwin window)) (window-res window) (xwin-res-name (window-xwin window)) (window-role window) (xwin-role (window-xwin window)) (window-type window) (xwin-type (window-xwin window)) (window-normal-hints window) (get-normalized-normal-hints (window-xwin window)) (window-number window) (find-free-window-number (window-group window)) (window-state window) +iconic-state+ (xwin-state (window-xwin window)) +iconic-state+ (screen-withdrawn-windows screen) (delete window (screen-withdrawn-windows screen)) ;; put the window at the end of the list (group-windows (window-group window)) (append (group-windows (window-group window)) (list window))) (screen-add-mapped-window screen (window-xwin window)) (register-window window) (group-add-window (window-group window) window) (netwm-set-group window) ;; It is effectively a new window in terms of the window list. (run-hook-with-args *new-window-hook* window) ;; FIXME: only called frame-raise-window instead of this function ;; which will likely call focus-all. (group-raise-request (window-group window) window :map))) (defun withdraw-window (window) "Withdrawing a window means just putting it in a list til we get a destroy event." (declare (type window window)) ;; This function cannot request info about WINDOW from the xserver as it may not exist anymore. (let ((group (window-group window)) (screen (window-screen window))) (dformat 1 "withdraw window ~a~%" screen) ;; Save it for later since it is only withdrawn, not destroyed. (push window (screen-withdrawn-windows screen)) (setf (window-state window) +withdrawn-state+ (xwin-state (window-xwin window)) +withdrawn-state+) (xlib:unmap-window (window-parent window)) ;; Clean up the window's entry in the screen and group (setf (group-windows group) (delete window (group-windows group))) (screen-remove-mapped-window screen (window-xwin window)) (when (window-in-current-group-p window) ;; since the window doesn't exist, it doesn't have focus. (setf (screen-focus screen) nil)) (netwm-remove-window window) (group-delete-window group window) ;; quite often the modeline displays the window list, so update it (update-all-mode-lines) ;; Run the destroy hook on the window (run-hook-with-args *destroy-window-hook* window))) (defun destroy-window (window) (declare (type window window)) "The window has been destroyed. clean up our data structures." ;; This function cannot request info about WINDOW from the xserver (let ((screen (window-screen window))) (unless (eql (window-state window) +withdrawn-state+) (withdraw-window window)) ;; now that the window is withdrawn, clean up the data structures (setf (screen-withdrawn-windows screen) (delete window (screen-withdrawn-windows screen))) (setf (screen-urgent-windows screen) (delete window (screen-urgent-windows screen))) (dformat 1 "destroy window ~a~%" screen) (dformat 3 "destroying parent window~%") (dformat 7 "parent window is ~a~%" (window-parent window)) (xlib:destroy-window (window-parent window)))) (defun move-window-to-head (group window) "Move window to the head of the group's window list." (declare (type group group)) (declare (type window window)) ;(assert (member window (screen-mapped-windows screen))) (move-to-head (group-windows group) window) (netwm-update-client-list-stacking (group-screen group))) (defun no-focus (group last-win) "don't focus any window but still read keyboard events." (dformat 3 "NO-FOCUS called~%") (let* ((screen (group-screen group))) (setf (group-current-window group) nil) ;; lame workaround to fix bug where non-focused window doesn't ;; listen unless an event is caught by the listener. In this case ;; a fake click is sent. (xlib-fake-click (screen-root screen) (screen-focus-window screen) 1) (when (eq group (screen-current-group screen)) (xlib:set-input-focus *display* (screen-focus-window screen) :POINTER-ROOT) (setf (screen-focus screen) nil) (move-screen-to-head screen)) (when last-win (update-decoration last-win)))) (defmethod focus-window (window &optional (raise t)) "Make the window visible and give it keyboard focus. If raise is t, raise the window." (dformat 3 "focus-window: ~s~%" window) (let* ((group (window-group window)) (screen (group-screen group)) (cw (screen-focus screen)) (xwin (window-xwin window))) (when raise (raise-window window)) (cond ((eq window cw) ;; If window to focus is already focused then our work is done. ) ;; If a WM_TAKE_FOCUS client message is not sent to the window, ;; widgets in Java applications tend to lose focus when the ;; window gets focused. This is hopefully the right way to ;; handle this. ((member :WM_TAKE_FOCUS (xlib:wm-protocols xwin) :test #'eq) (let ((hints (xlib:wm-hints xwin))) (when (or (null hints) (eq (xlib:wm-hints-input hints) :on)) (screen-set-focus screen window))) (setf (group-current-window group) window) (update-decoration window) (when cw (update-decoration cw)) (move-window-to-head group window) (send-client-message window :WM_PROTOCOLS (xlib:intern-atom *display* :WM_TAKE_FOCUS) ;; From reading the ICCCM spec, it's not ;; entirely clear that this is the correct ;; value for time that we send here. (or *current-event-time* 0)) (update-mode-lines (window-screen window)) (run-hook-with-args *focus-window-hook* window cw)) (t (screen-set-focus screen window) (setf (group-current-window group) window) (update-decoration window) (when cw (update-decoration cw)) ;; Move the window to the head of the mapped-windows list (move-window-to-head group window) (update-mode-lines (window-screen window)) (run-hook-with-args *focus-window-hook* window cw))))) (defun xwin-kill (window) "Kill the client associated with window." (dformat 3 "Kill client~%") (xlib:kill-client *display* (xlib:window-id window))) (defun default-window-menu-filter (item-string item-object user-input) "The default filter predicate for window menus." (or (menu-item-matches-regexp item-string item-object user-input) (match-all-regexps user-input (window-title item-object) :case-insensitive t))) (defvar *window-menu-filter* #'default-window-menu-filter "The filter predicate used to filter menu items in window menus created by SELECT-WINDOW-FROM-MENU. The interface for filter predicates is described in the docstring for SELECT-FROM-ITEM.") (defun select-window-from-menu (windows fmt &optional prompt (filter-pred *window-menu-filter*)) "Allow the user to select a window from the list passed in @var{windows}. The @var{fmt} argument specifies the window formatting used. Returns the window selected." (second (select-from-menu (current-screen) (mapcar (lambda (w) (list (format-expand *window-formatters* fmt w) w)) windows) prompt (or (position (current-window) windows) 0) ; Initial selection nil ; Extra keymap filter-pred))) ;;; Window commands (defcommand delete-window (&optional (window (current-window))) () "Delete a window. By default delete the current window. This is a request sent to the window. The window's client may decide not to grant the request or may not be able to if it is unresponsive." (when (find window *always-show-windows*) (disable-always-show-window window (current-screen))) (when window (send-client-message window :WM_PROTOCOLS (xlib:intern-atom *display* :WM_DELETE_WINDOW)))) (defcommand-alias delete delete-window) (defcommand kill-window (&optional (window (current-window))) () "Tell X to disconnect the client that owns the specified window. Default to the current window. if @command{delete-window} didn't work, try this." (when window (xwin-kill (window-xwin window)))) (defun kill-windows (windows) "Kill all windows @var{windows}" (dolist (window windows) (xwin-kill (window-xwin window)))) (defun kill-windows-in-group (group) "Kill all windows in group @var{group}" (kill-windows (group-windows group))) (defcommand kill-windows-current-group () () "Kill all windows in the current group." (kill-windows-in-group (current-group))) (defcommand kill-windows-other () () "Kill all windows in current group except the current-window" (let ((target-windows (remove (current-window) (group-windows (current-group))))) (kill-windows target-windows))) (defcommand-alias kill kill-window) (defcommand title (title) ((:rest "Set window's title to: ")) "Override the current window's title." (if (current-window) (setf (window-user-title (current-window)) title) (message "No Focused Window."))) (defcommand select-window (query) ((:window-name "Select: ")) "Switch to the first window that starts with @var{query}." (let (match) (labels ((match (win) (let* ((wname (window-name win)) (end (min (length wname) (length query)))) (string-equal wname query :end1 end :end2 end)))) (unless (null query) (setf match (find-if #'match (group-windows (current-group))))) (when match (group-focus-window (current-group) match))))) (defcommand-alias select select-window) (defcommand select-window-by-name (name) ((:window-name "Select: ")) "Switch to the first window whose name is exactly @var{name}." (let ((win (find name (group-windows (current-group)) :test #'string= :key #'window-name))) (when win (group-focus-window (current-group) win)))) (defcommand select-window-by-number (num &optional (group (current-group))) ((:window-number "Select: ")) "Find the window with the given number and focus it in its frame." (labels ((match (win) (= (window-number win) num))) (let ((win (find-if #'match (group-windows group)))) (when win (group-focus-window group win))))) (defgeneric group-windows-for-cycling (group &key sorting) (:documentation "Return a list of windows in the group that can be selected with Next, Prev and Other command.")) (defmethod group-windows-for-cycling (group &key (sorting nil)) (if sorting (sort-windows group) (group-windows group))) (defgeneric focus-other-window (group) (:documentation "Focus the window in the group last focused")) (defmethod focus-other-window (group) (let* ((wins (group-windows-for-cycling group)) ;; the frame could be empty (win (if (group-current-window group) (second wins) (first wins)))) (if win (group-focus-window group win) (echo-string (group-screen group) "No other window.")))) (defgeneric focus-next-window (group) (:documentation "Focus the next window in the windows list of the group")) (defgeneric focus-prev-window (group) (:documentation "Focus the previous window in the windows list of the group")) (defmethod focus-next-window (group) (let* ((w (group-current-window group)) (wins (group-windows-for-cycling group :sorting t)) (nw (or (cadr (member w wins)) (first wins)))) (if (and nw (not (eq w nw))) (group-focus-window group nw) (message "No other window.")))) (defmethod focus-prev-window (group) (let* ((w (group-current-window group)) (wins (reverse (group-windows-for-cycling group :sorting t))) (nw (or (cadr (member w wins)) (first wins)))) (if (and nw (not (eq w nw))) (group-focus-window group nw) (message "No other window.")))) (defcommand other-window (&optional (group (current-group))) () "Switch to the window last focused." (focus-other-window group)) (defcommand-alias other other-window) (defcommand next () () "Go to the next window in the window list." (let ((group (current-group))) (if (group-current-window group) (focus-next-window group) (other-window group)))) (defcommand prev () () "Go to the previous window in the window list." (let ((group (current-group))) (if (group-current-window group) (focus-prev-window group) (other-window group)))) (defcommand renumber (nt &optional (group (current-group))) ((:number "Number: ")) "Change the current window's number to the specified number. If another window is using the number, then the windows swap numbers. Defaults to current group." (let ((nf (window-number (group-current-window group))) (win (find-if #'(lambda (win) (= (window-number win) nt)) (group-windows group)))) ;; Is it already taken? (if win (progn ;; swap the window numbers (setf (window-number win) nf) (setf (window-number (group-current-window group)) nt)) ;; Just give the window the number (setf (window-number (group-current-window group)) nt)))) (defcommand-alias number renumber) (defcommand repack-window-numbers (&optional preserved) () "Ensure that used window numbers do not have gaps; ignore PRESERVED window numbers." (let* ((group (current-group)) (windows (sort-windows group))) (loop for w in windows do (unless (find (window-number w) preserved) (setf (window-number w) (find-free-number (remove (window-number w) (mapcar 'window-number windows)) 0)))))) ;; It would make more sense that the window-list argument was before the fmt one ;; but window-list was added latter and I didn't want to break other's code. (defcommand windowlist (&optional (fmt *window-format*) window-list) (:rest) "Allow the user to select a window from the list of windows and focus the selected window. For information of menu bindings see @ref{Menus}. The optional argument @var{fmt} can be specified to override the default window formatting. The optional argument @var{window-list} can be provided to show a custom window list (see @command{windowlist-by-class}). The default window list is the list of all window in the current group. Also note that the default window list is sorted by number and if the @var{windows-list} is provided, it is shown unsorted (as-is)." ;; Shadowing the window-list argument. (if-let ((window-list (or window-list (sort-windows-by-number (group-windows (current-group)))))) (if-let ((window (select-window-from-menu window-list fmt))) (group-focus-window (current-group) window) (throw 'error :abort)) (message "No Managed Windows"))) (defcommand windowlist-by-class (&optional (fmt *window-format-by-class*)) (:rest) "Allow the user to select a window from the list of windows (sorted by class) and focus the selected window. For information of menu bindings see @ref{Menus}. The optional argument @var{fmt} can be specified to override the default window formatting. This is a simple wrapper around the command @command{windowlist}." (windowlist fmt (sort-windows-by-class (group-windows (current-group))))) (defcommand window-send-string (string &optional (window (current-window))) ((:rest "Insert: ")) "Send the string of characters to the current window as if they'd been typed." (when window (map nil (lambda (ch) ;; exploit the fact that keysyms for ascii characters ;; are the same as their ascii value. (let ((sym (cond ((<= 32 (char-code ch) 127) (char-code ch)) ((char= ch #\Tab) (stumpwm-name->keysym "TAB")) ((char= ch #\Newline) (stumpwm-name->keysym "RET")) (t (first (xlib:character->keysyms ch *display*)))))) (when sym (send-fake-key window (make-key :keysym sym))))) string))) (defcommand-alias insert window-send-string) (defcommand mark () () "Toggle the current window's mark." (let ((win (current-window))) (when win (setf (window-marked win) (not (window-marked win))) (message (if (window-marked win) "Marked!" "Unmarked!"))))) (defcommand clear-window-marks (&optional (group (current-group)) (windows (group-windows group))) () "Clear all marks in the current group." (dolist (w windows) (setf (window-marked w) nil))) (defcommand-alias clear-marks clear-window-marks) (defcommand echo-windows (&optional (fmt *window-format*) (group (current-group)) (windows (group-windows group))) (:rest) "Display a list of managed windows. The optional argument @var{fmt} can be used to override the default window formatting." (let* ((wins (sort1 windows '< :key 'window-number)) (highlight (position (group-current-window group) wins)) (names (mapcar (lambda (w) (format-expand *window-formatters* fmt w)) wins))) (if (null wins) (echo-string (group-screen group) "No Managed Windows") (echo-string-list (group-screen group) names highlight)))) (defcommand-alias windows echo-windows) (defcommand info (&optional (fmt *window-info-format*)) (:rest) "Display information about the current window." (if (current-window) (message "~a" (format-expand *window-formatters* fmt (current-window))) (message "No Current Window."))) (defcommand refresh () () "Refresh current window without changing its size." (when-let* ((window (current-window)) (w (window-width window)) (h (window-height window))) (set-window-geometry window :width (- w (window-width-inc window)) :height (- h (window-height-inc window))) ;; make sure the first one goes through before sending the second (xlib:display-finish-output *display*) (set-window-geometry window :width w :height h))) (defcommand toggle-always-on-top () () "Toggle whether the current window always appears over other windows. The order windows are added to this list determines priority." (let ((w (current-window)) (windows (group-on-top-windows (current-group)))) (when w (if (find w windows) (setf (group-on-top-windows (current-group)) (remove w windows)) (push (current-window) (group-on-top-windows (current-group))))))) (defcommand fullscreen () () "Toggle the fullscreen mode of the current widnow. Use this for clients with broken (non-NETWM) fullscreen implementations, such as any program using SDL." (update-fullscreen (current-window) 2)) stumpwm-22.11/wrappers.lisp000066400000000000000000000157631433701203600160020ustar00rootroot00000000000000;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, see ;; . ;; Commentary: ;; ;; portability wrappers. Any code that must run different code for ;; different lisps should be wrapped up in a function and put here. ;; ;; Code: (in-package #:stumpwm) (export '(getenv)) (define-condition not-implemented (stumpwm-error) () (:documentation "A function has been called that is not implemented yet.")) (defun screen-display-string (screen &optional (assign t)) (format nil (if assign "DISPLAY=~a:~d.~d" "~a:~d.~d") (screen-host screen) (xlib:display-display *display*) (screen-id screen))) (defun run-prog (prog &rest opts &key args output (wait t) &allow-other-keys) "Common interface to shell. Does not return anything useful." (remf opts :args) (remf opts :output) (remf opts :wait) (let ((env (sb-ext:posix-environ))) (when (current-screen) (setf env (cons (screen-display-string (current-screen) t) (remove-if (lambda (str) (string= "DISPLAY=" str :end2 (min 8 (length str)))) env)))) (apply #'sb-ext:run-program prog args :output (if output output t) :error t :wait wait :environment env opts))) (defun run-prog-collect-output (prog &rest args) "run a command and read its output." (with-output-to-string (s) (run-prog prog :args args :output s :wait t))) (defun getenv (var) "Return the value of the environment variable." (sb-posix:getenv (string var))) (defun (setf getenv) (val var) "Set the value of the environment variable, @var{var} to @var{val}." (sb-posix:putenv (format nil "~A=~A" (string var) (string val)))) (defun pathname-is-executable-p (pathname) "Return T if the pathname describes an executable file." (let ((filename (coerce (sb-ext:native-namestring pathname) 'string))) (and (or (pathname-name pathname) (pathname-type pathname)) (sb-unix:unix-access filename sb-unix:x_ok)))) (defun probe-path (path) "Return the truename of a supplied path, or nil if it does not exist." (handler-case (truename (let ((pathname (pathname path))) ;; If there is neither a type nor a name, we have a directory ;; pathname already. Otherwise make a valid one. (if (and (not (pathname-name pathname)) (not (pathname-type pathname))) pathname (make-pathname :directory (append (or (pathname-directory pathname) (list :relative)) (list (file-namestring pathname))) :name nil :type nil :defaults pathname)))) (file-error () nil))) (defun print-backtrace (&optional (frames 100)) "print a backtrace of FRAMES number of frames to standard-output" (sb-debug:print-backtrace :count frames :stream *standard-output*)) (defun utf8-to-string (octets) "Convert the list of octets to a string." (let ((octets (coerce octets '(vector (unsigned-byte 8))))) (handler-bind ((sb-impl::octet-decoding-error #'(lambda (c) (declare (ignore c)) (invoke-restart 'use-value (string #\replacement_character))))) (sb-ext:octets-to-string octets :external-format :utf-8)))) (defun directory-no-deref (pathspec) "Call directory without dereferencing symlinks in the results" (directory pathspec :resolve-symlinks nil)) ;;; On GNU/Linux some contribs use sysfs to figure out useful info for ;;; the user. SBCL upto at least 1.0.16 (but probably much later) has ;;; a problem handling files in sysfs caused by SBCL's slightly ;;; unusual handling of files in general and Linux' sysfs violating ;;; POSIX. When this situation is resolved, this function may be removed. #+ linux (export '(read-line-from-sysfs)) #+ linux (defun read-line-from-sysfs (stream &optional (blocksize 80)) "READ-LINE, but with a workaround for a known SBCL/Linux bug regarding files in sysfs. Data is read in chunks of BLOCKSIZE bytes." (let ((buf (make-array blocksize :element-type '(unsigned-byte 8) :initial-element 0)) (fd (sb-sys:fd-stream-fd stream)) (string-filled 0) (string (make-string blocksize)) bytes-read pos (stringlen blocksize)) (loop ;; Read in the raw bytes (setf bytes-read (sb-unix:unix-read fd (sb-sys:vector-sap buf) blocksize)) ;; Why does SBCL return NIL when an error occurs? (when (or (null bytes-read) (< bytes-read 0)) (error "UNIX-READ failed.")) ;; This is # bytes both read and in the correct line. (setf pos (or (position (char-code #\Newline) buf) bytes-read)) ;; Resize the string if necessary. (when (> (+ pos string-filled) stringlen) (setf stringlen (max (+ pos string-filled) (* 2 stringlen))) (let ((new (make-string stringlen))) (replace new string) (setq string new))) ;; Translate read bytes to string (setf (subseq string string-filled) (sb-ext:octets-to-string (subseq buf 0 pos))) (incf string-filled pos) (if (< pos blocksize) (return (subseq string 0 string-filled)))))) (defun execv (program &rest arguments) (declare (ignorable program arguments)) (sb-alien:with-alien ((prg sb-alien:c-string program) (argv (array sb-alien:c-string 256))) (loop for i in arguments for j below 255 do (setf (sb-alien:deref argv j) i)) (setf (sb-alien:deref argv (length arguments)) nil) (sb-alien:alien-funcall (sb-alien:extern-alien "execv" (function sb-alien:int sb-alien:c-string (* sb-alien:c-string))) prg (sb-alien:cast argv (* sb-alien:c-string))))) (defun open-pipe (&key (element-type '(unsigned-byte 8))) "Create a pipe and return two streams. The first value is the input stream, and the second value is the output stream." (multiple-value-bind (in-fd out-fd) (sb-posix:pipe) (let ((in-stream (sb-sys:make-fd-stream in-fd :input t :element-type element-type)) (out-stream (sb-sys:make-fd-stream out-fd :output t :element-type element-type))) (values in-stream out-stream)))) ;;; EOF stumpwm-22.11/wse.lisp000066400000000000000000000117671433701203600147350ustar00rootroot00000000000000;; Copyright 2011 Michael Raskin ;; ;; Maintainer: Michael Raskin ;; ;; This file is part of stumpwm. ;; ;; stumpwm is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; stumpwm is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Window Selection Expressions (in-package :stumpwm) (export '(move-windows-to-group act-on-matching-windows)) (defun move-windows-to-group (windows &optional (arggroup nil)) "Move all windows from the list to the group" (let* ((group (if (stringp arggroup) (or (find-group (current-screen) arggroup) (add-group (current-screen) arggroup)) (or arggroup (current-group))))) (mapcar (lambda (w) (move-window-to-group w group)) windows))) (defgeneric list-windows (range) (:documentation "List all the windows in a set.")) (defmethod list-windows ((range t)) (error "Unknown kind of window set")) (defmethod list-windows ((range (eql :screen))) (list-windows (current-screen))) (defmethod list-windows ((range (eql :group))) (list-windows (current-group))) (defmethod list-windows ((range (eql :frame))) (list-windows (tile-group-current-frame (current-group)))) (defmethod list-windows ((range screen)) (screen-windows range)) (defmethod list-windows ((range group)) (group-windows range)) (defmethod list-windows ((range frame)) (frame-windows (current-group) range)) (defmethod list-windows ((range list)) range) (defmacro act-on-matching-windows ((var &optional (range '(current-screen))) condition &rest code) "Run code on all windows matching condition; var is the shared lambda variable. Range can be any screen/group/frame or :screen/:group/:frame for the current instance. Condition is just the code to evaluate." `(let ((range ,range)) (loop for ,var in (cond ((typep range 'screen) (screen-windows range)) ((typep range 'group) (group-windows range)) ((typep range 'frame) (frame-windows (current-group) range)) ((typep range 'list) range) ((eq range :screen) (screen-windows (current-screen))) ((eq range :group) (group-windows (current-group))) ((eq range :frame) (frame-windows (current-group) (tile-group-current-frame (current-group)))) (t (error "Unknown kind of window set"))) when ,condition collect (progn ,@code)))) (defun pull-w (w &optional g) "Pull the window w: to the current group or to the specified group g." (move-windows-to-group (list w) (or g (current-group)))) (defun titled-p (w title) "Check whether window title of the window w is equal to the string title." (equal (window-title w) title)) (defun title-re-p (w tre) "Check whether the window title of the window w matches the regular expression tre." (cl-ppcre:scan tre (window-title w))) (defun classed-p (w class) "Check whether the window class of the window w is equal to the string class." (equal (window-class w) class)) (defun class-re-p (w cre) "Check whether the window class of the window w matches the regular expression cre." (cl-ppcre:scan cre (window-class w))) (defun typed-p (w type) "Check whether the window type of the window w is equal to the string type." (equal (window-type w) type)) (defun type-re-p (w tre) "Check whether the window type of the window w matches the regular expression tre." (cl-ppcre:scan tre (window-type w))) (defun roled-p (w role) "Check whether the window role of the window w is equal to the string role." (equal (window-role w) role)) (defun role-re-p (w rre) "Check whether the window role of the window w matches the regular expression rre." (cl-ppcre:scan rre (window-role w))) (defun resed-p (w res) "Check whether the window resource of the window w is equal to the string res." (equal (window-res w) res)) (defun res-re-p (w rre) "Check whether the window resource of the window w matches the regular expression rre." (cl-ppcre:scan rre (window-res w))) (defun grouped-p (w &optional name) "Check whether the window w belongs to the group name or the current group if name is not specified." (if name (equal name (group-name (window-group w))) (equal (window-group w) (current-group)))) (defun in-frame-p (w &optional f) "Check whether the window w belongs to the frame f or to the current frame if the frame is not specified." (eq (window-frame w) (or f (tile-group-current-frame (current-group (current-screen))))))