pax_global_header00006660000000000000000000000064116233770510014517gustar00rootroot0000000000000052 comment=ca08e0842f4d2d69d8523862d5b9c68d18abc366 stumpwm-20110819.gitca08e08/000077500000000000000000000000001162337705100152555ustar00rootroot00000000000000stumpwm-20110819.gitca08e08/.dir-locals.el000066400000000000000000000000451162337705100177050ustar00rootroot00000000000000((nil . ((indent-tabs-mode . nil)))) stumpwm-20110819.gitca08e08/.gitattributes000066400000000000000000000000211162337705100201410ustar00rootroot00000000000000*.lisp diff=lisp stumpwm-20110819.gitca08e08/.gitignore000066400000000000000000000003241162337705100172440ustar00rootroot00000000000000*.fas *.lib *.fasl *.a *.o *.*fsl *~ configure config.log config.status autom4te.cache Makefile stumpwm stumpwm.info TAGS make-image.lisp version.lisp stumpwm-*.tgz stumpwm-*.tgz.sig .dotest patches stumpwm.texi stumpwm-20110819.gitca08e08/AUTHORS000066400000000000000000000046011162337705100163260ustar00rootroot00000000000000The Stump Window Manager Authors -------------------------------- Shawn Betts sabetts at gmail com Ryan M. Golbeck rmgolbeck at uwaterloo ca Manuel Giraud manuel.giraud at cetp ipsl 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 stumpwm-20110819.gitca08e08/COPYING000066400000000000000000000431101162337705100163070ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 Library 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 Library General Public License instead of this License. stumpwm-20110819.gitca08e08/HACKING000066400000000000000000000000401162337705100162360ustar00rootroot00000000000000See the StumpWM Texinfo manual. stumpwm-20110819.gitca08e08/Makefile.in000066400000000000000000000066151162337705100173320ustar00rootroot00000000000000LISP=@LISP_PROGRAM@ clisp_BUILDOPTS=-K full -on-error exit ./make-image.lisp sbcl_BUILDOPTS=--load ./make-image.lisp ccl_BUILDOPTS=--load ./make-image.lisp ecl_BUILDOPTS=-norc -shell ./make-image.lisp clisp_INFOOPTS=-K full -on-error exit -x "(require 'asdf '(\"asdf.lisp\")) (load \"stumpwm.asd\") (load \"@PPCRE_PATH@/cl-ppcre.asd\") (asdf:operate 'asdf:load-op :stumpwm) (load (compile-file \"manual.lisp\")) (stumpwm::generate-manual) (ext:exit)" sbcl_INFOOPTS=--eval "(progn (require 'asdf) (require 'stumpwm) (load \"manual.lisp\"))" --eval "(progn (stumpwm::generate-manual) (sb-ext:quit))" ccl_INFOOPTS=--eval "(progn (require 'asdf) (require 'stumpwm))" --load manual.lisp --eval "(progn (stumpwm::generate-manual) (quit))" ecl_INFOOPTS=-eval "(progn (require 'asdf) (load \"@PPCRE_PATH@/cl-ppcre.asd\") (require 'stumpwm) (load \"manual.lisp\"))" -eval "(progn (stumpwm::generate-manual) (ext:quit))" datarootdir = @datarootdir@ prefix=@prefix@ exec_prefix= @exec_prefix@ bindir=@bindir@ infodir=@infodir@ # You shouldn't have to edit past this # This is copied from the .asd file. It'd be nice to have the list in # one place, but oh well. FILES=stumpwm.asd package.lisp primitives.lisp wrappers.lisp \ pathnames.lisp keysyms.lisp keytrans.lisp kmap.lisp input.lisp \ core.lisp command.lisp menu.lisp screen.lisp head.lisp group.lisp \ window.lisp floating-group.lisp tile-window.lisp window-placement.lisp \ message-window.lisp selection.lisp user.lisp iresize.lisp \ bindings.lisp events.lisp help.lisp fdump.lisp mode-line.lisp \ time.lisp color.lisp module.lisp stumpwm.lisp version.lisp all: stumpwm stumpwm.info stumpwm.info: stumpwm.texi makeinfo stumpwm.texi # FIXME: This rule is too hardcoded stumpwm.texi: stumpwm.texi.in $(LISP) $(@LISP@_INFOOPTS) stumpwm: $(FILES) $(LISP) $(@LISP@_BUILDOPTS) release: git tag -a -m "version @PACKAGE_VERSION@" @PACKAGE_VERSION@ git archive --format=tar --prefix=stumpwm-@PACKAGE_VERSION@/ HEAD > stumpwm-@PACKAGE_VERSION@.tar tar xf stumpwm-@PACKAGE_VERSION@.tar cd stumpwm-@PACKAGE_VERSION@ && tar zxf @PPCRE_PATH@/../cl-ppcre.tar.gz && mv cl-ppcre-* cl-ppcre git log > stumpwm-@PACKAGE_VERSION@/ChangeLog cp configure stumpwm-@PACKAGE_VERSION@/ tar zcf stumpwm-@PACKAGE_VERSION@.tgz stumpwm-@PACKAGE_VERSION@ rm -fr stumpwm-@PACKAGE_VERSION@/ stumpwm-@PACKAGE_VERSION@.tar upload-release: gpg -b stumpwm-@PACKAGE_VERSION@.tgz scp stumpwm-@PACKAGE_VERSION@.tgz stumpwm-@PACKAGE_VERSION@.tgz.sig sabetts@dl.sv.nongnu.org:/releases/stumpwm/ ( echo rm stumpwm-latest.tgz.sig && echo rm stumpwm-latest.tgz && echo ln stumpwm-@PACKAGE_VERSION@.tgz stumpwm-latest.tgz && echo ln stumpwm-@PACKAGE_VERSION@.tgz.sig stumpwm-latest.tgz.sig ) | sftp -b - sabetts@dl.sv.nongnu.org:/releases/stumpwm/ 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)" install -m 644 stumpwm.info "$(destdir)$(infodir)" install-info --info-dir="$(destdir)$(infodir)" "$(destdir)$(infodir)/stumpwm.info" 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-20110819.gitca08e08/NEWS000066400000000000000000000127251162337705100157630ustar00rootroot00000000000000-*- 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 >>>>>>> master:NEWS ** 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-20110819.gitca08e08/README000066400000000000000000000070211162337705100161350ustar00rootroot00000000000000The Stump Window Manager ------------------------ 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. Build & Start Stumpwm --------------------- Prerequisites ============= * a common lisp distribution. CCL, CLISP, and SBCL all work. * clx * cl-ppcre If you intend to use SBCL or CCL you need to install portable-clx. If you're using clisp, make sure you use at least version 2.42 and that clisp is compiled with new-clx. As of clisp 2.42, new-clx works fine with stumpwm. Any version before that is too buggy to run stumpwm. You can use asdf-install to install lisp libraries: $ sbcl * (require 'asdf) * (require 'asdf-install) * (asdf-install:install 'clx) * (asdf-install:install 'cl-ppcre) If using clisp, you'll need to install asdf first to use asdf-install. $ mkdir -p ~/.cl/asdf && cd ~/.cl $ wget http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp -O ~/.cl/asdf/asdf.lisp $ echo "(load #p\"/home/USER/.cl/asdf/asdf\")" >> ~/.clisprc.lisp $ mkdir -p ~/.cl/systems $ echo "(push #p\"/home/USER/.cl/systems\" asdf:*central-registry*)" >> ~/.clisprc.lisp $ wget http://common-lisp.net/project/asdf-install/asdf-install_latest.tar.gz $ tar xf asdf-install_latest.tar.gz $ ln -s ~/.cl/asdf-install/asdf-install/asdf-install.asd ~/.cl/systems/ $ clisp * (asdf:operate 'asdf:compile-op 'asdf-install) * (asdf:operate 'asdf:load-op 'asdf-install) * (asdf-install:install :cl-ppcre) CCL has asdf built in, but you will need to get asdf-install like with clisp. Your operating system distribution may also have these libraries available. Building ======== Building stumpwm from CVS requires that you build the configure script: $ autoconf If there's already a configure script then just run it. $ ./configure By default stumpwm elects sbcl. If you have both installed, you can explicitly select clisp like so: $ ./configure --with-lisp=clisp If your lisps are in strange places you may need to tell the script where to find them: $ configure --with-sbcl=/home/sabetts/opt/bin/sbcl --with-clisp=/usr/local/downstairs/to/the/left/clisp Now build it: $ make If all goes well, you should have a stumpwm binary now. Sorry there's no install yet. Just copy the binary wherever you want or run it out of the stumpwm/ directory. If autoconf worked properly, you can install the binary, along with the .info documentation with: $ make install Now that you have a binary, call it from your ~/.xinitrc file: $ echo /path/to/stumpwm >> ~/.xinitrc $ startx Hopefully that will put you in X running stumpwm! CCL And Virtual Memory ---------------------- On 64bit platforms, CCL reserves a "very large" amount of virtual memory. If this bothers you for some reason, you can pass the -R or --heap-reserve option to the binary in your ~/.xinitrc file. See http://ccl.clozure.com/manual/chapter15.1.html for an explanation. 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. For other stuff visit the stumpwm wiki: http://stumpwm.antidesktop.net/ There's a #stumpwm channel on irc.freenode.net, too. Questions? ---------- See http://stumpwm.nongnu.org/community.html for more information on contacting stumpwm developers and users. stumpwm-20110819.gitca08e08/asdf.lisp000066400000000000000000001333731162337705100170750ustar00rootroot00000000000000;;; This is asdf: Another System Definition Facility. $Revision: 1.109 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the CVS HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' ;;; Copyright (c) 2001-2007 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; the problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous #:hyperdocumentation #:hyperdoc #:compile-op #:load-op #:load-source-op #:test-system-version #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:input-files #:output-files #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file #:doc-file #:html-file #:text-file #:source-file-type #:module ; components #:system #:unix-dso #:module-components ; component accessors #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-property #:component-system #:component-depends-on #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:system-licence #:system-source-file #:system-relative-pathname #:operation-on-warnings #:operation-on-failure ;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors #:duplicate-names #:retry #:accept ; restarts #:preference-file-for-system/operation #:load-preferences ) (:use :cl)) #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision: 1.109 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) :junk-allowed t) (parse-integer v :start (1+ dot) :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) (defparameter +asdf-methods+ '(perform explain output-files operation-done-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defun pathname-sans-name+type (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) (define-modify-macro appendf (&rest args) append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s "~@" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) ;;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (inline-methods :accessor component-inline-methods :initform nil) (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) (format s "~@" (missing-requires c) (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity t) (ignore-errors (prin1 (component-name c) stream)))) (defclass module (component) ((components :initform nil :accessor module-components :initarg :components) ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail :accessor module-if-component-dep-fails :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defun component-parent-pathname (component) (aif (component-parent component) (component-pathname it) *default-pathname-defaults*)) (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname :directory `(:relative ,(component-name component)) :host (pathname-host (component-parent-pathname component))))) (defmethod component-pathname ((component component)) (let ((*default-pathname-defaults* (component-parent-pathname component))) (merge-pathnames (component-relative-pathname component)))) (defgeneric component-property (component property)) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (defgeneric (setf component-property) (new-value component property)) (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license))) ;;; version-satisfies ;;; with apologies to christophe rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer (split (component-version c) nil '(#\.)))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) (defun coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (defvar *system-definition-search-functions* '(sysdef-central-registry-search)) (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) *system-definition-search-functions*)) (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" #+nil "telent:asdf;systems;")) (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) (let* ((defaults (eval dir)) (file (and defaults (make-pathname :defaults defaults :version :newest :name name :type "asd" :case :local)))) (if (and file (probe-file file)) (return file))))))) (defun make-temporary-package () (flet ((try (counter) (ignore-errors (make-package (format nil "ASDF~D" counter) :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) (in-memory (gethash name *defined-systems*)) (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) (let ((package (make-temporary-package))) (unwind-protect (let ((*package* package)) (format *verbose-out* "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" ;; FIXME: This wants to be (ENOUGH-NAMESTRING ;; ON-DISK), but CMUCL barfs on that. on-disk *package*) (load on-disk)) (delete-package package)))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) (cdr in-memory)) (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding components (defgeneric find-component (module name &optional version) (:documentation "Finds the component with name NAME present in the MODULE module; if MODULE is nil, then the component is assumed to be a system.")) (defmethod find-component ((module module) name &optional version) (if (slot-boundp module 'components) (let ((m (find name (module-components module) :test #'equal :key #'component-name))) (if (and m (version-satisfies m version)) m)))) ;;; a component with no parent is a system (defmethod find-component ((module (eql nil)) name &optional version) (let ((m (find-system name nil))) (if (and m (version-satisfies m version)) m))) ;;; component subclasses (defclass source-file (component) ()) (defclass cl-source-file (source-file) ()) (defclass c-source-file (source-file) ()) (defclass java-source-file (source-file) ()) (defclass static-file (source-file) ()) (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ()) (defgeneric source-file-type (component system)) (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") (defmethod source-file-type ((c c-source-file) (s module)) "c") (defmethod source-file-type ((c java-source-file) (s module)) "java") (defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) (let ((relative-pathname (slot-value component 'relative-pathname))) (if relative-pathname (merge-pathnames relative-pathname (make-pathname :type (source-file-type component (component-system component)))) (let* ((*default-pathname-defaults* (component-parent-pathname component)) (name-type (make-pathname :name (component-name component) :type (source-file-type component (component-system component))))) name-type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations ;;; one of these is instantiated whenever (operate ) is called (defclass operation () ((forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform nil :accessor operation-visited-nodes) (visiting-nodes :initform nil :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) (print-unreadable-object (o stream :type t :identity t) (ignore-errors (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names &key force &allow-other-keys) (declare (ignore slot-names force)) ;; empty method to disable initarg validity checking ) (defgeneric perform (operation component)) (defgeneric operation-done-p (operation component)) (defgeneric explain (operation component)) (defgeneric output-files (operation component)) (defgeneric input-files (operation component)) (defun node-for (o c) (cons (class-name (class-of o)) c)) (defgeneric operation-ancestor (operation) (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) (operation-ancestor it) operation)) (defun make-sub-operation (c o dep-c dep-o) (let* ((args (copy-list (operation-original-initargs o))) (force-p (getf args :force))) ;; note explicit comparison with T: any other non-NIL force value ;; (e.g. :recursive) will pass through (cond ((and (null (component-parent c)) (null (component-parent dep-c)) (not (eql c dep-c))) (when (eql force-p t) (setf (getf args :force) nil)) (apply #'make-instance dep-o :parent o :original-initargs args args)) ((subtypep (type-of o) dep-o) o) (t (apply #'make-instance dep-o :parent o :original-initargs args args))))) (defgeneric visit-component (operation component data)) (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) (push (cons (node-for o c) data) (operation-visited-nodes (operation-ancestor o))))) (defgeneric component-visited-p (operation component)) (defmethod component-visited-p ((o operation) (c component)) (assoc (node-for o c) (operation-visited-nodes (operation-ancestor o)) :test 'equal)) (defgeneric (setf visiting-component) (new-value operation component)) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables (declare (ignorable new-value operation component))) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value (pushnew node (operation-visiting-nodes a) :test 'equal) (setf (operation-visiting-nodes a) (remove node (operation-visiting-nodes a) :test 'equal))))) (defgeneric component-visiting-p (operation component)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (cons o c))) (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) (defgeneric component-depends-on (operation component) (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: ( *), where is a class designator and each is a component designator, which means that the component depends on having been performed on each ; or (FEATURE ), which means that the component depends on 's presence in *FEATURES*. Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) (defmethod component-depends-on ((op-spec symbol) (c component)) (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) (slot-value c 'in-order-to)))) (defgeneric component-self-dependencies (operation component)) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) (remove-if-not (lambda (x) (member (component-name c) (cdr x) :test #'string=)) all-deps))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) (self-deps (component-self-dependencies operation c))) (if self-deps (mapcan (lambda (dep) (destructuring-bind (op name) dep (output-files (make-instance op) (find-component parent name)))) self-deps) ;; no previous operations needed? I guess we work with the ;; original source file, then (list (component-pathname c))))) (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) (flet ((fwd-or-return-t (file) ;; if FILE-WRITE-DATE returns NIL, it's possible that the ;; user or some other agent has deleted an input file. If ;; that's the case, well, that's not good, but as long as ;; the operation is otherwise considered to be done we ;; could continue and survive. (let ((date (file-write-date file))) (cond (date) (t (warn "~@" file o c) (return-from operation-done-p t)))))) (let ((out-files (output-files o c)) (in-files (input-files o c))) (cond ((and (not in-files) (not out-files)) ;; arbitrary decision: an operation that uses nothing to ;; produce nothing probably isn't doing much t) ((not out-files) (let ((op-done (gethash (type-of o) (component-operation-times c)))) (and op-done (>= op-done (apply #'max (mapcar #'fwd-or-return-t in-files)))))) ((not in-files) nil) (t (and (every #'probe-file out-files) (> (apply #'min (mapcar #'file-write-date out-files)) (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination ;;; runs :before methods most->least-specific, which is back to front ;;; for our purposes. And CLISP doesn't have non-standard method ;;; combinations, so let's keep it simple and aspire to portability (defgeneric traverse (operation component)) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) (labels ((do-one-dep (required-op required-c required-v) (let* ((dep-c (or (find-component (component-parent c) ;; XXX tacky. really we should build the ;; in-order-to slot with canonicalized ;; names instead of coercing this late (coerce-name required-c) required-v) (error 'missing-dependency :required-by c :version required-v :requires required-c))) (op (make-sub-operation c operation dep-c required-op))) (traverse op dep-c))) (do-dep (op dep) (cond ((eq op 'feature) (or (member (car dep) *features*) (error 'missing-dependency :required-by c :requires (car dep) :version nil))) (t (dolist (d dep) (cond ((consp d) (assert (string-equal (symbol-name (first d)) "VERSION")) (appendf forced (do-one-dep op (second d) (third d)))) (t (appendf forced (do-one-dep op d nil))))))))) (aif (component-visited-p operation c) (return-from traverse (if (cdr it) (list (cons 'pruned-op c)) nil))) ;; dependencies (if (component-visiting-p operation c) (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (loop for (required-op . deps) in (component-depends-on operation c) do (do-dep required-op deps)) ;; constituent bits (let ((module-ops (when (typep c 'module) (let ((at-least-one nil) (forced nil) (error nil)) (loop for kid in (module-components c) do (handler-case (appendf forced (traverse operation kid )) (missing-dependency (condition) (if (eq (module-if-component-dep-fails c) :fail) (error condition)) (setf error condition)) (:no-error (c) (declare (ignore c)) (setf at-least-one t)))) (when (and (eq (module-if-component-dep-fails c) :try-next) (not at-least-one)) (error error)) forced)))) ;; now the thing itself (when (or forced module-ops (not (operation-done-p operation c)) (let ((f (operation-forced (operation-ancestor operation)))) (and f (or (not (consp f)) (member (component-name (operation-ancestor operation)) (mapcar #'coerce-name f) :test #'string=))))) (let ((do-first (cdr (assoc (class-name (class-of operation)) (slot-value c 'do-first))))) (loop for (required-op . deps) in do-first do (do-dep required-op deps))) (setf forced (append (delete 'pruned-op forced :key #'car) (delete 'pruned-op module-ops :key #'car) (list (cons operation c)))))) (setf (visiting-component operation c) nil) (visit-component operation c (and forced t)) forced))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error "~@" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) nil) (defmethod explain ((operation operation) (component component)) (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) ;;; compile-op (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (on-warnings :initarg :on-warnings :accessor operation-on-warnings :initform *compile-file-warnings-behaviour*) (on-failure :initarg :on-failure :accessor operation-on-failure :initform *compile-file-failure-behaviour*))) (defmethod perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time)) (load-preferences c operation)) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) (compile-file source-file :output-file output-file) ;(declare (ignore output)) (when warnings-p (case (operation-on-warnings operation) (:warn (warn "~@" operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (when failure-p (case (operation-on-failure operation) (:warn (warn "~@" operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) (unless output (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) #+:broken-fasl-loader (list (component-pathname c))) (defmethod perform ((operation compile-op) (c static-file)) nil) (defmethod output-files ((operation compile-op) (c static-file)) nil) (defmethod input-files ((op compile-op) (c static-file)) nil) ;;; load-op (defclass basic-load-op (operation) ()) (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) (defmethod perform ((operation load-op) (c static-file)) nil) (defmethod operation-done-p ((operation load-op) (c static-file)) t) (defmethod output-files ((o operation) (c component)) nil) (defmethod component-depends-on ((operation load-op) (c component)) (cons (list 'compile-op (component-name c)) (call-next-method))) ;;; load-source-op (defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) (and (load source) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) nil) (defmethod output-files ((operation load-source-op) (c component)) nil) ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (let ((what-would-load-op-do (cdr (assoc 'load-op (slot-value c 'in-order-to))))) (mapcar (lambda (dep) (if (eq (car dep) 'load-op) (cons 'load-source-op (cdr dep)) dep)) what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) (if (or (not (component-property c 'last-loaded-as-source)) (> (file-write-date (component-pathname c)) (component-property c 'last-loaded-as-source))) nil t)) (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) nil) (defgeneric load-preferences (system operation) (:documentation "Called to load system preferences after . Typical uses are to set parameters that don't exist until after the system has been loaded.")) (defgeneric preference-file-for-system/operation (system operation) (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load.")) (defmethod load-preferences ((s t) (operation t)) ;; do nothing (values)) (defmethod load-preferences ((s system) (operation basic-load-op)) (let* ((*package* (find-package :common-lisp)) (file (probe-file (preference-file-for-system/operation s operation)))) (when file (when *verbose-out* (format *verbose-out* "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" (component-name s) (type-of operation) file)) (load file)))) (defmethod preference-file-for-system/operation ((system t) (operation t)) ;; cope with anything other than systems (preference-file-for-system/operation (find-system system t) operation)) (defmethod preference-file-for-system/operation ((s system) (operation t)) (let ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *default-pathname-defaults*))) (merge-pathnames (make-pathname :name (component-name s) :type "lisp" :directory '(:relative ".asdf")) (truename (user-homedir-pathname))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations (defun operate (operation-class system &rest args &key (verbose t) version &allow-other-keys) (let* ((op (apply #'make-instance operation-class :original-initargs args args)) (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) (system (if (typep system 'component) system (find-system system)))) (unless (version-satisfies system version) (error 'missing-component :requires system :version version)) (let ((steps (traverse op system))) (with-compilation-unit () (loop for (op . component) in steps do (loop (restart-case (progn (perform op component) (return)) (retry () :report (lambda (s) (format s "~@" op component))) (accept () :report (lambda (s) (format s "~@" op component)) (setf (gethash (type-of op) (component-operation-times component)) (get-universal-time)) (return))))))))) (defun oos (&rest args) "Alias of OPERATE function" (apply #'operate args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax (defun remove-keyword (key arglist) (labels ((aux (key arglist) (cond ((null arglist) nil) ((eq key (car arglist)) (cddr arglist)) (t (cons (car arglist) (cons (cadr arglist) (remove-keyword key (cddr arglist)))))))) (aux key arglist))) (defmacro defsystem (name &body options) (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options (let ((component-options (remove-keyword :class options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) (s #+clisp (sysdef-error "Cannot redefine the existing system ~A with a different class" s) #-clisp (change-class (cdr s) ',class)) (t (register-system (quote ,name) (make-instance ',class :name ',name))))) (parse-component-form nil (apply #'list :module (coerce-name ',name) :pathname (or ,pathname (when *load-truename* (pathname-sans-name+type (resolve-symlinks *load-truename*))) *default-pathname-defaults*) ',component-options)))))) (defun class-for-type (parent type) (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) (find-symbol (symbol-name type) #.(package-name *package*)))) (class (dolist (symbol (if (keywordp type) extra-symbols (cons type extra-symbols))) (when (and symbol (find-class symbol nil) (subtypep symbol 'component)) (return (find-class symbol)))))) (or class (and (eq type :file) (or (module-default-component-class parent) (find-class 'cl-source-file))) (sysdef-error "~@" type)))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. Returns the new tree (which probably shares structure with the old one)" (let ((first-op-tree (assoc op1 tree))) (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) (if (find c (cdr it)) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) (acons op2 (list c) (cdr first-op-tree)))) tree) (acons op1 (list (list op2 c)) tree)))) (defun union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) (dolist (op (cdr op-tree)) (dolist (c (cdr op)) (setf new-tree (maybe-add-tree new-tree (car op-tree) (car op) c)))))) new-tree)) (defun remove-keys (key-names args) (loop for ( name val ) on args by #'cddr unless (member (symbol-name name) key-names :key #'symbol-name :test 'equal) append (list name val))) (defvar *serial-depends-on*) (defun parse-component-form (parent options) (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p)) (check-component-input type name weakly-depends-on depends-on components in-order-to) (when (and parent (find-component parent name) ;; ignore the same object when rereading the defsystem (not (typep (find-component parent name) (class-for-type parent type)))) (error 'duplicate-names :name name)) (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to) rest)) (ret (or (find-component parent name) (make-instance (class-for-type parent type))))) (when weakly-depends-on (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) (when (boundp '*serial-depends-on*) (setf depends-on (concatenate 'list *serial-depends-on* depends-on))) (apply #'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent other-args) (when (typep ret 'module) (setf (module-default-component-class ret) (or default-component-class (and (typep parent 'module) (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) (loop for c-form in components for c = (parse-component-form ret c-form) collect c if serial do (push (component-name c) *serial-depends-on*)))) ;; check for duplicate names (let ((name-hash (make-hash-table :test #'equal))) (loop for c in (module-components ret) do (if (gethash (component-name c) name-hash) (error 'duplicate-names :name (component-name c)) (setf (gethash (component-name c) name-hash) t))))) (setf (slot-value ret 'in-order-to) (union-of-dependencies in-order-to `((compile-op (compile-op ,@depends-on)) (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) (%remove-component-inline-methods ret rest) ret))) (defun %remove-component-inline-methods (ret rest) (loop for name in +asdf-methods+ do (map 'nil ;; this is inefficient as most of the stored ;; methods will not be for this particular gf n ;; But this is hardly performance-critical (lambda (m) (remove-method (symbol-function name) m)) (component-inline-methods ret))) ;; clear methods, then add the new ones (setf (component-inline-methods ret) nil) (loop for name in +asdf-methods+ for v = (getf rest (intern (symbol-name name) :keyword)) when v do (destructuring-bind (op qual (o c) &body body) v (pushnew (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) ,@body)) (component-inline-methods ret))))) (defun check-component-input (type name weakly-depends-on depends-on components in-order-to) "A partial test of the values of a component." (when weakly-depends-on (warn "We got one! XXXXX")) (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." type name depends-on)) (unless (listp weakly-depends-on) (sysdef-error-component ":weakly-depends-on must be a list." type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." type name components)) (unless (and (listp in-order-to) (listp (car in-order-to))) (sysdef-error-component ":in-order-to must be NIL or a list of components." type name in-order-to))) (defun sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg "~&The value specified for ~(~A~) ~A is ~W") type name value)) (defun resolve-symlinks (path) #-allegro (truename path) #+allegro (excl:pathname-resolve-symbolic-links path) ) ;;; optional extras ;;; run-shell-command functions for other lisp implementations will be ;;; gratefully accepted, if they do the same thing. If the docstring ;;; is ambiguous, send a bug report (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (format *verbose-out* "; $ ~A~%" command) #+sbcl (sb-ext:process-exit-code (sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) #+allegro (excl:run-shell-command command :input nil :output *verbose-out*) #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :output-stream *verbose-out*) #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) #+openmcl (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) (defgeneric hyperdocumentation (package name doc-type)) (defmethod hyperdocumentation ((package symbol) name doc-type) (hyperdocumentation (find-package package) name doc-type)) (defun hyperdoc (name doc-type) (hyperdocumentation (symbol-package name) name doc-type)) (defun system-source-file (system-name) (let ((system (asdf:find-system system-name))) (make-pathname :type "asd" :name (asdf:component-name system) :defaults (asdf:component-relative-pathname system)))) (defun system-source-directory (system-name) (make-pathname :name nil :type nil :defaults (system-source-file system-name))) (defun system-relative-pathname (system pathname &key name type) (let ((directory (pathname-directory pathname))) (when (eq (car directory) :absolute) (setf (car directory) :relative)) (merge-pathnames (make-pathname :name (or name (pathname-name pathname)) :type (or type (pathname-type pathname)) :directory directory) (system-source-directory system)))) (pushnew :asdf *features*) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") (pushnew :sbcl-hooks-require *features*))) #+(and sbcl sbcl-hooks-require) (progn (defun module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning)) (let* ((*verbose-out* (make-broadcast-stream)) (system (asdf:find-system name nil))) (when system (asdf:operate 'asdf:load-op name) t)))) (defun contrib-sysdef-search (system) (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) (when home (let* ((name (coerce-name system)) (home (truename home)) (contrib (merge-pathnames (make-pathname :directory `(:relative ,name) :name name :type "asd" :case :local :version :newest) home))) (probe-file contrib))))) (pushnew '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) (when home (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew '(merge-pathnames ".sbcl/systems/" (user-homedir-pathname)) *central-registry*) (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) (provide 'asdf) stumpwm-20110819.gitca08e08/autogen.sh000077500000000000000000000000651162337705100172570ustar00rootroot00000000000000#!/bin/sh # generate the configure script autoconf stumpwm-20110819.gitca08e08/bindings.lisp000066400000000000000000000200471162337705100177460ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; define standard key bindings ;; ;; Code: (in-package #:stumpwm) (export '(*groups-map* *help-map* 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 *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 *help-map* nil "Help related bindings hang from this keymap") (defvar *group-top-maps* '((tile-group *tile-group-top-map*) (float-group *float-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) (defvar *tile-group-top-map* nil) (defvar *tile-group-root-map* nil) (defvar *float-group-top-map* nil) (defvar *float-group-root-map* nil) ;; 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 "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 "w") "windows" (kbd "C-w") "windows" (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") (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 "M-n") "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 "M-p") "prev" (kbd "C-M-p") "prev-in-frame" (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 "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 *float-group-top-map*) (fill-keymap *float-group-root-map*) (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 *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 ratpoison 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 send-escape () () "Send the escape key to the current window." (send-meta-key (current-screen) *escape-key*)) stumpwm-20110819.gitca08e08/color.lisp000066400000000000000000000262041162337705100172700ustar00rootroot00000000000000;; Copyright (C) 2007-2008 Jonathan Moore Liles ;; ;; 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 simplified implementation of the the C color code is as follows: ;; ;; ^B bright ;; ^b dim ;; ^n normal (sgr0) ;; ;; ^00 black black ;; ^10 red black ;; ^01 black red ;; ^1* red clear ;; ;; and so on. ;; ;; I won't explain here the many reasons that C is better than ANSI, so just ;; take my word for it. (in-package :stumpwm) (export '(*colors* update-color-map adjust-color update-screen-color-context)) (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).") (defvar *color-map* nil) (defvar *foreground* nil) (defvar *background* nil) (defvar *reverse* nil) (defvar *color-stack* '()) (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)))) (defun alloc-color (screen color) (xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color)) (defun lookup-color (screen color) (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)) ;; Normal colors are dimmed and bright colors are intensified in order ;; to more closely resemble the VGA pallet. (defun update-color-map (screen) "Read *colors* and cache their pixel colors for use when rendering colored text." (let ((scm (xlib:screen-default-colormap (screen-number screen)))) (labels ((map-colors (amt) (loop for c in *colors* as color = (xlib:lookup-color scm c) do (adjust-color color amt) collect (xlib:alloc-color scm color)))) (setf (screen-color-map-normal screen) (apply #'vector (map-colors -0.25)) (screen-color-map-bright screen) (apply #'vector (map-colors 0.25)))))) (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)))) (defun get-bg-color (screen cc color) (setf *background* color) (if color (svref (screen-color-map-normal screen) color) (ccontext-default-bg cc))) (defun get-fg-color (screen cc color) (setf *foreground* color) (if color (svref *color-map* color) (if (eq *color-map* (screen-color-map-bright screen)) (ccontext-default-bright cc) (ccontext-default-fg cc)))) (defun set-color (screen cc s i) (let* ((gc (ccontext-gc cc)) (l (- (length s) i)) (r 2) (f (subseq s i (1+ i))) (b (if (< l 2) "*" (subseq s (1+ i) (+ i 2))))) (labels ((set-fg-bg (fg bg) (if *reverse* (setf (xlib:gcontext-foreground gc) bg (xlib:gcontext-background gc) fg) (setf (xlib:gcontext-foreground gc) fg (xlib:gcontext-background gc) bg))) (update-colors () (set-fg-bg (get-fg-color screen cc *foreground*) (get-bg-color screen cc *background*)))) (case (elt f 0) (#\n ; normal (setf f "*" b "*" r 1 *color-map* (screen-color-map-normal screen) *reverse* nil) (get-fg-color screen cc nil) (get-bg-color screen cc nil)) (#\b ; bright off (setf *color-map* (screen-color-map-normal screen)) (update-colors) (return-from set-color 1)) (#\B ; bright on (setf *color-map* (screen-color-map-bright screen)) (update-colors) (return-from set-color 1)) (#\R (setf *reverse* t) (update-colors) (return-from set-color 1)) (#\r (setf *reverse* nil) (update-colors) (return-from set-color 1)) (#\[ (push (list *foreground* *background* *color-map*) *color-stack*) (return-from set-color 1)) (#\] (let ((colors (pop *color-stack*))) (when colors (setf *foreground* (first colors) *background* (second colors) *color-map* (third colors)))) (update-colors) (return-from set-color 1)) (#\^ ; circumflex (return-from set-color 1))) (handler-case (let ((fg (if (equal f "*") (progn (get-fg-color screen cc nil) (ccontext-default-fg cc)) (get-fg-color screen cc (parse-integer f)))) (bg (if (equal b "*") (progn (get-bg-color screen cc nil) (ccontext-default-bg cc)) (get-bg-color screen cc (parse-integer b))))) (set-fg-bg fg bg)) (error (c) (dformat 1 "Invalid color code: ~A" c)))) r)) (defun render-strings (screen cc padx pady strings highlights &optional (draw t)) (let* ((height (+ (xlib:font-descent (screen-font screen)) (xlib:font-ascent (screen-font screen)))) (width 0) (gc (ccontext-gc cc)) (win (ccontext-win cc)) (px (ccontext-px cc)) (*foreground* nil) (*background* nil) (*reverse* nil) (*color-stack* '()) (*color-map* (screen-color-map-normal screen))) (when draw (when (or (not px) (/= (xlib:drawable-width px) (xlib:drawable-width win)) (/= (xlib:drawable-height px) (xlib:drawable-height win))) (when px (xlib:free-pixmap px)) (setf px (xlib:create-pixmap :drawable win :width (xlib:drawable-width win) :height (xlib:drawable-height win) :depth (xlib:drawable-depth win)) (ccontext-px cc) px)) (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 s in strings ;; We need this so we can track the row for each element for i from 0 to (length strings) do (let ((x 0) (off 0) (len (length s))) (loop for st = 0 then (+ en (1+ off)) as en = (position #\^ s :start st) do (progn (let ((en (cond ((and en (= (1+ en) len)) nil) ((and en (char= #\^ (char s (1+ en)))) (1+ en)) (t en)))) (when draw (xlib:draw-image-glyphs px gc (+ padx x) (+ pady (* i height) (xlib:font-ascent (screen-font screen))) (subseq s st en) :translate #'translate-id :size 16)) (setf x (+ x (xlib:text-width (screen-font screen) (subseq s st en) :translate #'translate-id)) width (max width x))) (when (and en (< (1+ en) len)) ;; right-align rest of string? (if (char= #\> (char s (1+ en))) (progn (when draw (setf x (- (xlib:drawable-width px) (* 2 padx) ;; get width of rest of s (render-strings screen cc padx pady (list (subseq s (+ en 2))) '() nil)) width (- (xlib:drawable-width px) (* 2 padx)))) (setf off 1)) (setf off (set-color screen cc s (1+ en)))))) while en)) when (find i highlights :test 'eql) do (when draw (invert-rect screen px 0 (* i height) (xlib:drawable-width px) height))) (when draw (xlib:copy-area px gc 0 0 (xlib:drawable-width px) (xlib:drawable-height px) win 0 0)) (set-color screen cc "n" 0) width)) ;;; FIXME: It would be nice if the output of this parser was used to ;;; draw the text, but the current drawing implementation is probably ;;; faster. (defun parse-color (s i) (let ((l (- (length s) i))) (when (zerop l) (return-from parse-color (values `("^") 0))) (let ((f (subseq s i (1+ i))) (b (if (< l 2) "*" (subseq s (1+ i) (+ i 2))))) (case (elt f 0) (#\n ; normal (values `((:background "*") (:foreground "*") (:reverse nil)) 1)) (#\b ; bright off (values `((:bright nil)) 1)) (#\B ; bright on (values `((:bright t)) 1)) (#\R (values `((:reverse t)) 1)) (#\r (values `((:reverse nil)) 1)) (#\[ (values `((:push)) 1)) (#\] (values `((:pop)) 1)) (#\^ ; circumflex (values `("^") 1)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (values `((:background ,(if (string= f "*") "*" (parse-integer f))) (:foreground ,(if (string= b "*") "*" (parse-integer b)))) 2)) (t (values `(,(format nil "^~a" f)) 1)))))) (defun parse-color-string (string) "parse a color coded string into a list of strings and color codes" (loop with color = nil with off = 0 for st = 0 then (min (+ en (1+ off)) (length string)) as en = (position #\^ string :start st) ;; avoid empty strings at the beginning and end unless (or (eql en st) (eql st (length string))) collect (subseq string st en) while en append (progn (multiple-value-setq (color off) (parse-color string (1+ en))) color))) (defun uncolorify (string) "Remove any color markup in STRING" (format nil "~{~a~}" (remove-if-not 'stringp (parse-color-string string)))) stumpwm-20110819.gitca08e08/command.lisp000066400000000000000000000510021162337705100175620ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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)) (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 "") ;; XXX: I'd like to just use straight warn, but sbcl drops to the ;; debugger when compiling so i've made a style warning instead ;; -sabetts (define-condition command-docstring-warning (style-warning) ((command :initarg :command)) (:report (lambda (c s) (format s "command ~a doesn't have a docstring" (slot-value c '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. 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 yes to be parsed. @item :module An existing stumpwm module @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)) (let ((docstring (if (stringp (first body)) (first body) (warn (make-condition 'command-docstring-warning :command name)))) (body (if (stringp (first body)) (cdr body) body)) (name (if (atom name) name (first name))) (group (if (atom name) t (second name)))) `(progn (defun ,name ,args ,docstring (let ((%interactivep% *interactivep*) (*interactivep* nil)) (declare (ignorable %interactivep%)) ,@body)) (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) (typep (current-group) (command-class command)) ;; TODO: minor modes ) (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 exceded") 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) (let* ((p1 (position-if-not (lambda (ch) (char= ch #\Space)) (argument-line-string input) :start (argument-line-start input))) (p2 (or (and p1 (position #\Space (argument-line-string input) :start p1)) (length (argument-line-string input))))) (prog1 ;; we wanna return nil if they're the same (unless (= p1 p2) (subseq (argument-line-string input) p1 p2)) (setf (argument-line-start input) (1+ p2)))))) (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 ((s (or (argument-pop input) (read-one-line (current-screen) (concat prompt "(y/n): "))))) (when s (values (list (equal s "y")))))) (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 (symbol-function sym) (symbol-function sym) (throw 'error (format nil "the symbol ~a::~a has no 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 (second (multiple-value-list (read-from-keymap (top-maps) #'update))))))))) (define-stumpwm-type :window-number (input prompt) (let ((n (or (argument-pop input) (completing-read (current-screen) prompt (mapcar 'prin1-to-string (mapcar 'window-number (group-windows (current-group)))))))) (when n (handler-case (parse-integer n) (parse-error (c) (declare (ignore c)) (throw 'error "Number required.")))))) (define-stumpwm-type :number (input prompt) (let ((n (or (argument-pop input) (read-one-line (current-screen) prompt)))) (when n (handler-case (parse-integer 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) (let ((s (or (argument-pop input) (read-one-line (current-screen) prompt)))) (when s (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))) (dir (second (assoc (argument-pop-or-read input prompt values) 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))) (gravity (second (assoc (argument-pop-or-read input prompt values) 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 (princ-to-string (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)) (let ((arg (argument-pop input))) (if arg (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) (or (argument-pop-rest input) (completing-read (current-screen) prompt 'complete-program))) (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) ;; FIXME: Is it presumptuous to assume NIL means abort? (or (funcall fn arg-line prompt) (throw 'error :abort))))))) ;; 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) (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." (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-20110819.gitca08e08/configure.ac000066400000000000000000000064731162337705100175550ustar00rootroot00000000000000# -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_PREREQ(2.59) AC_INIT(Stump Window Manager, 0.9.8-git, sabetts@gmail.com) AC_SUBST(CONTRIB_DIR) AC_SUBST(LISP_PROGRAM) AC_SUBST(LISP) AC_SUBST(PPCRE_PATH) # Checks for programs. AC_ARG_WITH(lisp, [ --with-lisp=IMPL use the specified lisp (sbcl, clisp, ccl or ecl)], LISP=$withval, LISP="sbcl") AC_ARG_WITH(sbcl, [ --with-sbcl=PATH specify location of sbcl], SBCL_PATH=$withval, SBCL_PATH="") AC_ARG_WITH(clisp, [ --with-clisp=PATH specify location of clisp], CLISP_PATH=$withval, CLISP_PATH="") AC_ARG_WITH(ccl, [ --with-ccl=PATH specify location of ccl], CCL_PATH=$withval, CCL_PATH="") AC_ARG_WITH(ecl, [ --with-ecl=PATH specify location of ecl], ECL_PATH=$withval, ECL_PATH="") AC_ARG_WITH(ppcre, [ --with-ppcre=PATH specify location of cl-ppcre], PPCRE_PATH=$withval, PPCRE_PATH="`pwd`/cl-ppcre") AC_ARG_WITH(contrib-dir, [ --with-contrib-dir=PATH specify location of contrib modules], CONTRIB_DIR=$withval, CONTRIB_DIR="`pwd`/contrib") 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 "$CLISP_PATH"; then CLISP=$CLISP_PATH AC_MSG_CHECKING([for clisp]) AC_MSG_RESULT($CLISP) else AC_PATH_PROG([CLISP],clisp,"") fi if test -x "$CCL_PATH"; then CCL=$CCL_PATH AC_MSG_CHECKING([for ccl]) AC_MSG_RESULT($CCL) else AC_PATH_PROG([CCL],ccl,"") fi if test -x "$ECL_PATH"; then ECL=$ECL_PATH AC_MSG_CHECKING([for ecl]) AC_MSG_RESULT($ECL) else AC_PATH_PROG([ECL], ecl,"") fi if test "x$LISP" = "xclisp"; then if test "x$CLISP" = "x"; then LISP=sbcl LISP_PROGRAM=$SBCL else LISP_PROGRAM=$CLISP fi elif test "x$LISP" = "xsbcl"; then if test "x$SBCL" = "x"; then LISP=clisp LISP_PROGRAM=$CLISP else LISP_PROGRAM=$SBCL fi elif test "x$LISP" = "xccl"; then if test "x$CCL" = "x"; then LISP=sbcl LISP_PROGRAM=$SBCL else LISP_PROGRAM=$CCL fi elif test "x$LISP" = "xecl"; then if test "x$ECL" = "x"; then LISP=sbcl LISP_PROGRAM=$SBCL else LISP_PROGRAM=$ECL 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_ERROR([Please install makeinfo for the manual.]) fi AC_CHECK_PROG(XDPYINFO,xdpyinfo,yes,no) if test "$XDPINFO" = "no"; then AC_MSG_WARN([xdpyinfo is needed for xinerama support.]) fi if test "$LISP" = "clisp"; then AC_CHECK_FILE([$PPCRE_PATH/cl-ppcre.asd],,AC_MSG_ERROR([Cannot find ppcre. When using clisp you must specify its location using --with-ppcre])) fi # XXX How to do an OR ? if test "$LISP" = "ecl"; then AC_CHECK_FILE([$PPCRE_PATH/cl-ppcre.asd],,AC_MSG_ERROR([Cannot find ppcre. When using ecl you must specify its location using --with-ppcre])) fi # Checks for libraries. # Checks for header files. # Checks for typedefs, structures, and compiler characteristics. # Checks for library functions. AC_OUTPUT(Makefile) AC_OUTPUT(make-image.lisp) AC_OUTPUT(version.lisp) stumpwm-20110819.gitca08e08/contrib/000077500000000000000000000000001162337705100167155ustar00rootroot00000000000000stumpwm-20110819.gitca08e08/contrib/amixer.lisp000066400000000000000000000054721162337705100211030ustar00rootroot00000000000000;;; Amixer module for StumpWM. ;;; ;;; Copyright 2007 Amy Templeton, Jonathan Moore Liles, Ivy Foster. ;;; ;;; Maintainer: Ivy Foster ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Make sure you have your media keys (or whatever) mapped to the appropriate ;;; keysyms (using xmodmap), then put: ;;; ;;; (load "/path/to/amixer.lisp") ;;; ;;; ...in your ~/.stumpwmrc, followed by some keybindings (according ;;; to your preference) ;;; TODO: ;;; ;;; Make the `defvolcontrol' macro create all the necessary commands at once. ;;; ;;; - Should it just create, say, amixer-pcm, which would be passed an ;;; argument? i.e., (define-key *this-map* (kbd "e") "amixer-pcm 1-") ;;; ;;; - Else, figure out how to make the macro not error when converting a ;;; string to a symbol for the name of the command ;;; Code: (in-package :stumpwm) (defun volcontrol (channel amount) (let ((percent (parse-integer (run-shell-command (concat "amixer sset " channel " " (or amount "toggle") "| tail -1" "| sed 's/^.*\\[\\([[:digit:]]\\+\\)%\\].*$/\\1/'") t)))) (message (concat "Mixer: " channel " " (or amount "toggled") (format nil "~C^B~A%" #\Newline percent) "^b [^[^7*" (bar percent 50 #\# #\:) "^]]")))) (defmacro defvolcontrol (name channel valence) `(defcommand ,name () () (volcontrol ,channel ,valence))) (defvolcontrol amixer-PCM-1- "PCM" "1-") (defvolcontrol amixer-PCM-1+ "PCM" "1+") (defvolcontrol amixer-PCM-toggle "PCM" "toggle") (defvolcontrol amixer-Front-1- "Front" "1-") (defvolcontrol amixer-Front-1+ "Front" "1+") (defvolcontrol amixer-Front-toggle "Front" "toggle") (defvolcontrol amixer-Master-1- "Master" "1-") (defvolcontrol amixer-Master-1+ "Master" "1+") (defvolcontrol amixer-Master-toggle "Master" "toggle") (defvolcontrol amixer-Headphone-1- "Headphone" "1-") (defvolcontrol amixer-Headphone-1+ "Headphone" "1+") (defvolcontrol amixer-Headphone-toggle "Headphone" "toggle") (defcommand amixer-sense-toggle () () (message (concat "Headphone Jack Sense toggled" (run-shell-command "amixer sset 'Headphone Jack Sense' toggle" t)))) ;;; End of file stumpwm-20110819.gitca08e08/contrib/app-menu.lisp000066400000000000000000000020071162337705100213270ustar00rootroot00000000000000(in-package :stumpwm) (export '(show-menu load-menu-file)) (defvar *app-menu* nil "Where the menu structure is held") (defun load-menu-file (file-name &key (strip 0)) (with-open-file (file file-name) (when (char= #\# (peek-char nil file)) (read-line file)) ; Hack around the "autogenerated file" comment (let* ((*read-eval* nil) (list (list (read file)))) (dotimes (i strip) (setf list (mapcan #'cdr list))) (setf *app-menu* (nconc *app-menu* list))))) (defcommand show-menu () () "Show the application menu" (let ((stack (list *app-menu*))) (loop (let ((choice (cdr (select-from-menu (current-screen) (append (first stack) (list (cons "Up a level" :up))))))) (cond ((not choice) (return)) ((eq choice :up) (pop stack) (unless stack (return))) ((stringp choice) (run-shell-command choice) (return)) (t (push choice stack))))))) stumpwm-20110819.gitca08e08/contrib/aumix.lisp000066400000000000000000000074271162337705100207430ustar00rootroot00000000000000;;; Aumix front end module for stumpwm ;;; ;;; Copyright (C) 2008 Fredrik Tolf ;;; ;;; Maintainer: Fredrik Tolf ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load-module "aumix") ;;; ;;; In your ~/.stumpwmrc (in-package :stumpwm-user) (defvar *aumix-program* "/usr/bin/aumix") (defvar *aumix-channels* '((:pcm . "w") (:master . "v") (:alt-pcm . "W") (:line . "l"))) (defun assert-ret (val) (assert val) val) (defun process-aumix-volstring (output) (do* ((i 0 (+ i 1)) (ch (aref output i) (aref output i)) (st 'ch) (buf "") left right) (nil) (setq st (case st ((ch) (if (eql ch #\space) 'left 'ch)) ((left) (if (digit-char-p ch) (progn (setq buf (concatenate 'string buf (string ch))) 'left) (progn (setq left (/ (parse-integer buf) 100)) 'space))) ((space) (if (eql ch #\space) (progn (setq buf "") 'right) (error "Invalid output from aumix"))) ((right) (if (digit-char-p ch) (progn (setq buf (concatenate 'string buf (string ch))) 'right) (progn (setq right (/ (parse-integer buf) 100)) (return (values (/ (+ left right) 2) left right))))) (t (error "Invalid output from aumix")))))) (defun aumix-call (channel op amount) (let* ((ch (assert-ret (cdr (assoc channel *aumix-channels*)))) (opstr (concat (case op ((:up) "+") ((:down) "-") ((:set) "") (t (error "Unknown volume operation"))) (format nil "~D" (round (* 100 amount))))) (output (stumpwm::run-prog-collect-output *aumix-program* (concat "-" ch opstr) (concat "-" ch "q")))) (process-aumix-volstring output))) (defun aumix-get (channel) (process-aumix-volstring (stumpwm::run-prog-collect-output *aumix-program* (concat "-" (assert-ret (cdr (assoc channel *aumix-channels*))) "q")))) (define-stumpwm-type :mixer-channel (input prompt) (let ((n (or (argument-pop input) (completing-read (current-screen) prompt (mapcar (lambda (sym) (string-downcase (symbol-name (car sym)))) *aumix-channels*))))) (intern (string-upcase n) 'keyword))) (defcommand mixer (channel opstr) ((:mixer-channel "Channel: ") (:rest "Op: ")) "Change mixer channel." (let* ((fc (aref opstr 0)) (op (cond ((eql fc #\+) (setq opstr (subseq opstr 1)) :up) ((eql fc #\-) (setq opstr (subseq opstr 1)) :down) ((eql fc #\=) (setq opstr (subseq opstr 1)) :set) ((digit-char-p fc) :set) (t (error "Illegal mixer operation")))) (amount (parse-integer opstr))) (message "~A: ~D%" (symbol-name channel) (round (* (aumix-call channel op (/ amount 100)) 100))))) stumpwm-20110819.gitca08e08/contrib/battery-portable.lisp000066400000000000000000000313201162337705100230650ustar00rootroot00000000000000;;; Portable battery information for StumpWM's mode-line. ;;; ;;; Written by Julian Stecklina with inspiration from John Li and ;;; Rupert Swarbrick. ;;; ;;; Copyright (c) 2008 Julian Stecklina ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; ;;; To load this module, place ;;; ;;; (load-module "battery-portable") ;;; ;;; in your .stumpwmrc. Battery information is then available via %B ;;; in your mode-line config. ;;; ;;; If you have an older kernel and the above doesn't work, add ;;; ;;; (setf stumpwm.contrib.battery-portable:*prefer-sysfs* nil) ;;; ;;; below the above line. (defpackage :stumpwm.contrib.battery-portable (:use :common-lisp :stumpwm :cl-ppcre) (:export #:*refresh-time* #:*prefer-sysfs* )) (in-package :stumpwm.contrib.battery-portable) ;;; CLISP doesn't include :linux in *features* even if it runs on ;;; Linux. :-/ ;;; Configuration (defvar *refresh-time* 5 "Time in seconds between updates of battery information.") (defvar *prefer-sysfs* t "Prefer sysfs over procfs for information gathering. This has effect only on Linux.") ;;; Method base class (defclass battery-method () () (:documentation "Base class for battery information retrieval")) (defgeneric all-batteries (method) (:documentation "Returns all recognized batteries.")) (defun preferred-battery-method () #- (or linux openbsd) nil #+ linux (if *prefer-sysfs* (make-instance 'sysfs-method) (make-instance 'procfs-method)) #+ openbsd (make-instance 'usr-sbin-apm-method)) ;;; Battery class (defclass battery () () (:documentation "Base class for battery information.")) (defgeneric state-of (battery) (:documentation "Returns either :UNKNOWN, :CHARGED, :CHARGING, or :DISCHARGING with the obvious meanings. If the state is not :UNKNOWN, returns the battery fill percentage. If the state is :CHARGING or :DISCHARGING, this function returns a third value indicating the corresponding time in seconds.")) ;;; Linux procfs implementation #+ linux (progn (defclass procfs-method (battery-method) () (:documentation "Collect battery information through Linux' procfs interface.")) (defclass procfs-battery (battery) ((path :initarg :path :initform (error ":path missing") :reader path-of) (info-hash :initform (make-hash-table :test 'equal) :reader info-hash-of))) (defmethod update-info ((battery procfs-battery)) (clrhash (info-hash-of battery)) (loop for filename in '("state" "info") do (with-open-file (file (merge-pathnames (make-pathname :name filename) (path-of battery))) (loop for line = (read-line file nil nil) while line do (multiple-value-bind (match? matches) (scan-to-strings "^([^:]+):\\s*([^\\s]+)(\\s.*)?$" line) (if (not match?) (format t "Unrecognized line: ~S~%" line) (setf (gethash (aref matches 0) (info-hash-of battery)) (aref matches 1)))))))) (define-condition info-value-not-present (error) ()) (defmethod info-value ((battery procfs-battery) key) (multiple-value-bind (val found?) (gethash key (info-hash-of battery)) (if found? val (error 'info-value-not-present)))) (defmethod info-value-int ((battery procfs-battery) key) (values (parse-integer (info-value battery key)))) (defmethod all-batteries ((method procfs-method)) (mapcar (lambda (p) (make-instance 'procfs-battery :path p)) (list-directory "/proc/acpi/battery/"))) (defmethod state-of ((battery procfs-battery)) (handler-case (progn (update-info battery) (if (string/= (info-value battery "present") "yes") :unknown (let* ((state (info-value battery "charging state"))) (flet ((percent () (/ (info-value-int battery "remaining capacity") (info-value-int battery "last full capacity")))) (cond ((string= state "charged") (values :charged (percent))) ((string= state "discharging") (values :discharging (percent) (* 3600 (/ (info-value-int battery "remaining capacity") (info-value-int battery "present rate"))))) ((string= state "charging") (values :charging (percent) (* 3600 (/ (- (info-value-int battery "last full capacity") (info-value-int battery "remaining capacity")) (info-value-int battery "present rate"))))) (t :unknown)))))) (t () :unknown)))) ;;; Linux sysfs implementation #+ linux (progn (defclass sysfs-method (battery-method) () (:documentation "Collect battery information through Linux' class-based sysfs interface.")) (defclass sysfs-battery (battery) ((path :initarg :path :initform (error ":path missing") :reader path-of))) (defun sysfs-field-exists? (path name) (probe-file (merge-pathnames (make-pathname :name name) path))) (defun sysfs-field (path name) (with-open-file (file (merge-pathnames (make-pathname :name name) path)) (read-line-from-sysfs file))) (defun sysfs-int-field (path name) (parse-integer (sysfs-field path name) :junk-allowed t)) (defun sysfs-int-field-or-nil (path name) (if (sysfs-field-exists? path name) (sysfs-int-field path name) nil)) (defmethod all-batteries ((m sysfs-method)) (remove nil (mapcar (lambda (path) (handler-case (when (string= "Battery" (sysfs-field path "type")) (make-instance 'sysfs-battery :path path)) (file-error () nil))) (list-directory "/sys/class/power_supply/")))) (defmethod state-of ((battery sysfs-battery)) (handler-case (let ((path (path-of battery))) (if (string= (sysfs-field path "present") "0") :unknown (let* ((state (sysfs-field path "status")) (consumption (or (sysfs-int-field-or-nil path "power_now") (sysfs-int-field-or-nil path "current_now") (return-from state-of :unknown))) (curr (or (sysfs-int-field-or-nil path "energy_now") ;; energy_* seems not to be there on ;; some boxes. Strange... (sysfs-int-field-or-nil path "charge_now") (return-from state-of :unknown))) (full (or (sysfs-int-field-or-nil path "energy_full") (sysfs-int-field-or-nil path "charge_full") (return-from state-of :unknown))) (percent (* 100 (/ curr full)))) (cond ((string= state "Full") (values :charged percent)) ((string= state "Discharging") (values :discharging percent (if (zerop consumption) 0 (* 3600 (/ curr consumption))))) ((string= state "Charging") (values :charging percent (if (zerop consumption) 0 (* 3600 (/ (- full curr) consumption))))) (t :unknown))))) (t () :unknown)))) ;;; OpenBSD /usr/sbin/apm implementation #+ openbsd (progn (defclass usr-sbin-apm-method (battery-method) () (:documentation "Collect battery information through OpenBSD' /usr/sbin/apm program.")) (defclass usr-sbin-apm-battery (battery) ()) (defun read-usr-sbin-apm-info () (with-input-from-string (apm (run-shell-command "/usr/sbin/apm -ablm" t)) (let* ((state (ignore-errors (parse-integer (read-line apm)))) (percent (ignore-errors (parse-integer (read-line apm)))) (minutes (ignore-errors (parse-integer (read-line apm)))) (ac (ignore-errors (parse-integer (read-line apm))))) (unless (and (or (null state) (eql state 4)) (or (null ac) (eql ac 255))) (values (case state (0 :high) (1 :low) (2 :critical) (3 :charging) (4 :absent) (t :unknown)) percent minutes (case ac (0 :disconnected) (1 :connected) (2 :backup) (t :unknown))))))) (defmethod all-batteries ((method usr-sbin-apm-method)) (unless (null (read-usr-sbin-apm-info)) (list (make-instance 'usr-sbin-apm-battery)))) (defmethod state-of ((battery usr-sbin-apm-battery)) (multiple-value-bind (state percent minutes ac) (read-usr-sbin-apm-info) (let ((percent (or percent 0)) (seconds (when minutes (* minutes 60)))) (case ac ((:disconnected :backup) (values :discharging percent seconds)) (:connected (cond ((or (eql state :absent) (eql state :unknown)) (values :unknown)) ((eql percent 100) (values :charged percent)) (t (values :charging percent seconds)))) (t (values :unknown))))))) ;;; Interface to the outside world. (defun fmt-time (stream arg colonp atp) (declare (ignore colonp atp)) (when (numberp arg) (multiple-value-bind (hours rest) (truncate arg 3600) (format stream "~D:~2,'0D" hours (floor rest 60))))) (defun battery-info-string () "Compiles a string suitable for StumpWM's mode-line." (with-output-to-string (fmt) (let ((batteries (all-batteries (or (preferred-battery-method) (return-from battery-info-string "(not implemented)"))))) (if (endp batteries) (format fmt "(no battery)") (loop for bat in batteries do (multiple-value-bind (state perc time) (state-of bat) (ecase state (:unknown (format fmt "(no info)")) (:charged (format fmt "~~ ~D%" (round perc))) ((:charging :discharging) (format fmt "~/stumpwm.contrib.battery-portable::fmt-time/~A ^[~A~D%^]" time (if (eq state :charging) #\+ #\-) (bar-zone-color perc 90 50 20 t) (round perc)))))))))) ;;; The actual mode-line format function. A bit ugly... (let ((next 0) (last-value "")) (defun fmt-bat (ml) (declare (ignore ml)) ;; Return the last info again, if we are called too quickly. (let ((now (get-universal-time))) (when (< now next) (return-from fmt-bat last-value)) (setf next (+ now *refresh-time*))) ;; Generate info string. (setf last-value (battery-info-string)))) ;;; Put this at the end to avoid evaluating it when the core above ;;; throws an error. (add-screen-mode-line-formatter #\B #'fmt-bat) ;;; EOF stumpwm-20110819.gitca08e08/contrib/battery.lisp000066400000000000000000000121671162337705100212670ustar00rootroot00000000000000;;; Battery charge formatters for the mode-line ;;; ;;; Copyright 2008 Vitaly Mayatskikh ;;; ;;; Maintainer: Julian Stecklina ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load "/path/to/battery.lisp") ;;; ;;; In your ~/.stumpwmrc ;;; ;;; Then you can use "%b" in your mode line format. ;;; ;;; NOTES: ;;; ;;; This is specific to Linux. (in-package :stumpwm) (export '(*battery-name*)) (dolist (a '((#\b fmt-bat-charge))) (pushnew a *screen-mode-line-formatters* :test 'equal)) (defvar *bat-state* nil) (defvar *bat-remain* 0) (defvar *bat-remain-time* nil) (defvar *bat-prev-time* 0) (defvar *battery-name* "BAT0") (defun read-battery-file (battery fname) (let ((fields (make-hash-table :test #'equal))) (with-open-file (s (concatenate 'string "/proc/acpi/battery/" battery "/" fname) :if-does-not-exist nil) (if s (do ((line (read-line s nil nil) (read-line s nil nil))) ((null line) fields) (let ((split (cl-ppcre:split ":\\s*" line))) (setf (gethash (string-trim '(#\Space) (car split)) fields) (string-trim '(#\Space) (cadr split))))) "")))) (defun current-battery-charge () "Calculate remaining battery charge. Don't make calculation more than once in 15 seconds." (let ((now (/ (get-internal-real-time) internal-time-units-per-second))) (when (or (= 0 *bat-prev-time*) (>= (- now *bat-prev-time*) 15)) (setf *bat-prev-time* now) (let ((battery-state (read-battery-file *battery-name* "state")) (battery-info (read-battery-file *battery-name* "info"))) (if (string= "no" (gethash "present" battery-state)) (setf *bat-state* nil) (let ((charge-state (gethash "charging state" battery-state)) (remain (parse-integer (gethash "remaining capacity" battery-state) :junk-allowed t)) (rate (/ (or (parse-integer (gethash "present rate" battery-state) :junk-allowed t) 0) 60)) (full (parse-integer (gethash "last full capacity" battery-info) :junk-allowed t))) (setf *bat-remain* (round (/ (* 100 remain) full)) *bat-state* charge-state *bat-remain-time* nil) (when (> rate 0) (let* ((online (round (/ (if (string= "charging" *bat-state*) (- full remain) remain) rate)))) (setf *bat-remain-time* (multiple-value-bind (h m) (truncate online 60) (list h m))))))))))) (defun fmt-bat-charge (ml) "Returns a string representing the remaining battery charge (for laptop users.)" (declare (ignore ml)) (current-battery-charge) (if *bat-state* (format nil "BAT: ^[~A~D%^]~A" (bar-zone-color *bat-remain* 50 30 10 t) *bat-remain* (if *bat-remain-time* (format nil " (~2,'0d:~2,'0d) ~A" (car *bat-remain-time*) (cadr *bat-remain-time*) *bat-state*) "")) "no battery")) ;; Alternative display: ;; ;; TT: RRR% (HH:MM) [or "NO BAT" if present = no] ;; ;; TT = AC/DC (AC if charging state = charged/charging, ;; DC if charging state = discharging) ;; ;; RRR = remain/full ;; ;; HH:MM = time until charged/discharged (present when state is charging ;; or discharging) ;; ;; (defun fmt-bat-charge (ml) ;; "Returns a string representing the remaining battery charge (for laptop users.)" ;; (declare (ignore ml)) ;; (current-battery-charge) ;; (if (not *bat-state*) ;; "NO BAT" ;; (format nil "~A:~D%~A" ;; (if (or (string= *bat-state* "charging") ;; (string= *bat-state* "charged")) ;; "AC" "DC") ;; *bat-remain* ;; (if (and (string/= *bat-state* "charged") *bat-remain-time*) ;; (format nil (if (and (= (car *bat-remain-time*) 0) ;; (< (cadr *bat-remain-time*) 30)) ;; " (^[^B^1*~2,'0d:~2,'0d^])" " (~2,'0d:~2,'0d)") ;; (car *bat-remain-time*) ;; (cadr *bat-remain-time*)) ;; "")))) stumpwm-20110819.gitca08e08/contrib/cpu.lisp000066400000000000000000000132271162337705100204020ustar00rootroot00000000000000;;; CPU formatters for the mode-line ;;; ;;; Copyright 2007 Anonymous Coward, Jonathan Moore Liles. ;;; ;;; Maintainer: Julian Stecklina ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load "/path/to/cpu.lisp") ;;; ;;; In your ~/.stumpwmrc ;;; ;;; Then you can use "%c %t" in your mode line format. ;;; ;;; NOTES: ;;; ;;; This is specific to Linux. (in-package :stumpwm) (export '(*acpi-thermal-zone*)) ;; Install formatters. (dolist (a '((#\c fmt-cpu-usage) (#\C fmt-cpu-usage-bar) (#\f fmt-cpu-freq) (#\t fmt-cpu-temp))) (pushnew a *screen-mode-line-formatters* :test 'equal)) ;; Defaults arguments for fmt-cpu-usage-bar (defvar *cpu-usage-bar-width* 10) (defvar *cpu-usage-bar-full* #\#) (defvar *cpu-usage-bar-empty* #\:) (defvar *prev-user-cpu* 0) (defvar *prev-sys-cpu* 0) (defvar *prev-idle-cpu* 0) (defvar *prev-iowait* 0) (defvar *prev-result* '(0 0 0)) (defvar *prev-time* 0) ;; More or less yanked from the wiki. (defun current-cpu-usage () "Return the average CPU usage since the last call. First value is percent of CPU in use. Second value is percent of CPU in use by system processes. Third value is percent of time since last call spent waiting for IO (or 0 if not available). Don't make calculation more than once a second." (let ((cpu-result 0) (sys-result 0) (io-result nil) (now (/ (get-internal-real-time) internal-time-units-per-second))) (when (>= (- now *prev-time*) 1) (setf *prev-time* now) (with-open-file (in #P"/proc/stat" :direction :input) (read in) (let* ((norm-user (read in)) (nice-user (read in)) (user (+ norm-user nice-user)) (sys (read in)) (idle (read in)) (iowait (or (ignore-errors (read in)) 0)) (step-denom (- (+ user sys idle iowait) (+ *prev-user-cpu* *prev-sys-cpu* *prev-idle-cpu* *prev-iowait*)))) (setf cpu-result (/ (- (+ user sys) (+ *prev-user-cpu* *prev-sys-cpu*)) step-denom) sys-result (/ (- sys *prev-sys-cpu*) step-denom) io-result (/ (- iowait *prev-iowait*) step-denom) *prev-user-cpu* user *prev-sys-cpu* sys *prev-idle-cpu* idle *prev-iowait* iowait *prev-result* (list cpu-result sys-result io-result)))))) (apply 'values *prev-result*)) (defun fmt-cpu-usage (ml) "Returns a string representing current the percent of average CPU utilization." (declare (ignore ml)) (let ((cpu (truncate (* 100 (current-cpu-usage))))) (format nil "CPU: ^[~A~3D%^] " (bar-zone-color cpu) cpu))) (defun fmt-cpu-usage-bar (ml &optional (width *cpu-usage-bar-width*) (full *cpu-usage-bar-full*) (empty *cpu-usage-bar-empty*)) "Returns a coloured bar-graph representing the current percent of average CPU utilization." (declare (ignore ml)) (let ((cpu (truncate (* 100 (current-cpu-usage))))) (bar cpu width full empty))) (defun get-proc-file-field (fname field) (with-open-file (s fname :if-does-not-exist nil) ; (if s (do ((line (read-line s nil nil) (read-line s nil nil))) ((null line) nil) (let ((split (cl-ppcre:split "\\s*:\\s*" line))) (when (string= (car split) field) (return (cadr split))))) ""))) (defun fmt-cpu-freq (ml) "Returns a string representing the current CPU frequency (especially useful for laptop users.)" (declare (ignore ml)) (let ((mhz (parse-integer (get-proc-file-field "/proc/cpuinfo" "cpu MHz") :junk-allowed t))) (if (>= mhz 1000) (format nil "~,2FGHz" (/ mhz 1000)) (format nil "~DMHz" mhz)))) (defvar *acpi-thermal-zone* (let ((proc-dir (list-directory #P"/proc/acpi/thermal_zone/")) (sys-dir (sort (remove-if-not (lambda (x) (when (cl-ppcre:scan "^.*/thermal_zone\\d+/" (namestring x)) x)) (list-directory #P"/sys/class/thermal/")) #'string< :key #'namestring))) (cond (proc-dir (cons :procfs (make-pathname :directory (pathname-directory (first proc-dir)) :name "temperature"))) (sys-dir (cons :sysfs (make-pathname :directory (pathname-directory (first sys-dir)) :name "temp")))))) (defun fmt-cpu-temp (ml) "Returns a string representing the current CPU temperature." (declare (ignore ml)) (format nil "~a°C" (case (car *acpi-thermal-zone*) (:procfs (parse-integer (get-proc-file-field (cdr *acpi-thermal-zone*) "temperature") :junk-allowed t)) (:sysfs (with-open-file (f (cdr *acpi-thermal-zone*)) (/ (read f) 1000)))))) stumpwm-20110819.gitca08e08/contrib/debian/000077500000000000000000000000001162337705100201375ustar00rootroot00000000000000stumpwm-20110819.gitca08e08/contrib/debian/menu-method000077500000000000000000000010651162337705100223110ustar00rootroot00000000000000#!/usr/bin/install-menu # # Generates a stumpwm menu file # BE CERTAIN to chenge the pathnames as appropriate BEFORE using outputencoding="LOCALE" !include menu.h genmenu="stump.menu" rcfile="stump.menu" rootprefix="/tmp/" userprefix="src/stumpwm/contrib/" treewalk="(M)" startmenu= nstring(level(), " ") "(\"" $title "\" . (\n" endmenu= nstring(level(), " ") "))\n" supported x11= nstring(level(), " ") "(\"" title() "\" . \"" esc($command, "\"") "\")\n" text= nstring(level(), " ") "(\"" title() "\" . \"" esc(term(), "\"") "\")\n" endsupported stumpwm-20110819.gitca08e08/contrib/disk.lisp000066400000000000000000000063531162337705100205470ustar00rootroot00000000000000;;; Disk usage monitoring for stumpwm's modeline ;;; ;;; Copyright 2007 Morgan Veyret. ;;; ;;; Maintainer: Morgan Veyret ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load-module "disk") ;;; ;;; ...into your ~/.stumpwmrc ;;; ;;; Then you can use "%D" in your mode line format. ;;; You can customize the modeline format (*disk-modeline-fmt*). See the ;;; documentation for *disk-modeline-fmt* for more information. ;;; CODE: (in-package :stumpwm) (dolist (a '((#\D disk-modeline))) (pushnew a *screen-mode-line-formatters* :test 'equal)) (defvar *disk-usage* nil) (defun disk-usage-tokenize (usage-line-str) (ppcre:split "(\\s+)" usage-line-str)) (defun disk-update-usage (paths) (setf *disk-usage* (with-input-from-string (usage-str (run-shell-command (format nil "df -h ~{~a ~} | grep -v 'Filesystem'" paths) t)) (loop for i = (read-line usage-str nil nil) while i collect (disk-usage-tokenize i))))) (defvar *disk-usage-paths* '("/")) (defun disk-usage-get-field (path field-number) (let ((usage-infos (find-if (lambda (item) (string= (car (last item)) path)) *disk-usage*))) (nth field-number usage-infos))) (defun disk-get-device (path) (disk-usage-get-field path 0)) (defun disk-get-size (path) (disk-usage-get-field path 1)) (defun disk-get-used (path) (disk-usage-get-field path 2)) (defun disk-get-available (path) (disk-usage-get-field path 3)) (defun disk-get-use-percent (path) (disk-usage-get-field path 4)) (defun disk-get-mount-point (path) (disk-usage-get-field path 5)) (defun disk-modeline (ml) (declare (ignore ml)) (disk-update-usage *disk-usage-paths*) (let ((fmts (loop for p in *disk-usage-paths* collect (format-expand *disk-formatters-alist* *disk-modeline-fmt* p)))) (format nil "~{~a ~}" fmts))) (defvar *disk-formatters-alist* '((#\d disk-get-device) (#\s disk-get-size) (#\u disk-get-used) (#\a disk-get-available) (#\p disk-get-use-percent) (#\m disk-get-mount-point))) (defvar *disk-modeline-fmt* "%m: %u/%s" "The default value for displaying disk usage information on the modeline. @table @asis @item %% A literal '%' @item %d Filesystem device @item %s Filesystem size @item %u Filesystem used space @item %a Filesystem available space @item %p Filesystem used space in percent @item %m Filesystem mount point @end table ") stumpwm-20110819.gitca08e08/contrib/g15-keysyms.lisp000066400000000000000000000054341162337705100217120ustar00rootroot00000000000000;;; keysyms for the Logitech G15 keyboard ;;; ;;; Copyright 2008 Ted Zlatanov ;;; ;;; Maintainer: ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load "/path/to/g15-keysyms.lisp") ;;; (g15-original) or (g15-revised) deppending of the model you have. ;;; In your ~/.stumpwmrc ;;; (in-package #:stumpwm) (defun g15-original () (define-keysym #x15000001 "G1") (define-keysym #x15000002 "G2") (define-keysym #x15000003 "G3") (define-keysym #x15000004 "G4") (define-keysym #x15000005 "G5") (define-keysym #x15000006 "G6") (define-keysym #x15000007 "G7") (define-keysym #x15000008 "G8") (define-keysym #x15000009 "G9") (define-keysym #x15000010 "G10") (define-keysym #x15000011 "G11") (define-keysym #x15000012 "G12") (define-keysym #x15000013 "G13") (define-keysym #x15000014 "G14") (define-keysym #x15000015 "G15") (define-keysym #x15000016 "G16") (define-keysym #x15000017 "G17") (define-keysym #x15000018 "G18") (define-keysym #x15000019 "M1") (define-keysym #x1500001a "M2") (define-keysym #x1500001b "M3") (define-keysym #x1500001d "LCD0") (define-keysym #x1500001e "LCD1") (define-keysym #x1500001f "LCD2") (define-keysym #x15000020 "LCD3") (define-keysym #x15000021 "LCD4")) (defun g15-revised () ;; the orange version (let ((gkeycodes '(177 152 190 208 129 178)) ;; These are the keycodes G keys in order (mediakeycodes '((144 "Prev") (153 "Next") (160 "Mute") (162 "Play") (164 "Stop") (174 "LowerVolume") (176 "RaiseVolume")))) (dotimes (i (length gkeycodes)) (run-shell-command (concatenate 'string "xmodmap -e 'keycode " (write-to-string (nth i gkeycodes)) " = XF86Launch" (write-to-string (1+ i)) "'")) (define-keysym (+ (keysym-name->keysym "XF86Launch1") i) (concatenate 'string "G" (write-to-string (1+ i))))) (dotimes (i (length mediakeycodes)) (run-shell-command (concatenate 'string "xmodmap -e 'keycode " (write-to-string (first (nth i mediakeycodes))) " = XF86Audio" (second (nth i mediakeycodes)) "'"))))) stumpwm-20110819.gitca08e08/contrib/maildir.lisp000066400000000000000000000105341162337705100212320ustar00rootroot00000000000000;;; Maildir monitoring for stumpwm's modeline ;;; ;;; Copyright 2007 Morgan Veyret. ;;; ;;; Maintainer: Morgan Veyret ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load-module "maildir") ;;; ;;; ...into your ~/.stumpwmrc ;;; ;;; Then you can use "%M" in your mode line format. ;;; You can customize the modeline format (*maildir-modeline-fmt*). See the ;;; documentation for *maildir-modeline-fmt* for more information. ;;; TODO: ;;; ;;; - Add per mailbox formatter ;;; CODE: (in-package :stumpwm) (dolist (a '((#\M maildir-modeline))) (pushnew a *screen-mode-line-formatters* :test 'equal)) (defvar *maildir-timer* nil) (defvar *maildir-update-time* 900 "Time between two updates of the maildir informations (in seconds).") (defun maildir-set-update-time (time-in-seconds) "Set the maildir informations update interval." (when *maildir-timer* (cancel-timer *maildir-timer*)) (setf *maildir-update-time* time-in-seconds) (setf *maildir-timer* (run-with-timer *maildir-update-time* *maildir-update-time* 'update-maildir-infos))) (defvar *maildir-path* (merge-pathnames (make-pathname :directory '(:relative "Mail")) (user-homedir-pathname)) "Pathname to the mail directory. Defaults to ~/Mail.") (defun maildir-mailboxes (maildir) "Returns a list of all mailboxes in *maildir-path*." (directory (merge-pathnames (make-pathname :directory '(:relative :wild)) maildir))) (defun maildir-mailbox-dir (mailbox dir-name) "Returns the specified sub-directory pathname for the provided mailbox." (merge-pathnames (make-pathname :directory (list :relative dir-name) :name :wild) mailbox)) (defvar *maildir-new* '() "Number of new mails for each mailbox.") (defvar *maildir-cur* '() "Number of mails for each mailbox.") (defvar *maildir-tmp* '() "Number of tmp mails for each mailbox.") (defun update-maildir-infos () "Update mail counts for *maildir-path*." (loop for m in (maildir-mailboxes *maildir-path*) collect (length (directory (maildir-mailbox-dir m "new"))) into nb-new collect (length (directory (maildir-mailbox-dir m "cur"))) into nb-cur collect (length (directory (maildir-mailbox-dir m "tmp"))) into nb-tmp finally (progn (setf *maildir-new* nb-new) (setf *maildir-cur* nb-cur) (setf *maildir-tmp* nb-tmp)))) ;; modeline formatter (defun maildir-modeline (ml) (declare (ignore ml)) ;; setup a timer to check every *maildir-update-time* seconds ;; disk access are slow and you obviously don't need to check ;; emails every time the modeline gets updated (unless *maildir-timer* (update-maildir-infos) (setf *maildir-timer* (run-with-timer *maildir-update-time* *maildir-update-time* 'update-maildir-infos))) (format-expand *maildir-formatters-alist* *maildir-modeline-fmt*)) (defun maildir-get-new () (let ((total-new (reduce #'+ *maildir-new*))) (format nil "~D" total-new))) (defun maildir-get-cur () (let ((total-cur (reduce #'+ *maildir-cur*))) (format nil "~D" total-cur))) (defun maildir-get-tmp () (let ((total-tmp (reduce #'+ *maildir-tmp*))) (format nil "~D" total-tmp))) (defvar *maildir-formatters-alist* '((#\n maildir-get-new) (#\c maildir-get-cur) (#\t maildir-get-tmp))) (defvar *maildir-modeline-fmt* "%n %c" "The default value for displaying maildir information on the modeline. @table @asis @item %% A literal '%' @item %n New mails number @item %c Current mails number @item %t Temporary mails number @end table ") stumpwm-20110819.gitca08e08/contrib/mem.lisp000066400000000000000000000056721162337705100203760ustar00rootroot00000000000000;;; MEM formatters for the mode-line ;;; ;;; Copyright 2009 Vitaly Mayatskikh ;;; ;;; Maintainer: ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load "/path/to/mem.lisp") ;;; ;;; In your ~/.stumpwmrc ;;; ;;; Then you can use "%M" and/or "%N in your mode line format. ;;; ;;; NOTES: ;;; ;;; This is specific to Linux. (defpackage :stumpwm.contrib.mem (:use :common-lisp :stumpwm :cl-ppcre)) (in-package :stumpwm.contrib.mem) ;; Install formatters. (dolist (a '((#\M fmt-mem-usage) (#\N fmt-mem-usage-bar))) (pushnew a *screen-mode-line-formatters* :test 'equal)) ;; Defaults arguments for fmt-mem-usage-bar (defvar *mem-usage-bar-width* 10) (defvar *mem-usage-bar-full* #\#) (defvar *mem-usage-bar-empty* #\:) (defun get-proc-fd-field (s field) (if s (do ((line (read-line s nil nil) (read-line s nil nil))) ((null line) nil) (let ((split (cl-ppcre:split "\\s*:\\s*" line))) (when (string= (car split) field) (return (cadr split))))) "")) (defun mem-usage () "Returns a list containing 3 values: total amount of memory, allocated memory, allocated/total ratio" (let ((allocated 0)) (multiple-value-bind (mem-total mem-free buffers cached) (with-open-file (file #P"/proc/meminfo" :if-does-not-exist nil) (values (read-from-string (get-proc-fd-field file "MemTotal")) (read-from-string (get-proc-fd-field file "MemFree")) (read-from-string (get-proc-fd-field file "Buffers")) (read-from-string (get-proc-fd-field file "Cached")))) (setq allocated (- mem-total (+ mem-free buffers cached))) (list mem-total allocated (/ allocated mem-total))))) (defun fmt-mem-usage (ml) "Returns a string representing the current percent of used memory." (declare (ignore ml)) (let* ((mem (mem-usage)) (|%| (truncate (* 100 (nth 2 mem)))) (allocated (truncate (/ (nth 1 mem) 1000)))) (format nil "MEM: ~4D mb ^[~A~3D%^] " allocated (bar-zone-color |%|) |%|))) (defun fmt-mem-usage-bar (ml &optional (width *mem-usage-bar-width*) (full *mem-usage-bar-full*) (empty *mem-usage-bar-empty*)) "Returns a coloured bar-graph representing the current allocation of memory." (declare (ignore ml)) (let ((cpu (truncate (* 100 (nth 2 (mem-usage)))))) (stumpwm::bar cpu width full empty))) stumpwm-20110819.gitca08e08/contrib/mpd.lisp000066400000000000000000000713231162337705100203740ustar00rootroot00000000000000;;; MPD client & formatters for stumpwm ;;; ;;; Copyright 2007-2008 Morgan Veyret, Ivy Foster. ;;; ;;; Maintainer: Morgan Veyret ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load-module "mpd") ;;; ;;; ...into your ~/.stumpwmrc ;;; ;;; Then you can use "%m" in your mode line format, as well as various commands ;;; defined at the end of the file. ;;; ;;; You can customize the modeline format (*mpd-modeline-fmt*), the status ;;; message displayed by the command mpd-status (*mpd-status-fmt*; note that ;;; this is also used on the modeline), and the status message displayed by the ;;; command mpd-current-song (*mpd-current-song-fmt*). See the documentation for ;;; *mpd-modeline-fmt* for more information. ;;; NOTES: ;;; ;;; See http://mpd.wikia.com/wiki/Protocol_Reference for full protocol ;;; TODO: ;;; ;;; - Implement optional shortening for formatting functions ;;; - Implement notification window on song change etc... ;;; CODE: #-(or sbcl clisp) (error "unimplemented") (in-package :stumpwm) (export '(*mpd-timeout* *mpd-collapse-album-length* *mpd-collapse-all-length* *mpd-current-song-fmt* *mpd-formatters-alist* *mpd-status-fmt* *mpd-modeline-fmt* *mpd-volume-step* *mpd-port* mpd-browse-playlist select-song-from-playlist mpd-play mpd-toggle-repeat mpd-toggle-random mpd-toggle-pause mpd-kill mpd-disconnect mpd-connect *mpd-browse-menu-map* mpd-browse-artists mpd-browse-albums mpd-browse-genres mpd-browse-tracks mpd-update mpd-clear mpd-volume-down mpd-volume-up mpd-set-volume mpd-prev mpd-next mpd-stop mpd-play-track mpd-remove-track mpd-swap-tracks mpd-search-genre mpd-search-album mpd-search-title mpd-search-file mpd-search-artist mpd-search-and-add-genre mpd-search-and-add-album mpd-search-and-add-title mpd-search-and-add-file mpd-search-and-add-artist mpd-add-file mpd-playlist mpd-status mpd-current-song *mpd-map* *mpd-add-map* *mpd-browse-map* *mpd-search-map*)) ;;mpd client (defparameter *mpd-socket* nil) (defparameter *mpd-server* #+clisp "localhost" #+sbcl #(127 0 0 1) ) (defparameter *mpd-port* 6600) (defparameter *mpd-password* nil) (defvar *mpd-timeout* 50) (defvar *mpd-timer* nil) (defvar *mpd-collapse-album-length* nil) (defvar *mpd-collapse-all-length* nil) (defmacro with-mpd-connection (&body body) `(if *mpd-socket* (handler-case (progn ,@body) (error (c) (progn (message "Error with mpd connection: ~a" c) (setf *mpd-socket* nil) (when *mpd-timer* (cancel-timer *mpd-timer*))))) (message "Error: not connected to mpd"))) (defun mpd-send (command) "Send command to stream ending with newline" (with-mpd-connection (#+clisp ext:write-char-sequence #+sbcl write-sequence (concatenate 'string command (string #\Newline)) *mpd-socket*))) (defun mpd-send-command (cmd) (mpd-send cmd) (mpd-receive)) (defun mpd-format-command (fmt &rest args) (mpd-send-command (apply 'format nil fmt args))) (defun mpd-termination-p (str) (or (mpd-error-p str) (mpd-ok-p str))) (defun mpd-error-p (str) (when (>= (length str) 3) (equal (subseq str 0 3) "ACK"))) (defun mpd-ok-p (str) (equal str "OK")) (defun mpd-tokenize (str) (let ((pos (position #\: str))) (list (read-from-string (concatenate 'string ":" (subseq str 0 pos))) (subseq str (+ pos 2))))) (defun assoc-value (name list) (cadr (assoc name list))) (defun mpd-receive () "Returns a list containing all data sent by mpd." (with-mpd-connection (loop for i = (read-line *mpd-socket*) when (mpd-error-p i) do (message "Error sent back by mpd: ~a" i) until (mpd-termination-p i) collect (mpd-tokenize i)))) (defun init-mpd-connection () "Connect to mpd server" (setf *mpd-socket* #+clisp (handler-case (socket:socket-connect *mpd-port* *mpd-server* :element-type 'character) ((or system::simple-os-error error) (err) (format t "Error connecting to mpd: ~a~%" err))) #+sbcl (handler-case (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (sb-bsd-sockets:socket-connect s *mpd-server* *mpd-port*) (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :none)) ((or simple-error error) (err) (format t "Error connecting to mpd: ~a~%" err)))) (when *mpd-socket* (when *mpd-timeout* (setf *mpd-timer* (run-with-timer *mpd-timeout* *mpd-timeout* 'mpd-ping))) (read-line *mpd-socket*) (when *mpd-password* (mpd-format-command "password \"~a\"" *mpd-password*)))) (defun mpd-ping () (mpd-send-command "ping")) (defun mpd-search (type what &optional (exact-search nil)) (mpd-format-command "~a ~a \"~a\"" (if exact-search "find" "search") type what)) (defun mpd-add (files) (loop for i in files do (mpd-format-command "add \"~a\"" i))) ;;; ------------------------------------------------------------------ ;;; Formatting ;;; ------------------------------------------------------------------ (dolist (a '((#\m mpd-modeline))) (pushnew a *screen-mode-line-formatters* :test 'equal)) (defparameter *mpd-current-song* nil) (defparameter *mpd-status* nil) (defun mpd-update-current-song () (setf *mpd-current-song* (mpd-send-command "currentsong"))) (defun mpd-update-status () (setf *mpd-status* (mpd-send-command "status"))) (defun mpd-get-artist () (assoc-value :artist *mpd-current-song*)) (defun mpd-get-album () (assoc-value :album *mpd-current-song*)) (defun mpd-get-date () (assoc-value :date *mpd-current-song*)) (defun mpd-minutes-seconds (time) (let ((minutes) (seconds)) (if (< time 60) (progn (setf minutes 0) (setf seconds time)) (progn (setf minutes (write-to-string (floor time 60))) (setf seconds (rem time 60)))) (when (< seconds 10) (setf seconds (concat "0" (write-to-string seconds)))) (format nil "~a:~a" minutes seconds))) (defun mpd-get-elapsed () (let* ((total (assoc-value :time *mpd-current-song*)) (time (assoc-value :time *mpd-status*)) (elapsed (parse-integer (subseq time 0 (- (length time) (length total) 1))))) (mpd-minutes-seconds elapsed))) (defun mpd-get-length () (let ((time (parse-integer (assoc-value :time *mpd-current-song*))) (minutes) (seconds)) (mpd-minutes-seconds time))) (defun mpd-get-status () (cond ((equal (assoc-value :state *mpd-status*) "play") "Playing") ((equal (assoc-value :state *mpd-status*) "pause") "Paused") ((equal (assoc-value :state *mpd-status*) "stop") "Stopped"))) (defun mpd-get-file () (assoc-value :file *mpd-current-song*)) (defun mpd-get-volume () (assoc-value :volume *mpd-status*)) (defun mpd-get-xfade () (let ((xfade (assoc-value :xfade *mpd-status*))) (if (> (parse-integer xfade) 0) (format nil "F=~a" (assoc-value :xfade *mpd-status*)) "_"))) (defun mpd-get-genre () (assoc-value :genre *mpd-current-song*)) (defun mpd-get-number () (write-to-string (1+ (parse-integer (assoc-value :song *mpd-status*))))) (defun mpd-get-playlistlength () (assoc-value :playlistlength *mpd-status*)) (defun mpd-repeating-p () (if (string= (assoc-value :repeat *mpd-status*) "1") t nil)) (defun mpd-get-repeat () (if (mpd-repeating-p) "R" "_")) (defun mpd-shuffle-p () (if (string= (assoc-value :random *mpd-status*) "1") t nil)) (defun mpd-get-shuffle () (if (mpd-shuffle-p) "S" "_")) (defun mpd-get-title () (assoc-value :title *mpd-current-song*)) (defun mpd-get-track () (assoc-value :track *mpd-current-song*)) (defun mpd-get-song-name () (let* ((artist (assoc-value :artist *mpd-current-song*)) (album (assoc-value :album *mpd-current-song*)) (title (assoc-value :title *mpd-current-song*)) (file (assoc-value :file *mpd-current-song*)) (song (if (or (null artist) (null album) (null title)) (format nil "~a" file) (format nil "~a \"~a\" - ~a" artist (if (and *mpd-collapse-album-length* (> (length album) *mpd-collapse-album-length*)) (concatenate 'string (subseq album 0 *mpd-collapse-album-length*) "...") album) title)))) (if (and *mpd-collapse-all-length* (> (length song) *mpd-collapse-all-length*)) (concatenate 'string (subseq song 0 *mpd-collapse-all-length*) "...") song))) (defun mpd-modeline (ml) (declare (ignore ml)) (if *mpd-socket* (with-mpd-connection (mpd-update-status) (if (equal "Stopped" (mpd-get-status)) (format-expand *mpd-formatters-alist* *mpd-status-fmt*) (progn (mpd-update-current-song) (format-expand *mpd-formatters-alist* *mpd-modeline-fmt*)))) "Not connected to mpd")) (defvar *mpd-formatters-alist* '((#\a mpd-get-artist) (#\A mpd-get-album) (#\d mpd-get-date) (#\e mpd-get-elapsed) (#\f mpd-get-file) (#\F mpd-get-xfade) (#\g mpd-get-genre) (#\l mpd-get-length) (#\n mpd-get-number) (#\p mpd-get-playlistlength) (#\r mpd-get-repeat) (#\s mpd-get-shuffle) (#\S mpd-get-status) (#\t mpd-get-title) (#\T mpd-get-track) (#\v mpd-get-volume) (#\m mpd-get-song-name))) (defvar *mpd-current-song-fmt* "%a %A %t (%n/%p)" "The default value for displaying the current song. For more information on valid formatters, please see the documentation for `*mpd-modeline-fmt*'") (defvar *mpd-status-fmt* "%S [%s;%r;%F]" "The default value for displaying the current MPD status. For more information on valid formatters, please see the documentation for `*mpd-modeline-fmt*'") (defvar *mpd-modeline-fmt* "%S [%s;%r;%F]: %a - %A - %t (%n/%p)" "The default value for displaying MPD information on the modeline. @table @asis @item %% A literal '%' @item %a Artist @item %A Album @item %d Date @item %e Elapsed time @item %f Filename @item %F 'F=#' if crossfade is set, '_' otherwise @item %g Genre @item %l Song length @item %n Position in playlist (song Number, for a mnemonic) @item %p Total playlist length @item %r 'R' if repeat is on, '_' otherwise @item %s 'S' if shuffle is on, '_' otherwise @item %S 'Playing' if playing, 'Paused' if paused, else 'Stopped' @item %t Title @item %T Track number (relative to the album, not the playlist) @item %v Volume @end table ") ;;; ------------------------------------------------------------------ ;;; Misc. commands ;;; ------------------------------------------------------------------ (defvar *mpd-volume-step* 5) (defun mpd-menu (title options keymap &optional initial-selection) (let ((*menu-map* keymap)) (multiple-value-bind (choice selection) (select-from-menu (current-screen) options title (or initial-selection 0)) (cond ((null choice) (throw 'stumpwm::error "Abort.")) (t (values choice selection)))))) (defun mpd-selected-item (menu) (nth (menu-state-selected menu) (menu-state-table menu))) (defun mpd-menu-action (action-type) (lambda (menu) (declare (ignore menu)) (setf *current-menu-input* "") (throw :menu-quit (values action-type (mpd-selected-item menu))))) ;; playlist navigation/edition (defvar *mpd-playlist-menu-map* nil) (when (null *mpd-playlist-menu-map*) (setf *mpd-playlist-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 "k") 'menu-up) (define-key m (kbd "C-n") 'menu-down) (define-key m (kbd "Down") 'menu-down) (define-key m (kbd "j") 'menu-down) (define-key m (kbd "C-g") 'menu-abort) (define-key m (kbd "ESC") 'menu-abort) (define-key m (kbd "S-Up") (mpd-menu-action :mpd-playlist-move-up)) (define-key m (kbd "S-Down") (mpd-menu-action :mpd-playlist-move-down)) (define-key m (kbd "d") (mpd-menu-action :mpd-playlist-delete)) (define-key m (kbd "RET") (mpd-menu-action :mpd-playlist-play)) m))) (defun mpd-uniq-and-sort-list (list criteria &optional do-sort) (let ((lst (mapcar #'cadr (remove-if (lambda (item) (not (equal criteria (first item)))) list)))) (if do-sort (sort lst #'string<) lst))) (defcommand mpd-browse-playlist (&optional current-song) () (let* ((status (mpd-send-command "status")) (response (mpd-send-command "playlistinfo")) (options (mpd-uniq-and-sort-list response :file))) (multiple-value-bind (action choice) (mpd-menu "Current playlist" options *mpd-playlist-menu-map* (if current-song current-song (if (equal (assoc-value :state status) "play") (parse-integer (assoc-value :song status)) 0))) (let ((song-number (position choice options))) (case action (:mpd-playlist-move-up (if (= song-number 1) (mpd-browse-playlist song-number) (progn (mpd-swap-tracks song-number (1- song-number)) (mpd-browse-playlist (1- song-number))))) (:mpd-playlist-move-down (if (= song-number (length options)) (mpd-browse-playlist song-number) (progn (mpd-swap-tracks song-number (1+ song-number)) (mpd-browse-playlist (1+ song-number))))) (:mpd-playlist-delete (when song-number (mpd-remove-track song-number) (mpd-browse-playlist song-number))) (:mpd-playlist-play (when song-number (mpd-play-track song-number)))))))) (defcommand-alias select-song-from-playlist browse-playlist) ;; database browsing (defvar *mpd-browse-menu-map* nil) (when (null *mpd-browse-menu-map*) (setf *mpd-browse-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 "k") 'menu-up) (define-key m (kbd "C-n") 'menu-down) (define-key m (kbd "Down") 'menu-down) (define-key m (kbd "j") 'menu-down) (define-key m (kbd "C-g") 'menu-abort) (define-key m (kbd "ESC") 'menu-abort) (define-key m (kbd "RET") (mpd-menu-action :mpd-browse-add-and-quit)) (define-key m (kbd "S-RET") (mpd-menu-action :mpd-browse-add)) (define-key m (kbd "Right") (mpd-menu-action :mpd-browse-next)) (define-key m (kbd "Left") (mpd-menu-action :mpd-browse-previous)) m))) (defcommand mpd-browse-artists (&optional genre) () (let* ((response (mpd-send-command (if genre (format nil "list artist genre \"~a\"" genre) "list artist"))) (options (mpd-uniq-and-sort-list response :artist t))) (multiple-value-bind (action choice) (mpd-menu "Select artist" options *mpd-browse-menu-map*) (case action (:mpd-browse-add-and-quit (mpd-search-and-add-artist choice t)) (:mpd-browse-add (mpd-search-and-add-artist choice t) (mpd-browse-artists genre)) (:mpd-browse-previous (unless %interactivep% (mpd-browse-genres))) (:mpd-browse-next (mpd-browse-albums choice genre)))))) (defcommand mpd-browse-genres () () (let* ((response (mpd-send-command "list genre")) (options (mpd-uniq-and-sort-list response :genre t))) (multiple-value-bind (action choice) (mpd-menu "Select genre" options *mpd-browse-menu-map*) (case action (:mpd-browse-add-and-quit (mpd-search-and-add-genre choice t)) (:mpd-browse-add (mpd-search-and-add-genre choice t) (mpd-browse-genres)) (:mpd-browse-next (mpd-browse-artists choice)))))) (defcommand mpd-browse-albums (&optional artist genre) ((:string "Artist: ")) (let* ((response (mpd-send-command (if artist (format nil "list album artist \"~a\"" artist) "list album"))) (options (mpd-uniq-and-sort-list response :album))) (multiple-value-bind (action choice) (mpd-menu "Select album" options *mpd-browse-menu-map*) (case action (:mpd-browse-add-and-quit (mpd-search-and-add-album choice t)) (:mpd-browse-add (mpd-search-and-add-album choice t) (mpd-browse-albums artist genre)) (:mpd-browse-previous (unless %interactivep% (mpd-browse-artists genre))) (:mpd-browse-next (mpd-browse-tracks choice artist)))))) (defcommand mpd-browse-tracks (album &optional artist) ((:string "Album: ")) (let* ((response (mpd-send-command (format nil "list title album \"~a\"" album))) (options (mpd-uniq-and-sort-list response :title))) (multiple-value-bind (action choice) (mpd-menu "Select track" options *mpd-browse-menu-map*) (case action (:mpd-browse-add-and-quit (mpd-search-and-add-title choice t)) (:mpd-browse-add (mpd-search-and-add-title choice t) (mpd-browse-tracks album artist)) (:mpd-browse-previous (unless %interactivep% (mpd-browse-albums artist))))))) ;;misc. commands (defcommand mpd-connect () () (message "~a" (init-mpd-connection))) (defcommand mpd-disconnect () () "Disconnect from mpd server" (with-mpd-connection (close *mpd-socket*) (setf *mpd-socket* nil) (when *mpd-timer* (cancel-timer *mpd-timer*)))) (defcommand mpd-kill () () (mpd-send-command "kill")) (defcommand mpd-toggle-pause () () (mpd-update-status) (cond ((equal (mpd-get-status) "Playing") (mpd-send-command "pause 1")) ((equal (mpd-get-status) "Paused") (mpd-send-command "pause 0")) ((equal (mpd-get-status) "Stopped") (mpd-play)))) (defcommand mpd-toggle-random () () (mpd-update-status) (if (mpd-shuffle-p) (mpd-send-command "random 0") (mpd-send-command "random 1"))) (defcommand mpd-toggle-repeat () () (mpd-update-status) (if (mpd-repeating-p) (mpd-send-command "repeat 0") (mpd-send-command "repeat 1"))) (defvar *mpd-xfade-default* 5 "The value to which to set crossfade by default. Can be set in your rc or using `mpd-set-xfade' (this session only).") (defcommand mpd-toggle-xfade () () "Toggles crossfade. Uses `mpd-xfade-default' when turning crossfade on." (if (equal (assoc-value :xfade *mpd-status*) "0") (mpd-send-command (concat "crossfade " (write-to-string *mpd-xfade-default*))) (mpd-send-command "crossfade 0"))) (defcommand mpd-set-xfade (xfade) ((:number "Fade: ")) "Sets the crossfade to the specified value (in seconds). Passed an argument of zero and if crossfade is on, toggles crossfade off." (unless (equal xfade 0) (setf *mpd-xfade-default* xfade)) (mpd-send-command (concat "crossfade " (write-to-string xfade)))) (defcommand mpd-play () () (mpd-send-command "play")) (defcommand mpd-play-track (track) ((:number "Track: ")) (mpd-format-command "play ~d" track)) (defcommand mpd-stop () () (mpd-send-command "stop")) (defcommand mpd-next () () (mpd-send-command "next")) (defcommand mpd-prev () () (mpd-send-command "previous")) (defcommand mpd-set-volume (vol) ((:number "Set volume to: ")) (mpd-send-command (format nil "setvol ~a" vol))) (defcommand mpd-volume-up () () (let* ((status (mpd-send-command "status")) (vol (read-from-string (assoc-value :volume status)))) (mpd-send-command (format nil "setvol ~a" (+ vol *mpd-volume-step*))))) (defcommand mpd-volume-down () () (let* ((status (mpd-send-command "status")) (vol (read-from-string (assoc-value :volume status)))) (mpd-send-command (format nil "setvol ~a" (- vol *mpd-volume-step*))))) (defcommand mpd-clear () () (mpd-send-command "clear")) (defcommand mpd-update (&optional (path nil)) () (if path (message "~a" (mpd-format-command "update ~a" path)) (message "~a" (mpd-send-command "update")))) (defcommand mpd-current-song () () (mpd-update-current-song) (mpd-update-status) (message "~a" (format-expand *mpd-formatters-alist* *mpd-current-song-fmt*))) (defcommand mpd-status () () (mpd-update-status) (mpd-update-current-song) (message "~a" (format-expand *mpd-formatters-alist* *mpd-status-fmt*))) (defcommand mpd-playlist () () (let* ((response (mpd-send-command "playlistinfo")) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (if (< (length result) 80) (message "Current playlist (~a): ~%^7*~{~a~%~}" (length result) result) (message "~a files in playlist" (length result))))) (defcommand mpd-add-file (file) ((:rest "Add file to playlist: ")) (mpd-format-command "add \"~a\"" file)) (defcommand mpd-remove-track (track-number) ((:number "Delete track number: ")) (mpd-format-command "delete ~d" track-number)) (defcommand mpd-swap-tracks (track-1 track-2) () (mpd-format-command "swap ~d ~d" track-1 track-2)) ;;search and add commands (defcommand mpd-search-and-add-artist (what &optional (exact-search nil)) ((:rest "Search & add artist to playlist: ")) (let* ((response (mpd-search "artist" what exact-search)) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (mpd-add result) (if (< (length result) 80) (message "Added ~a files: ~%^7*~{~a~%~}" (length result) result) (message "~a files added" (length result))))) (defcommand mpd-search-and-add-file (what &optional (exact-search nil)) ((:rest "Search & add file to playlist: ")) (let* ((response (mpd-search "file" what exact-search)) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (mpd-add result) (if (< (length result) 80) (message "Added ~a files: ~%^7*~{~a~%~}" (length result) result) (message "~a files added" (length result))))) (defcommand mpd-search-and-add-title (what &optional (exact-search nil)) ((:rest "Search & add title to playlist: ")) (let* ((response (mpd-search "title" what exact-search)) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (mpd-add result) (if (< (length result) 80) (message "Added ~a files: ~%^7*~{~a~%~}" (length result) result) (message "~a files added" (length result))))) (defcommand mpd-search-and-add-album (what &optional (exact-search nil)) ((:rest "Search & add album to playlist: ")) (let* ((response (mpd-search "album" what exact-search)) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (mpd-add result) (if (< (length result) 80) (message "Added ~a files: ~%^7*~{~a~%~}" (length result) result) (message "~a files added" (length result))))) (defcommand mpd-search-and-add-genre (what &optional (exact-search nil)) ((:rest "Search & add genre to playlist: ")) (let* ((response (mpd-search "genre" what exact-search)) (result (mapcar #'cadr (remove-if (lambda (item) (not (equal :file (first item)))) response)))) (mpd-add result) (if (< (length result) 80) (message "Added ~a files: ~%^7*~{~a~%~}" (length result) result) (message "~a files added" (length result))))) ;;search commands (defcommand mpd-search-artist (what) ((:rest "Search artist: ")) (mpd-send-command (format nil "search artist \"~a\"" what))) (defcommand mpd-search-file (what) ((:rest "Search file: ")) (mpd-send-command (format nil "search file \"~a\"" what))) (defcommand mpd-search-title (what) ((:rest "Search title: ")) (mpd-send-command (format nil "search title \"~a\"" what))) (defcommand mpd-search-album (what) ((:rest "Search album: ")) (mpd-send-command (format nil "search album \"~a\"" what))) (defcommand mpd-search-genre (what) ((:rest "Search genre: ")) (mpd-send-command (format nil "search genre \"~a\"" what))) (defvar *mpd-search-map* nil) (defvar *mpd-browse-map* nil) (defvar *mpd-add-map* nil) (defvar *mpd-map* nil) ;;Key map (fill-keymap *mpd-search-map* (kbd "a") "mpd-search-artist" (kbd "A") "mpd-search-album" (kbd "t") "mpd-search-title" (kbd "f") "mpd-search-file" (kbd "g") "mpd-search-genre") (fill-keymap *mpd-browse-map* (kbd "p") "mpd-browse-playlist" (kbd "l") "mpd-browse-albums" (kbd "g") "mpd-browse-genres" (kbd "t") "mpd-browse-tracks" (kbd "a") "mpd-browse-artists") (fill-keymap *mpd-add-map* (kbd "a") "mpd-search-and-add-artist" (kbd "A") "mpd-search-and-add-album" (kbd "t") "mpd-search-and-add-title" (kbd "f") "mpd-search-and-add-file" (kbd "g") "mpd-search-and-add-genre" (kbd "F") "mpd-add-file") (fill-keymap *mpd-map* (kbd "SPC") "mpd-toggle-pause" (kbd "s") "mpd-toggle-random" (kbd "r") "mpd-toggle-repeat" (kbd "f") "mpd-toggle-xfade" (kbd "F") "mpd-set-xfade" (kbd "S") "mpd-current-song" (kbd "p") "mpd-play" (kbd "q") "mpd-browse-playlist" (kbd "o") "mpd-stop" (kbd "m") "mpd-next" (kbd "l") "mpd-prev" (kbd "c") "mpd-clear" (kbd "x") "mpd-connect" (kbd "k") "mpd-kill" (kbd "u") "mpd-update" (kbd "a") "mpd-search-and-add-artist" (kbd "z") "mpd-playlist" (kbd "v") "mpd-set-volume" (kbd "e") "mpd-volume-up" (kbd "d") "mpd-volume-down" (kbd "S") '*mpd-search-map* (kbd "b") '*mpd-browse-map* (kbd "A") '*mpd-add-map*) ;;; End of file stumpwm-20110819.gitca08e08/contrib/net.lisp000066400000000000000000000114501162337705100203750ustar00rootroot00000000000000;;; Network activity formatter for the mode-line ;;; ;;; Copyright 2009 Vitaly Mayatskikh ;;; ;;; Maintainer: ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; USAGE: ;;; ;;; Put: ;;; ;;; (load "/path/to/net.lisp") ;;; ;;; In your ~/.stumpwmrc ;;; ;;; Then you can use "%l" in your mode line format. ;;; ;;; NOTES: ;;; ;;; This is specific to Linux. (defpackage :stumpwm.contrib.net (:use :common-lisp :stumpwm :cl-ppcre) (:export #:*net-device*)) (in-package :stumpwm.contrib.net) ;; Install formatters. (dolist (a '((#\l fmt-net-usage))) (pushnew a *screen-mode-line-formatters* :test 'equal)) (defvar *net-device* nil) ; nil means auto. or specify explicitly, i.e. "wlan0" (defvar *net-last-rx* 0) (defvar *net-last-tx* 0) (defvar *net-last-time* nil) (defvar *net-rx* nil) (defvar *net-tx* nil) (defvar *net-time* nil) ;; stuff for parsing /proc/net/route (defconstant +iface+ 0) (defconstant +destination+ 1) (defconstant +gateway+ 2) (defconstant +flags+ 3) (defconstant +mask+ 7) (defconstant +ipv4-zero+ "00000000") (defun now () (/ (get-internal-real-time) internal-time-units-per-second)) (defvar *last-route-rescan-time* (now)) (defvar *last-route-device* nil) (defun find-default () "Tries to found device with default route. NIL if none." (with-open-file (file #P"/proc/net/route" :if-does-not-exist nil) (when file (read-line file nil) ; skip desc (loop :as line = (read-line file nil) :when (null line) :return nil :do (let ((split (cl-ppcre:split "\\s+" line))) (when (and (string= (nth +destination+ split) +ipv4-zero+) (string= (nth +mask+ split) +ipv4-zero+) (logand (parse-integer (nth +flags+ split) :junk-allowed t) 2)) (return (nth +iface+ split)))))))) (defun net-device () "Returns statically assigned device name or tries to find it be default gw. For the second case rescans route table every minute." (if *net-device* *net-device* (if (and *last-route-device* (< (- (now) *last-route-rescan-time*) 60)) *last-route-device* (let ((new-device (or (find-default) "lo"))) (when (string/= new-device *last-route-device*) (setq *net-last-tx* 0 *net-last-rx* 0 *net-last-time* nil *net-rx* nil *net-tx* nil *net-time* nil)) (setq *last-route-rescan-time* (now) *last-route-device* new-device))))) (defun net-sys-stat-read (device stat-file) (with-open-file (file (concatenate 'string "/sys/class/net/" device "/statistics/" stat-file) :if-does-not-exist nil) (if file (parse-integer (read-line-from-sysfs file) :junk-allowed t) (progn (setq *net-device* nil *last-route-device* nil) 0)))) (defun net-usage () "Returns a list of 2 values: rx and tx bytes/second." (let ((now (now)) (rx-s 0.0) (tx-s 0.0) (t-s 0.1) ; don't want division by zero (rx (net-sys-stat-read (net-device) "rx_bytes")) (tx (net-sys-stat-read (net-device) "tx_bytes"))) (when (and *net-last-time* (> (- now *net-last-time*) 0.0)) (let ((drx (/ (- rx *net-last-rx*) (- now *net-last-time*))) (dtx (/ (- tx *net-last-tx*) (- now *net-last-time*)))) (push drx *net-rx*) (push dtx *net-tx*) (push now *net-time*) (when (> (length *net-time*) 1) (dotimes (i (1- (length *net-time*))) (let ((dt (- (nth (1+ i) *net-time*) (nth i *net-time*))) (rx (nth i *net-rx*)) (tx (nth i *net-tx*))) (incf rx-s (* rx dt)) (incf tx-s (* tx dt)) (incf t-s dt))) ;; cut off old values (when (> (length *net-time*) 5) (pop *net-rx*) (pop *net-tx*) (pop *net-time*))))) (setq *net-last-rx* rx *net-last-tx* tx *net-last-time* now) (list (round (/ rx-s t-s)) (round (/ tx-s t-s))))) (defun fmt-net-usage (ml) "Returns a string representing the current network activity." (declare (ignore ml)) (let ((net (net-usage)) dn up) (defun kbmb (x y) (if (>= (/ x 1e6) y) (list (/ x 1e6) "m") (list (/ x 1e3) "k"))) (setq dn (kbmb (car net) 0.1) up (kbmb (cadr net) 0.1)) (format nil "~A: ~5,2F~A/~5,2F~A " (net-device) (car dn) (cadr dn) (car up) (cadr up)))) stumpwm-20110819.gitca08e08/contrib/notifications.lisp000066400000000000000000000106361162337705100224650ustar00rootroot00000000000000;;; notifications.lisp -- Poor man's systray for StumpWM ;; Copyright 2008 Tassilo Horn ;; ;; Maintainer: ;; ;; This program is free software: you can redistribute it and/or modify it under ;; the terms of the GNU General Public License as published by the Free Software ;; Foundation, either version 3 of the License, or (at your option) any later ;; version. ;; ;; This program is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for ;; more details. ;; ;; You should have received a copy of the GNU General Public License along with ;; this program. If not, see . ;;; Usage: ;; This StumpWM module acts as notification monitor for external applications. ;; They can send messages via `stumpish' which will be displayed in the ;; mode-line. (Thus `stumpish' has to be in your PATH.) ;; ;; To use it add this to your ~/.stumpwmrc.lisp: ;; ;; (load "/path/to/stumpwm/contrib/notifications.lisp") ;; ;; Then add the formatter %N to your mode-line spec, i.e. like this: ;; ;; (setf *screen-mode-line-format* "[%W] {%g} (%N)") ;; ;; You might want to bind *notifications-map* to a key: ;; ;; (define-key *root-map* (kbd "N") '*notifications-map*) ;; ;; With this map you can add notifications with a, reset them with r, delete ;; the first/last with d/D or show them in a popup with s. ;; ;; External applications can add notification messages using stumpish: ;; ;; $ stumpish notifications-add 'Foo Bar Baz' ;; ;; For example this is the elisp code that I use to let rcirc (an Emacs IRC ;; client) notify me when a message with my nickname or a IM message arrives: ;; ;; (defun th-rcirc-notification (process sender response target text) ;; (let ((my-nick (rcirc-nick process))) ;; (when (and (string= response "PRIVMSG") ;; (not (string= sender my-nick)) ;; (or ;; ;; BitlBee IM messages ;; (string-match "localhost" (format "%s" process)) ;; ;; Messages that mention my name ;; (string-match my-nick text))) ;; (th-notifications-add (concat "rcirc: " target))))) ;; ;; (add-hook 'rcirc-print-hooks 'th-rcirc-notification) ;; ;; (defun th-notifications-add (str) ;; (interactive "sNotification: ") ;; (start-process "notifications-add" nil ;; "stumpish" "notifications-add" str)) ;; ;;; Code: (in-package :stumpwm) (pushnew '(#\N notifications-as-string) *screen-mode-line-formatters* :test 'equal) (defparameter *notifications-delimiters* '("[" "]")) (defvar notifications nil "A list of notification strings.") (defcommand notifications-add (str) ((:rest "Notification: ")) "Add a notification string. If a notification is already included, it will be moved to the front instead of added anew." (when (not (string= (car notifications) str)) (when (member str notifications :test #'string=) (setf notifications (delete str notifications :test #'string=))) (push str notifications))) (defcommand notifications-reset () () "Clear all notifications." (setf notifications nil)) (defcommand notifications-delete (str) () "Delete the specified notification." (setf notifications (delete str notifications :test #'string=))) (defcommand notifications-delete-first () () "Delete the first notification." (setf notifications (cdr notifications))) (defcommand notifications-delete-last () () "Delete the first notification." (setf notifications (nreverse (cdr (nreverse notifications))))) (defun notifications-as-string (&rest r) (declare (ignore r)) (if notifications (format nil "~a ~{ ~a ~#[~:;;~]~} ~a" (first *notifications-delimiters*) notifications (second *notifications-delimiters*)) "")) (defcommand notifications-show () () "Messages all notifications." (message "Notifications: ~a" (notifications-as-string))) (defvar *notifications-map* (let ((m (make-sparse-keymap))) (define-key m (kbd "a") "notifications-add") (define-key m (kbd "r") "notifications-reset") (define-key m (kbd "d") "notifications-delete-first") (define-key m (kbd "D") "notifications-delete-last") (define-key m (kbd "s") "notifications-show") m)) ;; Local Variables: ;; mode: outline-minor ;; coding: utf-8 ;; End: stumpwm-20110819.gitca08e08/contrib/passwd.lisp000066400000000000000000000045051162337705100211130ustar00rootroot00000000000000(in-package :stumpwm-user) (export '(*hmac-static-seed* *passphrase-remember-timeout*)) (require 'ironclad) (defvar *hmac-static-seed* nil "Static seed appended to the passphrase to add even more entropy") (defvar *passphrase-remember-timeout* 5 "How long will the passphrase be remembered (in minutes)") (defvar *clipboard-clear-timeout* 10 "How long will the passphrase be remembered (in seconds)") (defvar *hmac-algo* :sha1 "Hashing algorithm used by ironclad to compute the HMAC") (defvar *passphrase* nil) (defvar *passphrase-timer* #+sbcl (sb-ext:make-timer (lambda () (setf *passphrase* nil))) #-sbcl (error 'not-implemented)) (defvar *old-clipboard* nil) (defvar *clipboard-timer* #+sbcl (sb-ext:make-timer (lambda () (set-x-selection *old-clipboard*) (setf *old-clipboard* nil))) #-sbcl (error 'not-implemented)) (define-stumpwm-type :hmac-passphrase (input prompt) (or *passphrase* (setf *passphrase* (or (argument-pop-rest input) (read-one-line (current-screen) prompt :password t))))) (defun reset-timer (timer timeout) #+sbcl (progn (when (sb-ext:timer-scheduled-p timer) (sb-ext:unschedule-timer timer)) (sb-ext:schedule-timer timer timeout)) #-sbcl (error 'not-implemented)) (defcommand get-password (pass key) ((:hmac-passphrase "Key: ") (:rest "Password for: ")) (let ((hmac (ironclad:make-hmac (ironclad:ascii-string-to-byte-array (concatenate 'string pass *hmac-static-seed*)) *hmac-algo*))) (ironclad:update-hmac hmac (ironclad:ascii-string-to-byte-array key)) (unless *old-clipboard* (setf *old-clipboard* (get-x-selection))) (when (and *clipboard-clear-timeout* (> *clipboard-clear-timeout* 0)) (reset-timer *clipboard-timer* *clipboard-clear-timeout*)) (if (and *passphrase-remember-timeout* (> *passphrase-remember-timeout* 0)) (reset-timer *passphrase-timer* (* *passphrase-remember-timeout* 60)) (setf *passphrase* nil)) (set-x-selection (ironclad:byte-array-to-hex-string (ironclad:hmac-digest hmac))) (message "Copied to clipboard"))) (setf *passphrase* nil) stumpwm-20110819.gitca08e08/contrib/productivity.lisp000066400000000000000000000126701162337705100223610ustar00rootroot00000000000000;; Productivity module for StumpWM. ;; ;; Copyright (C) 2008 Ivy Foster ;; ;; Maintainer: Ivy Foster ;; ;; This module 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. ;; ;; This module 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: ;; ;; There are those for whom simply using a window manager like StumpWM ;; is enough to force them to buckle down and work, mostly because ;; they don't know how to play around with it (due to a lack of ;; frills). However, there are also those who know how to move around ;; in StumpWM and who may find themselves falling into the same bad ;; habits as those who use "normal" WMs; that is, switching between ;; windows a lot and fiddling with random functions the WM has ;; available. This fixes that by temporarily disabling StumpWM. ;; ;; Incidentally, I'm not positive, but I believe that this may be ;; StumpWM's first Minor Mode. ;;; Usage: ;; ;; Just add the following line to your .stumpwmrc file: ;; ;; (load-module "productivity") ;; ;; ...and then bind `productivity-mode-toggle' to a key in your ;; *top-map*. I recommend H-# (Hyper-shift-3). ;; ;; When you activate productivity-mode, you won't be able to access ;; any of your StumpWM keymaps. That's right--the window manager is ;; effectively disabled! If you try to leave the window, or display ;; the time, or go to another group, or control MPD, or switch frames, ;; or whatever, you will instead be presented with a curt reminder of ;; what you're supposed to be doing. To escape from this mode, just ;; hit the key you have `productivity-mode-toggle' bound to again. ;; ;; Absolutely DO NOT start productivity-mode from your .stumpwmrc file ;; unless you (a) are absolutely *sure* you have ;; productivity-mode-toggle bound to a key already, (b) automatically ;; switch to a window capable of controlling StumpWM (i.e., Emacs or a ;; terminal) in your .stumpwmrc, (c) want to convince your friends ;; your computer is broken, or (d) are crazy. ;;; Configuration: ;; ;; The following can be customized. If no example is given, please see ;; the code. ;; ;; `*productivity-keys*': Any and all keys you have bound to the ;; *top-map* and their associated commands. ;; ex: ;; (setf *productivity-keys* ;; '(("H-t" *root-map*) ;; ("C-;" *rat-map*) ;; ("Print" "screenshot"))) ;; ;; `*productivity-start-message*': What StumpWM should print when you ;; start productivity-mode. ;; ;; `*productivity-stop-message*': What StumpWM should print when you ;; stop productivity-mode ;; ;; `*productivity-back-to-work-message*': What StumpWM should print ;; when you attempt to waste time (you lazy, lazy, um...lazy ;; person). ;;; TODO: ;; ;; - [ ] Add an option to toggle the mode-line on and off. ;; ;; - [ ] Add an option to display a notifier for this mode, when on, ;; in the mode-line (a la Emacs' minor modes). ;; ;; - Perhaps this could be integrated into a "minor modes" ;; package? (Just in case somebody insinuates that StumpWM ;; doesn't have *everything*.) ;; ;; - [ ] Add a timer feature (i.e., have it toggle itself at a given ;; interval or hour, so you can have your work time and ;; messing-around-on-the-computer time predetermined). ;; ;; - [ ] Add an option to disable stumpish, slime and/or ;; stumpwm-mode.el (choose your poison/s). ;; ;; - [ ] Make it do your work for you. ;; ;; - Note to self: Finish this one first, then have it write the ;; rest for you. ;;; Code: (defvar *productivity-mode-is-on* nil "Is productivity-mode on? Do not customize by hand unless you're crazy.") (defvar *productivity-keys* '(("C-t" *root-map*)) "List of all the keys you have bound to your `*top-map*' and their associated commands.") (defvar *productivity-stop-message* "Break time!" "What should StumpWM print when you stop productivity-mode?") (defvar *productivity-start-message* "Get to work!" "What should StumpWM print when you start productivity-mode?") (defvar *productivity-back-to-work-message* "Get back to work!" "What should StumpWM print when you attempt to waste time?") (defcommand productivity-back-to-work () () (message *productivity-back-to-work-message*)) (defun productivity-mode-on () "Turns on productivity mode. Do not call interactively." (setf *productivity-mode-is-on* t) (dolist (key *productivity-keys*) (define-key *top-map* (kbd (car key)) "productivity-back-to-work")) (message *productivity-start-message*)) (defun productivity-mode-off () "Turns off productivity mode. Do not call interactively." (setf *productivity-mode-is-on* nil) (dolist (key *productivity-keys*) (define-key *top-map* (kbd (car key)) (cadr key))) (message *productivity-stop-message*)) (defcommand productivity-mode-toggle () () "Toggles productivity mode." (if *productivity-mode-is-on* (productivity-mode-off) (productivity-mode-on))) ;;; End of file stumpwm-20110819.gitca08e08/contrib/sbclfix.lisp000066400000000000000000000103351162337705100212420ustar00rootroot00000000000000;;; Amixer module for StumpWM. ;;; ;;; Copyright 2008 Julian Stecklina ;;; ;;; Maintainer: Julian Stecklina ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; Thanks to Fredrik Tolf for formatting it as a stumpwm module. (in-package :stumpwm-user) ;;; Overview of the Problem ;;; ;;; Stumpwm's EXEC-AND-COLLECT-OUTPUT tends to hang in all recent SBCL ;;; versions (at least until 1.0.22) in rare cases which in turn ;;; causes stumpwm to stop servicing requests and generally freezes ;;; your desktop. The problem is a unsafe signal handler in SBCL's ;;; RUN-PROGRAM. To quote François-René Rideau from the SBCL-DEVEL ;;; mailing list: ;;; ;;; [...] Long story short: SBCL tries to do excessively clever ;;; things inside signal handlers to track the status of children ;;; processes. This is a bad idea, because a signal handler can ;;; catch the Lisp with its pants down [...] ;;; ;;; The whole thread can be found at: ;;; http://sourceforge.net/mailarchive/message.php?msg_id=87wsgazm20.fsf%40tabernacle.localnet ;;; ;;; Based on explanations in the above mentioned thread, I implemented ;;; a workaround without using signals for ;;; EXEC-AND-COLLECT-OUTPUT. Stumpwm's RUN-PROG should not be affected ;;; by this bug. #+sbcl (progn (defun exec-and-collect-output (name args env) "Runs the command NAME with ARGS as parameters and return everything the command has printed on stdout as string." (flet ((to-simple-strings (string-list) (mapcar (lambda (x) (coerce x 'simple-string)) string-list))) (let ((simplified-args (to-simple-strings (cons name args))) (simplified-env (to-simple-strings env)) (progname (sb-impl::native-namestring name)) (devnull (sb-posix:open "/dev/null" sb-posix:o-rdwr))) (multiple-value-bind (pipe-read pipe-write) (sb-posix:pipe) (unwind-protect (let ((child ;; Any nicer way to do this? (sb-sys:without-gcing (sb-impl::with-c-strvec (c-argv simplified-args) (sb-impl::with-c-strvec (c-env simplified-env) (sb-impl::spawn progname c-argv devnull pipe-write ; stdout devnull 1 c-env nil ; PTY 1 ; wait? (seems to do nothing) )))))) (when (= child -1) (error "Starting ~A failed." name)) ;; We need to close this end of the pipe to get EOF when the child is done. (sb-posix:close pipe-write) (setq pipe-write nil) (with-output-to-string (out) ;; XXX Could probably be optimized. But shouldn't ;; make a difference for our use case. (loop with in-stream = (sb-sys:make-fd-stream pipe-read :buffering :none) for char = (read-char in-stream nil nil) while char do (write-char char out)) ;; The child is now finished. Call waitpid to avoid ;; creating zombies. (handler-case (sb-posix:waitpid child 0) (sb-posix:syscall-error () ;; If we get a syscall-error, RUN-PROGRAM's ;; SIGCHLD handler probably retired our child ;; already. So we are fine here to ignore this. nil)))) ;; Cleanup (sb-posix:close pipe-read) (when pipe-write (sb-posix:close pipe-write)) (sb-posix:close devnull)))))) (defun stumpwm::run-prog-collect-output (prog &rest args) "run a command and read its output." (exec-and-collect-output prog args (cons (stumpwm::screen-display-string (current-screen)) (remove-if (lambda (str) (string= "DISPLAY=" str :end2 (min 8 (length str)))) (sb-ext:posix-environ)))))) ;;; EOF stumpwm-20110819.gitca08e08/contrib/stumpish000077500000000000000000000101231162337705100205140ustar00rootroot00000000000000#!/bin/sh # Copyright (C) 2007 Jonathan Moore Liles # # Maintainer: Jonathan Moore Liles # # stumpish 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. # # stumpish 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 ### STUMPwm Interactive SHell. DELAY=0.01 if ! sleep $DELAY 2>/dev/null >&2 then DELAY=1 fi # replace -E with -r option for old versions of GNU sed if ! sed -E 1p /dev/null 2>/dev/null; then sed() { shift; command sed -r "$@"; } fi # parse C-style backslash sequences by default if [ "$(echo -e foo)" = foo ]; then echo() { builtin echo -e "$@"; } fi wait_result () { while true do RESULT=$(xprop -root -f STUMPWM_COMMAND_RESULT 8s \ STUMPWM_COMMAND_RESULT 2>/dev/null | sed -E 's/\\([[:digit:]]+)/\\0\1/g') if echo "$RESULT" | grep -v -q 'not found.$' then break fi sleep $DELAY done xprop -root -remove STUMPWM_COMMAND_RESULT if echo "$RESULT" | grep -q '= $' then return 1 fi echo "$RESULT" | sed -E 's/[^"\\n]+"// /^"[[:space:]]*$/d s/(^|[^\\])\\n/\1\ /g s/\\(["\\n])/\1/g s/\^([*[:digit:]]+|[Bbn])//g' } send_cmd () { local cmd="$1" if [ "$cmd" = "stumpwm-quit" ] then cmd=quit elif [ "$cmd" = "quit" ] then exit fi xprop -root -f STUMPWM_COMMAND 8s -set STUMPWM_COMMAND "$cmd" wait_result } usage () { cat <&2 } tput () { local cap1=$1 cap2=$2 shift 2 command tput $cap1 $@ 2>/dev/null || command tput $cap2 $@ 2>/dev/null } READLINE=yes if [ "x$1" = "x-r" ] then READLINE=no shift 1 fi if [ $# -gt 0 ] then [ "$1" = "--help" ] && usage if [ "$1" = "-e" ] then if [ $# -ne 2 ] then echo "'-e' requires exactly one argument!" exit fi shift 1 IFS='' ARGS=$(cat /dev/stdin) send_cmd "$1 $ARGS" else IFS=' ' send_cmd "$*" fi else if [ -t 0 ] then if ! type rlwrap 2>/dev/null >&2 then warn rlwrap not found, command completion won\'t work elif [ $READLINE = yes ] then COMMANDS="${TMPDIR:-/tmp}/stumpish.commands.$$" echo $(send_cmd "commands") | sed -E 's/[[:space:]]+/\ /g' | sort > "$COMMANDS" trap 'rm -f "$COMMANDS"' exit int term rlwrap -b '' -f "$COMMANDS" "$0" -r exit fi tput AF setaf 5 echo Welcome to the STUMPwm Interactive SHell. tput me sgr0 echo 'Type \c' tput AF setaf 2 echo 'commands\c' tput me sgr0 echo \ for a list of commands. while read -p '> ' REPLY do tput md bold tput AF setaf 2 send_cmd "$REPLY" tput me sgr0 done else while read REPLY do send_cmd "$REPLY" done fi fi stumpwm-20110819.gitca08e08/contrib/stumpwm-mode.el000066400000000000000000000044511162337705100217010ustar00rootroot00000000000000;;; stumpwm-mode.el --- special lisp mode for evaluating code into running stumpwm ;; Copyright (C) 2007 Shawn Betts ;; Maintainer: Shawn Betts ;; Keywords: comm, lisp, tools ;; This file 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. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; load this file, set stumpwm-shell-program to point to stumpish and ;; run M-x stumpwm-mode in your stumpwm lisp files. Now, you can ;; easily eval code into a running stumpwm using the regular bindings. ;;; Code: (defvar stumpwm-shell-program "stumpish" "program name, including path if needed, for the stumpish program.") (define-minor-mode stumpwm-mode "add some bindings to eval code into a running stumpwm using stumpish." :global nil :lighter " StumpWM" :keymap (let ((m (make-sparse-keymap))) (define-key m (kbd "C-M-x") 'stumpwm-eval-defun) (define-key m (kbd "C-x C-e") 'stumpwm-eval-last-sexp) m)) (defun stumpwm-eval-region (start end) (interactive "r") (let ((s (buffer-substring-no-properties start end))) (message "%s" (with-temp-buffer (call-process stumpwm-shell-program nil (current-buffer) nil "eval" s) (delete-char -1) (buffer-string))))) (defun stumpwm-eval-defun () (interactive) (save-excursion (end-of-defun) (skip-chars-backward " \t\n\r\f") (let ((end (point))) (beginning-of-defun) (stumpwm-eval-region (point) end)))) (defun stumpwm-eval-last-sexp () (interactive) (stumpwm-eval-region (save-excursion (backward-sexp) (point)) (point))) (provide 'stumpwm-mode) ;;; stumpwm-mode.el ends here stumpwm-20110819.gitca08e08/contrib/surfraw.lisp000066400000000000000000000071561162337705100213100ustar00rootroot00000000000000;; SURFRAW module for StumpWM. ;; ;; Copyright (C) 2008 Ivy Foster ;; Copyright (C) 2010 Ivy Foster, Friedrich Delgado ;; ;; Maintainer: Ivy Foster ;; ;; This module 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. ;; ;; This module 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: ;; ;; I like surfraw (http://surfraw.alioth.debian.org). If you're ;; reading this, you probably like surfraw. I've got surfraw-related ;; code in my .stumpwmrc, and (judging from some judicious googling ;; for RC files early on in my use of stumpwm) I know that I'm not the ;; only one. So it seemed like a good idea to just put that code in ;; a library. ;;; Usage: ;; ;; Just add the following line to your .stumpwmrc file: ;; ;; (load "/path/to/stumpwm/contrib/surfraw.lisp") ;; ;; ...and then either call the functions here with "colon" (C-t ;) or ;; bind them to a key. I figure other people will probably have ;; different key preferences than I have, so I leave them entirely up ;; to you. ;; ;; If you want to use the bookmark functions, don't forget to tell ;; stumpwm where your *surfraw-bookmark-file* is. ;; ;; Note that there are also "surfraw-selection" variants on each ;; command that work on the X selection. ;;; Code: (defun split-by-- (str) (let ((pos (position #\- str :start (1+ (position #\- str))))) (list (subseq str 0 (1- pos)) (subseq str (1+ pos))))) (defun surfraw-elvis-list () (mapcar (lambda (x) (mapcar (lambda (x) (string-trim '(#\Space #\Tab #\Newline) x)) (split-by-- x))) (cdr (split-string (run-shell-command "surfraw -elvi" :collect-output-p) '(#\Newline))))) (defmacro auto-define-surfraw-commands-from-elvis-list () (let ((commands nil)) (dolist (elvi (surfraw-elvis-list)) (let ((key (first elvi)) (description (second elvi))) (push `(defcommand ,(intern (concat "sr-" key)) (search) ((:string ,(concat description ": "))) ,description (surfraw ,key search)) commands) (push `(defcommand ,(intern (concat "sr-sel-" key)) () () (surfraw ,key (get-x-selection))) commands))) (cons 'progn (reverse commands)))) (auto-define-surfraw-commands-from-elvis-list) ;;; Regular surfraw commands (defcommand surfraw (engine search) ((:string "What engine? ") (:string "Search for what? ")) "Use SURFRAW to surf the net; reclaim heathen lands." (check-type engine string) (check-type search string) (run-shell-command (concat "exec surfraw -g " engine " " search))) ;;; Bookmarks (defun display-file (file) "Display a file in the message area." (if (probe-file file) (run-shell-command (concat "cat " file) t) (message "The file ~a does not exist." file))) (defvar *surfraw-bookmark-file* nil "The surfraw bookmark file") (defcommand sr-bookmark (bmk) ((:string "Bookmark: ")) (surfraw "" bmk)) (defcommand sr-bookmark-file-display () () (display-file *surfraw-bookmark-file*)) ;;; surfraw.lisp ends here stumpwm-20110819.gitca08e08/contrib/undocumented.lisp000066400000000000000000000030521162337705100223000ustar00rootroot00000000000000;; Copyright (C) 2011 Ben Spencer ;; ;; This module 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. ;; This module 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: ;; ;; Look for stuff that should probably be in the manual that isn't ;; ;; Code: (in-package :stumpwm) (defun list-undocumented (&optional (manual #p"stumpwm.texi.in")) "List symbols that are exported from the stumpwm package and have documentation strings but do not appear in the manual" (let ((documented '())) (with-open-file (s manual :direction :input) (loop for line = (read-line s nil s) until (eq line s) do (ppcre:register-groups-bind (sym) ("^[@%#\\$!]{3} (.*)" line) (push sym documented)))) (loop for sym being the external-symbols in :stumpwm when (and (or (documentation sym 'function) (documentation sym 'variable)) (not (find sym documented :test #'string-equal))) collecting sym))) stumpwm-20110819.gitca08e08/contrib/wifi.lisp000066400000000000000000000111501162337705100205420ustar00rootroot00000000000000;;; Wifi formatter for the mode-line ;;; ;;; Copyright 2008 John Li ;;; ;;; Maintainer: John Li ;;; ;;; This module 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. ;;; ;;; This module 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 ;;; ;;; WARNING: ;;; ;;; This triggers a yet to be discovered bug in SBCL, which causes ;;; stumpwm to freeze. ;;; USAGE: ;;; ;;; Place the following in your ~/.stumpwmrc file: ;;; ;;; (load-module "wifi") ;;; ;;; Then you can use "%I" in your mode line format (both "w" and "W" ;;; were taken. Think _I_EEE 802.11 :-)). ;;; ;;; Notes: This gets information through sysfs, so it only works on ;;; Linux with a mounted sysfs. (defpackage :stumpwm.contrib.wifi (:use :common-lisp :stumpwm ) (:export #:*iwconfig-path* #:*wireless-device*)) (in-package :stumpwm.contrib.wifi) (defvar *iwconfig-path* "/sbin/iwconfig" "Location if iwconfig, defaults to /sbin/iwconfig.") (defvar *wireless-device* nil "Set to the name of the wireless device you want to monitor. If set to NIL, try to guess.") (defmacro defun-cached (name interval arglist &body body) "Creates a function that does simple caching. The body must be written in a functional style - the value returned is set as the prev-val." (let ((prev-time (gensym "PREV-TIME")) (prev-val (gensym "PREV-VAL")) (now (gensym "NOW")) (docstring (when (stringp (car body)) (pop body)))) `(let ((,prev-time 0) (,prev-val nil)) (defun ,name ,arglist ;; if no docstring, return nothing (not even nil) ,@(when docstring (list docstring)) (let ((,now (get-internal-real-time))) (when (>= (- ,now ,prev-time) (* ,interval internal-time-units-per-second)) (setf ,prev-time ,now) (setf ,prev-val (locally ,@body))) ,prev-val))))) (defun guess-wireless-device () (or (loop for path in (list-directory "/sys/class/net/") thereis (let ((device-name (car (last (pathname-directory path))))) (if (probe-file (merge-pathnames (make-pathname :directory '(:relative "wireless") :name "status") path)) device-name nil))) (error "No wireless device found."))) (defun read-wifi-info (device what) (let ((path (make-pathname :directory `(:absolute "sys" "class" "net" ,device "wireless")))) (with-open-file (in (merge-pathnames (make-pathname :name what) path)) (read-line-from-sysfs in)))) (defun read-wifi-info-int (device what) (parse-integer (read-wifi-info device what))) (defun-cached fmt-wifi 5 (ml) "Formatter for wifi status. Displays the ESSID of the access point you're connected to as well as the signal strength. When no valid data is found, just displays nil." (declare (ignore ml)) (handler-case (let* ((device (or *wireless-device* (guess-wireless-device))) (essid (multiple-value-bind (match? sub) (cl-ppcre:scan-to-strings "ESSID:\"(.*)\"" (run-shell-command (format nil "~A ~A 2>/dev/null" *iwconfig-path* device) t)) (if match? (aref sub 0) (return-from fmt-wifi "no link"))))) (let* ((qual (read-wifi-info-int device "link"))) (format nil "~A ^[~A~D%^]" essid (bar-zone-color qual 40 30 15 t) qual))) ;; CLISP has annoying newlines in their error messages... Just ;; print a string showing our confusion. (t (c) (format nil "~A" c)))) ;;; Add mode-line formatter (add-screen-mode-line-formatter #\I #'fmt-wifi) ;;; EOF stumpwm-20110819.gitca08e08/contrib/window-tags.lisp000066400000000000000000000223231162337705100220530ustar00rootroot00000000000000;; Copyright 2009 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 (in-package :stumpwm) ; Window tags. Window tags are special window properties (stored in X11 window properties) ; that can be used for window manipulations. They can survive temporary WM change and allow ; more flexible classification of windows than selecting window groups for them. ; String parsing for commands (defun string-split-by-spaces (x) (if (not x) nil (if (listp x) (mapcar 'string-upcase x) (cl-ppcre:split " " (string-upcase x))))) ; Basic operations (defcommand window-tags (&optional (argwin nil)) () "Show window tags" (let* ((win (or argwin (current-window))) (tags (xlib:get-property (window-xwin win) :STUMPWM_TAGS)) (tagstring (utf8-to-string tags)) (taglist (if tags (string-split-by-spaces tagstring) nil))) (if argwin taglist (message "Tags: ~{~%~a~}" taglist)))) (defun (setf window-tags) (newtags &optional (argwin nil)) "Set the window tag set for a window" (let* ((win (or argwin (current-window))) (tagstring (format nil "~{~a ~}" (mapcar 'string-upcase newtags)))) (xlib:change-property (window-xwin win) :STUMPWM_TAGS (string-to-utf8 tagstring) :UTF8_STRING 8))) (defun clear-tags-if (clearp &optional (argwin nil)) "Remove tags matched by predicate" (let* ((win (or argwin (current-window))) (new-tags (remove-if clearp (window-tags win)))) (setf (window-tags win) new-tags))) ; Commands for basic operations (defcommand clear-tags (&optional (argtags nil) (argwin nil)) (:rest :rest) "Remove specified or all tags" (let* ((tags (string-split-by-spaces argtags)) (condition (if tags (lambda(x) (find x tags :test 'equalp)) (lambda (x) t)))) (clear-tags-if condition argwin))) (defcommand clear-all-tags () () "Remove all tags and start afresh" (mapcar (lambda(x) (clear-tags nil x)) (screen-windows (current-screen)))) (defcommand tag-window (argtag &optional (argwin nil)) ((:rest "Tag to set: ") :rest) "Add a tag to current window" (let* ((win (or argwin (current-window))) (tag (string-split-by-spaces argtag))) (setf (window-tags win) (union tag (window-tags win) :test 'equalp)))) (defcommand all-tags () () "List all windows with their tags" (let ((*suppress-echo-timeout* t)) (message "Window list: ~{~%~{[ ~a ] ( ~a | ~a | ~a ) ~% ->~{~a, ~}~}~}" (mapcar (lambda(x) (list (window-title x) (window-class x) (window-res x) (window-role x) (window-tags x))) (screen-windows (current-screen)))))) ; Selection of tags and windows by tags (defun tags-from (argtags &optional (argwindow nil)) "Check whether (current) window has one of the specified tags. Tag T is implicitly assigned to all windows." (let* ((tags (string-split-by-spaces argtags)) (window (or argwindow (current-window))) (wtags (union (list "T") (window-tags window) :test 'equalp))) (intersection tags wtags :test 'equalp))) (defun select-by-tags (argtags &optional (without nil)) "Select windows with (without) one of the specified tags (any of the specified tags) from current screen. Tag T is implicitly assigned to every window" (let* ((tags (string-split-by-spaces argtags)) (condition (lambda(w) (tags-from tags w))) (windows (screen-windows (current-screen)))) (if without (remove-if condition windows) (remove-if-not condition windows)))) ; Window manipulations using tags ; General function (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))) ; And convenient instances (defcommand pull-tag (argtag) ((:rest "Tag(s) to pull: ")) "Pull all windows with the tag (any of the tags) to current group" (move-windows-to-group (select-by-tags (string-split-by-spaces argtag)))) (defcommand push-without-tag (argtag) ((:rest "Tag(s) needed to stay in the group: ")) "Push windows not having the tag (any of the tags) to .tag-store" (move-windows-to-group (select-by-tags (string-split-by-spaces argtag) T) ".tag-store")) (defcommand push-tag (argtag) ((:rest "Tag(s) to push: ")) "Push windows having the tag (any of the tags) to .tag-store" (move-windows-to-group (select-by-tags (string-split-by-spaces argtag)) ".tag-store")) (defcommand pull+push (argtag) ((:rest "Tag(s) to select: ")) "Pull all windows with the tag, push all without" (pull-tag argtag) (push-without-tag argtag)) (defcommand push-window () () "Push window to tag store" (move-windows-to-group (list (current-window)) ".tag-store")) ; Manage window numbers by tags.. (defun window-number-from-tag (window) "Find a numeric tag, if any, and parse it" (let* ((tags (window-tags window)) (numtag (find-if (lambda(x) (cl-ppcre:scan "^[0-9]+$" x)) tags)) (num (and numtag (parse-integer numtag)))) num)) (defcommand number-by-tags () () "Every window tagged will have a chance to have that number. The remaining windows will have packed numbers" ; First, assign impossible numbers. (mapcar (lambda(x) (setf (window-number x) -1)) (group-windows (current-group))) ; Now try to assign numbers to windows holding corresponding tags. (mapcar (lambda (x) (let* ((num (window-number-from-tag x)) (occupied (mapcar 'window-number (group-windows (current-group))))) (if (and num (not (find num occupied))) (setf (window-number x) num)))) (group-windows (current-group))) ; Give up and give smallest numbers possible (repack-window-numbers (mapcar 'window-number (remove-if-not (lambda(x) (equalp (window-number x) (window-number-from-tag x))) (group-windows (current-group)))))) (defcommand tag-visible (&optional (argtags nil)) (:rest) "IN-CURRENT-GROUP or another specified tag will be assigned to all windows in current group and only to them" (let* ( (tags (if (or (equalp argtags "") (not argtags)) "IN-CURRENT-GROUP" argtags))) (mapcar (lambda (x) (clear-tags tags x)) (screen-windows (current-screen))) (mapcar (lambda (x) (tag-window tags x)) (group-windows (current-group))))) (defcommand raise-tag (tag) ((:rest "Tag to pull: ")) "Make window current by tag" (let* ((window (car (select-by-tags tag)))) (if window (progn (move-window-to-group window (current-group)) (really-raise-window window) window) nil))) (defcommand search-tag (tag-regex) ((:rest "Tag regex to select: ")) (only) (fclear) (let* ( (current (current-group (current-screen))) (tag-store (find-group (current-screen) ".tag-store"))) (loop for w in (screen-windows (current-screen)) do (if (find-if (lambda (s) (cl-ppcre:scan (concatenate 'string "(?i)" tag-regex) s)) (window-tags w)) (move-window-to-group w current) (move-window-to-group w tag-store))))) (defcommand search-tag-pull (tag-regex) ((:rest "Tag regex to pull: ")) (only) (fclear) (let* ( (current (current-group (current-screen))) (tag-store (find-group (current-screen) ".tag-store"))) (loop for w in (screen-windows (current-screen)) do (if (find-if (lambda (s) (cl-ppcre:scan (concatenate 'string "(?i)" tag-regex) s)) (window-tags w)) (move-window-to-group w current) (progn))))) (defcommand select-by-title-regexp (regex) ((:rest "Title regex to select: ")) (only) (fclear) (let* ( (current (current-group (current-screen))) (tag-store (find-group (current-screen) ".tag-store"))) (loop for w in (screen-windows (current-screen)) do (if (cl-ppcre:scan regex (window-title w)) (move-window-to-group w current) (move-window-to-group w tag-store))))) (defcommand pull-by-title-regexp (regex) ((:rest "Title regex to select: ")) (only) (fclear) (let* ( (current (current-group (current-screen))) (tag-store (find-group (current-screen) ".tag-store"))) (loop for w in (screen-windows (current-screen)) do (if (cl-ppcre:scan regex (window-title w)) (move-window-to-group w current) (progn))))) stumpwm-20110819.gitca08e08/contrib/wmii-like-stumpwmrc.lisp000066400000000000000000000053621162337705100235420ustar00rootroot00000000000000;;; -*- Mode: Lisp -*- ;;; Written by Julian Stecklina, based on sample-stumpwmrc.lisp. ;;; This is a sample Wmii-like .stumpwmrc file using Super as modifier ;;; (which happens to be the Windows key on my keyboard). It doesn't ;;; cover the whole Wmii command set, but it will ease the transition ;;; to StumpWM for people coming from Wmii. ;;; ;;; The "normal" StumpWM commands are still available with their ;;; default keybindings (see the manual) and you will probably need ;;; them. So go read the manual. :) (in-package :stumpwm) ;;; A mode line showing all groups in its first and all windows in the ;;; current group in the second line. (setq *screen-mode-line-format* (format nil "%g~%%W")) ;;; Wmii-like keybindings (defvar *terminal* "xterm" "The command used to start a terminal. It should understand the -e parameter.") ;; Use focus-follows-mouse, like wmii does. (setq *mouse-focus-policy* :sloppy) ;; Change the prefix key to something else. The default is C-t. Use ;; this to access stumpwm's original keybindings. ;(set-prefix-key (kbd "Menu")) ;;; If you like Meta (most probably alt on your keyboard) more than ;;; Super (which is the Windows key on mine), change 's-' into 'M-'. (define-key *top-map* (kbd "s-RET") (format nil "exec ~A" *terminal*)) (define-key *top-map* (kbd "s-S-RET") "exec-in-terminal") (define-key *top-map* (kbd "s-C") "delete") (define-key *top-map* (kbd "s-p") "exec") (define-key *top-map* (kbd "s-d") "vsplit") (define-key *top-map* (kbd "s-D") "hsplit") (define-key *top-map* (kbd "s-R") "remove") (define-key *top-map* (kbd "s-SPC") "pull-hidden-next") ;;; s-DIGIT moves or creates to a numbered group. (dotimes (i 9) (define-key *top-map* (kbd (format nil "s-~A" (1+ i))) (format nil "gselect-or-create ~A" (1+ i)))) ;;; s-[hjkl] navigate through frames. If you press shift, it will move ;;; the current window in that direction. (loop for (vi-key name) in '(("k" "up") ("j" "down") ("h" "left") ("l" "right")) do (let ((key-combo (format nil "s-~A" vi-key)) (shifted-key-combo (format nil "s-~A" (string-upcase vi-key)))) (define-key *top-map* (kbd key-combo) (format nil "move-focus ~A" name)) (define-key *top-map* (kbd shifted-key-combo) (format nil "move-window ~A" name)))) (defcommand gselect-or-create (group-number) ((:number "Group number: ")) (gselect (or (select-group (current-screen) (format nil "~A" group-number) ) (let ((group (add-group (current-screen) (format nil "unnamed~A" group-number)))) ;; number should be free, since select-group failed. (setf (group-number group) group-number) group)))) (defcommand exec-in-terminal (cmd) ((:string "Command: ")) (run-shell-command (format nil "~A -e ~A" *terminal* cmd))) ;;; EOF stumpwm-20110819.gitca08e08/core.lisp000066400000000000000000000136461162337705100171100ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; This file contains core functionality including functions on ;; windows, screens, and events. ;; ;; Code: (in-package :stumpwm) ;; Wow, is there an easier way to do this? (defmacro def-thing-attr-macro (thing hash-slot) (let ((attr (gensym "ATTR")) (obj (gensym "METAOBJ")) (val (gensym "METAVAL"))) `(defmacro ,(intern1 (format nil "DEF-~a-ATTR" thing)) (,attr) "Create a new attribute and corresponding get/set functions." (let ((,obj (gensym "OBJ")) (,val (gensym "VAL"))) `(progn (defun ,(intern1 (format nil ,(format nil "~a-~~a" thing) ,attr)) (,,obj) (gethash ,,attr (,(quote ,hash-slot) ,,obj))) (defun (setf ,(intern1 (format nil ,(format nil "~a-~~a" thing) ,attr))) (,,val ,,obj) (setf (gethash ,,attr (,(quote ,hash-slot) ,,obj))) ,,val)))))) ;;; 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." (multiple-value-bind (code state) (key-to-keycode+state key) (xlib:send-event (window-xwin win) :key-press (xlib:make-event-mask :key-press) :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 (window-xwin win) :event-window (window-xwin win) :code code :state state))) (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 (multiple-value-bind (x y) (xlib:query-pointer (window-xwin win)) (multiple-value-bind (rx ry) (xlib:query-pointer (screen-root (window-screen win))) (xlib:send-event (window-xwin win) :button-press (xlib:make-event-mask :button-press) :display *display* :root (screen-root (window-screen win)) :window (window-xwin win) :event-window (window-xwin win) :code button :state 0 :x x :y y :root-x rx :root-y ry :same-screen-p t) (xlib:send-event (window-xwin win) :button-release (xlib:make-event-mask :button-release) :display *display* :root (screen-root (window-screen win)) :window (window-xwin win) :event-window (window-xwin win) :code button :state #x100 :x x :y y :root-x rx :root-y ry :same-screen-p t)))))) ;;; Pointer helper functions (defun grab-pointer (screen) "Grab the pointer and set the pointer shape." (incf *grab-pointer-count*) (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) (cursor-font (xlib:open-font *display* "cursor")) (cursor (xlib:create-glyph-cursor :source-font cursor-font :source-char 64 :mask-font cursor-font :mask-char 65 :foreground black :background white))) (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-20110819.gitca08e08/events.lisp000066400000000000000000000674651162337705100174740ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Event handling. ;; ;; Code: (in-package #:stumpwm) ;;; Event handler functions (defparameter *event-fn-table* (make-hash-table) "A hash of event types to functions") (defmacro define-stump-event-handler (event keys &body body) (let ((fn-name (gensym)) (event-slots (gensym))) `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys) (declare (ignore ,event-slots)) ,@body)) (setf (gethash ,event *event-fn-table*) #',fn-name)))) ;(define-stump-event-handler :map-notify (event-window window override-redirect-p) ; ) (defun handle-mode-line-window (xwin x y width height) (declare (ignore width)) (let ((ml (find-mode-line-window xwin))) (when ml (setf (xlib:drawable-height xwin) height) (update-mode-line-position ml x y) (resize-mode-line ml) (sync-mode-line ml)))) (defun handle-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." (labels ((has-x (mask) (= 1 (logand mask 1))) (has-y (mask) (= 2 (logand mask 2))) (has-w (mask) (= 4 (logand mask 4))) (has-h (mask) (= 8 (logand mask 8))) (has-bw (mask) (= 16 (logand mask 16))) ;; (has-stackmode (mask) (= 64 (logand mask 64))) ) (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))))) (defun update-configuration (win) ;; Send a synthetic configure-notify event so that the window ;; knows where it is onscreen. (xwin-send-configuration-notify (window-xwin win) (xlib:drawable-x (window-parent win)) (xlib:drawable-y (window-parent win)) (window-width win) (window-height win) 0)) (define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) (labels ((has-x () (= 1 (logand value-mask 1))) (has-y () (= 2 (logand value-mask 2))) (has-w () (= 4 (logand value-mask 4))) (has-h () (= 8 (logand value-mask 8))) (has-stackmode () (= 64 (logand value-mask 64)))) ;; Grant the configure request but then maximize the window after the granting. (dformat 3 "CONFIGURE REQUEST ~@{~S ~}~%" stack-mode window x y width height border-width value-mask) (let ((win (find-window window))) (cond (win (when (or (has-w) (has-h) (has-stackmode)) ;; 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) (has-y)) (group-move-request (window-group win) win x y :parent)) (when (or (has-w) (has-h)) (group-resize-request (window-group win) win width height)) (when (has-stackmode) (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)) ((handle-mode-line-window win x y width height)) (t (handle-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) (let ((screen (find-screen window))) (when screen (let ((old-heads (copy-list (screen-heads screen)))) (setf (screen-heads screen) nil) (let ((new-heads (make-screen-heads screen (screen-root screen)))) (setf (screen-heads screen) old-heads) (cond ((equalp old-heads new-heads) (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t) (t (dformat 1 "Updating Xinerama configuration for ~S.~%" screen) (if new-heads (progn (scale-screen screen new-heads) (mapc 'group-sync-all-heads (screen-groups screen)) (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 (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))) (let ((window (find-window window))) ;; if we can't find the window then there's nothing we need to ;; do. (when 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 :create-notify (#|window parent x y width height border-width|# override-redirect-p)) ;; (unless (or override-redirect-p ;; (internal-window-p (window-screen window) window)) ;; (process-new-window (window-screen window) window)) ;; (run-hook-with-args *new-window-hook* 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. (let ((win (or (find-window window) (find-withdrawn-window window)))) (if win (destroy-window win) (progn (let ((ml (find-mode-line-window window))) (when ml (destroy-mode-line-window 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 (list (kbd "?") (kbd "C-h")) :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." (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*) ;; TODO: Minor Mode maps go here ;; lastly, group maps. Last because minor modes should be able to ;; shadow a group's default bindings. (loop for i in *group-top-maps* when (typep group (first i)) collect (second i)))) (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 ;; 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)) (eval-command cmd t) t) (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq)))))))))) (defun bytes-to-window (bytes) "A sick hack to assemble 4 bytes into a 32 bit number. This is because ratpoison sends the rp_command_request window in 8 byte chunks." (+ (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)) (cmd (bytes-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 (string-to-bytes (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 (let ((window (find-window window))) (when 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 () (setf *x-selection* nil)) (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-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)))))) (frame-raise-window (window-group window) (window-frame window) window (if (eq (window-frame window) (tile-group-current-frame (window-group window))) t nil)))) (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 (let ((our-window (find-window window))) (when our-window (delete-window our-window)))) (:_NET_WM_STATE (let ((our-window (find-window window))) (when our-window (let ((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 (let ((our-window (find-window window))) (when our-window (let ((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)) ;;; 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))))) (define-stump-event-handler :button-press (window code x y child time) ;; Pass click to client (xlib:allow-events *display* :replay-pointer time) (let (screen ml win) (cond ((and (setf screen (find-screen window)) (not child)) (group-button-press (screen-current-group screen) x y :root)) ((setf ml (find-mode-line-window window)) (run-hook-with-args *mode-line-click-hook* ml code x y)) ((setf win (find-window-by-parent window (top-windows))) (group-button-press (window-group win) x y win))))) ;; Handling event :KEY-PRESS ;; (:DISPLAY # :EVENT-KEY :KEY-PRESS :EVENT-CODE 2 :SEND-EVENT-P NIL :CODE 45 :SEQUENCE 1419 :TIME 98761213 :ROOT # :WINDOW # :EVENT-WINDOW # :CHILD ;; # :ROOT-X 754 :ROOT-Y 223 :X 753 :Y 222 :STATE 4 :SAME-SCREEN-P T) ;; H (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))) (when eventfn ;; XXX: In both the clisp and 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-20110819.gitca08e08/fdump.lisp000066400000000000000000000175351162337705100172740ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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-to-file (foo name) (with-open-file (fp name :direction :output :if-exists :supersede) (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." (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" (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" (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." (let ((dump (read-dump-from-file 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)) stumpwm-20110819.gitca08e08/floating-group.lisp000066400000000000000000000262261162337705100211130ustar00rootroot00000000000000;;; implementation of a floating style window management group (in-package :stumpwm) ;;; floating window (defclass 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)) ) (defvar *float-window-border* 1) (defvar *float-window-title-height* 10) ;; some book keeping functions (defmethod (setf window-x) :before (val (window float-window)) (unless (eql (window-x window) val) (setf (float-window-last-x window) (window-x window)))) (defmethod (setf window-y) :before (val (window float-window)) (unless (eql (window-y window) val) (setf (float-window-last-y window) (window-y window)))) (defmethod (setf window-width) :before (val (window float-window)) (unless (eql (window-width window) val) (setf (float-window-last-width window) (window-width window)))) (defmethod (setf window-height) :before (val (window float-window)) (unless (eql (window-height window) val) (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-slots (xwin 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)) (xlib:alloc-color (xlib:screen-default-colormap (screen-number (window-screen window))) (if (eq (group-current-window group) window) "Orange" "SteelBlue4"))) (xlib:clear-area (window-parent window)))) (defmethod window-sync ((window float-window) hint) (declare (ignore hint)) ) (defmethod window-head ((window float-window)) (dolist (head (screen-heads (group-screen (window-group window)))) (when (and (>= (window-x window) (frame-x head)) (>= (window-y window) (frame-y head)) (<= (+ (window-x window) (window-width window)) (+ (frame-x head) (frame-width head))) (<= (+ (window-y window) (window-height window)) (+ (frame-y head) (frame-height head)))) (return head)))) (defmethod window-visible-p ((win float-window)) (eql (window-state win) +normal-state+)) (defmethod (setf window-fullscreen) :after (val (window float-window)) (with-slots (last-x last-y last-width last-height parent) window (if val (let ((head (window-head window))) (with-slots (x y width 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))))) ;;; floating group (defclass float-group (group) ((current-window :accessor float-group-current-window)) ) (defmethod group-startup ((group float-group)) ) (defmethod group-add-window ((group float-group) window &key &allow-other-keys) (change-class window 'float-window) (float-window-align window) (focus-window window)) (defun &float-focus-next (group) (if (group-windows group) (focus-window (first (group-windows group))) (no-focus group nil))) (defmethod group-delete-window ((group float-group) 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-window ((group float-group)) (screen-focus (group-screen group))) (defmethod group-current-head ((group float-group)) (first (screen-heads (group-screen group)))) (defun float-window-align (window) (with-slots (parent xwin width 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)))) (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)) (focus-window 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-resize-head ((group float-group) oh nh) (declare (ignore oh nh))) (defmethod group-sync-all-heads ((group float-group)) ) (defmethod group-sync-head ((group float-group) head) (declare (ignore head)) ) (defmethod group-button-press ((group float-group) x y (window float-window)) (let ((screen (group-screen group))) (cond ((or (< x (xlib:drawable-x (window-xwin window))) (> x (+ (xlib:drawable-width (window-xwin window)) (xlib:drawable-x (window-xwin window)))) (< y (xlib:drawable-y (window-xwin window))) (> y (+ (xlib:drawable-height (window-xwin window)) (xlib:drawable-y (window-xwin window))))) (multiple-value-bind (relx rely same-screen-p child state-mask) (xlib:query-pointer (window-parent window)) (declare (ignore same-screen-p child)) (let ((initial-width (xlib:drawable-width (slot-value window 'parent))) (initial-height (xlib:drawable-height (slot-value window 'parent)))) (labels ((move-window-event-handler (&rest event-slots &key event-key &allow-other-keys) (case event-key (:button-release :done) (:motion-notify (with-slots (parent) window (xlib:with-state (parent) ;; Either move or resize the window (cond ((find :button-1 (xlib:make-state-keys state-mask)) (setf (xlib:drawable-x parent) (- (getf event-slots :x) relx) (xlib:drawable-y parent) (- (getf event-slots :y) rely))) ((find :button-3 (xlib:make-state-keys state-mask)) (let ((w (+ initial-width (- (getf event-slots :x) relx (xlib:drawable-x parent)))) (h (+ initial-height (- (getf event-slots :y) rely (xlib:drawable-y parent) *float-window-title-height*)))) ;; Don't let the window become too small (float-window-move-resize window :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))))))) (t (when (eq *mouse-focus-policy* :click) (focus-window window)))))) (defmethod group-button-press ((group float-group) x y where) (declare (ignore x y where)) ) (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-20110819.gitca08e08/group.lisp000066400000000000000000000503471162337705100173130ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; All group related code resides here ;; ;; Code: (in-package #:stumpwm) (export '(current-group)) (defvar *default-group-type* 'tile-group "The type of group that should be created by default.") (defclass group () ((screen :initarg :screen :accessor group-screen) (windows :initform nil :accessor group-windows) (number :initarg :number :accessor group-number) (name :initarg :name :accessor group-name))) ;;; 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-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 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-resize-head (group oh nh) (:documentation "A head is being 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.")) (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)) 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)))) (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) (update-all-mode-lines) (run-hook-with-args *focus-group-hook* new-group old-group)))) (defun move-window-to-group (window 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)))) (if (eq next-group current) nil 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-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 (dolist (w (group-windows group)) (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP (list i) :cardinal 32)))) (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 (string-to-utf8 (group-name group)) '(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 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) (if (or (string= name "") (string= name ".")) (error "Groups must have a name.") (let ((ng (or (find-group screen name) (let ((ng (make-instance type :screen screen :number (if (char= (char name 0) #\.) (find-free-hidden-group-number screen) (find-free-group-number screen)) :name name))) (setf (screen-groups screen) (append (screen-groups screen) (list ng))) (netwm-set-group-properties screen) (netwm-update-groups screen) ng)))) (unless background (switch-to-group ng)) ng))) (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." (let ((ng (next-group current (non-hidden-groups list)))) (when ng (switch-to-group ng) ng))) (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." (let ((next (group-forward current list)) (win (group-current-window current))) (when (and next win) (move-window-to-group win next) (really-raise-window 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." (add-group (current-screen) name)) (defcommand gnewbg (name) ((:string "Group Name: ")) "Create a new group but do not switch to it." (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)))) (when (> (length groups) 1) (switch-to-group (second groups))))) (defcommand grename (name) ((:string "New name for group: ")) "Rename the current group." (let ((group (current-group))) (cond ((find-group (current-screen) name) (message "^1*^BError: Name already exists")) ((or (zerop (length name)) (string= name ".")) (message "^1*^BError: empty name")) (t (cond ((and (char= (char name 0) #\.) ;change to hidden group (not (char= (char (group-name group) 0) #\.))) (setf (group-number group) (find-free-hidden-group-number (current-screen)))) ((and (not (char= (char name 0) #\.)) ;change from hidden group (char= (char (group-name group) 0) #\.)) (setf (group-number group) (find-free-group-number (current-screen))))) (setf (group-name group) name))))) (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 (to-group) ((:group "Select Group: ")) "Select the first group that starts with @var{substring}. @var{substring} can also be a number, in which case @command{gselect} selects the group with that number." (when to-group (switch-to-group to-group))) (defcommand grouplist (&optional (fmt *group-format*)) (:rest) "Allow the user to select a group from a list, like windowlist but for groups" (let ((group (second (select-from-menu (current-screen) (mapcar (lambda (g) (list (format-expand *group-formatters* fmt g) g)) (screen-groups (current-screen))))))) (when group (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-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)))) (progn (switch-to-group to-group) (kill-group dead-group to-group) (message "Deleted")) (message "Canceled")) (message "There's only one group left")))) (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-20110819.gitca08e08/head.lisp000066400000000000000000000134601162337705100170530ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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 parse-xinerama-head (line) (ppcre:register-groups-bind (('parse-integer number width height x y)) ("^ +head #([0-9]+): ([0-9]+)x([0-9]+) @ ([0-9]+),([0-9]+)" line :sharedp t) (handler-case (make-head :number number :x x :y y :width width :height height) (parse-error () nil)))) (defun make-screen-heads (screen root) "or use xdpyinfo to query the xinerama extension, if it's enabled." (or (and (xlib:query-extension *display* "XINERAMA") (with-current-screen screen ;; Ignore 'clone' heads. (loop for i = 0 then (1+ i) for h in (delete-duplicates (loop for i in (split-string (run-shell-command "xdpyinfo -ext XINERAMA" t)) for head = (parse-xinerama-head i) when head collect head) :test #'frames-overlap-p) do (setf (head-number h) i) collect h))) (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))) ;; Determining a frame's head based on position probably won't ;; work with overlapping heads. Would it be better to walk ;; up the frame tree? (defun frame-head (group frame) (let ((center-x (+ (frame-x frame) (ash (frame-width frame) -1))) (center-y (+ (frame-y frame) (ash (frame-height frame) -1)))) (dolist (head (screen-heads (group-screen group))) (when (and (>= center-x (frame-x head)) (>= center-y (frame-y head)) (<= center-x (+ (frame-x head) (frame-width head))) (<= center-y (+ (frame-y head) (frame-height head)))) (return head))))) (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) (eq head (window-head w))) (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)) (when (head-mode-line head) (toggle-mode-line screen head)) (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 scale-head (screen oh nh) "Scales head OH to match the dimensions of NH." (dolist (group (screen-groups screen)) (group-resize-head group oh nh)) (setf (head-x oh) (head-x nh) (head-y oh) (head-y nh) (head-width oh) (head-width nh) (head-height oh) (head-height nh))) (defun scale-screen (screen heads) "Scale all frames of all groups of SCREEN to match the dimensions of HEADS." (when (< (length heads) (length (screen-heads screen))) ;; Some heads were removed (or cloned), try to guess which. (dolist (oh (screen-heads screen)) (dolist (nh heads) (when (and (= (head-x nh) (head-x oh)) (= (head-y nh) (head-y oh))) ;; Same screen position; probably the same head. (setf (head-number nh) (head-number oh))))) ;; Actually remove the missing heads. (dolist (head (set-difference (screen-heads screen) heads :key 'head-number)) (remove-head screen head))) (loop for nh in heads as oh = (find (head-number nh) (screen-heads screen) :key 'head-number) do (if oh (scale-head screen oh nh) (add-head screen nh)))) stumpwm-20110819.gitca08e08/help.lisp000066400000000000000000000131231162337705100170760ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Help and introspection commands ;; ;; Code: (in-package #:stumpwm) (export '()) (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 rows 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))) (apply 'mapcar 'concat ;; 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)))))))) (defun display-bindings-for-keymaps (key-seq &rest keymaps) (let* ((screen (current-screen)) (data (mapcan (lambda (map) (mapcar (lambda (b) (format nil "^5*~5a^n ~a" (print-key (binding-key b)) (binding-command b))) (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) (columnize data cols)))) (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)))) (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." (let ((cmd (loop for map in (top-maps) for cmd = (lookup-key-sequence map keys) when cmd return cmd))) (if cmd (message "~{~a~^ ~} is bound to \"~a\"." (mapcar 'print-key keys) cmd) (message "~{~a~^ ~} is not bound." (mapcar 'print-key keys))))) (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 var s)))) (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 fn s)))) (defcommand describe-command (com) ((:command "Describe Command: ")) "Print the online help associated with the specified command." (let* ((deref (dereference-command-symbol com)) (struct (get-command-structure com nil))) (cond ((null struct) (message "Error: Command \"~a\" not found." com)) ((eq deref struct) (message-no-timeout "Command \"~a\":~%~a" (command-name struct) (documentation (command-name struct) 'function))) (t (message-no-timeout "\"~a\" is an alias for the command \"~a\":~%~a" (command-alias-from deref) (command-name struct) (documentation (command-name struct) 'function)))))) (defcommand where-is (cmd) ((:rest "Where is command: ")) "Print the key sequences bound to the specified command." (let ((bindings (loop for map in (top-maps) append (search-kmap cmd map)))) (if bindings (message-no-timeout "\"~a\" is on ~{~a~^, ~}" cmd (mapcar 'print-key-seq bindings)) (message-no-timeout "Command \"~a\" is not currently bound" cmd)))) (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-20110819.gitca08e08/input.lisp000066400000000000000000000710261162337705100173130ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; This file handles input stuff ;; ;; Code: (in-package :stumpwm) (export '(*input-history-ignore-duplicates* *input-map* completing-read input-delete-region input-goto-char input-insert-char input-insert-string input-point input-substring input-validate-region read-one-char read-one-line)) (defstruct input-line string position history history-bk password) (defvar *input-map* nil "This is the keymap containing all input editing key bindings.") (when (null *input-map*) (setf *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 "TAB") 'input-complete-forward) (define-key map (kbd "ISO_Left_Tab") 'input-complete-backward) (define-key map t 'input-self-insert) map))) (defvar *input-history* nil "History for the input line.") (defvar *input-last-command* nil "The last input command.") (defvar *input-completions* nil "The list of completions") (defvar *input-current-completions* nil "The list of matching completions.") (defvar *input-current-completions-idx* nil "The current index in the current completions list.") (defvar *input-history-ignore-duplicates* nil "Do not add a command to the input history if it's already the first in the list.") ;;; 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 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 (+ (xlib:font-descent (screen-font screen)) (xlib:font-ascent (screen-font screen)))) (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 the prompt (draw-input-bucket screen prompt input) ;; Ready to recieve input )) (defun shutdown-input-window (screen) (xlib:ungrab-keyboard *display*) (xlib:unmap-window (screen-input-window screen))) (defun input-handle-key-press-event (&rest event-slots &key event-key root code state &allow-other-keys) (declare (ignore event-slots root)) ;; FIXME: don't use a cons (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 read-key-handle-event (&rest event-slots &key display event-key &allow-other-keys) (declare (ignore display)) (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 display event-key &allow-other-keys) (declare (ignore display)) (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 () "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 (cdr 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-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 (cdr 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 ((*input-completions* completions) (*input-current-completions* nil) (*input-current-completions-idx* nil)) (let ((line (read-one-line screen prompt :initial-input initial-input :require-match require-match))) (when line (string-trim " " line))))) (defun read-one-line (screen prompt &key (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 (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 *input-completions*))) (and (consp compls) (string= in (car compls))))) (key-loop () (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))))))) (setup-input-window screen prompt input) (catch :abort (unwind-protect (with-focus (screen-input-window screen) (key-loop)) (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 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)) (prompt-width (xlib:text-width (screen-font screen) prompt :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 (xlib:text-width (screen-font screen) string :translate #'translate-id)) (space-width (xlib:text-width (screen-font screen) " " :translate #'translate-id)) (tail-width (xlib:text-width (screen-font screen) tail :translate #'translate-id)) (full-string-width (+ string-width space-width)) (pos (input-line-position input)) (width (+ prompt-width (max 100 (+ full-string-width space-width tail-width))))) (xlib:with-state (win) (xlib:clear-area win :x (+ *message-window-padding* prompt-width string-width)) (setf (xlib:drawable-width win) (+ width (* *message-window-padding* 2))) (setup-win-gravity screen win *input-window-gravity*)) (xlib:with-state (win) (xlib:draw-image-glyphs win gcontext *message-window-padding* (xlib:font-ascent (screen-font screen)) prompt :translate #'translate-id :size 16) (xlib:draw-image-glyphs win gcontext (+ *message-window-padding* prompt-width) (xlib:font-ascent (screen-font screen)) string :translate #'translate-id :size 16) (xlib:draw-image-glyphs win gcontext (+ *message-window-padding* prompt-width full-string-width space-width) (xlib:font-ascent (screen-font screen)) tail :translate #'translate-id :size 16) ;; draw a block cursor (invert-rect screen win (+ *message-window-padding* prompt-width (xlib:text-width (screen-font screen) (subseq string 0 pos) :translate #'translate-id)) 0 (xlib:text-width (screen-font screen) (if (>= pos (length string)) " " (string (char string pos))) :translate #'translate-id) (+ (xlib:font-descent (screen-font screen)) (xlib:font-ascent (screen-font screen)))) ;; draw the error (when errorp (invert-rect screen win 0 0 (xlib:drawable-width win) (xlib:drawable-height win)) (xlib:display-force-output *display*) (sleep 0.05) (invert-rect screen win 0 0 (xlib:drawable-width win) (xlib:drawable-height win)))))) (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 2 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)))) ;;; 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) (if (or (functionp completions) (and (symbolp completions) (fboundp completions))) (funcall completions str) (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)))) completions))) (defun input-complete (input direction) ;; reset the completion list if this is the first time they're ;; trying to complete. (unless (find *input-last-command* '(input-complete-forward input-complete-backward)) (setf *input-current-completions* (input-find-completions (input-substring input 0 (input-point input)) *input-completions*) *input-current-completions-idx* -1)) (if *input-current-completions* (progn ;; Insert the next completion (input-delete-region input 0 (input-point input)) (if (eq direction :forward) (progn (incf *input-current-completions-idx*) (when (>= *input-current-completions-idx* (length *input-current-completions*)) (setf *input-current-completions-idx* 0))) (progn (decf *input-current-completions-idx*) (when (< *input-current-completions-idx* 0) (setf *input-current-completions-idx* (1- (length *input-current-completions*)))))) (let ((elt (nth *input-current-completions-idx* *input-current-completions*))) (input-insert-string input (if (listp elt) (first elt) elt)) (input-insert-char input #\Space))) :error)) (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 input-self-insert (input key) (let ((char (xlib:keysym->character *display* (key-keysym key)))) (if (or (key-mods-p key) (null char) (not (characterp char))) :error (input-insert-char input char)))) (defun input-yank-selection (input key) (declare (ignore key)) ;; if we own the selection then just insert it. (if *x-selection* (input-insert-string input *x-selection*) (xlib:convert-selection :primary :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)) :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 () (multiple-value-bind (shift-codes lock-codes control-codes mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes) (xlib:modifier-mapping *display*) (append shift-codes lock-codes control-codes mod1-codes mod2-codes mod3-codes mod4-codes mod5-codes))) (defun get-modifier-map () (labels ((find-mod (mod codes) (find (xlib:keysym->keycodes *display* (keysym-name->keysym mod)) 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) (char= (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 = (read-one-line (current-screen) (format nil "~a(yes or no) " message)) until (find line '("yes" "no") :test 'string-equal) do (message "Please answer yes or no") (sleep 1) finally (return (string-equal line "yes")))) stumpwm-20110819.gitca08e08/iresize.lisp000066400000000000000000000074651162337705100176340ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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 abort-iresize exit-iresize)) (defvar *resize-backup* nil) (defvar *resize-increment* 10 "Number of pixels to increment by when interactively resizing frames.") (defun set-resize-increment (val) (setf *resize-increment* val) (update-resize-map)) (defun update-resize-map () (let ((m (or *resize-map* (setf *resize-map* (make-sparse-keymap))))) (let ((i *resize-increment*)) (labels ((dk (m k c) (define-key m k (format nil c i)))) (dk m (kbd "Up") "resize 0 -~D") (dk m (kbd "C-p") "resize 0 -~D") (dk m (kbd "p") "resize 0 -~D") (dk m (kbd "k") "resize 0 -~D") (dk m (kbd "Down") "resize 0 ~D") (dk m (kbd "C-n") "resize 0 ~D") (dk m (kbd "n") "resize 0 ~D") (dk m (kbd "j") "resize 0 ~D") (dk m (kbd "Left") "resize -~D 0") (dk m (kbd "C-b") "resize -~D 0") (dk m (kbd "b") "resize -~D 0") (dk m (kbd "h") "resize -~D 0") (dk m (kbd "Right") "resize ~D 0") (dk m (kbd "C-f") "resize ~D 0") (dk m (kbd "f") "resize ~D 0") (dk m (kbd "l") "resize ~D 0") (define-key m (kbd "RET") "exit-iresize") (define-key m (kbd "C-g") "abort-iresize") (define-key m (kbd "ESC") "abort-iresize"))))) (update-resize-map) (defcommand (iresize tile-group) () () "Start the interactive resize mode. A new keymap specific to resizing the current frame is loaded. Hit @key{C-g}, @key{RET}, or @key{ESC} to exit." (let ((frame (tile-group-current-frame (current-group)))) (if (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))) (message "There's only 1 frame!") (progn (when *resize-hides-windows* (dolist (f (head-frames (current-group) (current-head))) (clear-frame f (current-group)))) (message "Resize Frame") (push-top-map *resize-map*) (draw-frame-outlines (current-group) (current-head))) ;; (setf *resize-backup* (copy-frame-tree (current-group))) ))) (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)))))) (defcommand (abort-iresize tile-group) () () "Exit from the interactive resize mode." (resize-unhide) (message "Abort resize") ;; TODO: actually revert the frames (pop-top-map)) (defcommand (exit-iresize tile-group) () () "Exit from the interactive resize mode." (resize-unhide) (message "Resize Complete") (pop-top-map)) stumpwm-20110819.gitca08e08/keysyms.lisp000066400000000000000000003650051162337705100176630ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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)) (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 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-keysym #xfe50 "dead_grave") (define-keysym #xfe51 "dead_acute") (define-keysym #xfe52 "dead_circumflex") (define-keysym #xfe53 "dead_tilde") (define-keysym #xfe54 "dead_macron") (define-keysym #xfe55 "dead_breve") (define-keysym #xfe56 "dead_abovedot") (define-keysym #xfe57 "dead_diaeresis") (define-keysym #xfe58 "dead_abovering") (define-keysym #xfe59 "dead_doubleacute") (define-keysym #xfe5a "dead_caron") (define-keysym #xfe5b "dead_cedilla") (define-keysym #xfe5c "dead_ogonek") (define-keysym #xfe5d "dead_iota") (define-keysym #xfe5e "dead_voiced_sound") (define-keysym #xfe5f "dead_semivoiced_sound") (define-keysym #xfe60 "dead_belowdot") (define-keysym #xfe61 "dead_hook") (define-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 #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 #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-20110819.gitca08e08/keytrans.lisp000066400000000000000000000073641162337705100200200ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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 "%" "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") stumpwm-20110819.gitca08e08/kmap.lisp000066400000000000000000000221631162337705100171020ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; This file handles keymaps ;; ;; Code: (in-package stumpwm) (export '(*top-map* *root-map* 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}. It is known as the @dfn{prefix map}.") (defstruct key keysym shift control meta alt hyper super) (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))) (define-condition kbd-parse-error (stumpwm-error) ((string :initarg :string)) (: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) (signal 'kbd-parse-error :string mods)) (apply #'nconc (loop for i from 0 below end by 2 if (char/= (char mods (1+ i)) #\-) do (signal 'kbd-parse) collect (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 (signal 'kbd-parse-error :string mods)))))) (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))))) (if keysym (apply 'make-key :keysym keysym mods) (signal '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 "^5*~{~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 exising 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-20110819.gitca08e08/make-image.lisp.in000066400000000000000000000026131162337705100205520ustar00rootroot00000000000000#-(or sbcl clisp openmcl ecl) (error "This lisp implementation is not supported.") (require 'asdf #+clisp'("asdf.lisp")) #+(or clisp ecl) (load "@PPCRE_PATH@/cl-ppcre.asd") (asdf:oos 'asdf:load-op 'stumpwm) #-ecl (stumpwm:set-contrib-dir "@CONTRIB_DIR@") #+sbcl (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 (sb-posix:putenv (format nil "SBCL_HOME=~A" #.(sb-ext:posix-getenv "SBCL_HOME"))) (stumpwm:stumpwm) 0) :executable t) #+clisp (ext:saveinitmem "stumpwm" :init-function (lambda () (stumpwm:stumpwm) (ext:quit)) :executable t :keep-global-handlers t :norc t :documentation "The StumpWM Executable") #+ccl (ccl:save-application "stumpwm" :prepend-kernel t :toplevel-function #'stumpwm:stumpwm) #+ecl (asdf:make-build 'stumpwm :type :program :monolithic t :move-here "." :name-suffix "" :epilogue-code '(progn (stumpwm:set-contrib-dir "@CONTRIB_DIR@") (stumpwm:stumpwm))) stumpwm-20110819.gitca08e08/manual.lisp000066400000000000000000000134451162337705100174320ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Generate the texinfo manual from docstrings in the source. Note, ;; this only works in sbcl and clisp ;; ;; Code: (in-package :stumpwm) #+sbcl (require :sb-introspect) ;; handy for figuring out which symbol is borking the documentation (defun dprint (sym) (declare (ignorable sym)) ;;(format t "~&Doing ~a..." sym)) ) (defun generate-function-doc (s line) (ppcre:register-groups-bind (name) ("^@@@ (.*)" line) (dprint name) (let ((fn (if (find #\( name :test 'char=) ;; handle (setf ) functions (with-standard-io-syntax (let ((*package* (find-package :stumpwm))) (fdefinition (read-from-string name)))) (symbol-function (find-symbol (string-upcase name) :stumpwm)))) (*print-pretty* nil)) (format s "@defun {~a} ~{~a~^ ~}~%~a~&@end defun~%~%" name #+sbcl (sb-introspect:function-arglist fn) #+clisp (ext:arglist fn) #- (or sbcl clisp) '("(Check the code for args list)") (documentation fn 'function)) t))) (defun generate-macro-doc (s line) (ppcre:register-groups-bind (name) ("^%%% (.*)" line) (dprint name) (let* ((symbol (find-symbol (string-upcase name) :stumpwm)) (*print-pretty* nil)) (format s "@defmac {~a} ~{~a~^ ~}~%~a~&@end defmac~%~%" name #+sbcl (sb-introspect:function-arglist (macro-function symbol)) #+clisp (ext:arglist symbol) #- (or sbcl clisp) '("(Check the code for args list)") ;;; FIXME: when clisp compiles ;;; a macro it discards the ;;; documentation string! So ;;; unless when generating the ;;; manual for clisp, it is ;;; loaded and not compiled ;;; this will return NIL. #+clisp (or (documentation symbol 'function) "Due to a bug in clisp, macro function documentation is not generated. Try building the manual using sbcl.") #-clisp (documentation symbol 'function)) t))) (defun generate-variable-doc (s line) (ppcre:register-groups-bind (name) ("^### (.*)" line) (dprint name) (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) (dprint name) (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) (dprint name) (let ((cmd (symbol-function (find-symbol (string-upcase name) :stumpwm)))) (format s "@deffn {Command} ~a ~{~a~^ ~}~%~a~&@end deffn~%~%" name #+sbcl (sb-introspect:function-arglist cmd) #+clisp (ext:arglist cmd) #- (or sbcl clisp) '("(Check the code for args list)") (documentation cmd 'function)) t))) (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) (write-line line os))))))) stumpwm-20110819.gitca08e08/menu.lisp000066400000000000000000000215111162337705100171120ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Implementation of an interactive menu. ;; ;; Code: ;;; interactive menu (in-package #:stumpwm) (export '()) (defvar *menu-map* nil "The keymap used by the interactive menu.") (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 "k") 'menu-up) (define-key m (kbd "S-Up") 'menu-scroll-up) (define-key m (kbd "SunPageUp") 'menu-page-up) (define-key m (kbd "K") 'menu-page-up) (define-key m (kbd "C-n") 'menu-down) (define-key m (kbd "Down") 'menu-down) (define-key m (kbd "j") 'menu-down) (define-key m (kbd "S-Down") 'menu-scroll-down) (define-key m (kbd "SunPageDown") 'menu-page-down) (define-key m (kbd "J") '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))) (defstruct menu-state table prompt selected view-start view-end current-input) (defun bound-check-menu (menu) "Adjust the menu view and selected item based on current view and new selection." (let ((len (length (menu-state-table menu)))) (setf (menu-state-selected menu) (cond ((< (menu-state-selected menu) 0) (1- len)) ((>= (menu-state-selected menu) len) 0) (t (menu-state-selected menu)))) (when (and *menu-maximum-height* (> len *menu-maximum-height*)) ; scrolling required (let ((sel (menu-state-selected menu))) (setf (values (menu-state-view-start menu) (menu-state-view-end menu)) (cond ((< sel *menu-maximum-height*) (values 0 *menu-maximum-height*)) ((> sel (- len *menu-maximum-height*)) (values (- len *menu-maximum-height*) len)) ((< sel (menu-state-view-start menu)) (values (- sel *menu-scrolling-step*) (- (+ sel *menu-maximum-height*) *menu-scrolling-step*))) ((>= sel (menu-state-view-end menu)) (values (+ (- sel *menu-maximum-height*) *menu-scrolling-step*) (+ sel *menu-scrolling-step*))) (t (values (menu-state-view-start menu) (menu-state-view-end menu))))))))) (defun menu-up (menu) (setf (menu-state-current-input menu) "") (decf (menu-state-selected menu)) (bound-check-menu menu)) (defun menu-down (menu) (setf (menu-state-current-input menu) "") (incf (menu-state-selected menu)) (bound-check-menu menu)) (defun menu-scroll-up (menu) (setf (menu-state-current-input menu) "") (decf (menu-state-selected menu) *menu-scrolling-step*) (bound-check-menu menu)) (defun menu-scroll-down (menu) (setf (menu-state-current-input menu) "") (incf (menu-state-selected menu) *menu-scrolling-step*) (bound-check-menu menu)) (defun menu-page-up (menu) (setf (menu-state-current-input menu) "") (decf (menu-state-selected menu) *menu-maximum-height*) (let ((*menu-scrolling-step* *menu-maximum-height*)) (bound-check-menu menu))) (defun menu-page-down (menu) (setf (menu-state-current-input menu) "") (incf (menu-state-selected menu) *menu-maximum-height*) (let ((*menu-scrolling-step* *menu-maximum-height*)) (bound-check-menu menu))) (defun menu-finish (menu) (throw :menu-quit (nth (menu-state-selected menu) (menu-state-table menu)))) (defun 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))) (defun menu-element-name (element) (if (listp element) (first element) element)) (defun check-menu-complete (menu key-seq) "If the use entered a key not mapped in @var{*menu-map}, check if he's trying to type an entry's name. Match is case insensitive as long as the user types lower-case characters." (let ((input-char (get-input-char key-seq))) (when input-char (setf (menu-state-current-input menu) (concatenate 'string (menu-state-current-input menu) (string input-char))) (do* ((cur-pos 0 (1+ cur-pos)) (rest-elem (menu-state-table menu) (cdr rest-elem)) (cur-elem (car rest-elem) (car rest-elem)) (cur-elem-name (menu-element-name cur-elem) (menu-element-name cur-elem)) (current-input-length (length (menu-state-current-input menu))) (match-regex (ppcre:create-scanner (menu-state-current-input menu) :case-insensitive-mode (string= (string-downcase (menu-state-current-input menu)) (menu-state-current-input menu))))) ((not cur-elem)) (when (and (>= (length cur-elem-name) current-input-length) (ppcre:scan match-regex cur-elem-name)) (setf (menu-state-selected menu) cur-pos) (bound-check-menu menu) (return)))))) (defun select-from-menu (screen table &optional prompt (initial-selection 0)) "Prompt the user to select from a menu on SCREEN. TABLE can be a list of values or an alist. If it's an alist, the CAR of each element is displayed in the menu. What is displayed as menu items must be strings. Returns the selected element in TABLE or nil if aborted. See *menu-map* for menu bindings." (check-type screen screen) (check-type table list) (check-type prompt (or null string)) (check-type initial-selection integer) (let* ((menu-options (mapcar #'menu-element-name table)) (menu-require-scrolling (and *menu-maximum-height* (> (length menu-options) *menu-maximum-height*))) (menu (make-menu-state :table table :prompt prompt :current-input "" :view-start (if menu-require-scrolling initial-selection 0) :view-end (if menu-require-scrolling (+ initial-selection *menu-maximum-height*) (length menu-options)) :selected initial-selection)) (*record-last-msg-override* t) (*suppress-echo-timeout* t)) (bound-check-menu menu) (catch :menu-quit (unwind-protect (with-focus (screen-key-window screen) (loop (let ((strings (subseq menu-options (menu-state-view-start menu) (menu-state-view-end menu))) (highlight (- (menu-state-selected menu) (menu-state-view-start menu)))) (unless (= 0 (menu-state-view-start menu)) (setf strings (cons "..." strings)) (incf highlight)) (unless (= (length menu-options) (menu-state-view-end menu)) (setf strings (nconc strings '("...")))) (unless (string= (menu-state-current-input menu) "") (setf strings (cons (format nil "Search: ~a" (menu-state-current-input menu)) strings)) (incf highlight)) (when prompt (setf strings (cons prompt strings)) (incf highlight)) (echo-string-list screen strings highlight)) (multiple-value-bind (action key-seq) (read-from-keymap (list *menu-map*)) (if action (funcall action menu) (check-menu-complete menu (first key-seq)))))) (unmap-all-message-windows))))) stumpwm-20110819.gitca08e08/message-window.lisp000066400000000000000000000275451162337705100211140ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; message printing functions ;; ;; Code: (in-package #:stumpwm) (export '(echo-string err message)) (defun max-width (font l) "Return the width of the longest string in L using FONT." (loop for i in l maximize (xlib:text-width font i :translate #'translate-id))) (defun get-gravity-coords (gravity width height minx miny maxx maxy) "Return the x y coords for a window on with gravity etc" (values (case gravity ((:top-right :bottom-right :right) (- maxx width)) ((:top :bottom :center) (truncate (- maxx minx width) 2)) (t minx)) (case gravity ((:bottom-left :bottom-right :bottom) (- maxy height)) ((:left :right :center) (truncate (- maxy miny height) 2)) (t miny)))) (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)) (h (xlib:drawable-height win)) (screen-width (head-width (current-head))) (screen-height (head-height (current-head)))) (let ((x (case gravity ((:top-left :bottom-left) 0) (:center (truncate (- screen-width w (* (xlib:drawable-border-width win) 2)) 2)) (t (- screen-width w (* (xlib:drawable-border-width win) 2))))) (y (case gravity ((:bottom-right :bottom-left) (- screen-height h (* (xlib:drawable-border-width win) 2))) (:center (truncate (- screen-height h (* (xlib:drawable-border-width win) 2)) 2)) (t 0)))) (setf (xlib:drawable-y win) (max (head-y (current-head)) (+ (head-y (current-head)) y)) (xlib:drawable-x win) (max (head-x (current-head)) (+ (head-x (current-head)) x))))))) (defun setup-message-window (screen lines width) (let ((height (* lines (+ (xlib:font-ascent (screen-font screen)) (xlib:font-descent (screen-font screen))))) (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 (xlib:drawable-width win) (+ width (* *message-window-padding* 2)) (xlib:window-priority win) :above) (setup-win-gravity screen win *message-window-gravity*)) (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 invert-rect (screen win x y width height) "invert the color in the rectangular area. Used for highlighting text." (let ((gcontext (xlib:create-gcontext :drawable win :foreground (screen-fg-color screen) :function boole-xor))) (xlib:draw-rectangle win gcontext x y width height t) (setf (xlib:gcontext-foreground gcontext) (screen-bg-color screen)) (xlib:draw-rectangle win gcontext x y width height t))) (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 () "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-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 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-x frame) (truncate (- (frame-width frame) (xlib:text-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 echo-in-window (win font fg bg string) (let* ((height (font-height font)) (gcontext (xlib:create-gcontext :drawable win :font font :foreground fg :background bg)) (width (xlib:text-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*) (xlib:draw-image-glyphs win gcontext 0 (xlib: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))))) (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 (unless *executing-stumpwm-command* (let ((width (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings '() nil))) (setup-message-window screen (length strings) width) (render-strings screen (screen-message-cc screen) *message-window-padding* 0 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))) (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-20110819.gitca08e08/mode-line.lisp000066400000000000000000000510151162337705100200210ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA (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* *hidden-window-color* *screen-mode-line-format* *screen-mode-line-formatters* add-screen-mode-line-formatter enable-mode-line toggle-mode-line bar-zone-color)) (defstruct mode-line screen head window format position contents cc height factor (mode :stump)) (defun mode-line-gc (ml) (ccontext-gc (mode-line-cc ml))) (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 *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 *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*} @end table") (defvar *screen-mode-line-formatters* '((#\w fmt-window-list) (#\g fmt-group-list) (#\h fmt-head) (#\n fmt-group) (#\W fmt-head-window-list) (#\u fmt-urgent-window-list) (#\v fmt-head-window-list-hidden-windows) (#\d fmt-modeline-time)) "An alist containing format character format function pairs for formatting screen mode-lines. functions are passed the screen's current group.") (defvar *current-mode-line-formatters* nil "used in formatting modeline strings.") (defvar *current-mode-line-formatter-args* nil "used in formatting modeline strings.") (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)))) ;; All mode-line formatters take the mode-line they are being invoked from ;; as the first argument. Additional arguments (everything between the first ;; ',' and the ';' are provided as strings [not yet implemented]). (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) (let ((str (format-expand *window-formatters* *window-format* w))) (if (eq w (current-window)) (fmt-highlight str) str))) (screen-urgent-windows (mode-line-screen ml))))) (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-expand *window-formatters* *window-format* w)) (sort-windows (mode-line-current-group ml))))) (defun fmt-group-list (ml) "Given a group list all the groups in the group's screen." (format nil "~{~a~^ ~}" (mapcar (lambda (w) (let* ((str (format-expand *group-formatters* *group-format* w))) (if (eq w (current-group)) (fmt-highlight str) str))) (sort-groups (group-screen (mode-line-current-group ml)))))) (defun fmt-head (ml) (format nil "~d" (head-number (mode-line-head ml)))) (defun fmt-group (ml) (format nil "~a" (group-name (mode-line-current-group ml)))) (defun fmt-highlight (s) (format nil "^R~A^r" s)) (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) (let ((str (format-expand *window-formatters* *window-format* w))) (if (eq w (current-window)) (fmt-highlight str) str))) (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)) (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) (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)))) (sort1 all #'< :key #'window-number))))) (defun fmt-modeline-time (ml) (declare (ignore ml)) (time-format *time-modeline-string*)) (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))) (defun make-mode-line-window (parent screen) "Create a window suitable for a modeline." (xlib:create-window :parent parent :x 0 :y 0 :width 1 :height 1 :background (alloc-color screen *mode-line-background-color*) :border (alloc-color screen *mode-line-border-color*) :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 resize-mode-line (ml) (when (eq (mode-line-mode ml) :stump) ;; This is a StumpWM mode-line (setf (xlib:drawable-height (mode-line-window ml)) (+ (* (1+ (count #\Newline (mode-line-contents ml) :test #'equal)) (font-height (xlib:gcontext-font (mode-line-gc ml)))) (* *mode-line-pad-y* 2)))) (setf (xlib:drawable-width (mode-line-window ml)) (- (frame-width (mode-line-head ml)) (* 2 (xlib:drawable-border-width (mode-line-window ml)))) (xlib:drawable-height (mode-line-window ml)) (min (xlib:drawable-height (mode-line-window ml)) (truncate (head-height (mode-line-head ml)) 4)) (mode-line-height ml) (+ (xlib:drawable-height (mode-line-window ml)) (* 2 (xlib:drawable-border-width (mode-line-window ml)))) (mode-line-factor ml) (- 1 (/ (mode-line-height ml) (head-height (mode-line-head ml)))) (xlib:drawable-x (mode-line-window ml)) (head-x (mode-line-head ml)) (xlib:drawable-y (mode-line-window ml)) (if (eq (mode-line-position ml) :top) (head-y (mode-line-head ml)) (- (+ (head-y (mode-line-head ml)) (head-height (mode-line-head ml))) (mode-line-height ml))))) (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 (or (eq val t) (eq val nil)) (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 make-mode-line-gc (window screen) (xlib:create-gcontext :drawable window :font (screen-font screen) :foreground (alloc-color screen *mode-line-foreground-color*) :background (alloc-color screen *mode-line-background-color*))) (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-head-mode-line (screen head format) (let* ((w (make-mode-line-window (screen-root screen) screen)) (gc (make-mode-line-gc w screen))) (make-mode-line :window w :screen screen :head head :format format :position *mode-line-position* :cc (make-ccontext :gc gc :win w :default-fg (xlib:gcontext-foreground gc) :default-bg (xlib:gcontext-background gc))))) (defun mode-line-current-group (ml) (screen-current-group (mode-line-screen ml))) (defun redraw-mode-line (ml &optional force) (when (eq (mode-line-mode ml) :stump) (let* ((*current-mode-line-formatters* *screen-mode-line-formatters*) (*current-mode-line-formatter-args* (list ml)) (string (mode-line-format-string ml))) (when (or force (not (string= (mode-line-contents ml) string))) (setf (mode-line-contents ml) string) (resize-mode-line ml) (render-strings (mode-line-screen ml) (mode-line-cc ml) *mode-line-pad-x* *mode-line-pad-y* (split-string string (string #\Newline)) '()))))) (defun find-mode-line-window (xwin) (dolist (s *screen-list*) (dolist (h (screen-heads s)) (let ((mode-line (head-mode-line h))) (when (and mode-line (eq (mode-line-window mode-line) xwin)) (return-from find-mode-line-window mode-line)))))) (defun sync-mode-line (ml) (dolist (group (screen-groups (mode-line-screen ml))) (group-sync-head group (mode-line-head ml)))) (defun set-mode-line-window (ml xwin) "Use an external window as mode-line." (xlib:destroy-window (mode-line-window ml)) (setf (mode-line-window ml) xwin (mode-line-mode ml) :visible (xlib:window-priority (mode-line-window ml)) :above) (resize-mode-line ml) (sync-mode-line ml)) (defun destroy-mode-line-window (ml) (xlib:destroy-window (mode-line-window ml)) (setf (head-mode-line (mode-line-head ml)) nil) (sync-mode-line ml)) (defun move-mode-line-to-head (ml head) (if (head-mode-line head) (when (mode-line-head ml) ;; head already has a mode-line. Try swapping them. (let ((old-head (mode-line-head ml))) (setf (mode-line-head ml) head (head-mode-line old-head) (head-mode-line head) (mode-line-head (head-mode-line head)) old-head (head-mode-line head) ml))) (progn (when (mode-line-head ml) (setf (head-mode-line (mode-line-head ml)) nil)) (setf (head-mode-line head) ml (mode-line-head ml) head)))) (defun update-mode-line-position (ml x y) (let ((head ;; Find the appropriate head (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 ml))))) (when (or (not head) (not (eq (head-mode-line head) ml))) ;; No luck. Just try to find a head without a mode-line already. (setf head (find-if-not #'head-mode-line (screen-heads (mode-line-screen ml))))) (if head (progn (unless (eq ml (head-mode-line head)) (move-mode-line-to-head ml head)) (when (mode-line-head ml) (setf (mode-line-position ml) (if (< y (/ (head-height (mode-line-head ml)) 2)) :top :bottom)))) nil))) (defun place-mode-line-window (screen xwin) (let ((ml (make-mode-line :window xwin :screen screen :mode :visible :position *mode-line-position*))) (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)))) (defun update-mode-lines (screen) "Update all mode lines on SCREEN" (dolist (h (screen-heads screen)) (let ((mode-line (head-mode-line h))) (when mode-line (redraw-mode-line mode-line))))) (defun update-all-mode-lines () "Update all mode lines." (mapc 'update-mode-lines *screen-list*)) (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 all-heads () "Return all heads on all screens." (loop for s in *screen-list* nconc (copy-list (screen-heads s)))) (defun maybe-cancel-mode-line-timer () (unless (find-if 'head-mode-line (all-heads)) (when (timer-p *mode-line-timer*) (cancel-timer *mode-line-timer*) (setf *mode-line-timer* nil)))) (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))) (:stump ;; Delete it (xlib:destroy-window (mode-line-window ml)) (xlib:free-gcontext (mode-line-gc ml)) (setf (head-mode-line head) nil) (maybe-cancel-mode-line-timer))) (progn (setf (head-mode-line head) (make-head-mode-line screen head format)) (update-mode-line-color-context (head-mode-line head)) (resize-mode-line (head-mode-line head)) (xlib:map-window (mode-line-window (head-mode-line head))) (redraw-mode-line (head-mode-line head)) (dformat 3 "modeline: ~s~%" (head-mode-line head)) ;; setup the timer (turn-on-mode-line-timer))) (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)) (if state (if (head-mode-line head) (when format (setf (mode-line-format (head-mode-line head)) format)) (toggle-mode-line screen head (or format *screen-mode-line-format*))) (when (head-mode-line head) (toggle-mode-line screen head)))) (defcommand mode-line () () "A command to toggle the mode line visibility." (toggle-mode-line (current-screen) (current-head))) stumpwm-20110819.gitca08e08/module.lisp000066400000000000000000000047121162337705100174370ustar00rootroot00000000000000;; Copyright (C) 2008 Julian Stecklina, Shawn Betts, 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Use `set-contrib-dir' to set the location stumpwm searches for modules. ;; Code: (in-package #:stumpwm) (export '(load-module list-modules *contrib-dir* set-contrib-dir find-module)) (defun module-string-as-directory (dir) (unless (string= "/" (subseq dir (1- (length dir)))) (setf dir (concat dir "/"))) (pathname dir)) (defvar *contrib-dir* #.(asdf:system-relative-pathname (asdf:find-system :stumpwm) (make-pathname :directory '(:relative "contrib"))) "The location of the contrib modules on your system.") (defcommand set-contrib-dir (dir) ((:string "Directory: ")) "Sets the location of the contrib modules" (setf *contrib-dir* (module-string-as-directory dir))) (define-stumpwm-type :module (input prompt) (or (argument-pop-rest input) (completing-read (current-screen) prompt (list-modules) :require-match t))) (defun list-modules () "Return a list of the available modules." (mapcar 'pathname-name (directory (make-pathname :defaults *contrib-dir* :name :wild :type "lisp")))) (defun find-module (name) (probe-file (make-pathname :defaults *contrib-dir* :name name :type "lisp"))) (defcommand load-module (name) ((:module "Load Module: ")) "Loads the contributed module with the given NAME." ;; FIXME: This should use ASDF in the future. And maybe there should ;; be an extra stumpwm-contrib repository. (when name (let ((module (find-module name))) (when module (load module))))) ;; End of file stumpwm-20110819.gitca08e08/package.lisp000066400000000000000000000016431162337705100175450ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA (defpackage :stumpwm (:use :cl) (:shadow #:yes-or-no-p #:y-or-n-p)) (defpackage :stumpwm-user (:use :cl :stumpwm)) stumpwm-20110819.gitca08e08/pathnames.lisp000066400000000000000000000117101162337705100201260ustar00rootroot00000000000000;;; -*- 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)) (defun component-present-p (value) "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE is neither NIL nor the keyword :UNSPECIFIC." (and value (not (eql value :unspecific)))) (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." (and (not (component-present-p (pathname-name pathspec))) (not (component-present-p (pathname-type pathspec))) pathspec)) (defun pathname-as-directory (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." (let ((pathname (pathname pathspec))) (when (wild-pathname-p pathname) (error "Can't reliably convert wild pathnames.")) (cond ((not (directory-pathname-p pathspec)) (make-pathname :directory (append (or (pathname-directory pathname) (list :relative)) (list (file-namestring pathname))) :name nil :type nil :defaults pathname)) (t pathname)))) (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 #-:cormanlisp :wild #+:cormanlisp "*" :type #-(or :clisp :cormanlisp) :wild #+:clisp nil #+:cormanlisp "*" :defaults (pathname-as-directory dirname))) #+:clisp (defun clisp-subdirectories-wildcard (wildcard) "Creates a wild pathname specifically for CLISP such that sub-directories are returned by DIRECTORY." (make-pathname :directory (append (pathname-directory wildcard) (list :wild)) :name nil :type nil :defaults wildcard)) (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.")) #+:ecl (let ((dir (pathname-as-directory dirname))) (concatenate 'list (directory (merge-pathnames (pathname "*/") dir)) (directory (merge-pathnames (pathname "*.*") dir)))) #-:ecl (let ((wildcard (directory-wildcard dirname))) #+:abcl (system::list-directory dirname) #+(or :sbcl :cmu :scl :lispworks) (directory wildcard) #+(or :openmcl :digitool) (directory wildcard :directories t) #+:allegro (directory wildcard :directories-are-files nil) #+:clisp (nconc (directory wildcard :if-does-not-exist :keep) (directory (clisp-subdirectories-wildcard wildcard))) #+:cormanlisp (nconc (directory wildcard) (cl::directory-subdirs dirname))) #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool) (error "LIST-DIRECTORY not implemented")) ;;; EOF stumpwm-20110819.gitca08e08/primitives.lisp000066400000000000000000001165541162337705100203550ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; This file contains primitive data structures and functions used ;; throughout stumpwm. ;; ;; Code: (in-package :stumpwm) (export '(*suppress-abort-messages* *suppress-frame-indicator* *timeout-wait* *timeout-frame-indicator-wait* *frame-indicator-text* *frame-indicator-timer* *message-window-timer* *command-mode-start-hook* *command-mode-end-hook* *urgent-window-hook* *new-window-hook* *destroy-window-hook* *focus-window-hook* *place-window-hook* *start-hook* *internal-loop-hook* *focus-frame-hook* *new-frame-hook* *split-frame-hook* *message-hook* *top-level-error-hook* *focus-group-hook* *key-press-hook* *root-click-hook* *mode-line-click-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-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 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)) ;;; 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-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 *message-window-timer* nil "Keep track of the timer that hides the message window.") (defvar *grab-pointer-count* 0 "The number of times the pointer has been grabbed") ;;; 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 *start-hook* '() "A hook called when stumpwm starts.") (defvar *internal-loop-hook* '() "A hook called inside stumpwm's inner loop.") (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 *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 *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.") ;; 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 *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-gravity* :top-right "This variable controls where the message window appears. The follow are valid values. @table @asis @item :top-left @item :top-right @item :bottom-left @item :bottom-right @item :center @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 follow are valid values. @table @asis @item :top-left @item :top-right @item :bottom-left @item :bottom-right @item :center @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+ "9x15bold") (defparameter +default-focus-color+ "White") (defparameter +default-unfocus-color+ "Black") (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) (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 stumpmwm.") (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") (defstruct frame (number nil :type integer) x y width height window) (defstruct (head (:include frame)) ;; point back to the screen this head belongs to screen ;; a bar along the top or bottom that displays anything you want. mode-line) (defclass screen () ((id :initform nil :accessor screen-id) (host :initform nil :accessor screen-host) (number :initform nil :accessor screen-number) (heads :initform nil :accessor screen-heads :documentation "heads of screen") (groups :initform nil :accessor screen-groups :documentation "the list of groups available on this screen") (current-group :initform nil :accessor screen-current-group) ;; various colors (as returned by alloc-color) (border-color :initform nil :accessor screen-border-color) (fg-color :initform nil :accessor screen-fg-color) (bg-color :initform nil :accessor screen-bg-color) (win-bg-color :initform nil :accessor screen-win-bg-color) (focus-color :initform nil :accessor screen-focus-color) (unfocus-color :initform nil :accessor screen-unfocus-color) (msg-border-width :initform nil :accessor screen-msg-border-width) (frame-outline-width :initform nil :accessor screen-frame-outline-width) (font :initform nil :accessor screen-font) (mapped-windows :initform nil :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 nil :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 nil :accessor screen-urgent-windows :documentation "a list of windows for which (window-urgent-p) currently true.") (input-window :initform nil :accessor screen-input-window) (key-window :initform nil :accessor screen-key-window :documentation "the window that accepts further keypresses after a toplevel key has been pressed.") (focus-window :initform nil :accessor screen-focus-window :documentation "The window that gets focus when no window has focus") ;; (frame-window :initform nil :accessor screen-frame-window) (frame-outline-gc :initform nil :accessor screen-frame-outline-gc) ;; color contexts (message-cc :initform nil :accessor screen-message-cc) (mode-line-cc :initform nil :accessor screen-mode-line-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 nil :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 win px gc default-fg default-bright default-bg) (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))) (defmethod print-object ((object frame) stream) (format stream "#S(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))) (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* "0123456789abcdefghijklmnopqrstuvxwyz" "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))) (or (and (< 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-object ((object screen) stream) (format stream "#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 (defun run-hook-with-args (hook &rest args) "Call each function in HOOK and pass args to it." (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 hook @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!\")) \(stumpmwm: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))) ;; Misc. utility functions (defun conc1 (list arg) "Append arg to the end of list" (nconc list (list arg))) (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 mapcar-hash (fn hash) "Just like maphash except it accumulates the result in a list." (let ((accum nil)) (labels ((mapfn (key val) (push (funcall fn key val) accum))) (maphash #'mapfn hash)) accum)) (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 remove-plist (plist &rest keys) "Remove the keys from the plist. Useful for re-using the &REST arg after removing some options." (do (copy rest) ((null (setq rest (nth-value 2 (get-properties plist keys)))) (nreconc copy plist)) (do () ((eq plist rest)) (push (pop plist) copy) (push (pop plist) copy)) (setq plist (cddr plist)))) (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 split-seq (seq separators &key test default-value) "split a sequence into sub sequences given the list of seperators." (let ((seps separators)) (labels ((sep (c) (find 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 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))) (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* *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) (decode-universal-time (get-universal-time)) (format *debug-stream* "~2,'0d:~2,'0d:~2,'0d " h m sec)) ;; 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*)) ;;; ;;; 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 windows 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. @xref{*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) (+ (xlib:font-descent font) (xlib:font-ascent font))) (defvar *x-selection* nil "This holds stumpwm's current selection. It is 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 this is assigned using LET.") (defvar *ignore-echo-timeout* nil "Assign this T and the message time out won't be touched. It is recommended this is assigned 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 &rest 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 create restore dump-name class instance type role title) @end example @table @var @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 the current group matches @var{target-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 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 window's class must match @var{class}. @item instance The window's instance/resource name must match @var{instance}. @item type The window's type must match @var{type}. @item role The window's role must match @var{role}. @item title The window's title must match @var{title}. @end table" (let ((x (gensym "X"))) `(dolist (,x ',frame-rules) ;; verify the correct structure (destructuring-bind (frame-number raise lock &rest keys &key create restore class instance type role title) ,x (declare (ignore create restore class instance type role title)) (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 *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.") (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 when *mouse-focus-policy* is :click.") (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* (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list ".stumpwm.d"))) "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 *data-dir* file) ,@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-error (error) () (:documentation "Any stumpwm specific error should inherit 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.")) stumpwm-20110819.gitca08e08/sample-stumpwmrc.lisp000066400000000000000000000050301162337705100214640ustar00rootroot00000000000000;; -*-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 Google and Imdb) (defmacro make-web-jump (name prefix) `(defcommand ,name (search) ((:rest ,(concatenate 'string name " search: "))) (substitute #\+ #\Space search) (run-shell-command (concatenate 'string ,prefix search)))) (make-web-jump "google" "firefox http://www.google.fr/search?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") "google") (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-20110819.gitca08e08/screen.lisp000066400000000000000000000504101162337705100174250ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Screen functionality ;; ;; Code: (in-package #:stumpwm) (export '(current-screen current-window screen-current-window set-fg-color set-bg-color set-border-color set-win-bg-color set-focus-color set-unfocus-color set-msg-border-width set-frame-outline-width set-font)) ;; 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) (if (stringp src) ; clx does this test so i guess it's needed (loop for i from src-start to src-end for j from dst-start as c = (char-code (char src i)) if (<= min c max) do (setf (aref dst j) c) ;; replace unknown characters with question marks else do (setf (aref dst j) (char-code #\?)) finally (return i)) (loop for i from src-start to src-end for j from dst-start as c = (elt src i) as n = (if (characterp c) (char-code c) c) if (and (integerp n) (<= min n max)) do (setf (aref dst j) n) ;; ditto else 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-true-height (screen) "Return the height of the screen regardless of the modeline" (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 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)) ;;(format t "FOCUS TO: ~a ~a~%" window (window-xwin window)) ;;(format t "FOCUS BEFORE: ~a~%" (multiple-value-list (xlib:input-focus *display*))) ;;(format t "FOCUS RET: ~a~%" (xlib:set-input-focus *display* (window-xwin window) :POINTER-ROOT)) (xlib:set-input-focus *display* (window-xwin window) :POINTER-ROOT) ;;(xlib:display-finish-output *display*) ;;(format t "FOCUS IS: ~a~%" (multiple-value-list (xlib:input-focus *display*))) (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))) (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))) (defun color-exists-p (color) (handler-case (loop for i in *screen-list* always (xlib:lookup-color (xlib:screen-default-colormap (screen-number i)) color)) (xlib:name-error () nil))) (defun font-exists-p (font-name) ;; if we can list the font then it exists (plusp (length (xlib:list-font-names *display* font-name :max-fonts 1)))) (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-msg-border-width (width) "Set the border width for the message bar and input bar." (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 for the message bar and input bar." (when (font-exists-p font) (dolist (i *screen-list*) (let ((fobj (xlib:open-font *display* (first (xlib:list-font-names *display* font :max-fonts 1))))) (xlib:close-font (screen-font i)) (setf (screen-font i) fobj (xlib:gcontext-font (screen-message-gc i)) fobj) ;; update the modelines too (dolist (h (screen-heads i)) (when (and (head-mode-line h) (eq (mode-line-mode (head-mode-line h)) :stump)) (setf (xlib:gcontext-font (mode-line-gc (head-mode-line h))) fobj) (resize-mode-line (head-mode-line h)) (sync-mode-line (head-mode-line h)))))) 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 focus-window) "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)) (root (xlib:screen-root screen-number))) ;; _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) (xlib:alloc-color (xlib:screen-default-colormap screen-number) color))) (let* ((screen (make-instance 'screen)) (fg (ac +default-foreground-color+)) (bg (ac +default-background-color+)) (border (ac +default-border-color+)) (focus (ac +default-focus-color+)) (unfocus (ac +default-unfocus-color+)) (win-bg (ac +default-window-background-color+)) (input-window (xlib:create-window :parent (xlib:screen-root screen-number) :x 0 :y 0 :width 20 :height 20 :background bg :border border :border-width 1 :colormap (xlib:screen-default-colormap screen-number) :event-mask '(:key-press :key-release))) (focus-window (xlib:create-window :parent (xlib:screen-root screen-number) :x 0 :y 0 :width 1 :height 1)) (key-window (xlib:create-window :parent (xlib:screen-root screen-number) :x 0 :y 0 :width 1 :height 1 :event-mask '(:key-press :key-release))) (message-window (xlib:create-window :parent (xlib:screen-root screen-number) :x 0 :y 0 :width 1 :height 1 :background bg :bit-gravity :north-east :border border :border-width 1 :colormap (xlib:screen-default-colormap screen-number) :event-mask '(:exposure))) (frame-window (xlib:create-window :parent (xlib:screen-root screen-number) :x 0 :y 0 :width 20 :height 20 :background bg :border border :border-width 1 :colormap (xlib:screen-default-colormap screen-number) :event-mask '(:exposure))) (font (xlib:open-font *display* (if (font-exists-p +default-font-name+) +default-font-name+ "*"))) (group (make-instance 'tile-group :screen screen :number 1 :name *default-group-name*))) ;; Create our screen structure ;; The focus window is mapped at all times (xlib:map-window focus-window) (xlib:map-window key-window) (setf (screen-number screen) screen-number (screen-id screen) id (screen-host screen) host (screen-groups screen) (list group) (screen-current-group screen) group (screen-font screen) font (screen-fg-color screen) fg (screen-bg-color screen) bg (screen-win-bg-color screen) win-bg (screen-border-color screen) border (screen-focus-color screen) focus (screen-unfocus-color screen) unfocus (screen-msg-border-width screen) 1 (screen-frame-outline-width screen) +default-frame-outline-width+ (screen-input-window screen) input-window (screen-focus-window screen) focus-window (screen-key-window screen) key-window (screen-frame-window screen) frame-window (screen-ignore-msg-expose screen) 0 (screen-message-cc screen) (make-ccontext :win message-window :gc (xlib:create-gcontext :drawable message-window :font font :foreground fg :background bg)) (screen-frame-outline-gc screen) (xlib:create-gcontext :drawable (screen-root screen) :font font :foreground fg :background fg :line-style :double-dash :line-width +default-frame-outline-width+)) (setf (screen-heads screen) (make-screen-heads screen (xlib:screen-root screen-number)) (tile-group-frame-tree group) (copy-heads screen) (tile-group-current-frame group) (first (tile-group-frame-tree group))) (netwm-set-properties screen focus-window) (update-colors-for-screen screen) (update-color-map screen) (xwin-grab-keys focus-window screen) 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-20110819.gitca08e08/selection.lisp000066400000000000000000000102721162337705100201350ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Handle the X selection. ;; ;; Code: (in-package #:stumpwm) (export '(get-x-selection set-x-selection)) (defun export-selection () (let* ((screen (current-screen)) (selwin (screen-focus-window (current-screen))) (root (screen-root screen))) (xlib:set-selection-owner *display* :primary selwin) (unless (xlib:window-equal (xlib:selection-owner *display* :primary) selwin) (error "Can't set selection owner")) ;; also set the cut buffer for completeness (xlib:change-property root :cut-buffer0 *x-selection* :string 8 :transform #'xlib:char->card8 :mode :replace))) (defun set-x-selection (text) "Set the X11 selection string to @var{string}." (setf *x-selection* text) (export-selection)) (defun send-selection (requestor property selection target time) (dformat 1 "send-selection ~s ~s ~s ~s ~s~%" requestor property selection target time) (cond ;; they're requesting what targets are available ((eq target :targets) (xlib:change-property requestor property (list :targets :string) target 8 :mode :replace)) ;; send them a string ((find target '(:string )) (xlib:change-property requestor property *x-selection* :string 8 :mode :replace :transform #'xlib:char->card8)) ;; 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) "Return the x selection no matter what client own it." (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 (xlib:get-property window property :type :string :result-type 'string :transform #'xlib:card8->char :delete-p t) ""))))) (if *x-selection* *x-selection* (progn (xlib:convert-selection :primary :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 (defcommand putsel (string) ((:rest "Text: ")) "Stuff the string @var{string} into the X selection." (set-x-selection string)) ;; FIXME: this function is basically useless atm. (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-20110819.gitca08e08/stumpwm.asd000066400000000000000000000033771162337705100174740ustar00rootroot00000000000000;;; -*- Mode: Lisp -*- (defpackage :stumpwm-system (:use :cl :asdf)) (in-package :stumpwm-system) ;; This is a hack for debian because it calls cmucl's clx ;; cmucl-clx. *very* annoying. I don't actually know if debian still ;; does this. #+cmu (progn (ignore-errors (require :cmucl-clx)) (ignore-errors (require :clx))) (defsystem :stumpwm :name "StumpWM" :author "Shawn Betts " :version "CVS" :maintainer "Shawn Betts " ;; :license "GNU General Public License" :description "A tiling, keyboard driven window manager" :serial t :depends-on (:cl-ppcre #-(or cmu clisp) :clx #+sbcl :sb-posix) :components ((:file "package") (:file "primitives") (:file "workarounds") (:file "wrappers") (:file "pathnames") (:file "keysyms") (:file "keytrans") (:file "kmap") (:file "input") (:file "core") (:file "command") (:file "menu") (:file "screen") (:file "head") (:file "group") (:file "window") (:file "floating-group") (:file "tile-group") (:file "tile-window") (:file "window-placement") (:file "message-window") (:file "selection") (:file "user") (:file "iresize") (:file "bindings") (:file "events") (:file "help") (:file "fdump") (:file "time") (:file "mode-line") (:file "color") (:file "module") (:file "stumpwm") ;; keep this last so it always gets recompiled if ;; anything changes (:file "version"))) stumpwm-20110819.gitca08e08/stumpwm.lisp000066400000000000000000000257531162337705100176760ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Code: (in-package :stumpwm) (export '(cancel-timer run-with-timer stumpwm timer-p)) ;;; 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 (user-homedir-pathname) #p".stumpwmrc"))) (etc-rc (probe-file #p"/etc/stumpwmrc")) (rc (or user-rc etc-rc))) (if rc ;; TODO: Should we compile the file before we load it? (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)))) ;;; Timers (defvar *timer-list* nil "List of active timers.") (defstruct timer time repeat function args) (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) (setf *timer-list* (sort-timers (cons timer *timer-list*))) timer)) (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (check-type timer timer) (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) "Return a new list of timers sorted by time to time out." (sort (copy-list timers) (lambda (a b) (< (timer-time a) (timer-time b))))) (defun run-expired-timers (timers) "Return a new list of valid timers and run the timer functions of those expired." (let ((now (get-internal-real-time))) (sort-timers (loop for i in timers with keepers = nil do (if (< (timer-time i) now) (progn (apply (timer-function i) (timer-args i)) (when (timer-repeat i) (schedule-timer i (timer-repeat i)) (push i keepers))) (push i keepers)) finally (return keepers))))) (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))) (defun perform-top-level-error-action (c) (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 (invoke-debugger c)) (:abort (throw :top-level (list c (backtrace-string)))))) (defun stumpwm-internal-loop () "The internal loop that waits for events and handles them." (loop (run-hook *internal-loop-hook*) (handler-bind ((xlib:lookup-error (lambda (c) (if (lookup-error-recoverable-p) (recover-from-lookup-error) (error c)))) (warning #'muffle-warning) ((or serious-condition error) (lambda (c) (run-hook *top-level-error-hook*) (perform-top-level-error-action c))) (t (lambda (c) ;; some other wacko condition was raised so first try ;; what we can to keep going. (cond ((find-restart 'muffle-warning) (muffle-warning)) ((find-restart 'continue) (continue))) ;; and if that fails treat it like a top level error. (perform-top-level-error-action c)))) ;; 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. (let ((timeout (get-next-timeout *timer-list*))) (dformat 10 "timeout: ~a~%" timeout) (if timeout (let* ((nevents (xlib:event-listen *display* (ceiling timeout)))) (setf *timer-list* (run-expired-timers *timer-list*)) (when nevents (xlib:process-event *display* :handler #'handle-event))) ;; Otherwise, simply wait for an event (xlib:process-event *display* :handler #'handle-event)) ;; flush any pending output. You'd think process-event would, but ;; it seems not. (xlib:display-finish-output *display*) ;;(dformat 10 "toplevel focus: ~a~%" (multiple-value-list (xlib:input-focus *display*))) )))) (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 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)) ;; 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*) ;; 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)))) ;; Let's manage. (let ((*package* (find-package *default-package*))) (run-hook *start-hook*) (stumpwm-internal-loop))) (xlib:close-display *display*)))) ;; what should the top level loop do? :quit) ;; Usage: (stumpwm) (defun stumpwm (&optional (display-str (or (getenv "DISPLAY") ":0"))) "Start the stump window manager." (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) (apply 'execv (first (argv)) (argv))) ((eq ret :restart)) (t ;; the number is the unix return code (return-from stumpwm 0)))))) stumpwm-20110819.gitca08e08/stumpwm.texi.in000066400000000000000000001350671162337705100203050ustar00rootroot00000000000000\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 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 @page @vskip 0pt plus 1filll Copyright @copyright{} 2000-2008 Shawn Betts 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:: * Interacting With Unix:: * Interacting With X11:: * Miscellaneous Commands:: * Colors:: * Hooks:: * Modules:: * Hacking:: * Command and Function Index:: * Variable Index:: @detailmenu --- The Detailed Node Listing --- Introduction * Starting StumpWM:: * Basic Usage:: * Interacting with the Lisp process:: * Contact the StumpWM developers:: Key Bindings * List of Default Keybindings:: * Binding Keys:: * Modifiers:: 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:: Frames * Interactively Resizing Frames:: * Frame Dumping:: Groups * Customizing Groups:: Screens * Xinerama:: * Programming With Screens:: Miscellaneous Commands * Menus:: * StumpWM's Data Directory:: * Debugging StumpWM:: * Timers:: * Getting Help:: Colors * Behind The Scenes Look At Colors:: Hacking * General Advice:: * Using git with StumpWM:: * Sending Patches:: @end detailmenu @end menu @node Introduction, Key Bindings, Top, Top @chapter Introduction StumpWM is an X11 window manager written entirely in Common Lisp. Its user interface goals are similar to ratpoison's but with an emphasis on customizability, completeness, and cushiness. @menu * Starting StumpWM:: * Basic Usage:: * Interacting with the Lisp process:: * 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 @command{sbcl}, the @command{portable-clx} package, and @command{cl-ppcre}. In Debian, @command{portable-clx} is the @command{cl-clx-sbcl} package. You can also use @command{asdf-install} to download and install@tie{}@command{clx}: @example $ sbcl * (require :asdf) * (require :asdf-install) * (asdf-install:install :clx) * (asdf-install:install :cl-ppcre) @end example Note that @command{asdf-install} requires @command{gnupg}. @item In the @file{stumpwm} directory, run @command{./configure}. @item run @command{make}. If all goes well, this should create 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 @node Basic Usage, Interacting with the Lisp process, 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 interwebs. 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 Interacting with the Lisp process, Contact the StumpWM developers, Basic Usage, 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 Contact the StumpWM developers, , Interacting with the Lisp process, Introduction @section Contact the StumpWM developers The StumpWM home page is @url{http://stumpwm.nongnu.org/}. You can reach Shawn Betts at @email{sabetts at vcn.bc.ca}. The StumpWM mailing list is @email{stumpwm-devel@@nongnu.org} which you can subscribe to at @url{http://mail.nongnu.org/mailman/listinfo/stumpwm-devel}. Posting is restricted to subscribers to keep spam out of the archives. The StumpWM IRC channel can be found on Freenode at @uref{irc://irc.freenode.net/#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:: @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. @itemx C-t C-g Abort the current command. This is useful if you accidentally hit @kbd{C-t} @item C-t w List all the windows @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 the windows, their number, and their name. @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 ran as Lisp programs; thus, input should be valid Common Lisp. @item C-t C-h @itemx C-t ? The help. @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* !!! bind @node Modifiers, , 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 graphical login manager (GDM, KDM, etc.), your @file{~/.Xmodmap} file should be fed to @command{xmodmap} when you log in. FIXME: verify this. @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 @node Commands, Message and Input Bar, Key Bindings, Top @chapter Commands If you've used emacs before you'll find commands and functions familiar. Commands are functions that can be bound to keys and executed interactively from StumpWM's input bar. A command expects a certain number of arguments and any that are not supplied will be prompted for. FIXME: actually write some docs here @node Message and Input Bar, Windows, Commands, Top @chapter Message and Input Bar !!! echo !!! colon @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. @@@ set-fg-color @@@ set-bg-color @@@ set-border-color @@@ set-msg-border-width @@@ set-font ### *message-window-padding* ### *message-window-gravity* ### *timeout-wait* ### *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 ### *input-history-ignore-duplicates* !!! 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 !!! pull-hidden-next !!! prev !!! pull-hidden-previous !!! delete-window !!! kill-window !!! echo-windows !!! other-window !!! pull-hidden-other !!! renumber !!! meta !!! select-window !!! select-window-by-number !!! title !!! windowlist !!! fullscreen !!! info !!! refresh !!! redisplay ### *window-format* ### *window-name-source* ### *new-window-prefered-frame* @menu * Window Marks:: * Customizing Window Appearance:: * Controlling Raise And Map Requests:: * Programming With Windows:: * Rule Based Window Placement:: @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* @@@ set-win-bg-color @@@ set-focus-color @@@ set-unfocus-color @@@ set-normal-gravity @@@ set-maxsize-gravity @@@ set-transient-gravity !!! gravity @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* @node Rule Based Window Placement, , 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 @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 !!! remove-split !!! only !!! curframe !!! fnext !!! sibling !!! fother !!! fselect !!! resize !!! balance-frames !!! fclear !!! move-focus !!! move-window !!! next-in-frame !!! prev-in-frame !!! other-in-frame !!! echo-frame-windows !!! exchange-direction ### *min-frame-width* ### *min-frame-height* ### *new-frame-action* @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. NOTE: This currently doesn't work. @item RET Select the highlighted option. @end table !!! iresize !!! abort-iresize !!! exit-iresize ### *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 @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 Xinerama 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* The following variables control the color, position, and size of the mode line. ### *mode-line-position* ### *mode-line-border-width* 1 ### *mode-line-pad-x* ### *mode-line-pad-y* ### *mode-line-background-color* ### *mode-line-foreground-color* ### *mode-line-border-color* ### *mode-line-timeout* @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 !!! gnewbg !!! gnewbg-float !!! gnext !!! gprev !!! gnext-with-window !!! gprev-with-window !!! gother !!! gmerge !!! groups !!! vgroups !!! gselect !!! gmove !!! gkill !!! grename !!! grouplist @menu * Customizing Groups:: @end menu @node Customizing Groups, , Groups, Groups @section Customizing Groups ### *group-formatters* ### *group-format* @@@ current-group @node Screens, Interacting With Unix, Groups, Top @chapter Screens StumpWM handles multiple screens. !!! snext !!! sprev !!! sother @menu * Xinerama:: * Programming With Screens:: @end menu @node Xinerama, Programming With Screens, Screens, Screens @section Xinerama StumpWM will attempt to detect Xinerama heads at startup (and at no other time.) Heads are logically contained by screens. In a dual-monitor Xinerama 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. @node Programming With Screens, , Xinerama, Screens @section Programming With Screens @@@ current-screen @@@ screen-current-window @@@ current-window ### *screen-list* @node Interacting With Unix, Interacting With X11, Screens, Top @chapter Interacting With Unix !!! run-shell-command @@@ programs-in-path @@@ pathname-is-executable-p ### *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 @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 section. !!! emacs !!! banish !!! ratwarp !!! ratrelwarp !!! ratclick !!! echo-date !!! eval-line !!! window-send-string !!! reload !!! loadrc !!! keyboard-quit !!! quit !!! restart-hard !!! restart-soft !!! getsel !!! putsel !!! command-mode !!! copy-unhandled-error !!! commands !!! lastmsg !!! list-window-properties @@@ run-commands %%% defcommand %%% define-stumpwm-type @@@ run-or-raise @@@ run-or-pull ### *run-or-raise-all-groups* ### *run-or-raise-all-screens* @@@ restarts-menu %%% with-restarts-menu ### *startup-message* ### *suppress-abort-messages* ### *default-package* %%% defprogram-shortcut ### *initializing* @menu * Menus:: * StumpWM's Data Directory:: * Debugging StumpWM:: * Timers:: * Getting Help:: @end menu @node Menus, StumpWM's Data Directory, Miscellaneous Commands, Miscellaneous Commands @section Menus Some commands present the options in a menu. The following are the menu key bindings: @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 C-g @itemx ESC Abort the menu. @item RET Select the highlighted option. @end table @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, Timers, StumpWM's Data Directory, Miscellaneous Commands @section Debugging StumpWM ### *debug-level* ### *debug-stream* @@@ redirect-all-output @node Timers, Getting Help, Debugging StumpWM, Miscellaneous Commands @section Timers StumpWM has a timer system similar to that of @dfn{Emacs}. @@@ 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 !!! where-is !!! modifiers @node Colors, Hooks, Miscellaneous Commands, Top @chapter Colors 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 ^^ 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. @@@ 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 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* $$$ *key-press-hook* $$$ *root-click-hook* $$$ *mode-line-click-hook* $$$ *urgent-window-hook* @node Modules, Hacking, Hooks, Top @chapter Modules StumpWM has a growing number of modules not loaded by default. All modules exist in the @file{contrib/} directory of StumpWM's archive. !!! load-module @node Hacking, Command and Function Index, Modules, Top @chapter Hacking For those of you who have worked on Free Software projects before, this part should probably be fairly intuitive. @menu * General Advice:: * Using git with StumpWM:: * Sending Patches:: @end menu @node General Advice, Using git with StumpWM, 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 placed in the @file{contrib/} 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. @item Remember: StumpWM is designed to run on both clisp and on SBCL. If you must use code specific to one or the other, at the very least warn people that it only works with one lisp implementation. Better yet, figure out how to do it in the other distribution and write a statement like this: @example #+clisp (your-clisp-code) #+sbcl (your-sbcl-code) @end example #to wrap the code for each lisp. Of course, the best option is to find a way to use the same code for clisp and SBCL. @end enumerate @node Using git with StumpWM, Sending Patches, General Advice, 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 one using one of the official releases or still using the now-obsolete CVS version, you can get the bleeding-edge source code from the official git repository with a single command: @example $ git clone git://git.savannah.nongnu.org/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 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 I'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 -a @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 When sending patches to the mailing list for inclusion in StumpWM, there are a few guidelines that will make everything go smoother. @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 Command and Function Index, Variable Index, Hacking, Top @unnumbered Command and Function Index @printindex fn @node Variable Index, , Command and Function Index, Top @unnumbered Variable Index @printindex vr @bye stumpwm-20110819.gitca08e08/test-wm.lisp000066400000000000000000000230051162337705100175460ustar00rootroot00000000000000(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-20110819.gitca08e08/tile-group.lisp000066400000000000000000001316251162337705100202450ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; Frame functions ;; ;; Code: (in-package #:stumpwm) (export '(save-frame-excursion)) (defclass 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 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-windows group)))) (if window (focus-frame group (window-frame window)) (focus-frame group (tile-group-current-frame group))))) (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) (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-add-window ((group tile-group) window &key frame raise &allow-other-keys) ;; This is important to get the frame slot (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)) ;; maybe show the window in its new frame (when (null (frame-window (window-frame window))) (really-raise-window window))) (defmethod group-current-window ((group tile-group)) (frame-window (tile-group-current-frame group))) (defmethod group-current-head ((group tile-group)) (frame-head group (tile-group-current-frame group))) (defmethod group-move-request ((group tile-group) 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* ((pos (if (eq relative-to :parent) (list (+ (xlib:drawable-x (window-parent window)) x) (+ (xlib:drawable-y (window-parent window)) y)) (list x y))) (frame (apply #'find-frame group pos))) (when frame (pull-window window frame))))) (defmethod group-resize-request ((group tile-group) 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-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) (frame-raise-window group (window-frame win) win)) (defmethod group-button-press ((group tile-group) x y (where (eql :root))) (when (and (eq *mouse-focus-policy* :click) *root-click-focuses-frame*) (let* ((frame (find-frame group x y))) (when frame (focus-frame group frame) (update-all-mode-lines))))) (defmethod group-button-press ((group tile-group) x y (where window)) (declare (ignore x y)) (when (eq *mouse-focus-policy* :click) (focus-all where) (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) (choose-new-frame-window frame group) (when (frame-window frame) (unhide-window (frame-window frame)))))) (defmethod group-remove-head ((group tile-group) head) (let ((windows (head-windows group head))) ;; Remove it from the frame tree. (setf (tile-group-frame-tree group) (delete (tile-group-frame-head group head) (tile-group-frame-tree group))) ;; Just set current frame to whatever. (let ((frame (first (group-frames 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-resize-head ((group tile-group) oh nh) (resize-tree (tile-group-frame-head group oh) (head-width nh) (head-height nh) (head-x nh) (head-y nh))) (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) (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 populate-frames (group) "Try to fill empty frames in GROUP with hidden windows" (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 (>= y fy) (<= y fhy) (>= x fx) (<= x fwx) (return f)))))) (defun frame-set-x (frame v) (decf (frame-width frame) (- v (frame-x frame))) (setf (frame-x frame) v)) (defun frame-set-y (frame v) (decf (frame-height frame) (- v (frame-y frame))) (setf (frame-y frame) v)) (defun frame-set-r (frame v) (setf (frame-width frame) (- v (frame-x frame)))) (defun frame-set-b (frame v) (setf (frame-height frame) (- v (frame-y frame)))) (defun frame-r (frame) (+ (frame-x frame) (frame-width frame))) (defun frame-b (frame) (+ (frame-y frame) (frame-height frame))) (defun frame-display-y (group frame) "Return a Y for frame that doesn't overlap the mode-line." (let* ((head (frame-head group frame)) (ml (head-mode-line head)) (head-y (frame-y head)) (rel-frame-y (- (frame-y frame) head-y))) (if (and ml (not (eq (mode-line-mode ml) :hidden))) (case (mode-line-position ml) (:top (+ head-y (+ (mode-line-height ml) (round (* rel-frame-y (mode-line-factor ml)))))) (:bottom (+ head-y (round (* rel-frame-y (mode-line-factor ml)))))) (frame-y frame)))) (defun frame-display-height (group frame) "Return a HEIGHT for frame that doesn't overlap the mode-line." (let* ((head (frame-head group frame)) (ml (head-mode-line head))) (if (and ml (not (eq (mode-line-mode ml) :hidden))) (round (* (frame-height frame) (mode-line-factor ml))) (frame-height frame)))) (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 (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-windows group))) (defun frame-sort-windows (group f) (remove-if-not (lambda (w) (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 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)) (f1 (make-frame :number (frame-number p) :x (frame-x p) :y (frame-y p) :width w :height h :window (frame-window 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))) (run-hook-with-args *split-frame-hook* p f1 f2) (run-hook-with-args *new-frame-hook* f2) (values f1 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)) (f1 (make-frame :number (frame-number p) :x (frame-x p) :y (frame-y p) :width w :height h :window (frame-window p))) (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))) (run-hook-with-args *split-frame-hook* p f1 f2) (run-hook-with-args *new-frame-hook* f2) (values f1 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 (truncate (* 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) (when (eq (window-frame w) src) (setf (window-frame w) dest))) (group-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 row splits, all children have the same width, so use the ;; first one. (tree-height (first tree))) (t ;; for column splits we add the width of each child (reduce '+ tree :key 'tree-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 (floor (* amount old-sz) total))) (remainder (- amount (apply '+ amt-list))) (ofs 0)) ;; spread the remainder out as evenly as possible (assert (< remainder (length amt-list))) (loop for i upfrom 0 while (> remainder 0) do (incf (nth i amt-list)) (decf remainder)) ;; 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 (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." (let* ((tw (tree-width tree)) (th (tree-height tree)) (tx (tree-x tree)) (ty (tree-y tree)) (wf (/ w tw)) (hf (/ h th))) (tree-iterate tree (lambda (f) (setf (frame-height f) (round (* (frame-height f) hf)) (frame-y f) (+ (round (* (- (frame-y f) ty) hf)) y) (frame-width f) (round (* (frame-width f) wf)) (frame-x f) (+ (round (* (- (frame-x f) tx) wf)) x)))) (dformat 4 "resize-tree ~Dx~D -> ~Dx~D~%" tw th (tree-width tree) (tree-height tree)))) (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)))) (defun sync-frame-windows (group frame) "synchronize windows attached to FRAME." (mapc (lambda (w) (when (eq (window-frame w) frame) (dformat 3 "maximizing ~S~%" w) (maximize-window w))) (group-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 resize-frame (group frame amount dim) "Resize FRAME by AMOUNT in DIM dimension, DIM can be either :width or :height" (check-type group group) (check-type frame frame) (check-type amount integer) ;; (check-type dim (member :width :height)) (labels ((max-amount (parent node min dim-fn) (let ((right-sibling (cadr (member node parent))) (left-sibling (cadr (member node (reverse parent))))) (dformat 10 "max ~@{~a~^ ~}~%" parent node min dim-fn right-sibling left-sibling) (if parent (cond (right-sibling (max 0 (- (funcall dim-fn right-sibling) min))) (left-sibling (max 0 (- (funcall dim-fn left-sibling) min))) (t 0)) ;; no parent means the frame can't get any bigger. 0)))) (let* ((tree (tile-group-frame-tree group)) (parent (tree-parent tree frame)) (gparent (tree-parent tree parent)) (split-type (tree-split-type parent))) (dformat 10 "~s ~s parent: ~s ~s width: ~s h: ~s~%" dim amount split-type parent (tree-width parent) (tree-height parent)) ;; normalize amount (let* ((max (ecase dim (:width (if (>= (frame-width frame) (frame-width (frame-head group frame))) 0 (if (eq split-type :column) (max-amount parent frame *min-frame-width* 'tree-width) (max-amount gparent parent *min-frame-width* 'tree-width)))) (:height (if (>= (frame-height frame) (frame-height (frame-head group frame))) 0 (if (eq split-type :row) (max-amount parent frame *min-frame-height* 'tree-height) (max-amount gparent parent *min-frame-height* 'tree-height)))))) (min (ecase dim ;; Frames taking up the entire HEAD in one ;; dimension can't be resized in that dimension. (:width (if (and (eq split-type :row) (or (null gparent) (>= (frame-width frame) (frame-width (frame-head group frame))))) 0 (- *min-frame-width* (frame-width frame)))) (:height (if (and (eq split-type :column) (or (null gparent) (>= (frame-height frame) (frame-height (frame-head group frame))))) 0 (- *min-frame-height* (frame-height frame))))))) (setf amount (max (min amount max) min)) (dformat 10 "bounds ~d ~d ~d~%" amount max min)) ;; if FRAME is taking up the whole DIM or if AMOUNT = 0, do nothing (unless (zerop amount) (let* ((resize-parent (or (and (eq split-type :column) (eq dim :height)) (and (eq split-type :row) (eq dim :width)))) (to-resize (if resize-parent parent frame)) (to-resize-parent (if resize-parent gparent parent)) (lastp (= (position to-resize to-resize-parent) (1- (length to-resize-parent)))) (to-shrink (if lastp (prev-sibling to-resize-parent to-resize) (next-sibling to-resize-parent to-resize)))) (expand-tree to-resize amount (ecase dim (:width (if lastp :left :right)) (:height (if lastp :top :bottom)))) (expand-tree to-shrink (- amount) (ecase dim (:width (if lastp :right :left)) (:height (if lastp :bottom :top)))) (unless (and *resize-hides-windows* (eq *top-map* *resize-map*)) (tree-iterate to-resize (lambda (leaf) (sync-frame-windows group leaf))) (tree-iterate to-shrink (lambda (leaf) (sync-frame-windows group leaf))))))))) (defun balance-frames-internal (group tree) "Resize all the children of tree to be of equal width or height depending on the tree's split direction." (let* ((split-type (tree-split-type tree)) (fn (if (eq split-type :column) 'tree-width 'tree-height)) (side (if (eq split-type :column) :right :bottom)) (total (funcall fn tree)) size rem) (multiple-value-setq (size rem) (truncate total (length tree))) (loop for i in tree for j = rem then (1- j) for totalofs = 0 then (+ totalofs ofs) for ofs = (+ (- size (funcall fn i)) (if (plusp j) 1 0)) do (expand-tree i ofs side) (offset-tree-dir i totalofs side) (tree-iterate i (lambda (leaf) (sync-frame-windows group leaf)))))) (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) (if (eq (tree-split-type tree) how) (list-splice-replace frame tree f1 f2) (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-x f)) (y (frame-display-y group f)) (w (frame-width 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-x 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))) (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))) (when (eq frame current) (show-frame-indicator group)))))) (defcommand-alias remove remove-split) (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 (atom (tile-group-frame-head group head)) (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)) (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)))))) (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 (when (and (tile-group-last-frame group) (find (tile-group-last-frame group) (group-frames group))) (focus-frame group (tile-group-last-frame group)))) (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)))) (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 (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))) (ch (read-one-char (group-screen group))) (num (read-from-string (string ch) nil nil))) (dformat 3 "read ~S ~S~%" ch num) (mapc #'xlib:destroy-window wins) (clear-frame-outlines group) (find ch (group-frames group) :test 'char= :key 'get-frame-number-translation))) (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. 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: ")) "Resize the current frame by @var{width} and @var{height} pixels" (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) () () "Make frames the same height or width in the current frame's subtree." (let* ((group (current-group)) (tree (tree-parent (tile-group-frame-head group (current-head)) (tile-group-current-frame group)))) (if tree (balance-frames-internal (current-group) tree) (message "There's only one frame.")))) stumpwm-20110819.gitca08e08/tile-window.lisp000066400000000000000000000457011162337705100204170ustar00rootroot00000000000000;;; a dumping spot for window stuff that has tiling stuff in it (in-package :stumpwm) (defclass tile-window (window) ((frame :initarg :frame :accessor window-frame))) (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 (and (> (length (group-frames group)) 1) (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)) ;; In this case, visible means the window is the top window in the ;; frame. This is not entirely true when it doesn't take up the ;; entire frame and there's a window below it. (eq window (frame-window (window-frame window)))) (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)))) ;;;; (defun really-raise-window (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)))) ;;; (defun geometry-hints (win) "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." (let* ((f (window-frame win)) (x (frame-x f)) (y (frame-display-y (window-group win) f)) (border (xlib:drawable-border-width (window-parent win))) (fwidth (- (frame-width 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-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))) (border (case *window-border-style* (:none 0) (t (default-border-width-for-type win)))) center) ;; (dformat 4 "hints: ~s~%" hints) ;; determine what the width and height should be (cond ;; handle specially fullscreen windows. ((window-fullscreen win) (let ((head (frame-head (window-group win) f))) (setf x (frame-x head) y (frame-y head) width (frame-width head) height (frame-height head) (xlib:window-priority (window-parent win)) :above)) (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))) ;; 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 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 hints-inc-y (plusp hints-inc-y)) (let ((h (or hints-height (window-height win)))) (setf height (+ h (* hints-inc-y (+ (floor (- fheight h -1) hints-inc-y))))))))) ;; adjust for gravity (multiple-value-bind (wx wy) (get-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-x 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-width 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 wy (- (xlib:drawable-width (window-parent win)) width wx) (- (xlib:drawable-height (window-parent win)) height wy)) :cardinal 32)))) ;;; (defun focus-next-window (group) (focus-forward group (sort-windows group))) (defun focus-prev-window (group) (focus-forward group (reverse (sort-windows group)))) (defcommand (next tile-group) () () "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 tile-group) () () "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)))) (defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win)))) (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) ;; 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)) (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 (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 (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))) (defun exchange-windows (win1 win2) "Exchange the 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. @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 (fullscreen tile-group) () () "Toggle the fullscreen mode of the current widnow. Use this for clients with broken (non-NETWM) fullscreen implemenations, such as any program using SDL." (update-fullscreen (current-window) 2)) (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 (frame-number (window-frame window))) (role (window-role window))) (push (list group-name frame-number 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) (first lock) (first 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))) (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 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-20110819.gitca08e08/time.lisp000066400000000000000000000154741162337705100171170ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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)) (defvar *time-format-string-default* "%a %b %e %k:%M:%S" "The default value for `echo-date', (e.g, Thu Mar 3 23:05:25 2005).") (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) ;;; ------------------------------------------------------------------ ;;; Helper functions ;;; ------------------------------------------------------------------ (defun time-plist (&optional time) (multiple-value-bind (sec min hour dom mon year dow dstp tz) (or time (get-decoded-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" (- (get-universal-time) (encode-universal-time 0 0 0 1 1 1970 0)))) (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-20110819.gitca08e08/user.lisp000066400000000000000000000422171162337705100171320ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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-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 ((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-x frame) (frame-width 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." (sort (loop for p in path for dir = (probe-path p) when dir nconc (loop for file in (union ;; SBCL doesn't match files with types if type ;; is not wild and CLISP won't match files ;; without a type when type is wild. So cover all the bases (directory-no-deref (merge-pathnames (make-pathname :name :wild) dir)) (directory-no-deref (merge-pathnames (make-pathname :name :wild :type :wild) dir)) :test 'equal) for namestring = (file-namestring file) when (pathname-is-executable-p file) collect (if full-path (namestring file) namestring))) #'string<)) (defstruct path-cache programs modification-dates paths) (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) (portable-file-write-date p))) paths))) (finish-output) (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 (message "^20~{~a~^~%~}" (mapcar 'prin1-to-string (multiple-value-list (eval (read-from-string cmd))))) (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 (progn (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 (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 () () "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." (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." (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}." (labels ;; Raise the window win and select its frame. For now, it ;; does not select the screen. ((goto-win (win) (let* ((group (window-group win)) (frame (window-frame win)) (old-frame (tile-group-current-frame group))) (frame-raise-window group frame win) (focus-all win) (unless (eq frame old-frame) (show-frame-indicator group))))) (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 (goto-win 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 (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))) (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) (coerce (mapcar 'xlib:card8->char x) 'string)) (split-seq values '(0))))) (:utf8_string (format nil "~{~s~^, ~}" (mapcar 'utf8-to-string (split-seq values '(0))))) (t values))))))) stumpwm-20110819.gitca08e08/version.lisp.in000066400000000000000000000025761162337705100202520ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; Commentary: ;; ;; This file contains version information. ;; ;; Code: (in-package :stumpwm) (export '(*version* version)) (defparameter *version* #.(concatenate 'string (if (probe-path ".git") (string-trim '(#\Newline) (run-shell-command "git describe" t)) "@PACKAGE_VERSION@") " 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-20110819.gitca08e08/window-placement.lisp000066400000000000000000000205661162337705100214340ustar00rootroot00000000000000;;; Window placement routines (in-package :stumpwm) (defun xwin-to-window (xwin) "Build a window for XWIN" (make-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) (or (gethash regex *rule-scanners-cache*) (setf (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 instance type role title) "Returns T if window matches all the given properties" (and (if class (string-match (window-class window) class) t) (if instance (string-match (window-res window) instance) t) (if type (string-match (window-type window) type) t) (if role (string-match (window-role window) role) t) (if title (string-match (window-title window) title) t) t)) (defun window-matches-rule-p (w rule) "Returns T if window matches rule" (destructuring-bind (group-name frame raise lock &key create restore class instance type role title) rule (declare (ignore frame raise create restore)) (if (or lock (equal group-name (group-name (or (when (slot-boundp w 'group) (window-group w)) (current-group))))) (window-matches-properties-p w :class class :instance instance :type type :role role :title title)))) (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 class instance type role title) match (declare (ignore lock class instance type role title)) (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 (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 (frame-by-number new-group frame) raise))) (t (message "^B^1*Error placing window, group \"^b~a^B\" does not exist." group-name) (values))))) (values)))) (defun sync-window-placement () "Re-arrange existing windows according to placement rules" (dolist (screen *screen-list*) (dolist (window (screen-windows screen)) (multiple-value-bind (to-group frame raise) (with-current-screen screen (get-window-placement screen window)) (declare (ignore raise)) (when to-group (unless (eq (window-group window) to-group) (move-window-to-group window to-group)) (unless (eq (window-frame window) frame) (pull-window window frame))))))) (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-20110819.gitca08e08/window.lisp000066400000000000000000001223441162337705100174630ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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)) (defvar *default-window-name* "Unnamed" "The name given to a window that does not supply its own name.") (defclass 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-object ((object window) stream) (format stream "#S(~a ~s #x~x)" (type-of object) (window-name object) (window-id object))) ;;; Window Management API (defgeneric update-decoration (window) (:documentation "Update the window decoration.")) (defgeneric focus-window (window) (:documentation "Give the specified window keyboard focus.")) (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.")) ;; 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) ;; XXX: as of clisp 2.46 flags is a list, not a number. (if (listp flags) (remove :urgency flags) (logand (lognot 256) flags))) (setf (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)))) ;; XXX: as of clisp 2.46 flags is a list, not a number. (or (and flags (if (listp flags) (find :urgency flags) (logtest 256 flags))) (find-wm-state (window-xwin window) :_NET_WM_STATE_DEMANDS_ATTENTION)))) (defun only-urgent (windows) "Return a list of all urgent windows on SCREEN" (remove-if-not 'window-urgent-p (copy-list windows))) (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))) (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) (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) (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 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" (let ((name (xlib:get-property win :_NET_WM_NAME))) (when name (utf8-to-string name)))) (defun xwin-name (win) (or (xwin-net-wm-name win) (xlib:wm-name win))) ;; FIXME: should we raise the winodw 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) (setf (xlib:window-priority (window-parent win)) :top-if))) ;; some handy wrappers (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)))) (defun sort-windows (group) "Return a copy of the screen's window list sorted by number." (sort1 (group-windows group) '< :key 'window-number)) (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, withdraw 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) (when (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+) (return (cdr (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+))))))) (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 (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 (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. (xlib:with-server-grabbed (*display*) (let ((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*))) (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 master-window) ;; ;; 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) (process-mapped-window screen win)))))))) (dolist (w (screen-windows screen)) (setf (window-state w) +normal-state+) (xwin-hide w))) (defun xwin-grab-keys (win screen) (labels ((grabit (w key) (loop for code in (multiple-value-list (xlib:keysym->keycodes *display* (key-keysym key))) do ;; some keysyms aren't mapped to keycodes so just ignore them. (when code ;; Some keysyms, such as upper case letters, need the ;; shift modifier to be set in order to grab properly. (when (and (not (eql (key-keysym key) (xlib:keycode->keysym *display* code 0))) (eql (key-keysym key) (xlib:keycode->keysym *display* code 1))) ;; don't butcher the caller's structure (setf key (copy-structure key) (key-shift key) t)) (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)))))) (dolist (map (dereference-kmaps (top-maps screen))) (dolist (i (kmap-bindings map)) (grabit 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 7 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 i)) do (xwin-grab-keys (screen-focus-window i) i)) (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)) (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~%") (let* ((screen (group-screen group))) (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) "Make the window visible and give it keyboard focus." (dformat 3 "focus-window: ~s~%" window) (let* ((group (window-group window)) (screen (group-screen group)) (cw (screen-focus screen))) ;; If window to focus is already focused then our work is done. (unless (eq window cw) (raise-window window) (screen-set-focus screen window) ;;(send-client-message window :WM_PROTOCOLS +wm-take-focus+) (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) (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 select-window-from-menu (windows fmt) "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) nil (or (position (current-window) windows) 0)))) ;;; 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 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)))) (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))))) (defcommand other-window (&optional (group (current-group))) () "Switch to the window last focused." (let* ((wins (group-windows 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.")))) (defcommand-alias other other-window) (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)))))) (defcommand windowlist (&optional (fmt *window-format*)) (:rest) "Allow the user to Select a window from the list of windows and focus the selected window. For information of menu bindings @xref{Menus}. The optional argument @var{fmt} can be specified to override the default window formatting." (if (null (group-windows (current-group))) (message "No Managed Windows") (let* ((group (current-group)) (window (select-window-from-menu (sort-windows group) fmt))) (if window (group-focus-window group window) (throw 'error :abort))))) (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 nil)))) (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." (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))) stumpwm-20110819.gitca08e08/workarounds.lisp000066400000000000000000000127051162337705100205310ustar00rootroot00000000000000;;; workarounds for bugs in clx (in-package :xlib) ;;; SBCL workaround for a clx caching bug. This is taken from portable-clx's display.lisp. ;;; NOTE! The latest clx in Rhodes' repository has fixed this in a far ;;; better way by only caching XIDs created by the client. ;; Define functions to find the CLX data types given a display and resource-id ;; If the data type is being cached, look there first. #+sbcl (macrolet ((generate-lookup-functions (useless-name &body types) `(within-definition (,useless-name generate-lookup-functions) ,@(mapcar #'(lambda (type) `(defun ,(xintern 'lookup- type) (display id) (declare (type display display) (type resource-id id)) (declare (clx-values ,type)) ,(if (member type +clx-cached-types+) `(let ((,type (lookup-resource-id display id))) (cond ((null ,type) ;; Not found, create and save it. (setq ,type (,(xintern 'make- type) :display display :id id)) (save-id display id ,type)) ;; Found. Check the type ((type? ,type ',type) ,type) (t (restart-case (x-error 'lookup-error :id id :display display :type ',type :object ,type) (:one () :report "Invalidate this cache entry" (save-id display id (,(xintern 'make- type) :display display :id id))) (:all () :report "Invalidate all display cache" (clrhash (display-resource-id-map display)) (save-id display id (,(xintern 'make- type) :display display :id id))))))) ;; Not being cached. Create a new one each time. `(,(xintern 'make- type) :display display :id id)))) types)))) (generate-lookup-functions ignore drawable window pixmap gcontext cursor colormap font)) ;;; Both clisp and SBCL can't handle incompliant (and in clisp's case, ;;; even compliant) wm-class strings. See test-wm-class in test-wm.lisp. #+sbcl (defun get-wm-class (window) (declare (type window window)) (declare (clx-values (or null name-string) (or null class-string))) (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) (declare (type (or null (vector card8)) value)) (when value ;; Buggy clients may not comply with the format, so deal with ;; the unexpected. (let* ((first-zero (position 0 (the (vector card8) value))) (second-zero (and first-zero (position 0 (the (vector card8) value) :start (1+ first-zero)))) (name (subseq (the (vector card8) value) 0 first-zero)) (class (and first-zero (subseq (the (vector card8) value) (1+ first-zero) second-zero)))) (values (and (plusp (length name)) (map 'string #'card8->char name)) (and (plusp (length class)) (map 'string #'card8->char class))))))) #+clisp (defun get-wm-class (window) (let ((value (get-property window :WM_CLASS :type :STRING :result-type 'string :transform #'card8->char))) (when value ;; Buggy clients may not comply with the format, so deal with ;; the unexpected. (let* ((first-zero (position (load-time-value (card8->char 0)) (the string value))) (second-zero (and first-zero (position (load-time-value (card8->char 0)) (the string value) :start (1+ first-zero)))) (name (subseq (the string value) 0 first-zero)) (class (and first-zero (subseq (the string value) (1+ first-zero) second-zero)))) (values (and (plusp (length name)) name) (and (plusp (length class)) class)))))) #+clisp (when (fboundp '%gcontext-key->mask) (defmacro WITH-GCONTEXT ((gcontext &rest options) &body body) (let ((saved (gensym)) (gcon (gensym)) (g0 (gensym)) (g1 (gensym)) (comps 0) (setf-forms nil) dashes? clip-mask?) (do ((q options (cddr q))) ((null q)) (cond ((eq (car q) :dashes) (setf dashes? t)) ((eq (car q) :clip-mask) (setf clip-mask? t))) (setf comps (logior comps (%gcontext-key->mask (car q))) setf-forms (nconc setf-forms (list (list (find-symbol (ext:string-concat "GCONTEXT-" (symbol-name (car q))) :xlib) gcon) (cadr q))))) `(LET* ((,gcon ,gcontext) (,saved (%SAVE-GCONTEXT-COMPONENTS ,gcon ,comps)) ,@(if dashes? (list `(,g0 (GCONTEXT-DASHES ,gcon)))) ,@(if clip-mask? (list `(,g1 (GCONTEXT-CLIP-MASK ,gcon))))) (UNWIND-PROTECT (PROGN (SETF ,@setf-forms) ,@body) (PROGN (%RESTORE-GCONTEXT-COMPONENTS ,gcon ,saved) ,@(if dashes? (list `(SETF (GCONTEXT-DASHES ,gcon) ,g0))) ,@(if clip-mask? (list `(SETF (GCONTEXT-CLIP-MASK ,gcon) ,g1))))))))) stumpwm-20110819.gitca08e08/wrappers.lisp000066400000000000000000000353631162337705100200230ustar00rootroot00000000000000;; 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, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA ;; 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 run-prog (prog &rest opts &key args output (wait t) &allow-other-keys) "Common interface to shell. Does not return anything useful." #+(or clisp ccl ecl gcl) ;; Arg. We can't pass in an environment so just set the DISPLAY ;; variable so it's inherited by the child process. (when (current-screen) (setf (getenv "DISPLAY") (screen-display-string (current-screen) nil))) (setq opts (remove-plist opts :args :output :wait)) #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args) :output output :wait wait :environment (when (current-screen) (list (cons "DISPLAY" (screen-display-string (current-screen))))) opts) #+ccl (ccl:run-program prog (mapcar (lambda (s) (if (simple-string-p s) s (coerce s 'simple-string))) args) :wait wait :output (if output output t) :error t) #+clisp (let ((stream (apply #'ext:run-program prog :arguments args :wait wait :output (if output :stream :terminal) opts))) (when output (loop for ch = (read-char stream nil stream) until (eq ch stream) do (write-char ch output)))) #+cmu (let ((env ext:*environment-list*)) (when (current-screen) (setf env (cons (cons "DISPLAY" (screen-display-string (current-screen) nil)) env))) (apply #'ext:run-program prog args :output (if output output t) :env env :error t :wait wait opts)) #+ecl (if output (let ((stream (ext:run-program prog args :input nil))) (loop for line = (read-line stream nil) while line do (format output "~A~%" line))) (ext:system (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait)))) #+gcl (let ((stream (apply #'si:run-process prog args))) (when wait (loop for ch = (read-char stream nil stream) until (eq ch stream) do (write-char ch output)))) #+liquid (apply #'lcl:run-program prog :output output :wait wait :arguments args opts) #+lispworks (let ((cmdline (format nil "~a ~a~{ '~a'~}" (screen-display-string (current-screen) t) prog args (not wait)))) (if output (apply #'sys::call-system-showing-output cmdline :output-stream output :wait wait args) (apply #'sys::call-system cmdline :wait wait args))) #+sbcl (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)) #-(or allegro ccl clisp cmu ecl gcl liquid lispworks sbcl) (error 'not-implemented)) (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." #+allegro (sys::getenv (string var)) #+clisp (ext:getenv (string var)) #+(or cmu scl) (cdr (assoc (string var) ext:*environment-list* :test #'equalp :key #'string)) #+gcl (si:getenv (string var)) #+lispworks (lw:environment-variable (string var)) #+lucid (lcl:environment-variable (string var)) #+mcl (ccl::getenv var) #+sbcl (sb-posix:getenv (string var)) #+openmcl (ccl:getenv (string var)) #+ecl (ext:getenv (string var)) #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl openmcl ecl) (error 'not-implemented)) (defun (setf getenv) (val var) "Set the value of the environment variable, @var{var} to @var{val}." #+allegro (setf (sys::getenv (string var)) (string val)) #+clisp (setf (ext:getenv (string var)) (string val)) #+(or cmu scl) (let ((cell (assoc (string var) ext:*environment-list* :test #'equalp :key #'string))) (if cell (setf (cdr cell) (string val)) (push (cons (intern (string var) "KEYWORD") (string val)) ext:*environment-list*))) #+gcl (si:setenv (string var) (string val)) #+lispworks (setf (lw:environment-variable (string var)) (string val)) #+lucid (setf (lcl:environment-variable (string var)) (string val)) #+sbcl (sb-posix:putenv (format nil "~A=~A" (string var) (string val))) #+openmcl (ccl:setenv (string var) (string val)) #+ecl (ext:setenv (string var) (string val)) #-(or allegro clisp cmu gcl lispworks lucid sbcl scl openmcl ecl) (error 'not-implemented)) (defun pathname-is-executable-p (pathname) "Return T if the pathname describes an executable file." (declare (ignorable pathname)) #+sbcl (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))) ;; FIXME: this is not exactly perfect #+clisp (logand (posix:convert-mode (posix:file-stat-mode (posix:file-stat pathname))) (posix:convert-mode '(:xusr :xgrp :xoth))) #-(or sbcl clisp) t) (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 portable-file-write-date (pathname) ;; clisp errors out if you run file-write-date on a directory. #+clisp (posix:file-stat-mtime (posix:file-stat pathname)) #-clisp (file-write-date pathname)) (defun print-backtrace (&optional (frames 100)) "print a backtrace of FRAMES number of frames to standard-output" #+sbcl (sb-debug:backtrace frames *standard-output*) #+clisp (ext:show-stack 1 frames (sys::the-frame)) #+ccl (ccl:print-call-history :count frames :stream *standard-output* :detailed-p nil) #-(or sbcl clisp ccl) (write-line "Sorry, no backtrace for you.")) (defun bytes-to-string (data) "Convert a list of bytes into a string." #+sbcl (handler-bind ((sb-impl::octet-decoding-error #'(lambda (c) (invoke-restart 'use-value "?")))) (sb-ext:octets-to-string (make-array (length data) :element-type '(unsigned-byte 8) :initial-contents data))) #+clisp (ext:convert-string-from-bytes (make-array (length data) :element-type '(unsigned-byte 8) :initial-contents data) custom:*terminal-encoding*) #-(or sbcl clisp) (map 'string #'code-char data)) (defun string-to-bytes (string) "Convert a string to a vector of octets." #+sbcl (sb-ext:string-to-octets string) #+clisp (ext:convert-string-to-bytes string custom:*terminal-encoding*) #-(or sbcl clisp) (map 'list #'char-code string)) (defun utf8-to-string (octets) "Convert the list of octets to a string." (let ((octets (coerce octets '(vector (unsigned-byte 8))))) #+ccl (ccl:decode-string-from-octets octets :external-format :utf-8) #+clisp (ext:convert-string-from-bytes octets charset:utf-8) #+sbcl (handler-bind ((sb-impl::octet-decoding-error #'(lambda (c) (declare (ignore c)) (invoke-restart 'use-value "?")))) (sb-ext:octets-to-string octets :external-format :utf-8)) #-(or ccl clisp sbcl) (map 'string #'code-char octets))) (defun string-to-utf8 (string) "Convert the string to a vector of octets." #+ccl (ccl:encode-string-to-octets string :external-format :utf-8) #+clisp (ext:convert-string-to-bytes string charset:utf-8) #+sbcl (sb-ext:string-to-octets string :external-format :utf-8) #-(or ccl clisp sbcl) (map 'list #'char-code string)) (defun make-xlib-window (xobject) "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 them." #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*) #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*) #-(or sbcl clisp ecl openmcl) (error 'not-implemented)) ;; Right now clisp and sbcl both work the same way (defun lookup-error-recoverable-p () #+(or clisp sbcl) (find :one (compute-restarts) :key 'restart-name) #-(or clisp sbcl) nil) (defun recover-from-lookup-error () #+(or clisp sbcl) (invoke-restart :one) #-(or clisp sbcl) (error 'not-implemented)) (defun directory-no-deref (pathspec) "Call directory without dereferencing symlinks in the results" #+(or cmu scl) (directory pathspec :truenamep nil) #+clisp (mapcar #'car (directory pathspec :full t)) #+lispworks (directory pathspec :link-transparency nil) #+openmcl (directory pathspec :follow-links nil) ;; FIXME: seems like there ought to be a less cumbersome way to run ;; different code based on the version. #+sbcl (macrolet ((dir (p) (if (>= (parse-integer (third (split-seq (lisp-implementation-version) '(#\.))) :junk-allowed t) 24) `(directory ,p :resolve-symlinks nil) `(directory ,p)))) (dir pathspec)) #-(or clisp cmu lispworks openmcl sbcl scl) (directory pathspec) ) ;;; CLISP does not include features to distinguish different Unix ;;; flavours (at least until version 2.46). Until this is fixed, use a ;;; hack to determine them. #+ (and clisp (not (or linux freebsd))) (eval-when (eval load compile) (let ((osname (posix:uname-sysname (posix:uname)))) (cond ((string= osname "Linux") (pushnew :linux *features*)) ((string= osname "FreeBSD") (pushnew :freebsd *features*)) (t (warn "Your operating system is not recognized."))))) ;;; 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." #- sbcl (declare (ignore blocksize)) #- sbcl (read-line stream) #+ sbcl (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 argv () #+sbcl (copy-list sb-ext:*posix-argv*) #+clisp (coerce (ext:argv) 'list) #-( or sbcl clisp) (error "unimplemented")) (defun execv (program &rest arguments) (declare (ignorable program arguments)) ;; FIXME: seems like there should be a way to do this in sbcl the way it's done in clisp. -sabetts #+sbcl (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)))) #+clisp (funcall (ffi::find-foreign-function "execv" (ffi:parse-c-type '(ffi:c-function (:arguments (prg ffi:c-string) (args (ffi:c-array-ptr ffi:c-string)) ) (:return-type ffi:int))) nil nil nil) program (coerce arguments 'array)) #-(or sbcl clisp) (error "Unimplemented")) ;;; EOF